-#
-# $Id: Base64.pm,v 2.37 2004/01/08 14:07:26 gisle Exp $
-
package MIME::Base64;
+# $Id: Base64.pm,v 3.0 2004/01/14 11:59:07 gisle Exp $
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw(encode_base64 decode_base64);
+
+$VERSION = '3.00_01';
+
+MIME::Base64->bootstrap($VERSION);
+
+*encode = \&encode_base64;
+*decode = \&decode_base64;
+
+1;
+
+__END__
+
=head1 NAME
MIME::Base64 - Encoding and decoding of base64 strings
L<MIME::QuotedPrint>
=cut
-
-use strict;
-use vars qw(@ISA @EXPORT $VERSION $OLD_CODE);
-
-require Exporter;
-require DynaLoader;
-@ISA = qw(Exporter DynaLoader);
-@EXPORT = qw(encode_base64 decode_base64);
-
-$VERSION = '2.23';
-
-eval { bootstrap MIME::Base64 $VERSION; };
-if ($@) {
- # can't bootstrap XS implementation, use perl implementation
- *encode_base64 = \&old_encode_base64;
- *decode_base64 = \&old_decode_base64;
-
- $OLD_CODE = $@;
- #warn $@ if $^W;
-}
-
-# Historically this module has been implemented as pure perl code.
-# The XS implementation runs about 20 times faster, but the Perl
-# code might be more portable, so it is still here.
-
-sub old_encode_base64 ($;$)
-{
- if ($] >= 5.006) {
- require bytes;
- if (bytes::length($_[0]) > length($_[0]) ||
- ($] >= 5.008 && $_[0] =~ /[^\0-\xFF]/))
- {
- require Carp;
- Carp::croak("The Base64 encoding is only defined for bytes");
- }
- }
-
- use integer;
-
- my $eol = $_[1];
- $eol = "\n" unless defined $eol;
-
- my $res = pack("u", $_[0]);
- # Remove first character of each line, remove newlines
- $res =~ s/^.//mg;
- $res =~ s/\n//g;
-
- $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs
- # fix padding at the end
- my $padding = (3 - length($_[0]) % 3) % 3;
- $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
- # break encoded string into lines of no more than 76 characters each
- if (length $eol) {
- $res =~ s/(.{1,76})/$1$eol/g;
- }
- return $res;
-}
-
-
-sub old_decode_base64 ($)
-{
- local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123]
- use integer;
-
- my $str = shift;
- $str =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars
- if (length($str) % 4) {
- require Carp;
- Carp::carp("Length of base64 data not a multiple of 4")
- }
- $str =~ s/=+$//; # remove padding
- $str =~ tr|A-Za-z0-9+/| -_|; # convert to uuencoded format
- return "" unless length $str;
-
- ## I guess this could be written as
- #return unpack("u", join('', map( chr(32 + length($_)*3/4) . $_,
- # $str =~ /(.{1,60})/gs) ) );
- ## but I do not like that...
- my $uustr = '';
- my ($i, $l);
- $l = length($str) - 60;
- for ($i = 0; $i <= $l; $i += 60) {
- $uustr .= "M" . substr($str, $i, 60);
- }
- $str = substr($str, $i);
- # and any leftover chars
- if ($str ne "") {
- $uustr .= chr(32 + length($str)*3/4) . $str;
- }
- return unpack ("u", $uustr);
-}
-
-# Set up aliases so that these functions also can be called as
-#
-# MIME::Base64::encode();
-# MIME::Base64::decode();
-
-*encode = \&encode_base64;
-*decode = \&decode_base64;
-
-1;
-/* $Id: Base64.xs,v 1.41 2004/01/08 14:07:26 gisle Exp $
+/* $Id: Base64.xs,v 3.0 2004/01/14 11:59:07 gisle Exp $
Copyright 1997-2004 Gisle Aas
# define SvPVbyte SvPV
#endif
+#ifndef isXDIGIT
+# define isXDIGIT isxdigit
+#endif
+
#ifndef NATIVE_TO_ASCII
# define NATIVE_TO_ASCII(ch) (ch)
#endif
+2004-01-14 Gisle Aas <gisle@ActiveState.com>
+
+ Release 3.00
+
+ Drop the pure Perl implementations of the encoders and
+ decoders. They are bloat that hides real problems in
+ the XS implementations. I will re-release them separately
+ in the new MIME-Base64-Perl distribution.
+
+ The 'gcc -Wall' fix in 2.22 broke support for perl5.005,
+ as the isXDIGIT() macro is not available in that perl.
+ This problem has now been fixed.
+
+
+
2004-01-08 Gisle Aas <gisle@ActiveState.com>
Release 2.23
-#
-# $Id: QuotedPrint.pm,v 2.19 2004/01/08 14:07:26 gisle Exp $
-
package MIME::QuotedPrint;
+# $Id: QuotedPrint.pm,v 3.0 2004/01/14 11:59:07 gisle Exp $
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(encode_qp decode_qp);
+
+$VERSION = "3.00";
+
+use MIME::Base64; # will load XS version of {en,de}code_qp()
+
+*encode = \&encode_qp;
+*decode = \&decode_qp;
+
+1;
+
+__END__
+
=head1 NAME
MIME::QuotedPrint - Encoding and decoding of quoted-printable strings
L<MIME::Base64>
=cut
-
-use strict;
-use vars qw(@ISA @EXPORT $VERSION);
-if (ord('A') == 193) { # on EBCDIC machines we need translation help
- require Encode;
-}
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(encode_qp decode_qp);
-
-$VERSION = "2.21";
-
-use MIME::Base64; # try to load XS version of encode_qp
-unless (defined &encode_qp) {
- *encode_qp = \&old_encode_qp;
- *decode_qp = \&old_decode_qp;
-}
-
-sub old_encode_qp ($;$)
-{
- my $res = shift;
- if ($] >= 5.006) {
- require bytes;
- if (bytes::length($res) > length($res) ||
- ($] >= 5.008 && $res =~ /[^\0-\xFF]/))
- {
- require Carp;
- Carp::croak("The Quoted-Printable encoding is only defined for bytes");
- }
- }
-
- my $eol = shift;
- $eol = "\n" unless defined $eol;
-
- # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
- # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
- if (ord('A') == 193) { # EBCDIC style machine
- if (ord('[') == 173) {
- $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$1))))/eg; # rule #2,#3
- $res =~ s/([ \t]+)$/
- join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
- split('', $1)
- )/egm; # rule #3 (encode whitespace at eol)
- }
- elsif (ord('[') == 187) {
- $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$1))))/eg; # rule #2,#3
- $res =~ s/([ \t]+)$/
- join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
- split('', $1)
- )/egm; # rule #3 (encode whitespace at eol)
- }
- elsif (ord('[') == 186) {
- $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$1))))/eg; # rule #2,#3
- $res =~ s/([ \t]+)$/
- join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
- split('', $1)
- )/egm; # rule #3 (encode whitespace at eol)
- }
- }
- else { # ASCII style machine
- $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
- $res =~ s/\n/=0A/g unless length($eol);
- $res =~ s/([ \t]+)$/
- join('', map { sprintf("=%02X", ord($_)) }
- split('', $1)
- )/egm; # rule #3 (encode whitespace at eol)
- }
-
- return $res unless length($eol);
-
- # rule #5 (lines must be shorter than 76 chars, but we are not allowed
- # to break =XX escapes. This makes things complicated :-( )
- my $brokenlines = "";
- $brokenlines .= "$1=$eol"
- while $res =~ s/(.*?^[^\n]{73} (?:
- [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
- |[^=\n] (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
- | (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
- ))//xsm;
- $res =~ s/\n\z/$eol/;
-
- "$brokenlines$res";
-}
-
-
-sub old_decode_qp ($)
-{
- my $res = shift;
- $res =~ s/\r\n/\n/g; # normalize newlines
- $res =~ s/[ \t]+\n/\n/g; # rule #3 (trailing space must be deleted)
- $res =~ s/=\n//g; # rule #5 (soft line breaks)
- if (ord('A') == 193) { # EBCDIC style machine
- if (ord('[') == 173) {
- $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp1047',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
- }
- elsif (ord('[') == 187) {
- $res =~ s/=([\da-fA-F]{2})/Encode::encode('posix-bc',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
- }
- elsif (ord('[') == 186) {
- $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
- }
- }
- else { # ASCII style machine
- $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
- }
- $res;
-}
-
-# Set up aliases so that these functions also can be called as
-#
-# MIME::QuotedPrint::encode();
-# MIME::QuotedPrint::decode();
-
-*encode = \&encode_qp;
-*decode = \&decode_qp;
-
-1;
--- /dev/null
+#!perl -w
+
+BEGIN {
+ eval {
+ require Perl::API;
+ };
+ if ($@) {
+ print "1..0 # skipped: Perl::API needed for this test\n";
+ print $@;
+ exit;
+ }
+}
+
+use strict;
+use Test qw(plan ok);
+use Perl::API qw(SvCUR SvCUR_set SvLEN);
+use MIME::Base64 qw(encode_base64 decode_base64);
+use MIME::QuotedPrint qw(encode_qp decode_qp);
+
+plan tests => 6;
+
+my $a = "abc";
+
+ok(SvCUR($a), 3);
+ok(SvLEN($a), 4);
+
+# Make sure that encode_base64 does not look beyond SvCUR().
+# This was fixed in v2.21. Valgrind would also show some
+# illegal reads on this.
+
+SvCUR_set($a, 1);
+ok(encode_base64($a), "YQ==\n");
+
+SvCUR_set($a, 4);
+ok(encode_base64($a), "YWJjAA==\n");
+
+ok(encode_qp($a), "abc=00");
+
+$a = "ab\n";
+
+SvCUR_set($a, 2);
+ok(encode_qp($a), "ab");
print "not ";
}
- if (ord('A') != 193) { # perl versions broken on EBCDIC
- # Try the old Perl versions too
- if ($encoded ne MIME::Base64::old_encode_base64($plain, '')) {
- print "old_encode_base64 give different result.\n";
- print "not ";
- }
- if ($plain ne MIME::Base64::old_decode_base64($encoded)) {
- print "old_decode_base64 give different result.\n";
- print "not ";
- }
- }
-
print "ok $testno\n";
$testno++;
}
--- /dev/null
+#!perl -w
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}){
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+BEGIN {
+ eval {
+ require warnings;
+ };
+ if ($@) {
+ print "1..0\n";
+ print $@;
+ exit;
+ }
+}
+
+use strict;
+use MIME::Base64 qw(decode_base64);
+
+print "1..1\n";
+
+use warnings;
+
+my @warn;
+$SIG{__WARN__} = sub { push(@warn, @_) };
+
+warn;
+my $a;
+$a = decode_base64("aa");
+$a = decode_base64("a===");
+warn;
+$a = do {
+ no warnings;
+ decode_base64("aa");
+};
+$a = do {
+ no warnings;
+ decode_base64("a===");
+};
+warn;
+$a = do {
+ local $^W;
+ decode_base64("aa");
+};
+$a = do {
+ local $^W;
+ decode_base64("a===");
+};
+warn;
+
+if ($^O eq 'MSWin32') {
+ for (@warn) {
+ s|\\|/|g;
+ }
+}
+
+for (@warn) {
+ print "# $_";
+}
+
+print "not " unless join("", @warn) eq <<"EOT"; print "ok 1\n";
+Warning: something's wrong at $0 line 31.
+Premature end of base64 data at $0 line 33.
+Premature padding of base64 data at $0 line 34.
+Warning: something's wrong at $0 line 35.
+Premature end of base64 data at $0 line 38.
+Premature padding of base64 data at $0 line 42.
+Warning: something's wrong at $0 line 44.
+Warning: something's wrong at $0 line 53.
+EOT
projects / p5sagit/p5-mst-13.2.git / commitdiff