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
|
---|