From 661c41a09e39a182865e0b51e34cc995a0dc96e8 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Wed, 12 May 2010 16:54:37 +0000 Subject: move tlperl.straw to tlperl git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/URI/data.pm | 140 ++++++++++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100755 Master/tlpkg/tlperl/lib/URI/data.pm (limited to 'Master/tlpkg/tlperl/lib/URI/data.pm') diff --git a/Master/tlpkg/tlperl/lib/URI/data.pm b/Master/tlpkg/tlperl/lib/URI/data.pm new file mode 100755 index 00000000000..dccd8181289 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/URI/data.pm @@ -0,0 +1,140 @@ +package URI::data; # RFC 2397 + +require URI; +@ISA=qw(URI); + +use strict; + +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 <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 class supports C objects belonging to the I +URI scheme. The I 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 objects belonging to the data scheme support the common methods +(described in L) 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 + +=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 -- cgit v1.2.3