[27174] | 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 | $data = uri_unescape($data);
|
---|
| 59 | return $base64 ? decode_base64($data) : $data;
|
---|
| 60 | }
|
---|
| 61 |
|
---|
| 62 | # I could not find a better way to interpolate the tr/// chars from
|
---|
| 63 | # a variable.
|
---|
| 64 | my $ENC = $URI::uric;
|
---|
| 65 | $ENC =~ s/%//;
|
---|
| 66 |
|
---|
| 67 | eval <<EOT; die $@ if $@;
|
---|
| 68 | sub _uric_count
|
---|
| 69 | {
|
---|
| 70 | \$_[0] =~ tr/$ENC//;
|
---|
| 71 | }
|
---|
| 72 | EOT
|
---|
| 73 |
|
---|
| 74 | 1;
|
---|
| 75 |
|
---|
| 76 | __END__
|
---|
| 77 |
|
---|
| 78 | =head1 NAME
|
---|
| 79 |
|
---|
| 80 | URI::data - URI that contains immediate data
|
---|
| 81 |
|
---|
| 82 | =head1 SYNOPSIS
|
---|
| 83 |
|
---|
| 84 | use URI;
|
---|
| 85 |
|
---|
| 86 | $u = URI->new("data:");
|
---|
| 87 | $u->media_type("image/gif");
|
---|
| 88 | $u->data(scalar(`cat camel.gif`));
|
---|
| 89 | print "$u\n";
|
---|
| 90 | open(XV, "|xv -") and print XV $u->data;
|
---|
| 91 |
|
---|
| 92 | =head1 DESCRIPTION
|
---|
| 93 |
|
---|
| 94 | The C<URI::data> class supports C<URI> objects belonging to the I<data>
|
---|
| 95 | URI scheme. The I<data> URI scheme is specified in RFC 2397. It
|
---|
| 96 | allows inclusion of small data items as "immediate" data, as if it had
|
---|
| 97 | been included externally. Examples:
|
---|
| 98 |
|
---|
| 99 | data:,Perl%20is%20good
|
---|
| 100 |
|
---|
| 101 | data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI
|
---|
| 102 | AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG
|
---|
| 103 | Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p
|
---|
| 104 | KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI
|
---|
| 105 | JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs=
|
---|
| 106 |
|
---|
| 107 |
|
---|
| 108 |
|
---|
| 109 | C<URI> objects belonging to the data scheme support the common methods
|
---|
| 110 | (described in L<URI>) and the following two scheme-specific methods:
|
---|
| 111 |
|
---|
| 112 | =over 4
|
---|
| 113 |
|
---|
| 114 | =item $uri->media_type( [$new_media_type] )
|
---|
| 115 |
|
---|
| 116 | Can be used to get or set the media type specified in the
|
---|
| 117 | URI. If no media type is specified, then the default
|
---|
| 118 | C<"text/plain;charset=US-ASCII"> is returned.
|
---|
| 119 |
|
---|
| 120 | =item $uri->data( [$new_data] )
|
---|
| 121 |
|
---|
| 122 | Can be used to get or set the data contained in the URI.
|
---|
| 123 | The data is passed unescaped (in binary form). The decision about
|
---|
| 124 | whether to base64 encode the data in the URI is taken automatically,
|
---|
| 125 | based on the encoding that produces the shorter URI string.
|
---|
| 126 |
|
---|
| 127 | =back
|
---|
| 128 |
|
---|
| 129 | =head1 SEE ALSO
|
---|
| 130 |
|
---|
| 131 | L<URI>
|
---|
| 132 |
|
---|
| 133 | =head1 COPYRIGHT
|
---|
| 134 |
|
---|
| 135 | Copyright 1995-1998 Gisle Aas.
|
---|
| 136 |
|
---|
| 137 | This library is free software; you can redistribute it and/or
|
---|
| 138 | modify it under the same terms as Perl itself.
|
---|
| 139 |
|
---|
| 140 | =cut
|
---|