git.maemo.org Git - pkg-perl/blob - deb-src/liburi-perl/liburi-perl-1.35.dfsg.1/URI/data.pm

   1 package URI::data;  # RFC 2397
   2
   3 require URI;
   4 @ISA=qw(URI);
   5
   6 use strict;
   7
   8 use MIME::Base64 qw(encode_base64 decode_base64);
   9 use URI::Escape  qw(uri_unescape);
  10
  11 sub media_type
  12 {
  13     my $self = shift;
  14     my $opaque = $self->opaque;
  15     $opaque =~ /^([^,]*),?/ or die;
  16     my $old = $1;
  17     my $base64;
  18     $base64 = $1 if $old =~ s/(;base64)$//i;
  19     if (@_) {
  20         my $new = shift;
  21         $new = "" unless defined $new;
  22         $new =~ s/%/%25/g;
  23         $new =~ s/,/%2C/g;
  24         $base64 = "" unless defined $base64;
  25         $opaque =~ s/^[^,]*,?/$new$base64,/;
  26         $self->opaque($opaque);
  27     }
  28     return uri_unescape($old) if $old;  # media_type can't really be "0"
  29     "text/plain;charset=US-ASCII";      # default type
  30 }
  31
  32 sub data
  33 {
  34     my $self = shift;
  35     my($enc, $data) = split(",", $self->opaque, 2);
  36     unless (defined $data) {
  37         $data = "";
  38         $enc  = "" unless defined $enc;
  39     }
  40     my $base64 = ($enc =~ /;base64$/i);
  41     if (@_) {
  42         $enc =~ s/;base64$//i if $base64;
  43         my $new = shift;
  44         $new = "" unless defined $new;
  45         my $uric_count = _uric_count($new);
  46         my $urienc_len = $uric_count + (length($new) - $uric_count) * 3;
  47         my $base64_len = int((length($new)+2) / 3) * 4;
  48         $base64_len += 7;  # because of ";base64" marker
  49         if ($base64_len < $urienc_len || $_[0]) {
  50             $enc .= ";base64";
  51             $new = encode_base64($new, "");
  52         } else {
  53             $new =~ s/%/%25/g;
  54         }
  55         $self->opaque("$enc,$new");
  56     }
  57     return unless defined wantarray;
  58     return $base64 ? decode_base64($data) : uri_unescape($data);
  59 }
  60
  61 # I could not find a better way to interpolate the tr/// chars from
  62 # a variable.
  63 my $ENC = $URI::uric;
  64 $ENC =~ s/%//;
  65
  66 eval <<EOT; die $@ if $@;
  67 sub _uric_count
  68 {
  69     \$_[0] =~ tr/$ENC//;
  70 }
  71 EOT
  72
  73 1;
  74
  75 __END__
  76
  77 =head1 NAME
  78
  79 URI::data - URI that contains immediate data
  80
  81 =head1 SYNOPSIS
  82
  83  use URI;
  84
  85  $u = URI->new("data:");
  86  $u->media_type("image/gif");
  87  $u->data(scalar(`cat camel.gif`));
  88  print "$u\n";
  89  open(XV, "|xv -") and print XV $u->data;
  90
  91 =head1 DESCRIPTION
  92
  93 The C<URI::data> class supports C<URI> objects belonging to the I<data>
  94 URI scheme.  The I<data> URI scheme is specified in RFC 2397.  It
  95 allows inclusion of small data items as "immediate" data, as if it had
  96 been included externally.  Examples:
  97
  98   data:,Perl%20is%20good
  99
 100   data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI
 101     AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG
 102     Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p
 103     KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI
 104     JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs=
 105
 106
 107
 108 C<URI> objects belonging to the data scheme support the common methods
 109 (described in L<URI>) and the following two scheme-specific methods:
 110
 111 =over 4
 112
 113 =item $uri->media_type( [$new_media_type] )
 114
 115 Can be used to get or set the media type specified in the
 116 URI.  If no media type is specified, then the default
 117 C<"text/plain;charset=US-ASCII"> is returned.
 118
 119 =item $uri->data( [$new_data] )
 120
 121 Can be used to get or set the data contained in the URI.
 122 The data is passed unescaped (in binary form).  The decision about
 123 whether to base64 encode the data in the URI is taken automatically,
 124 based on the encoding that produces the shorter URI string.
 125
 126 =back
 127
 128 =head1 SEE ALSO
 129
 130 L<URI>
 131
 132 =head1 COPYRIGHT
 133
 134 Copyright 1995-1998 Gisle Aas.
 135
 136 This library is free software; you can redistribute it and/or
 137 modify it under the same terms as Perl itself.
 138
 139 =cut