diff options
author | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
commit | b56b320b5e2515160073fa1b469514002688fe11 (patch) | |
tree | 965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/lib/URI/data.pm | |
parent | d26c206452d2e285c3bbf949f34011e4a55fd8f9 (diff) |
tlperl 5.22.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/URI/data.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/URI/data.pm | 142 |
1 files changed, 0 insertions, 142 deletions
diff --git a/Master/tlpkg/tlperl/lib/URI/data.pm b/Master/tlpkg/tlperl/lib/URI/data.pm deleted file mode 100644 index 19c390ec03c..00000000000 --- a/Master/tlpkg/tlperl/lib/URI/data.pm +++ /dev/null @@ -1,142 +0,0 @@ -package URI::data; # RFC 2397 - -use strict; -use warnings; - -use parent 'URI'; - -our $VERSION = '1.67'; - -use MIME::Base64 qw(encode_base64 decode_base64); -use URI::Escape qw(uri_unescape); - -sub media_type -{ - my $self = shift; - my $opaque = $self->opaque; - $opaque =~ /^([^,]*),?/ or die; - my $old = $1; - my $base64; - $base64 = $1 if $old =~ s/(;base64)$//i; - if (@_) { - my $new = shift; - $new = "" unless defined $new; - $new =~ s/%/%25/g; - $new =~ s/,/%2C/g; - $base64 = "" unless defined $base64; - $opaque =~ s/^[^,]*,?/$new$base64,/; - $self->opaque($opaque); - } - return uri_unescape($old) if $old; # media_type can't really be "0" - "text/plain;charset=US-ASCII"; # default type -} - -sub data -{ - my $self = shift; - my($enc, $data) = split(",", $self->opaque, 2); - unless (defined $data) { - $data = ""; - $enc = "" unless defined $enc; - } - my $base64 = ($enc =~ /;base64$/i); - if (@_) { - $enc =~ s/;base64$//i if $base64; - my $new = shift; - $new = "" unless defined $new; - my $uric_count = _uric_count($new); - my $urienc_len = $uric_count + (length($new) - $uric_count) * 3; - my $base64_len = int((length($new)+2) / 3) * 4; - $base64_len += 7; # because of ";base64" marker - if ($base64_len < $urienc_len || $_[0]) { - $enc .= ";base64"; - $new = encode_base64($new, ""); - } else { - $new =~ s/%/%25/g; - } - $self->opaque("$enc,$new"); - } - return unless defined wantarray; - $data = uri_unescape($data); - return $base64 ? decode_base64($data) : $data; -} - -# I could not find a better way to interpolate the tr/// chars from -# a variable. -my $ENC = $URI::uric; -$ENC =~ s/%//; - -eval <<EOT; die $@ if $@; -sub _uric_count -{ - \$_[0] =~ tr/$ENC//; -} -EOT - -1; - -__END__ - -=head1 NAME - -URI::data - URI that contains immediate data - -=head1 SYNOPSIS - - use URI; - - $u = URI->new("data:"); - $u->media_type("image/gif"); - $u->data(scalar(`cat camel.gif`)); - print "$u\n"; - open(XV, "|xv -") and print XV $u->data; - -=head1 DESCRIPTION - -The C<URI::data> class supports C<URI> objects belonging to the I<data> -URI scheme. The I<data> URI scheme is specified in RFC 2397. It -allows inclusion of small data items as "immediate" data, as if it had -been included externally. Examples: - - data:,Perl%20is%20good - - data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI - AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG - Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p - KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI - JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs= - - - -C<URI> objects belonging to the data scheme support the common methods -(described in L<URI>) and the following two scheme-specific methods: - -=over 4 - -=item $uri->media_type( [$new_media_type] ) - -Can be used to get or set the media type specified in the -URI. If no media type is specified, then the default -C<"text/plain;charset=US-ASCII"> is returned. - -=item $uri->data( [$new_data] ) - -Can be used to get or set the data contained in the URI. -The data is passed unescaped (in binary form). The decision about -whether to base64 encode the data in the URI is taken automatically, -based on the encoding that produces the shorter URI string. - -=back - -=head1 SEE ALSO - -L<URI> - -=head1 COPYRIGHT - -Copyright 1995-1998 Gisle Aas. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut |