Change 14280: Update bundled modules. Yow!
[email protected] (Chris Nandor) Tue, 15 Jan 2002 11:07:53 -0500
| Newsgroups | perl.perl5.changes.mac |
|---|---|
| Message-ID | <p05100304b86a04403523@[10.0.1.177]> |
Change 14280 by pudge@pudge-mobile on 2002/01/15 14:55:25
Update bundled modules. Yow!
Affected files ...
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/ANNOUNCE#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/Makefile.PL#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/Makefile.mk#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/README#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/Zlib.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/Zlib.xs#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/constants.h#1 add
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/constants.xs#1 add
.... //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/t/examples.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Call.pm#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Call.xs#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Makefile.PL#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/ppport.h#1 add
.... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/FilterTest.pm#2 delete
.... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/call.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/filter-util.pl#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/ChangeLog#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/README#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/Storable.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/blessed.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/canonical.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/compat-0.6.t#3 add
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/compat06.t#2 delete
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/dclone.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/dump.pl#3 add
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/forgive.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/freeze.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/lock.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/overload.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/recurse.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/retrieve.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/st-dump.pl#2 delete
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/store.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/tied.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/tied_hook.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/tied_items.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/utf8.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/File/Sort.pm#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Filter/Simple.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Headers.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Message.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Negotiate.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Request.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Response.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP/Authen/Digest.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP/Protocol/http.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP/Protocol/https.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP/UserAgent.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Address.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Cap.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Field.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Field/AddrList.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Field/Date.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Filter.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Header.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Internet.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Mailer.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Mailer/qmail.pm#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Mailer/test.pm#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Send.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Util.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/NEXT.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/Config.pm#4 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/Domain.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/FTP.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/FTP/E.pm#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/FTP/L.pm#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/HTTP.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/HTTP/Methods.pm#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/HTTPS.pm#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/NNTP.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/POP3.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/SMTP.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/libnetFAQ.pod#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Switch.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Text/Balanced.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/URI/Escape.pm#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/URI/ftp.pm#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/URI/ssh.pm#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/lwpcook.pod#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/ExportTest.pm#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/FilterOnlyTest.pm#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/FilterTest.pm#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/ImportTest.pm#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/data.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/export.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/filter.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/filter_only.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/import.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/actual.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/actuns.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/next.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/test.pl#3 delete
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/unseen.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Switch/t/nested.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extbrk.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extcbk.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extdel.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extmul.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extqlk.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/exttag.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extvar.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/gentag.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/config.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/ftp.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/hostname.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/netrc.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/nntp.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/require.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/smtp.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/base/headers.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/base/http.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/base/negotiate.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/activestate.t#1 add
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/google.t#2 delete
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-b.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-d.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-chunk.t#3 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-md5.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-te.t#2 edit
.... //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/validator.t#2 edit
.... //depot/maint-5.6/macperl/macos/lib/Mac/AppleEvents/Simple.pm#3 edit
.... //depot/maint-5.6/macperl/macos/lib/Mac/Glue.pm#4 edit
Differences ...
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/ANNOUNCE#2 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/ANNOUNCE
--- perl/macos/bundled_ext/Compress/Zlib/ANNOUNCE.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/ANNOUNCE Tue Jan 15 08:00:05 2002
@@ -41,13 +41,11 @@
The latest copy of Compress::ZLib is available on CPAN
- modules/by-module/Compress/Compress-Zlib-*
+ http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz
and zlib is available at
- http://www.cdrom.com/pub/infozip/zlib/
- ftp://ftp.uu.net/pub/archiving/zip/zlib*
- ftp://swrinde.nde.swri.edu/pub/png/src/zlib*
+ http://www.gzip.org/zlib/
Paul Marquess
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/Makefile.PL#3 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/Makefile.PL
--- perl/macos/bundled_ext/Compress/Zlib/Makefile.PL.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/Makefile.PL Tue Jan 15 08:00:05 2002
@@ -3,7 +3,7 @@
require 5.004 ;
use ExtUtils::MakeMaker 5.16 ;
use Config ;
-use File::Copy ;
+#use File::Copy ;
my $ZLIB_LIB ;
my $ZLIB_INCLUDE ;
@@ -11,19 +11,18 @@
ParseCONFIG() ;
-my @files = ('Zlib.pm', glob("t/*.t"), grep(!/\.bak$/, glob("examples/*"))) ;
-# warnings pragma is stable from 5.6.1 onward
-if ($] < 5.006001)
- { oldWarnings(@files) }
-else
- { newWarnings(@files) }
+my @files ;#= ('Zlib.pm', glob("t/*.t"), grep(!/\.bak$/, glob("examples/*"))) ;
+UpDowngrade(@files);
WriteMakefile(
NAME => 'Compress::Zlib',
VERSION_FROM => 'Zlib.pm',
INC => "-I$ZLIB_INCLUDE" ,
- 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz',
- DIST_DEFAULT => 'MyDoubleCheck tardist',
+ XS => { 'Zlib.xs' => 'Zlib.c' },
+ 'depend' => { 'Makefile' => 'config.in' },
+ 'clean' => { FILES => 'constants.h constants.xs' },
+ 'dist' => { COMPRESS=>'gzip', SUFFIX=>'gz',
+ DIST_DEFAULT => 'MyDoubleCheck Downgrade tardist',
},
($BUILD_ZLIB
? (MYEXTLIB => "$ZLIB_LIB/libz\$(LIB_EXT)")
@@ -36,24 +35,111 @@
),
) ;
+my @names = qw(
+
+ DEF_WBITS
+ MAX_MEM_LEVEL
+ MAX_WBITS
+ OS_CODE
+
+ Z_ASCII
+ Z_BEST_COMPRESSION
+ Z_BEST_SPEED
+ Z_BINARY
+ Z_BUF_ERROR
+ Z_DATA_ERROR
+ Z_DEFAULT_COMPRESSION
+ Z_DEFAULT_STRATEGY
+ Z_DEFLATED
+ Z_ERRNO
+ Z_FILTERED
+ Z_FINISH
+ Z_FULL_FLUSH
+ Z_HUFFMAN_ONLY
+ Z_MEM_ERROR
+ Z_NEED_DICT
+ Z_NO_COMPRESSION
+ Z_NO_FLUSH
+ Z_NULL
+ Z_OK
+ Z_PARTIAL_FLUSH
+ Z_STREAM_END
+ Z_STREAM_ERROR
+ Z_SYNC_FLUSH
+ Z_UNKNOWN
+ Z_VERSION_ERROR
+ );
+
+if (eval {require ExtUtils::Constant; 1}) {
+ # Check the constants above all appear in @EXPORT in Zlib.pm
+ my %names = map { $_, 1} @names, 'ZLIB_VERSION';
+ open F, "<Zlib.pm" or die "Cannot open Zlib.pm: $!\n";
+ while (<F>)
+ {
+ last if /^\s*\@EXPORT\s+=\s+qw\(/ ;
+ }
+
+ while (<F>)
+ {
+ last if /^\s*\)/ ;
+ /(\S+)/ ;
+ delete $names{$1} if defined $1 ;
+ }
+ close F ;
+
+ if ( keys %names )
+ {
+ my $missing = join ("\n\t", sort keys %names) ;
+ die "The following names are missing from \@EXPORT in Zlib.pm\n" .
+ "\t$missing\n" ;
+ }
+
+ push @names, {name => 'ZLIB_VERSION', type => 'PV' };
+
+ ExtUtils::Constant::WriteConstants(
+ NAME => 'Zlib',
+ NAMES => \@names,
+ C_FILE => 'constants.h',
+ XS_FILE => 'constants.xs',
+
+ );
+}
+else {
+# use File::Copy;
+# copy ('fallback.h', 'constants.h')
+# or die "Can't copy fallback.h to constants.h: $!";
+# copy ('fallback.xs', 'constants.xs')
+# or die "Can't copy fallback.xs to constants.xs: $!";
+}
+
sub MY::postamble {
- my $postamble =<<'END';
+ my $postamble = '
+
+Downgrade:
+ @echo Downgrading.
+ perl Makefile.PL -downgrade
MyDoubleCheck:
@echo Checking config.in is setup for a release
- @(grep '^LIB.*/usr/local/lib' config.in && \
- grep '^INCLUDE.*/usr/local/include' config.in && \
- grep '^BUILD_ZLIB.*False' config.in) >/dev/null || \
+ @(grep "^LIB.*/usr/local/lib" config.in && \
+ grep "^INCLUDE.*/usr/local/include" config.in && \
+ grep "^BUILD_ZLIB.*False" config.in) >/dev/null || \
(echo config.in needs fixing ; exit 1)
@echo config.in is ok
+MyTrebleCheck:
+ @echo Checking for $$^W in files: '. "@files" . '
+ @perl -ne \' \
+ exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/; \
+ \' ' . " @files || " . ' \
+ (echo found unexpected $$^W ; exit 1)
+ @echo All is ok.
+
Zlib.xs: typemap
@$(TOUCH) Zlib.xs
-Makefile: config.in
+' ;
-END
-
if ($BUILD_ZLIB) {
$postamble .=<<END ;
\$(MYEXTLIB): $ZLIB_LIB/Makefile
@@ -129,8 +215,8 @@
# check Makefile.NT has been copied to ZLIB_DIR
if (! -e "$ZLIB_LIB/Makefile.PL") {
- copy 'Makefile.NT', "$ZLIB_LIB/Makefile.PL" ||
- die "Could not copy Makefile.NT to $ZLIB_LIB/Makefile.PL: $!\n" ;
+# copy 'Makefile.NT', "$ZLIB_LIB/Makefile.PL" ||
+# die "Could not copy Makefile.NT to $ZLIB_LIB/Makefile.PL: $!\n" ;
print "Created a Makefile.PL for zlib\n" ;
}
@@ -148,51 +234,98 @@
}
-sub oldWarnings
+sub UpDowngrade
{
- local ($^I) = ".bak" ;
- local (@ARGV) = @_ ;
+ my @files = @_ ;
+
+ # our is stable from 5.6.0 onward
+ # warnings is stable from 5.6.1 onward
+
+ # Note: this code assumes that each statement it modifies is not
+ # split across multiple lines.
+
+
+ my $warn_sub = '';
+ my $our_sub = '' ;
+
+ my $opt = shift @ARGV || '' ;
+ my $upgrade = ($opt =~ /^-upgrade/i);
+ my $downgrade = ($opt =~ /^-downgrade/i);
+ push @ARGV, $opt unless $downgrade || $upgrade;
+
+ if ($downgrade) {
+ # From: use|no warnings "blah"
+ # To: local ($^W) = 1; # use|no warnings "blah"
+ $warn_sub = sub {
+ s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
+ s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
+ };
+ }
+ elsif ($] >= 5.006001 || $upgrade) {
+ # From: local ($^W) = 1; # use|no warnings "blah"
+ # To: use|no warnings "blah"
+ $warn_sub = sub {
+ s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
+ };
+ }
- while (<>)
- {
- if (/^__END__/)
- {
- print ;
- my $this = $ARGV ;
- while (<>)
- {
- last if $ARGV ne $this ;
- print ;
- }
- }
+ if ($downgrade) {
+ $our_sub = sub {
+ if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
+ my $indent = $1;
+ my $vars = join ' ', split /\s*,\s*/, $2;
+ $_ = "${indent}use vars qw($vars);\n";
+ }
+ };
+ }
+ elsif ($] >= 5.006000 || $upgrade) {
+ $our_sub = sub {
+ if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
+ my $indent = $1;
+ my $vars = join ', ', split ' ', $2;
+ $_ = "${indent}our ($vars);\n";
+ }
+ };
+ }
- s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
- s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
- print ;
+ if (! $our_sub && ! $warn_sub) {
+ warn "Up/Downgrade not needed.\n";
+ if ($upgrade || $downgrade)
+ { exit 0 }
+ else
+ { return }
}
+
+ foreach (@files)
+ { doUpDown($our_sub, $warn_sub, $_) }
+
+ warn "Up/Downgrade complete.\n" ;
+ exit 0 if $upgrade || $downgrade;
+
}
-sub newWarnings
+
+sub doUpDown
{
+ my $our_sub = shift;
+ my $warn_sub = shift;
+
local ($^I) = ".bak" ;
- local (@ARGV) = @_ ;
+ local (@ARGV) = shift;
while (<>)
{
- if (/^__END__/)
- {
- my $this = $ARGV ;
- print ;
- while (<>)
- {
- last if $ARGV ne $this ;
- print ;
- }
- }
+ print, last if /^__(END|DATA)__/ ;
- s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
+ &{ $our_sub }() if $our_sub ;
+ &{ $warn_sub }() if $warn_sub ;
print ;
}
+
+ return if eof ;
+
+ while (<>)
+ { print }
}
# end of file Makefile.PL
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/Makefile.mk#3 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/Makefile.mk
--- perl/macos/bundled_ext/Compress/Zlib/Makefile.mk.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/Makefile.mk Tue Jan 15 08:00:05 2002
@@ -1,7 +1,7 @@
# This Makefile is for the Compress::Zlib extension to perl.
#
# It was generated automatically by MakeMaker version
-# (Revision: ) from the contents of
+# 1.16 (Revision: ) from the contents of
# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
#
# ANY CHANGES MADE HERE WILL BE LOST!
@@ -14,16 +14,18 @@
# LIBS => [q[-L/usr/local/lib -lz ]]
# NAME => q[Compress::Zlib]
# VERSION_FROM => q[Zlib.pm]
-# depend => { dist=>q[MyRelease] }
-# dist => { COMPRESS=>q[gzip], SUFFIX=>q[gz] }
+# XS => { Zlib.xs=>q[Zlib.c] }
+# clean => { FILES=>q[constants.h constants.xs] }
+# depend => { Makefile=>q[config.in] }
+# dist => { DIST_DEFAULT=>q[MyDoubleCheck Downgrade tardist], COMPRESS=>q[gzip], SUFFIX=>q[gz] }
# --- MakeMaker constants section:
NAME = Compress::Zlib
DISTNAME = Compress-Zlib
NAME_SYM = Compress_Zlib
-VERSION = 1.14
-VERSION_SYM = 1_14
-XS_VERSION = 1.14
+VERSION = 1.16
+VERSION_SYM = 1_16
+XS_VERSION = 1.16
INST_LIB = :::::lib
INST_ARCHLIB = :::::lib
PERL_LIB = :::::lib
@@ -78,6 +80,7 @@
C_FILES = Zlib.c \
adler32.c \
compress.c \
+ constants.c \
crc32.c \
deflate.c \
gzio.c \
@@ -91,7 +94,8 @@
trees.c \
uncompr.c \
zutil.c
-H_FILES = deflate.h \
+H_FILES = constants.h \
+ deflate.h \
infblock.h \
infcodes.h \
inffast.h \
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/README#3 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/README
--- perl/macos/bundled_ext/Compress/Zlib/README.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/README Tue Jan 15 08:00:05 2002
@@ -1,8 +1,8 @@
Compress::Zlib
- Version 1.14
+ Version 1.16
- 27th August 2001
+ 13 December 2001
Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
@@ -285,7 +285,22 @@
1.14 - 27th August 2001
- * Memory overwrite bug fixed in "inflate". Kudos to Rob Somons for
+ * Memory overwrite bug fixed in "inflate". Kudos to Rob Simons for
reporting the bug and to Anton Berezin for fixing it for me.
+ 1.15 - 4th December 2001
+
+ * Changes a few types to get the module to build on 64-bit Solaris
+
+ * Changed the up/downgrade logic to default to the older constructs, and
+ to only call a downgrade if specifically requested. Some older versions
+ of Perl were having problems with the in-place edit.
+
+ * added the new XS constant code.
+
+ 1.16 - 13 December 2001
+
+ * Fixed bug in Makefile.PL that stopped "perl Makefile.PL PREFIX=..."
+ working.
+
Paul Marquess <[email protected]>
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/Zlib.pm#3 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/Zlib.pm
--- perl/macos/bundled_ext/Compress/Zlib/Zlib.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/Zlib.pm Tue Jan 15 08:00:05 2002
@@ -1,7 +1,7 @@
# File : Zlib.pm
# Author : Paul Marquess
-# Created : 27th August 2001
-# Version : 1.14
+# Created : 13 December 2001
+# Version : 1.16
#
# Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
@@ -19,28 +19,35 @@
use strict ;
use warnings ;
-use vars qw($VERSION @ISA @EXPORT $AUTOLOAD
- $deflateDefault $deflateParamsDefault $inflateDefault) ;
+use vars qw($VERSION @ISA @EXPORT $AUTOLOAD);
+use vars qw($deflateDefault $deflateParamsDefault $inflateDefault);
-$VERSION = "1.14" ;
+$VERSION = "1.16" ;
@ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
- deflateInit inflateInit
+ deflateInit
+ inflateInit
- compress uncompress
+ compress
+ uncompress
gzip gunzip
- gzopen $gzerrno
+ gzopen
+ $gzerrno
- adler32 crc32
+ adler32
+ crc32
ZLIB_VERSION
+ DEF_WBITS
+ OS_CODE
+
MAX_MEM_LEVEL
MAX_WBITS
@@ -75,24 +82,13 @@
sub AUTOLOAD {
- # This AUTOLOAD is used to 'autoload' constants from the constant()
- # XS function. If a constant is not found then control is passed
- # to the AUTOLOAD in AutoLoader.
-
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
- if ($! =~ /Invalid/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- croak "Your vendor has not defined Compress::Zlib macro $constname"
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
}
bootstrap Compress::Zlib $VERSION ;
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/Zlib.xs#3 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/Zlib.xs
--- perl/macos/bundled_ext/Compress/Zlib/Zlib.xs.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/Zlib.xs Tue Jan 15 08:00:05 2002
@@ -1,7 +1,7 @@
/* Filename: Zlib.xs
* Author : Paul Marquess, <[email protected]>
- * Created : 27th August 2001
- * Version : 1.14
+ * Created : 13 December 2001
+ * Version : 1.16
*
* Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
* This program is free software; you can redistribute it and/or
@@ -42,7 +42,7 @@
typedef struct di_stream {
z_stream stream;
- int bufsize;
+ uLong bufsize;
SV * dictionary ;
uLong dict_adler ;
} di_stream;
@@ -56,7 +56,7 @@
typedef struct gzType {
gzFile gz ;
SV * buffer ;
- int offset ;
+ uLong offset ;
bool closed ;
} gzType ;
@@ -69,6 +69,9 @@
#define GZERRNO "Compress::Zlib::gzerrno"
+#define adlerInitial adler32(0L, Z_NULL, 0)
+#define crcInitial crc32(0L, Z_NULL, 0)
+
#if 1
static char *my_z_errmsg[] = {
"need dictionary", /* Z_NEED_DICT 2 */
@@ -84,10 +87,7 @@
#endif
-static uLong adlerInitial ;
-static uLong crcInitial ;
static int trace = 0 ;
-SV *sv_NULL ;
static void
#ifdef CAN_PROTOTYPE
@@ -130,12 +130,44 @@
SetGzErrorNo(error_no) ;
}
+static void
+#ifdef CAN_PROTOTYPE
+DispStream(di_stream * s, char * message)
+#else
+DispStream(s, message)
+ di_stream * s;
+ char * message;
+#endif
+{
+ if (! trace)
+ return ;
+
+ printf("DispStream %d - %s \n", s, message) ;
+
+ if (s) {
+ printf(" stream %lx\n", s->stream);
+ printf(" stream.zalloc %lx\n", s->stream.zalloc);
+ printf(" stream.zfree %lx\n", s->stream.zfree);
+ printf(" stream.opaque %lx\n", s->stream.opaque);
+ printf(" stream.next_in %lx\n", s->stream.next_in);
+ printf(" stream.next_out %lx\n", s->stream.next_out);
+ printf(" stream.avail_in %lx\n", s->stream.avail_in);
+ printf(" stream.avail_out %lx\n", s->stream.avail_out);
+ printf(" bufsize %lx\n", s->bufsize);
+ printf(" dictionary %lx\n", s->dictionary);
+ printf(" dict_adler %lx\n", s->dict_adler);
+ printf("\n");
+
+ }
+}
+
+
static di_stream *
#ifdef CAN_PROTOTYPE
-InitStream(int bufsize)
+InitStream(uLong bufsize)
#else
InitStream(bufsize)
- int bufsize ;
+ uLong bufsize ;
#endif
{
di_stream *s = (di_stream *)safemalloc(sizeof(di_stream));
@@ -234,270 +266,20 @@
}
if (!SvOK(sv)) {
- sv = sv_NULL ;
+ sv = newSVpv("", 0);
}
return sv ;
}
-static double
-#ifdef CAN_PROTOTYPE
-constant(char * name, int arg)
-#else
-constant(name, arg)
-char *name;
-int arg;
-#endif
-{
- errno = 0;
- switch (*name) {
- case 'A':
- break;
- case 'B':
- break;
- case 'C':
- break;
- case 'D':
- if (strEQ(name, "DEF_WBITS"))
-#ifdef DEF_WBITS
- return DEF_WBITS;
-#else
- goto not_there;
-#endif
- break;
- case 'E':
- break;
- case 'F':
- goto not_there;
- break;
- case 'G':
- break;
- case 'H':
- break;
- case 'I':
- break;
- case 'J':
- break;
- case 'K':
- break;
- case 'L':
- break;
- case 'M':
- if (strEQ(name, "MAX_MEM_LEVEL"))
-#ifdef MAX_MEM_LEVEL
- return MAX_MEM_LEVEL;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "MAX_WBITS"))
-#ifdef MAX_WBITS
- return MAX_WBITS;
-#else
- goto not_there;
-#endif
- break;
- case 'N':
- break;
- case 'O':
- if (strEQ(name, "OS_CODE"))
-#ifdef OS_CODE
- return OS_CODE;
-#else
- goto not_there;
-#endif
- break;
- case 'P':
- break;
- case 'Q':
- break;
- case 'R':
- break;
- case 'S':
- break;
- case 'T':
- break;
- case 'U':
- break;
- case 'V':
- break;
- case 'W':
- break;
- case 'X':
- break;
- case 'Y':
- break;
- case 'Z':
- if (strEQ(name, "Z_ASCII"))
-#ifdef Z_ASCII
- return Z_ASCII;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_BEST_COMPRESSION"))
-#ifdef Z_BEST_COMPRESSION
- return Z_BEST_COMPRESSION;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_BEST_SPEED"))
-#ifdef Z_BEST_SPEED
- return Z_BEST_SPEED;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_BINARY"))
-#ifdef Z_BINARY
- return Z_BINARY;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_BUF_ERROR"))
-#ifdef Z_BUF_ERROR
- return Z_BUF_ERROR;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_DATA_ERROR"))
-#ifdef Z_DATA_ERROR
- return Z_DATA_ERROR;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_DEFAULT_COMPRESSION"))
-#ifdef Z_DEFAULT_COMPRESSION
- return Z_DEFAULT_COMPRESSION;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_DEFAULT_STRATEGY"))
-#ifdef Z_DEFAULT_STRATEGY
- return Z_DEFAULT_STRATEGY;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_DEFLATED"))
-#ifdef Z_DEFLATED
- return Z_DEFLATED;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_ERRNO"))
-#ifdef Z_ERRNO
- return Z_ERRNO;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_FILTERED"))
-#ifdef Z_FILTERED
- return Z_FILTERED;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_FINISH"))
-#ifdef Z_FINISH
- return Z_FINISH;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_FULL_FLUSH"))
-#ifdef Z_FULL_FLUSH
- return Z_FULL_FLUSH;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_HUFFMAN_ONLY"))
-#ifdef Z_HUFFMAN_ONLY
- return Z_HUFFMAN_ONLY;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_MEM_ERROR"))
-#ifdef Z_MEM_ERROR
- return Z_MEM_ERROR;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_NEED_DICT"))
-#ifdef Z_NEED_DICT
- return Z_NEED_DICT;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_NO_COMPRESSION"))
-#ifdef Z_NO_COMPRESSION
- return Z_NO_COMPRESSION;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_NO_FLUSH"))
-#ifdef Z_NO_FLUSH
- return Z_NO_FLUSH;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_NULL"))
-#ifdef Z_NULL
- return Z_NULL;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_OK"))
-#ifdef Z_OK
- return Z_OK;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_PARTIAL_FLUSH"))
-#ifdef Z_PARTIAL_FLUSH
- return Z_PARTIAL_FLUSH;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_STREAM_END"))
-#ifdef Z_STREAM_END
- return Z_STREAM_END;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_STREAM_ERROR"))
-#ifdef Z_STREAM_ERROR
- return Z_STREAM_ERROR;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_SYNC_FLUSH"))
-#ifdef Z_SYNC_FLUSH
- return Z_SYNC_FLUSH;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_UNKNOWN"))
-#ifdef Z_UNKNOWN
- return Z_UNKNOWN;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "Z_VERSION_ERROR"))
-#ifdef Z_VERSION_ERROR
- return Z_VERSION_ERROR;
-#else
- goto not_there;
-#endif
- break;
- }
- errno = EINVAL;
- return 0;
-
-not_there:
- errno = ENOENT;
- return 0;
-}
+#include "constants.h"
-
MODULE = Compress::Zlib PACKAGE = Compress::Zlib PREFIX = Zip_
REQUIRE: 1.924
PROTOTYPES: DISABLE
+INCLUDE: constants.xs
+
BOOT:
/* Check this version of zlib is == 1 */
if (zlibVersion()[0] != '1')
@@ -510,22 +292,12 @@
sv_setpv(gzerror_sv, "") ;
SvIOK_on(gzerror_sv) ;
}
- sv_NULL = newSVpv("", 0);
#define Zip_zlib_version() (char*)zlib_version
char*
Zip_zlib_version()
-#define Zip_ZLIB_VERSION() ZLIB_VERSION
-char *
-Zip_ZLIB_VERSION()
-
-double
-constant(name,arg)
- char * name
- int arg
-
Compress::Zlib::gzFile
gzopen_(path, mode)
@@ -586,7 +358,7 @@
unsigned len
SV * buf
voidp bufp = NO_INIT
- int bufsize = 0 ;
+ uLong bufsize = 0 ;
int RETVAL = 0 ;
CODE:
if (SvREADONLY(buf) && PL_curcop != &PL_compiling)
@@ -597,7 +369,7 @@
SvCUR_set(buf, 0);
/* any left over from gzreadline ? */
if ((bufsize = SvCUR(file->buffer)) > 0) {
- int movesize ;
+ uLong movesize ;
RETVAL = bufsize ;
if (bufsize < len) {
@@ -702,10 +474,6 @@
MODULE = Compress::Zlib PACKAGE = Compress::Zlib PREFIX = Zip_
-BOOT:
- adlerInitial = adler32(0L, Z_NULL, 0);
- crcInitial = crc32(0L, Z_NULL, 0);
-
#define Zip_adler32(buf, adler) adler32(adler, buf, (uInt)len)
uLong
@@ -720,11 +488,11 @@
buf = (Byte*)SvPV(sv, len) ;
if (items < 2)
- adler = adlerInitial ;
+ adler = adlerInitial;
else if (SvOK(ST(1)))
adler = SvUV(ST(1)) ;
else
- adler = crcInitial ;
+ adler = adlerInitial;
#define Zip_crc32(buf, crc) crc32(crc, buf, (uInt)len)
@@ -740,11 +508,11 @@
buf = (Byte*)SvPV(sv, len) ;
if (items < 2)
- crc = crcInitial ;
+ crc = crcInitial;
else if (SvOK(ST(1)))
crc = SvUV(ST(1)) ;
else
- crc = crcInitial ;
+ crc = crcInitial;
MODULE = Compress::Zlib PACKAGE = Compress::Zlib
@@ -755,7 +523,7 @@
int windowBits
int memLevel
int strategy
- int bufsize
+ uLong bufsize
SV * dictionary
PPCODE:
@@ -793,7 +561,7 @@
void
_inflateInit(windowBits, bufsize, dictionary)
int windowBits
- int bufsize
+ uLong bufsize
SV * dictionary
PPCODE:
@@ -831,7 +599,7 @@
deflate (s, buf)
Compress::Zlib::deflateStream s
SV * buf
- int outsize = NO_INIT
+ uLong outsize = NO_INIT
SV * output = NO_INIT
int err = 0;
PPCODE:
@@ -841,7 +609,8 @@
/* initialise the input buffer */
s->stream.next_in = (Bytef*)SvPV(buf, *(STRLEN*)&s->stream.avail_in) ;
- /* s->stream.avail_in = SvCUR(buf) ; */
+ /* s->stream.next_in = (Bytef*)SvPVX(buf); */
+ s->stream.avail_in = SvCUR(buf) ;
/* and the output buffer */
/* output = sv_2mortal(newSVpv("", s->bufsize)) ; */
@@ -852,6 +621,7 @@
s->stream.next_out = (Bytef*) SvPVX(output) ;
s->stream.avail_out = outsize;
+
while (s->stream.avail_in != 0) {
if (s->stream.avail_out == 0) {
@@ -890,7 +660,7 @@
flush(s, f=Z_FINISH)
Compress::Zlib::deflateStream s
int f
- int outsize = NO_INIT
+ uLong outsize = NO_INIT
SV * output = NO_INIT
int err = Z_OK ;
PPCODE:
@@ -959,7 +729,7 @@
inflate (s, buf)
Compress::Zlib::inflateStream s
SV * buf
- int outsize = NO_INIT
+ uLong outsize = NO_INIT
SV * output = NO_INIT
int err = Z_OK ;
ALIAS:
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/t/examples.t#3 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/t/examples.t
--- perl/macos/bundled_ext/Compress/Zlib/t/examples.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/t/examples.t Tue Jan 15 08:00:05 2002
@@ -11,6 +11,7 @@
print "ok $no\n" if $ok ;
print "not ok $no\n" unless $ok ;
+ printf "# Failed test at line %d\n", (caller)[2] unless $ok ;
}
sub writeFile
@@ -41,7 +42,7 @@
my $Inc = '' ;
foreach (@INC)
- { $Inc .= "-I$_ " }
+ { $Inc .= "-I'$_' " }
my $Perl = '' ;
$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ;
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Call.pm#2 (text) ====
Index: perl/macos/bundled_ext/Filter/Util/Call/Call.pm
--- perl/macos/bundled_ext/Filter/Util/Call/Call.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Filter/Util/Call/Call.pm Tue Jan 15 08:00:05 2002
@@ -18,7 +18,7 @@
@ISA = qw(Exporter DynaLoader);
@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ;
-$VERSION = "1.05" ;
+$VERSION = "1.06" ;
sub filter_read_exact($)
{
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Call.xs#2 (text) ====
Index: perl/macos/bundled_ext/Filter/Util/Call/Call.xs
--- perl/macos/bundled_ext/Filter/Util/Call/Call.xs.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Filter/Util/Call/Call.xs Tue Jan 15 08:00:05 2002
@@ -2,8 +2,8 @@
* Filename : Call.xs
*
* Author : Paul Marquess
- * Date : 26th March 2000
- * Version : 1.05
+ * Date : 11th November 2001
+ * Version : 1.06
*
* Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
* This program is free software; you can redistribute it and/or
@@ -15,28 +15,10 @@
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
-
-#ifndef PERL_VERSION
-# include "patchlevel.h"
-# define PERL_REVISION 5
-# define PERL_VERSION PATCHLEVEL
-# define PERL_SUBVERSION SUBVERSION
-#endif
-
-/* defgv must be accessed differently under threaded perl */
-/* DEFSV et al are in 5.004_56 */
-#ifndef DEFSV
-# define DEFSV GvSV(defgv)
-#endif
-
-#ifndef pTHX
-# define pTHX
-# define pTHX_
-# define aTHX
-# define aTHX_
+#ifdef _NOT_CORE
+# include "ppport.h"
#endif
-
/* Internal defines */
#define PERL_MODULE(s) IoBOTTOM_NAME(s)
#define PERL_OBJECT(s) IoTOP_GV(s)
@@ -48,13 +30,25 @@
do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
+/* Global Data */
+
+#define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION
+
+typedef struct {
+ int x_fdebug ;
+ int x_current_idx ;
+} my_cxt_t;
+
+START_MY_CXT
+
+#define fdebug (MY_CXT.x_fdebug)
+#define current_idx (MY_CXT.x_current_idx)
-static int fdebug = 0;
-static int current_idx ;
static I32
filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
{
+ dMY_CXT;
SV *my_sv = FILTER_DATA(idx);
char *nl = "\n";
char *p;
@@ -204,6 +198,7 @@
int size
CODE:
{
+ dMY_CXT;
SV * buffer = DEFSV ;
RETVAL = FILTER_READ(IDX + 1, buffer, size) ;
@@ -239,6 +234,7 @@
void
filter_del()
CODE:
+ dMY_CXT;
FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
@@ -251,8 +247,12 @@
BOOT:
+ {
+ MY_CXT_INIT;
+ fdebug = 0;
/* temporary hack to control debugging in toke.c */
if (fdebug)
filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
+ }
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/Makefile.PL#2 (text) ====
Index: perl/macos/bundled_ext/Filter/Util/Call/Makefile.PL
--- perl/macos/bundled_ext/Filter/Util/Call/Makefile.PL.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Filter/Util/Call/Makefile.PL Tue Jan 15 08:00:05 2002
@@ -2,6 +2,6 @@
WriteMakefile(
NAME => 'Filter::Util::Call',
+ DEFINE => '-D_NOT_CORE',
VERSION_FROM => 'Call.pm',
- MAN3PODS => {}, # Pods will be built by installman.
);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/call.t#3 (text) ====
Index: perl/macos/bundled_ext/Filter/t/call.t
--- perl/macos/bundled_ext/Filter/t/call.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Filter/t/call.t Tue Jan 15 08:00:05 2002
@@ -1,20 +1,10 @@
-BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) {
- print "1..0 # Skip: Filter::Util::Call was not built\n";
- exit 0;
- }
- require 'lib/filter-util.pl';
-}
-
use strict;
use warnings;
use vars qw($Inc $Perl);
+require 'filter-util.pl';
+
print "1..28\n" ;
$Perl = "$Perl -w" ;
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/t/filter-util.pl#3 (text) ====
Index: perl/macos/bundled_ext/Filter/t/filter-util.pl
--- perl/macos/bundled_ext/Filter/t/filter-util.pl.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Filter/t/filter-util.pl Tue Jan 15 08:00:05 2002
@@ -25,7 +25,7 @@
binmode(F) if $filename =~ /bin$/i;
foreach (@strings)
{ print F }
- close F ;
+ close F or die "Could not close: $!" ;
}
sub ok
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/ChangeLog#3 (text) ====
Index: perl/macos/bundled_ext/Storable/ChangeLog
--- perl/macos/bundled_ext/Storable/ChangeLog.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/ChangeLog Tue Jan 15 08:00:05 2002
@@ -1,3 +1,18 @@
+Sat Dec 1 14:37:54 MET 2001 Raphael Manfredi <[email protected]>
+
+. Description:
+
+ This is the LAST maintenance release of the Storable module.
+ Indeed, Storable is now part of perl 5.8, and will be maintained
+ as part of Perl. The CPAN module will remain available there
+ for people running pre-5.8 perls.
+
+ Avoid requiring Fcntl upfront, useful to embedded runtimes.
+ Use an eval {} for testing, instead of making Storable.pm
+ simply fail its compilation in the BEGIN block.
+
+ store_fd() will now correctly autoflush file if needed.
+
Tue Aug 28 23:53:20 MEST 2001 Raphael Manfredi <[email protected]>
. Description:
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/README#3 (text) ====
Index: perl/macos/bundled_ext/Storable/README
--- perl/macos/bundled_ext/Storable/README.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/README Tue Jan 15 08:00:05 2002
@@ -28,7 +28,7 @@
the stored file and recreate the same hiearchy in memory. If you
had blessed references, the retrieved references are blessed into
the same package, so you must make sure you have access to the
-same perl class than the one used to create the relevant objects.
+same perl class as the one used to create the relevant objects.
There is also a dclone() routine which performs an optimized mirroring
of any data structure, preserving its topology.
@@ -60,7 +60,10 @@
Albert N. Micheev <[email protected]>
Marc Lehmann <[email protected]>
Justin Banks <[email protected]>
- Jarkko Hietaniemi <[email protected]> (AGAIN, as perl 5.7.0 Pumpkin!)
+ Jarkko Hietaniemi <[email protected]> (AGAIN, as perl 5.7.0 Pumpking!)
+ Salvador Ortiz Garcia <[email protected]>
+ Dominic Dunlop <[email protected]>
+ Erik Haugan <[email protected]>
for their contributions.
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/Storable.pm#3 (text) ====
Index: perl/macos/bundled_ext/Storable/Storable.pm
--- perl/macos/bundled_ext/Storable/Storable.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/Storable.pm Tue Jan 15 08:00:05 2002
@@ -1,4 +1,4 @@
-;# $Id: Storable.pm,v 1.0.1.12 2001/08/28 21:51:51 ram Exp $
+;# $Id: Storable.pm,v 1.0.1.13 2001/12/01 13:34:49 ram Exp $
;#
;# Copyright (c) 1995-2000, Raphael Manfredi
;#
@@ -6,6 +6,10 @@
;# in the README file that comes with the distribution.
;#
;# $Log: Storable.pm,v $
+;# Revision 1.0.1.13 2001/12/01 13:34:49 ram
+;# patch14: avoid requiring Fcntl upfront, useful to embedded runtimes
+;# patch14: store_fd() will now correctly autoflush file if needed
+;#
;# Revision 1.0.1.12 2001/08/28 21:51:51 ram
;# patch13: fixed truncation race with lock_retrieve() in lock_store()
;#
@@ -66,7 +70,7 @@
use AutoLoader;
use vars qw($forgive_me $VERSION);
-$VERSION = '1.013';
+$VERSION = '1.014';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
@@ -93,8 +97,7 @@
#
BEGIN {
- require Fcntl;
- if (exists $Fcntl::EXPORT_TAGS{'flock'}) {
+ if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) {
Fcntl->import(':flock');
} else {
eval q{
@@ -234,6 +237,7 @@
# Call C routine nstore or pstore, depending on network order
eval { $ret = &$xsptr($file, $self) };
logcroak $@ if $@ =~ s/\.?\n$/,/;
+ local $\; print $file ''; # Autoflush the file if wanted
$@ = $da;
return $ret ? $ret : undef;
}
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/blessed.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/blessed.t
--- perl/macos/bundled_ext/Storable/t/blessed.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/blessed.t Tue Jan 15 08:00:05 2002
@@ -12,18 +12,7 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
-
+require 't/dump.pl';
sub ok;
use Storable qw(freeze thaw);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/canonical.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/canonical.t
--- perl/macos/bundled_ext/Storable/t/canonical.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/canonical.t Tue Jan 15 08:00:05 2002
@@ -12,17 +12,7 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
-}
-
+BEGIN { push @INC, "../blib" }
use Storable qw(freeze thaw dclone);
use vars qw($debugging $verbose);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/dclone.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/dclone.t
--- perl/macos/bundled_ext/Storable/t/dclone.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/dclone.t Tue Jan 15 08:00:05 2002
@@ -12,18 +12,7 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
-
+require 't/dump.pl';
use Storable qw(dclone);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/forgive.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/forgive.t
--- perl/macos/bundled_ext/Storable/t/forgive.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/forgive.t Tue Jan 15 08:00:05 2002
@@ -18,19 +18,7 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
-}
-
use Storable qw(store retrieve);
-use File::Spec;
print "1..8\n";
@@ -38,30 +26,30 @@
my $bad = ['foo', sub { 1 }, 'bar'];
my $result;
-eval {$result = store ($bad , 'store')};
+eval {$result = store ($bad , 't/store')};
print ((!defined $result)?"ok $test\n":"not ok $test\n"); $test++;
print (($@ ne '')?"ok $test\n":"not ok $test\n"); $test++;
$Storable::forgive_me=1;
-my $devnull = File::Spec->devnull;
-
open(SAVEERR, ">&STDERR");
-open(STDERR, ">$devnull") or
+open(STDERR, ">/dev/null") or
( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
-eval {$result = store ($bad , 'store')};
+eval {$result = store ($bad , 't/store')};
open(STDERR, ">&SAVEERR");
print ((defined $result)?"ok $test\n":"not ok $test\n"); $test++;
print (($@ eq '')?"ok $test\n":"not ok $test\n"); $test++;
-my $ret = retrieve('store');
+my $ret = retrieve('t/store');
print ((defined $ret)?"ok $test\n":"not ok $test\n"); $test++;
print (($ret->[0] eq 'foo')?"ok $test\n":"not ok $test\n"); $test++;
print (($ret->[2] eq 'bar')?"ok $test\n":"not ok $test\n"); $test++;
print ((ref $ret->[1] eq 'SCALAR')?"ok $test\n":"not ok $test\n"); $test++;
-END { 1 while unlink 'store' }
+END {
+ unlink 't/store';
+}
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/freeze.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/freeze.t
--- perl/macos/bundled_ext/Storable/t/freeze.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/freeze.t Tue Jan 15 08:00:05 2002
@@ -15,18 +15,8 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
- sub ok;
-}
+require 't/dump.pl';
+sub ok;
use Storable qw(freeze nfreeze thaw);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/lock.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/lock.t
--- perl/macos/bundled_ext/Storable/t/lock.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/lock.t Tue Jan 15 08:00:05 2002
@@ -2,7 +2,10 @@
# $Id: lock.t,v 1.0.1.4 2001/01/03 09:41:00 ram Exp $
#
-# @COPYRIGHT@
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
#
# $Log: lock.t,v $
# Revision 1.0.1.4 2001/01/03 09:41:00 ram
@@ -19,32 +22,16 @@
#
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- if ($^O eq 'mpeix') {
- print "1..0 # Skip: truncate missing on MPE\n";
- exit 0;
- }
-
- require 'lib/st-dump.pl';
-}
-
-sub ok;
-
use Storable qw(lock_store lock_retrieve);
unless (&Storable::CAN_FLOCK) {
- print "1..0 # Skip: fcntl/flock emulation broken on this platform\n";
+ print "1..0 # Skip: fcntl/flock emulation broken on this platform\n";
exit 0;
}
+require 't/dump.pl';
+sub ok;
+
print "1..5\n";
@a = ('first', undef, 3, -4, -3.14159, 456, 4.5);
@@ -53,10 +40,10 @@
# We're just ensuring things work, we're not validating locking.
#
-ok 1, defined lock_store(\@a, 'store');
+ok 1, defined lock_store(\@a, 't/store');
ok 2, $dumped = &dump(\@a);
-$root = lock_retrieve('store');
+$root = lock_retrieve('t/store');
ok 3, ref $root eq 'ARRAY';
ok 4, @a == @$root;
ok 5, &dump($root) eq $dumped;
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/overload.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/overload.t
--- perl/macos/bundled_ext/Storable/t/overload.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/overload.t Tue Jan 15 08:00:05 2002
@@ -15,18 +15,7 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
-
+require 't/dump.pl';
sub ok;
use Storable qw(freeze thaw);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/recurse.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/recurse.t
--- perl/macos/bundled_ext/Storable/t/recurse.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/recurse.t Tue Jan 15 08:00:05 2002
@@ -14,27 +14,14 @@
# Revision 1.0.1.2 2000/11/05 17:22:05 ram
# patch6: stress hook a little more with refs to lexicals
#
-# $Log: recurse.t,v $
# Revision 1.0.1.1 2000/09/17 16:48:05 ram
# patch1: added test case for store hook bug
#
-# $Log: recurse.t,v $
# Revision 1.0 2000/09/01 19:40:42 ram
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
-
+require 't/dump.pl';
sub ok;
use Storable qw(freeze thaw dclone);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/retrieve.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/retrieve.t
--- perl/macos/bundled_ext/Storable/t/retrieve.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/retrieve.t Tue Jan 15 08:00:05 2002
@@ -12,19 +12,8 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
+require 't/dump.pl';
-
use Storable qw(store retrieve nstore);
print "1..14\n";
@@ -37,24 +26,24 @@
@a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5,
$b, \$a, $a, $c, \$c, \%a);
-print "not " unless defined store(\@a, 'store');
+print "not " unless defined store(\@a, 't/store');
print "ok 1\n";
print "not " if Storable::last_op_in_netorder();
print "ok 2\n";
-print "not " unless defined nstore(\@a, 'nstore');
+print "not " unless defined nstore(\@a, 't/nstore');
print "ok 3\n";
print "not " unless Storable::last_op_in_netorder();
print "ok 4\n";
print "not " unless Storable::last_op_in_netorder();
print "ok 5\n";
-$root = retrieve('store');
+$root = retrieve('t/store');
print "not " unless defined $root;
print "ok 6\n";
print "not " if Storable::last_op_in_netorder();
print "ok 7\n";
-$nroot = retrieve('nstore');
+$nroot = retrieve('t/nstore');
print "not " unless defined $nroot;
print "ok 8\n";
print "not " unless Storable::last_op_in_netorder();
@@ -74,5 +63,5 @@
print "not " if length $root->[1];
print "ok 14\n";
-END { 1 while unlink('store', 'nstore') }
+unlink 't/store', 't/nstore';
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/store.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/store.t
--- perl/macos/bundled_ext/Storable/t/store.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/store.t Tue Jan 15 08:00:05 2002
@@ -12,17 +12,7 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
+require 't/dump.pl';
use Storable qw(store retrieve store_fd nstore_fd fd_retrieve);
@@ -36,13 +26,13 @@
@a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
$b, \$a, $a, $c, \$c, \%a);
-print "not " unless defined store(\@a, 'store');
+print "not " unless defined store(\@a, 't/store');
print "ok 1\n";
$dumped = &dump(\@a);
print "ok 2\n";
-$root = retrieve('store');
+$root = retrieve('t/store');
print "not " unless defined $root;
print "ok 3\n";
@@ -52,7 +42,7 @@
print "not " unless $got eq $dumped;
print "ok 5\n";
-1 while unlink 'store';
+unlink 'store';
package FOO; @ISA = qw(Storable);
@@ -65,10 +55,10 @@
package main;
$foo = FOO->make;
-print "not " unless $foo->store('store');
+print "not " unless $foo->store('t/store');
print "ok 6\n";
-print "not " unless open(OUT, '>>store');
+print "not " unless open(OUT, '>>t/store');
print "ok 7\n";
binmode OUT;
@@ -82,7 +72,7 @@
print "not " unless close(OUT);
print "ok 11\n";
-print "not " unless open(OUT, 'store');
+print "not " unless open(OUT, 't/store');
binmode OUT;
$r = fd_retrieve(::OUT);
@@ -114,6 +104,5 @@
print "ok 20\n";
close OUT;
-END { 1 while unlink 'store' }
-
+unlink 't/store';
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/tied.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/tied.t
--- perl/macos/bundled_ext/Storable/t/tied.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/tied.t Tue Jan 15 08:00:05 2002
@@ -12,18 +12,7 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
-
+require 't/dump.pl';
sub ok;
use Storable qw(freeze thaw);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/tied_hook.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/tied_hook.t
--- perl/macos/bundled_ext/Storable/t/tied_hook.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/tied_hook.t Tue Jan 15 08:00:05 2002
@@ -15,18 +15,7 @@
# Baseline for first official release.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
-
+require 't/dump.pl';
sub ok;
use Storable qw(freeze thaw);
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/tied_items.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/tied_items.t
--- perl/macos/bundled_ext/Storable/t/tied_items.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/tied_items.t Tue Jan 15 08:00:05 2002
@@ -16,18 +16,7 @@
# Tests ref to items in tied hash/array structures.
#
-sub BEGIN {
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
-}
-
+require 't/dump.pl';
sub ok;
$^W = 0;
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/utf8.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/utf8.t
--- perl/macos/bundled_ext/Storable/t/utf8.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/utf8.t Tue Jan 15 08:00:05 2002
@@ -2,7 +2,10 @@
# $Id: utf8.t,v 1.0.1.2 2000/09/28 21:44:17 ram Exp $
#
-# @COPYRIGHT@
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
#
# $Log: utf8.t,v $
# Revision 1.0.1.2 2000/09/28 21:44:17 ram
@@ -13,26 +16,16 @@
#
#
-sub BEGIN {
- if ($] < 5.006) {
- print "1..0 # Skip: no utf8 support\n";
+use Storable qw(thaw freeze);
+
+if ($] < 5.006) {
+ print "1..0\n";
exit 0;
- }
- chdir('t') if -d 't';
- @INC = '.';
- push @INC, '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bStorable\b/) {
- print "1..0 # Skip: Storable was not built\n";
- exit 0;
- }
- require 'lib/st-dump.pl';
}
+require 't/dump.pl';
sub ok;
-use Storable qw(thaw freeze);
-
print "1..1\n";
$x = chr(1234);
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/File/Sort.pm#2 (text) ====
Index: perl/macos/bundled_lib/blib/lib/File/Sort.pm
--- perl/macos/bundled_lib/blib/lib/File/Sort.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/File/Sort.pm Tue Jan 15 08:00:05 2002
@@ -10,7 +10,7 @@
use vars qw(@ISA @EXPORT_OK);
@ISA = 'Exporter';
@EXPORT_OK = 'sort_file';
-$VERSION = '1.00';
+$VERSION = '1.01';
sub sort_file {
my @args = @_;
@@ -935,6 +935,10 @@
=over 4
+=item v1.01, Monday, January 14, 2002
+
+Change license to be that of Perl.
+
=item v1.00, Tuesday, November 13, 2001
Long overdue release.
@@ -1060,14 +1064,14 @@
Chris Nandor E<lt>[email protected]<gt>, http://pudge.net/
-Copyright (c) 1997-2001 Chris Nandor. All rights reserved. This program
-is free software; you can redistribute it and/or modify it under the terms
-of the Artistic License, distributed with Perl.
+Copyright (c) 1997-2002 Chris Nandor. All rights reserved. This program
+is free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
=head1 VERSION
-v1.00, Tuesday, November 13, 2001
+v1.01, Monday, January 14, 2002
=head1 SEE ALSO
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Filter/Simple.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Filter/Simple.pm
--- perl/macos/bundled_lib/blib/lib/Filter/Simple.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Filter/Simple.pm Tue Jan 15 08:00:05 2002
@@ -1,39 +1,181 @@
package Filter::Simple;
-use vars qw{ $VERSION };
+use Text::Balanced ':ALL';
+
+use vars qw{ $VERSION @EXPORT };
-$VERSION = '0.61';
+$VERSION = '0.77';
use Filter::Util::Call;
use Carp;
+@EXPORT = qw( FILTER FILTER_ONLY );
+
+
sub import {
if (@_>1) { shift; goto &FILTER }
- else { *{caller()."::FILTER"} = \&FILTER }
+ else { *{caller()."::$_"} = \&$_ foreach @EXPORT }
}
sub FILTER (&;$) {
my $caller = caller;
my ($filter, $terminator) = @_;
+ no warnings 'redefine';
*{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator);
- *{"${caller}::unimport"} = \*filter_unimport;
+ *{"${caller}::unimport"} = gen_filter_unimport($caller);
+}
+
+sub fail {
+ croak "FILTER_ONLY: ", @_;
+}
+
+my $exql = sub {
+ my @bits = extract_quotelike $_[0], qr//;
+ return unless $bits[0];
+ return \@bits;
+};
+
+my $ws = qr/\s+/;
+my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/;
+my $EOP = qr/\n\n|\Z/;
+my $CUT = qr/\n=cut.*$EOP/;
+my $pod_or_DATA = qr/
+ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $EOP
+ | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
+ | ^__(DATA|END)__\n.*
+ /smx;
+
+my %extractor_for = (
+ quotelike => [ $ws, $id, { MATCH => \&extract_quotelike } ],
+ regex => [ $ws, $pod_or_DATA, $id, $exql ],
+ string => [ $ws, $pod_or_DATA, $id, $exql ],
+ code => [ $ws, { DONT_MATCH => $pod_or_DATA },
+ $id, { DONT_MATCH => \&extract_quotelike } ],
+ executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
+ all => [ { MATCH => qr/(?s:.*)/ } ],
+);
+
+my %selector_for = (
+ all => sub { my ($t)=@_; sub{ $_=$$_; $t->(@_); $_} },
+ executable=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} },
+ quotelike => sub { my ($t)=@_; sub{ref() && do{$_=$$_; $t->(@_)}; $_} },
+ regex => sub { my ($t)=@_;
+ sub{ref() or return $_;
+ my ($ql,undef,$pre,$op,$ld,$pat) = @$_;
+ return $_->[0] unless $op =~ /^(qr|m|s)/
+ || !$op && ($ld eq '/' || $ld eq '?');
+ $_ = $pat;
+ $t->(@_);
+ $ql =~ s/^(\s*\Q$op\E\s*\Q$ld\E)\Q$pat\E/$1$_/;
+ return "$pre$ql";
+ };
+ },
+ string => sub { my ($t)=@_;
+ sub{ref() or return $_;
+ local *args = \@_;
+ my ($pre,$op,$ld1,$str1,$rd1,$ld2,$str2,$rd2,$flg) = @{$_}[2..10];
+ return $_->[0] if $op =~ /^(qr|m)/
+ || !$op && ($ld1 eq '/' || $ld1 eq '?');
+ if (!$op || $op eq 'tr' || $op eq 'y') {
+ local *_ = \$str1;
+ $t->(@args);
+ }
+ if ($op =~ /^(tr|y|s)/) {
+ local *_ = \$str2;
+ $t->(@args);
+ }
+ my $result = "$pre$op$ld1$str1$rd1";
+ $result .= $ld2 if $ld1 =~ m/[[({<]/; #])}>
+ $result .= "$str2$rd2$flg";
+ return $result;
+ };
+ },
+);
+
+
+sub gen_std_filter_for {
+ my ($type, $transform) = @_;
+ return sub { my (@pieces, $instr);
+ for (extract_multiple($_,$extractor_for{$type})) {
+ if (ref()) { push @pieces, $_; $instr=0 }
+ elsif ($instr) { $pieces[-1] .= $_ }
+ else { push @pieces, $_; $instr=1 }
+ }
+ if ($type eq 'code') {
+ my $count = 0;
+ local $placeholder = qr/\Q$;\E(?:\C{4})\Q$;\E/;
+ my $extractor = qr/\Q$;\E(\C{4})\Q$;\E/;
+ $_ = join "",
+ map { ref $_ ? $;.pack('N',$count++).$; : $_ }
+ @pieces;
+ @pieces = grep { ref $_ } @pieces;
+ $transform->(@_);
+ s/$extractor/${$pieces[unpack('N',$1)]}/g;
+ }
+ else {
+ my $selector = $selector_for{$type}->($transform);
+ $_ = join "", map $selector->(@_), @pieces;
+ }
+ }
+};
+
+sub FILTER_ONLY {
+ my $caller = caller;
+ while (@_ > 1) {
+ my ($what, $how) = splice(@_, 0, 2);
+ fail "Unknown selector: $what"
+ unless exists $extractor_for{$what};
+ fail "Filter for $what is not a subroutine reference"
+ unless ref $how eq 'CODE';
+ push @transforms, gen_std_filter_for($what,$how);
+ }
+ my $terminator = shift;
+
+ my $multitransform = sub {
+ foreach my $transform ( @transforms ) {
+ $transform->(@_);
+ }
+ };
+ no warnings 'redefine';
+ *{"${caller}::import"} =
+ gen_filter_import($caller,$multitransform,$terminator);
+ *{"${caller}::unimport"} = gen_filter_unimport($caller);
}
+my $ows = qr/(?:[ \t]+|#[^\n]*)*/;
+
sub gen_filter_import {
my ($class, $filter, $terminator) = @_;
+ my %terminator;
+ my $prev_import = *{$class."::import"}{CODE};
return sub {
my ($imported_class, @args) = @_;
- $terminator = qr/^\s*no\s+$imported_class\s*;\s*$/
- unless defined $terminator;
+ my $def_terminator =
+ qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)$/;
+ if (!defined $terminator) {
+ $terminator{terminator} = $def_terminator;
+ }
+ elsif (!ref $terminator || ref $terminator eq 'Regexp') {
+ $terminator{terminator} = $terminator;
+ }
+ elsif (ref $terminator ne 'HASH') {
+ croak "Terminator must be specified as scalar or hash ref"
+ }
+ elsif (!exists $terminator->{terminator}) {
+ $terminator{terminator} = $def_terminator;
+ }
filter_add(
sub {
- my ($status, $off);
+ my ($status, $lastline);
my $count = 0;
my $data = "";
while ($status = filter_read()) {
return $status if $status < 0;
- if ($terminator && m/$terminator/) {
- $off=1;
+ if ($terminator{terminator} &&
+ m/$terminator{terminator}/) {
+ $lastline = $_;
last;
}
$data .= $_;
@@ -41,16 +183,34 @@
$_ = "";
}
$_ = $data;
- $filter->(@args) unless $status < 0;
- $_ .= "no $imported_class;\n" if $off;
+ $filter->($imported_class, @args) unless $status < 0;
+ if (defined $lastline) {
+ if (defined $terminator{becomes}) {
+ $_ .= $terminator{becomes};
+ }
+ elsif ($lastline =~ $def_terminator) {
+ $_ .= $lastline;
+ }
+ }
return $count;
}
);
+ if ($prev_import) {
+ goto &$prev_import;
+ }
+ elsif ($class->isa('Exporter')) {
+ $class->export_to_level(1,@_);
+ }
}
}
-sub filter_unimport {
- filter_del();
+sub gen_filter_unimport {
+ my ($class) = @_;
+ my $prev_unimport = *{$class."::unimport"}{CODE};
+ return sub {
+ filter_del();
+ goto &$prev_unimport if $prev_unimport;
+ }
}
1;
@@ -231,15 +391,28 @@
=head2 Disabling or changing <no> behaviour
-By default, the installed filter only filters to a line of the form:
+By default, the installed filter only filters up to a line consisting of one of
+the three standard source "terminators":
+
+ no ModuleName; # optional comment
+
+or:
+
+ __END__
+
+or:
- no ModuleName;
+ __DATA__
-but this can be altered by passing a second argument to C<use Filter::Simple>.
+but this can be altered by passing a second argument to C<use Filter::Simple>
+or C<FILTER> (just remember: there's I<no> comma after the initial block when
+you use C<FILTER>).
That second argument may be either a C<qr>'d regular expression (which is then
used to match the terminator line), or a defined false value (which indicates
-that no terminator line should be looked for).
+that no terminator line should be looked for), or a reference to a hash
+(in which case the terminator is the value associated with the key
+C<'terminator'>.
For example, to cause the previous filter to filter only up to a line of the
form:
@@ -254,7 +427,14 @@
FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
}
- => qr/^\s*GNAB\s+esu\s*;\s*?$/;
+ qr/^\s*GNAB\s+esu\s*;\s*?$/;
+
+or:
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ { terminator => qr/^\s*GNAB\s+esu\s*;\s*?$/ };
and to prevent the filter's being turned off in any way:
@@ -264,8 +444,17 @@
FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
}
- => "";
- # or: => 0;
+ ""; # or: 0
+
+or:
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ { terminator => "" };
+
+B<Note that, no matter what you set the terminator pattern too,
+the actual terminator itself I<must> be contained on a single source line.>
=head2 All-in-one interface
@@ -301,34 +490,215 @@
except that the C<FILTER> subroutine is not exported by Filter::Simple.
-=head2 Using Filter::Simple and Exporter together
+
+=head2 Filtering only specific components of source code
+
+One of the problems with a filter like:
+
+ use Filter::Simple;
+
+ FILTER { s/BANG\s+BANG/die 'BANG' if \$BANG/g };
+
+is that it indiscriminately applies the specified transformation to
+the entire text of your source program. So something like:
+
+ warn 'BANG BANG, YOU'RE DEAD';
+ BANG BANG;
-You can't directly use Exporter when Filter::Simple.
+will become:
-Filter::Simple generates an C<import> subroutine for your module
-(which hides the one inherited from Exporter).
+ warn 'die 'BANG' if $BANG, YOU'RE DEAD';
+ die 'BANG' if $BANG;
-The C<FILTER> code you specify will, however, receive the C<import>'s argument
-list, so you can use that filter block as your C<import> subroutine.
+It is very common when filtering source to only want to apply the filter
+to the non-character-string parts of the code, or alternatively to I<only>
+the character strings.
-You'll need to call C<Exporter::export_to_level> from your C<FILTER> code
-to make it work correctly.
+Filter::Simple supports this type of filtering by automatically
+exporting the C<FILTER_ONLY> subroutine.
+C<FILTER_ONLY> takes a sequence of specifiers that install separate
+(and possibly multiple) filters that act on only parts of the source code.
For example:
+ use Filter::Simple;
+
+ FILTER_ONLY
+ code => sub { s/BANG\s+BANG/die 'BANG' if \$BANG/g },
+ quotelike => sub { s/BANG\s+BANG/CHITTY CHITYY/g };
+
+The C<"code"> subroutine will only be used to filter parts of the source
+code that are not quotelikes, POD, or C<__DATA__>. The C<quotelike>
+subroutine only filters Perl quotelikes (including here documents).
+
+The full list of alternatives is:
+
+=over
+
+=item C<"code">
+
+Filters only those sections of the source code that are not quotelikes, POD, or
+C<__DATA__>.
+
+=item C<"executable">
+
+Filters only those sections of the source code that are not POD or C<__DATA__>.
+
+=item C<"quotelike">
+
+Filters only Perl quotelikes (as interpreted by
+C<&Text::Balanced::extract_quotelike>).
+
+=item C<"string">
+
+Filters only the string literal parts of a Perl quotelike (i.e. the
+contents of a string literal, either half of a C<tr///>, the second
+half of an C<s///>).
+
+=item C<"regex">
+
+Filters only the pattern literal parts of a Perl quotelike (i.e. the
+contents of a C<qr//> or an C<m//>, the first half of an C<s///>).
+
+=item C<"all">
+
+Filters everything. Identical in effect to C<FILTER>.
+
+=back
+
+Except for C<< FILTER_ONLY code => sub {...} >>, each of
+the component filters is called repeatedly, once for each component
+found in the source code.
+
+Note that you can also apply two or more of the same type of filter in
+a single C<FILTER_ONLY>. For example, here's a simple
+macro-preprocessor that is only applied within regexes,
+with a final debugging pass that printd the resulting source code:
+
+ use Regexp::Common;
+ FILTER_ONLY
+ regex => sub { s/!\[/[^/g },
+ regex => sub { s/%d/$RE{num}{int}/g },
+ regex => sub { s/%f/$RE{num}{real}/g },
+ all => sub { print if $::DEBUG };
+
+
+
+=head2 Filtering only the code parts of source code
+
+Most source code ceases to be grammatically correct when it is broken up
+into the pieces between string literals and regexes. So the C<'code'>
+component filter behaves slightly differently from the other partial filters
+described in the previous section.
+
+Rather than calling the specified processor on each individual piece of
+code (i.e. on the bits between quotelikes), the C<'code'> partial filter
+operates on the entire source code, but with the quotelike bits
+"blanked out".
+
+That is, a C<'code'> filter I<replaces> each quoted string, quotelike,
+regex, POD, and __DATA__ section with a placeholder. The
+delimiters of this placeholder are the contents of the C<$;> variable
+at the time the filter is applied (normally C<"\034">). The remaining
+four bytes are a unique identifier for the component being replaced.
+
+This approach makes it comparatively easy to write code preprocessors
+without worrying about the form or contents of strings, regexes, etc.
+For convenience, during a C<'code'> filtering operation, Filter::Simple
+provides a package variable (C<$Filter::Simple::placeholder>) that contains
+a pre-compiled regex that matches any placeholder. Placeholders can be
+moved and re-ordered within the source code as needed.
+
+Once the filtering has been applied, the original strings, regexes,
+POD, etc. are re-inserted into the code, by replacing each
+placeholder with the corresponding original component.
+
+For example, the following filter detects concatentated pairs of
+strings/quotelikes and reverses the order in which they are
+concatenated:
+
+ package DemoRevCat;
use Filter::Simple;
- use base Exporter;
- @EXPORT = qw(foo);
- @EXPORT_OK = qw(bar);
+ FILTER_ONLY code => sub { my $ph = $Filter::Simple::placeholder;
+ s{ ($ph) \s* [.] \s* ($ph) }{ $2.$1 }gx
+ };
+
+Thus, the following code:
+
+ use DemoRevCat;
+
+ my $str = "abc" . q(def);
+
+ print "$str\n";
+
+would become:
+
+ my $str = q(def)."abc";
+
+ print "$str\n";
+
+and hence print:
+
+ defabc
+
+
+=head2 Using Filter::Simple with an explicit C<import> subroutine
+
+Filter::Simple generates a special C<import> subroutine for
+your module (see L<"How it works">) which would normally replace any
+C<import> subroutine you might have explicitly declared.
+
+However, Filter::Simple is smart enough to notice your existing
+C<import> and Do The Right Thing with it.
+That is, if you explcitly define an C<import> subroutine in a package
+that's using Filter::Simple, that C<import> subroutine will still
+be invoked immediately after any filter you install.
+
+The only thing you have to remember is that the C<import> subroutine
+I<must> be declared I<before> the filter is installed. If you use C<FILTER>
+to install the filter:
+
+ package Filter::TurnItUpTo11;
+
+ use Filter::Simple;
+
+ FILTER { s/(\w+)/\U$1/ };
+
+that will almost never be a problem, but if you install a filtering
+subroutine by passing it directly to the C<use Filter::Simple>
+statement:
+
+ package Filter::TurnItUpTo11;
+
+ use Filter::Simple sub{ s/(\w+)/\U$1/ };
+
+then you must make sure that your C<import> subroutine appears before
+that C<use> statement.
+
+
+=head2 Using Filter::Simple and Exporter together
+
+Likewise, Filter::Simple is also smart enough
+to Do The Right Thing if you use Exporter:
+
+ package Switch;
+ use base Exporter;
+ use Filter::Simple;
+
+ @EXPORT = qw(switch case);
+ @EXPORT_OK = qw(given when);
+
+ FILTER { $_ = magic_Perl_filter($_) }
- sub foo { print "foo\n" }
- sub bar { print "bar\n" }
+Immediately after the filter has been applied to the source,
+Filter::Simple will pass control to Exporter, so it can do its magic too.
- FILTER {
- # Your filtering code here
- __PACKAGE__->export_to_level(2,undef,@_);
- }
+Of course, here too, Filter::Simple has to know you're using Exporter
+before it applies the filter. That's almost never a problem, but if you're
+nervous about it, you can guarantee that things will work correctly by
+ensuring that your C<use base Exporter> always precedes your
+C<use Filter::Simple>.
=head2 How it works
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Headers.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/HTTP/Headers.pm
--- perl/macos/bundled_lib/blib/lib/HTTP/Headers.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/HTTP/Headers.pm Tue Jan 15 08:00:05 2002
@@ -1,7 +1,6 @@
-#
-# $Id: Headers.pm,v 1.41 2001/04/12 06:50:28 gisle Exp $
+package HTTP::Headers;
-package HTTP::Headers;
+# $Id: Headers.pm,v 1.43 2001/11/15 06:19:22 gisle Exp $
=head1 NAME
@@ -10,13 +9,17 @@
=head1 SYNOPSIS
require HTTP::Headers;
- $h = new HTTP::Headers;
+ $h = HTTP::Headers->new;
+
+ $h->header('Content-Type' => 'text/plain'); # set
+ $ct = $h->header('Content-Type'); # get
+ $h->remove_header('Content-Type'); # delete
=head1 DESCRIPTION
The C<HTTP::Headers> class encapsulates HTTP-style message headers.
-The headers consist of attribute-value pairs, which may be repeated,
-and which are printed in a particular order.
+The headers consist of attribute-value pairs also called fields, which
+may be repeated, and which are printed in a particular order.
Instances of this class are usually created as member variables of the
C<HTTP::Request> and C<HTTP::Response> classes, internal to the
@@ -29,63 +32,66 @@
=cut
use strict;
-use vars qw($VERSION $TRANSLATE_UNDERSCORE);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.41 $ =~ /(\d+)\.(\d+)/);
-
use Carp ();
-# Could not use the AutoLoader becase several of the method names are
-# not unique in the first 8 characters.
-#use SelfLoader;
+use vars qw($VERSION $TRANSLATE_UNDERSCORE);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/);
+# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
+# as a replacement for '-' in header field names.
+$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
# "Good Practice" order of HTTP message headers:
# - General-Headers
# - Request-Headers
# - Response-Headers
# - Entity-Headers
-# (From draft-ietf-http-v11-spec-rev-01, Nov 21, 1997)
my @header_order = qw(
- Cache-Control Connection Date Pragma Transfer-Encoding Upgrade Trailer Via
+ Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
+ Via Warning
Accept Accept-Charset Accept-Encoding Accept-Language
Authorization Expect From Host
- If-Modified-Since If-Match If-None-Match If-Range If-Unmodified-Since
+ If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
Max-Forwards Proxy-Authorization Range Referer TE User-Agent
- Accept-Ranges Age Location Proxy-Authenticate Retry-After Server Vary
- Warning WWW-Authenticate
+ Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
+ Vary WWW-Authenticate
- Allow Content-Base Content-Encoding Content-Language Content-Length
- Content-Location Content-MD5 Content-Range Content-Type
- ETag Expires Last-Modified
+ Allow Content-Encoding Content-Language Content-Length Content-Location
+ Content-MD5 Content-Range Content-Type Expires Last-Modified
);
# Make alternative representations of @header_order. This is used
# for sorting and case matching.
-my $i = 0;
my %header_order;
my %standard_case;
-for (@header_order) {
- my $lc = lc $_;
- $header_order{$lc} = ++$i;
- $standard_case{$lc} = $_;
+
+{
+ my $i = 0;
+ for (@header_order) {
+ my $lc = lc $_;
+ $header_order{$lc} = ++$i;
+ $standard_case{$lc} = $_;
+ }
}
-$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
-=item $h = new HTTP::Headers
+=item $h = HTTP::Headers->new
Constructs a new C<HTTP::Headers> object. You might pass some initial
attribute-value pairs as parameters to the constructor. I<E.g.>:
- $h = new HTTP::Headers
- Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
- Content_Type => 'text/html; version=3.2',
- Content_Base => 'http://www.perl.org/';
+ $h = HTTP::Headers->new(
+ Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
+ Content_Type => 'text/html; version=3.2',
+ Content_Base => 'http://www.perl.org/');
+
+The constructor arguments are passed to the C<header> method which is
+described below.
=cut
@@ -100,28 +106,39 @@
=item $h->header($field [=> $value],...)
-Get or set the value of a header. The header field name is not case
-sensitive. To make the life easier for perl users who wants to avoid
-quoting before the => operator, you can use '_' as a synonym for '-'
-in header names (this behaviour can be suppressed by setting
-$HTTP::Headers::TRANSLATE_UNDERSCORE to a FALSE value).
+Get or set the value of one or more header fields. The header field name
+($field) is not case sensitive. To make the life easier for perl
+users who wants to avoid quoting before the => operator, you can use
+'_' as a replacement for '-' in header names (this behaviour can be
+suppressed by setting the $HTTP::Headers::TRANSLATE_UNDERSCORE
+variable to a FALSE value).
+
+The header() method accepts multiple ($field => $value) pairs, which
+means that you can update several fields with a single invocation.
+
+The $value argument may be a plain string or a reference to an array
+of strings for a multi-valued field. If the $value is undefined or not
+given, then that header field will remain unchanged.
-The header() method accepts multiple ($field => $value) pairs, so you
-can update several fields with a single invocation.
+The old value (or values) of the last of the header fields is returned.
+If no such field exists C<undef> will be returned.
-The optional $value argument may be a scalar or a reference to a list
-of scalars. If the $value argument is undefined or not given, then the
-header is not modified.
+A multi-valued field will be retuned as separate values in list
+context and will be concatenated with ", " as separator in scalar
+context. The HTTP spec (RFC 2616) promise that joining multiple
+values in this way will not change the semantic of a header field, but
+in practice there are cases like old-style Netscape cookies (see
+L<HTTP::Cookies>) where "," is used as part of the syntax of a single
+field value.
-The old value of the last of the $field values is returned.
-Multi-valued fields will be concatenated with "," as separator in
-scalar context.
+Examples:
$header->header(MIME_Version => '1.0',
User_Agent => 'My-Web-Client/0.01');
$header->header(Accept => "text/html, text/plain, image/*");
$header->header(Accept => [qw(text/html text/plain image/*)]);
- @accepts = $header->header('Accept');
+ @accepts = $header->header('Accept'); # get multiple values
+ $accepts = $header->header('Accept'); # get values as a single string
=cut
@@ -138,14 +155,19 @@
}
-=item $h->push_header($field, $val)
+=item $h->push_header($field, $value)
+
+Add a new field value for the specified header field. Previous values
+for the same field are retained.
+
+As for the header() method, the field name ($field) is not case
+sensitive and '_' can be used as a replacement for '-'.
-Add a new field value of the specified header. The header field name
-is not case sensitive. The field need not already have a
-value. Previous values for the same field are retained. The argument
-may be a scalar or a reference to a list of scalars.
+The $value argument may be a scalar or a reference to a list of
+scalars.
$header->push_header(Accept => 'image/jpeg');
+ $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
=cut
@@ -155,10 +177,16 @@
shift->_header(@_, 'PUSH');
}
-=item $h->init_header($field, $val)
+=item $h->init_header($field, $value)
+
+Set the specified header to the given value, but only if no previous
+value for that field is set.
+
+The header field name ($field) is not case sensitive and '_'
+can be used as a replacement for '-'.
-Set the specified header to the given value unless it already has a
-value. The header field name is not case sensitive.
+The $value argument may be a scalar or a reference to a list of
+scalars.
=cut
@@ -171,7 +199,16 @@
=item $h->remove_header($field,...)
-This function removes the headers with the specified names.
+This function removes the headers fields with the specified names.
+
+The header field names ($field) are not case sensitive and '_'
+can be used as a replacement for '-'.
+
+The return value is the values of the fields removed. In scalar
+context the number of fields removed is returned.
+
+Note that if you pass in multiple field names then it is generally not
+possible to tell which of the returned values belonged to which field.
=cut
@@ -179,10 +216,13 @@
{
my($self, @fields) = @_;
my $field;
+ my @values;
foreach $field (@fields) {
$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
- delete $self->{lc $field};
+ my $v = delete $self->{lc $field};
+ push(@values, ref($v) ? @$v : $v) if defined $v;
}
+ return @values;
}
@@ -196,7 +236,7 @@
my $lc_field = lc $field;
unless(defined $standard_case{$lc_field}) {
- # generate a %stadard_case entry for this field
+ # generate a %standard_case entry for this field
$field =~ s/\b(\w)/\u$1/g;
$standard_case{$lc_field} = $field;
}
@@ -231,12 +271,15 @@
=item $h->scan(\&doit)
-Apply a subroutine to each header in turn. The callback routine is
-called with two parameters; the name of the field and a single value.
-If the header has more than one value, then the routine is called once
-for each value. The field name passed to the callback routine has
-case as suggested by HTTP Spec, and the headers will be visited in the
-recommended "Good Practice" order.
+Apply a subroutine to each header field in turn. The callback routine
+is called with two parameters; the name of the field and a single
+value (a string). If a header field is multi-valued, then the
+routine is called once for each value. The field name passed to the
+callback routine has case as suggested by HTTP spec, and the headers
+will be visited in the recommended "Good Practice" order.
+
+Any return values of the callback routine are ignored. The loop can
+be broken by raising an exception (C<die>).
=cut
@@ -262,14 +305,14 @@
=item $h->as_string([$endl])
Return the header fields as a formatted MIME header. Since it
-internally uses the C<scan()> method to build the string, the result
-will use case as suggested by HTTP Spec, and it will follow
+internally uses the C<scan> method to build the string, the result
+will use case as suggested by HTTP spec, and it will follow
recommended "Good Practice" of ordering the header fieds. Long header
-values are not folded.
+values are not folded.
-The optional parameter specifies the line ending sequence to use. The
-default is C<"\n">. Embedded "\n" characters in the header will be
-substitued with this line ending sequence.
+The optional $endl parameter specifies the line ending sequence to
+use. The default is "\n". Embedded "\n" characters in header field
+values will be substitued with this line ending sequence.
=cut
@@ -297,7 +340,7 @@
=item $h->clone
-Returns a copy of this HTTP::Headers object.
+Returns a copy of this C<HTTP::Headers> object.
=back
@@ -318,6 +361,7 @@
following convenience methods. These methods can both be used to read
and to set the value of a header. The header value is set if you pass
an argument to the method. The old header value is always returned.
+If the given header did not exists then C<undef> is returned.
Methods that deal with dates/times always convert their value to system
time (seconds since Jan 1, 1970) and they also expect this kind of
@@ -341,9 +385,9 @@
=item $h->if_unmodified_since
-This header is used to make a request conditional. If the requested
-resource has (not) been modified since the time specified in this field,
-then the server will return a C<"304 Not Modified"> response instead of
+These header fields are used to make a request conditional. If the requested
+resource has (or has not) been modified since the time specified in this field,
+then the server will return a C<304 Not Modified> response instead of
the document itself.
=item $h->last_modified
@@ -352,8 +396,10 @@
modified. I<E.g.>:
# check if document is more than 1 hour old
- if ($h->last_modified < time - 60*60) {
- ...
+ if (my $last_mod = $h->last_modified) {
+ if ($last_mod < time - 60*60) {
+ ...
+ }
}
=item $h->content_type
@@ -387,7 +433,8 @@
The natural language(s) of the intended audience for the message
content. The value is one or more language tags as defined by RFC
-1766. Eg. "no" for Norwegian and "en-US" for US-English.
+1766. Eg. "no" for some kind of Norwegian and "en-US" for English the
+way it is written in the US.
=item $h->title
@@ -416,20 +463,39 @@
$h->from('King Kong <[email protected]>');
+I<This header is no longer part of the HTTP standard.>
+
=item $h->referer
Used to specify the address (URI) of the document from which the
requested resouce address was obtained.
+The "Free On-line Dictionary of Computing" as this to say about the
+word I<referer>:
+
+ <World-Wide Web> A misspelling of "referrer" which
+ somehow made it into the {HTTP} standard. A given {web
+ page}'s referer (sic) is the {URL} of whatever web page
+ contains the link that the user followed to the current
+ page. Most browsers pass this information as part of a
+ request.
+
+ (1998-10-19)
+
+By popular demand C<referrer> exists as an alias for this method so you
+can avoid this misspelling in your programs and still send the right
+thing on the wire.
+
+
=item $h->www_authenticate
-This header must be included as part of a "401 Unauthorized" response.
+This header must be included as part of a C<401 Unauthorized> response.
The field value consist of a challenge that indicates the
authentication scheme and parameters applicable to the requested URI.
=item $h->proxy_authenticate
-This header must be included in a "407 Proxy Authentication Required"
+This header must be included in a C<407 Proxy Authentication Required>
response.
=item $h->authorization
@@ -506,8 +572,8 @@
sub from { (shift->_header('From', @_))[0] }
sub referer { (shift->_header('Referer', @_))[0] }
+*referrer = \&referer; # on tchrist's request
sub warning { (shift->_header('Warning', @_))[0] }
-*referrer = \&referer; # on tchrist's request
sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
sub authorization { (shift->_header('Authorization', @_))[0] }
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Message.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/HTTP/Message.pm
--- perl/macos/bundled_lib/blib/lib/HTTP/Message.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/HTTP/Message.pm Tue Jan 15 08:00:05 2002
@@ -1,5 +1,5 @@
#
-# $Id: Message.pm,v 1.24 2001/08/06 23:47:06 gisle Exp $
+# $Id: Message.pm,v 1.25 2001/11/15 06:42:23 gisle Exp $
package HTTP::Message;
@@ -15,7 +15,7 @@
=head1 DESCRIPTION
-A C<HTTP::Message> object contains some headers and a content (body).
+An C<HTTP::Message> object contains some headers and a content (body).
The class is abstract, i.e. it only used as a base class for
C<HTTP::Request> and C<HTTP::Response> and should never instantiated
as itself.
@@ -32,12 +32,12 @@
require Carp;
use strict;
use vars qw($VERSION $AUTOLOAD);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/);
$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
eval "require $HTTP::URI_CLASS"; die $@ if $@;
-=item $mess = new HTTP::Message;
+=item $mess = HTTP::Message->new
This is the object constructor. It should only be called internally
by this library. External code should construct C<HTTP::Request> or
@@ -78,7 +78,7 @@
=item $mess->protocol([$proto])
Sets the HTTP protocol used for the message. The protocol() is a string
-like "HTTP/1.0" or "HTTP/1.1".
+like C<HTTP/1.0> or C<HTTP/1.1>.
=cut
@@ -92,8 +92,8 @@
=item $mess->add_content($data)
-The add_content() methods appends more data to the end of the previous
-content.
+The add_content() methods appends more data to the end of the current
+content buffer.
=cut
@@ -111,9 +111,9 @@
=item $mess->content_ref
-The content_ref() method will return a reference to content string.
+The content_ref() method will return a reference to content buffer string.
It can be more efficient to access the content this way if the content
-is huge, and it can be used for direct manipulation of the content,
+is huge, and it can even be used for direct manipulation of the content,
for instance:
${$res->content_ref} =~ s/\bfoo\b/bar/g;
@@ -137,8 +137,12 @@
=item $mess->headers_as_string([$endl])
-Call the HTTP::Headers->as_string() method for the headers in the
-message.
+Call the as_string() method for the headers in the
+message. This will be the same as:
+
+ $mess->headers->as_string
+
+but it will make your program a whole character shorter :-)
=cut
@@ -153,9 +157,10 @@
details of these methods:
$mess->header($field => $val);
- $mess->scan(\&doit);
$mess->push_header($field => $val);
+ $mess->init_header($field => $val);
$mess->remove_header($field);
+ $mess->scan(\&doit);
$mess->date;
$mess->expires;
@@ -183,10 +188,14 @@
# delegate all other method calls the the _headers object.
sub AUTOLOAD
{
- my $self = shift;
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
return if $method eq "DESTROY";
- $self->{'_headers'}->$method(@_);
+
+ # We create the function here so that it will not need to be
+ # autoloaded the next time.
+ no strict 'refs';
+ *$method = eval "sub { shift->{'_headers'}->$method(\@_) }";
+ goto &$method;
}
# Private method to access members in %$self
@@ -203,7 +212,7 @@
=head1 COPYRIGHT
-Copyright 1995-1997 Gisle Aas.
+Copyright 1995-2001 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Negotiate.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/HTTP/Negotiate.pm
--- perl/macos/bundled_lib/blib/lib/HTTP/Negotiate.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/HTTP/Negotiate.pm Tue Jan 15 08:00:05 2002
@@ -1,9 +1,9 @@
-# $Id: Negotiate.pm,v 1.9 2001/08/07 00:10:45 gisle Exp $
+# $Id: Negotiate.pm,v 1.11 2001/11/27 22:41:33 gisle Exp $
#
package HTTP::Negotiate;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/);
sub Version { $VERSION; }
require 5.002;
@@ -45,17 +45,26 @@
$request->scan(sub {
my($key, $val) = @_;
- return unless $key =~ s/^Accept-?//;
- my $type = lc $key;
- $type = "type" unless length $key;
+
+ my $type;
+ if ($key =~ s/^Accept-//) {
+ $type = lc($key);
+ }
+ elsif ($key eq "Accept") {
+ $type = "type";
+ }
+ else {
+ return;
+ }
+
$val =~ s/\s+//g;
- my $name;
- for $name (split(/,/, $val)) {
+ my $default_q = 1;
+ for my $name (split(/,/, $val)) {
my(%param, $param);
if ($name =~ s/;(.*)//) {
for $param (split(/;/, $1)) {
my ($pk, $pv) = split(/=/, $param, 2);
- $param{$pk} = $pv;
+ $param{lc $pk} = $pv;
}
}
$name = lc $name;
@@ -63,10 +72,12 @@
$param{'q'} = 1 if $param{'q'} > 1;
$param{'q'} = 0 if $param{'q'} < 0;
} else {
- $param{'q'} = 1;
+ $param{'q'} = $default_q;
+
+ # This makes sure that the first ones are slightly better off
+ # and therefore more likely to be chosen.
+ $default_q -= 0.0001;
}
-
- $param{'q'} = 1 unless defined $param{'q'};
$accept{$type}{$name} = \%param;
}
});
@@ -102,10 +113,11 @@
for (@$variants) {
my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
$qs = 1 unless defined $qs;
+ $ct = '' unless defined $ct;
$bs = 0 unless defined $bs;
$lang = lc($lang) if $lang; # lg tags are always case-insensitive
if ($DEBUG) {
- print "\nEvaluating $id ($ct)\n";
+ print "\nEvaluating $id (ct='$ct')\n";
printf " qs = %.3f\n", $qs;
print " enc = $enc\n" if $enc && !ref($enc);
print " enc = @$enc\n" if $enc && ref($enc);
@@ -268,7 +280,7 @@
if ($DEBUG) {
$mbx = "undef" unless defined $mbx;
- printf "Q=%.3f", $Q;
+ printf "Q=%.4f", $Q;
print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
}
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Request.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/HTTP/Request.pm
--- perl/macos/bundled_lib/blib/lib/HTTP/Request.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/HTTP/Request.pm Tue Jan 15 08:00:05 2002
@@ -1,5 +1,5 @@
#
-# $Id: Request.pm,v 1.29 2001/08/28 05:08:57 gisle Exp $
+# $Id: Request.pm,v 1.30 2001/11/15 06:42:40 gisle Exp $
package HTTP::Request;
@@ -10,7 +10,7 @@
=head1 SYNOPSIS
require HTTP::Request;
- $request = HTTP::Request->new(GET => 'http://www.oslonett.no/');
+ $request = HTTP::Request->new(GET => 'http://www.oslo.net/');
=head1 DESCRIPTION
@@ -23,13 +23,12 @@
of an C<LWP::UserAgent> object:
$ua = LWP::UserAgent->new;
- $request = HTTP::Request->new(GET => 'http://www.oslonett.no/');
+ $request = HTTP::Request->new(GET => 'http://www.oslo.net/');
$response = $ua->request($request);
C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
inherits its methods. The inherited methods most often used are header(),
-push_header(), remove_header(), headers_as_string() and content().
-See L<HTTP::Message> for details.
+push_header(), remove_header(), and content(). See L<HTTP::Message> for details.
The following additional methods are available:
@@ -39,16 +38,21 @@
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.29 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/);
use strict;
-=item $r = HTTP::Request->new($method, $uri, [$header, [$content]])
+=item $r = HTTP::Request->new($method, $uri)
+
+=item $r = HTTP::Request->new($method, $uri, $header)
+
+=item $r = HTTP::Request->new($method, $uri, $header, $content)
Constructs a new C<HTTP::Request> object describing a request on the
object C<$uri> using method C<$method>. The C<$uri> argument can be
-either a string, or a reference to a C<URI> object. The $header
+either a string, or a reference to a C<URI> object. The optional $header
argument should be a reference to an C<HTTP::Headers> object.
+The optional $content argument should be a string.
=cut
@@ -84,6 +88,8 @@
value. If no argument is given the value is not touched. In either
case the previous value is returned.
+The method() method argument should be a string.
+
The uri() method accept both a reference to a URI object and a
string as its argument. If a string is given, then it should be
parseable as an absolute URI.
@@ -160,7 +166,7 @@
=head1 COPYRIGHT
-Copyright 1995-1998 Gisle Aas.
+Copyright 1995-2001 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/HTTP/Response.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/HTTP/Response.pm
--- perl/macos/bundled_lib/blib/lib/HTTP/Response.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/HTTP/Response.pm Tue Jan 15 08:00:05 2002
@@ -1,5 +1,5 @@
#
-# $Id: Response.pm,v 1.35 2001/08/07 00:26:57 gisle Exp $
+# $Id: Response.pm,v 1.36 2001/11/15 06:42:40 gisle Exp $
package HTTP::Response;
@@ -32,7 +32,7 @@
C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
inherits its methods. The inherited methods most often used are header(),
-push_header(), remove_header(), headers_as_string(), and content().
+push_header(), remove_header(), and content().
The header convenience methods are also available. See
L<HTTP::Message> for details.
@@ -45,7 +45,7 @@
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.35 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.36 $ =~ /(\d+)\.(\d+)/);
use HTTP::Status ();
use strict;
@@ -386,7 +386,7 @@
=head1 COPYRIGHT
-Copyright 1995-1997 Gisle Aas.
+Copyright 1995-2001 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/LWP.pm
--- perl/macos/bundled_lib/blib/lib/LWP.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/LWP.pm Tue Jan 15 08:00:05 2002
@@ -1,9 +1,9 @@
#
-# $Id: LWP.pm,v 1.112 2001/10/26 23:24:03 gisle Exp $
+# $Id: LWP.pm,v 1.117 2001/12/14 20:43:12 gisle Exp $
package LWP;
-$VERSION = "5.60";
+$VERSION = "5.63";
sub Version { $VERSION; }
require 5.004;
@@ -15,7 +15,7 @@
=head1 NAME
-LWP - Library for WWW access in Perl
+LWP - The World-Wide Web library for Perl
=head1 SYNOPSIS
@@ -25,18 +25,18 @@
=head1 DESCRIPTION
-Libwww-perl is a collection of Perl modules which provides a simple
-and consistent application programming interface (API) to the World-Wide Web. The
-main focus of the library is to provide classes and functions that
-allow you to write WWW clients, thus libwww-perl is a WWW
-client library. The library also contain modules that are of more
-general use.
+The libwww-perl collection is a set of Perl modules which provides a
+simple and consistent application programming interface (API) to the
+World-Wide Web. The main focus of the library is to provide classes
+and functions that allow you to write WWW clients. The library also
+contain modules that are of more general use and even classes that
+help you implement simple HTTP servers.
-Most modules in this library are object oriented. The user
+Most modules in this library provide an object oriented API. The user
agent, requests sent and responses received from the WWW server are
all represented by objects. This makes a simple and powerful
-interface to these services. The interface should be easy to extend
-and customize for your needs.
+interface to these services. The interface is easy to extend
+and customize for your own needs.
The main features of the library are:
@@ -76,11 +76,6 @@
=item *
-Cooperates with Tk. A simple Tk-based GUI browser
-called 'tkweb' is distributed with the Tk extension for perl.
-
-=item *
-
Implements HTTP content negotiation algorithm that can
be used both in protocol modules and in server scripts (like CGI
scripts).
@@ -157,13 +152,13 @@
=item *
The B<method> is a short string that tells what kind of
-request this is. The most used methods are B<GET>, B<PUT>,
+request this is. The most common methods are B<GET>, B<PUT>,
B<POST> and B<HEAD>.
=item *
-The B<url> is a string denoting the protocol, server and
-the name of the "document" we want to access. The B<url> might
+The B<uri> is a string denoting the protocol, server and
+the name of the "document" we want to access. The B<uri> might
also encode various other parameters.
=item *
@@ -241,12 +236,11 @@
your application code and the network. Through this interface you are
able to access the various servers on the network.
-The libwww-perl class name for the user agent is
-C<LWP::UserAgent>. Every libwww-perl application that wants to
-communicate should create at least one object of this class. The main
-method provided by this object is request(). This method takes an
-C<HTTP::Request> object as argument and (eventually) returns a
-C<HTTP::Response> object.
+The class name for the user agent is C<LWP::UserAgent>. Every
+libwww-perl application that wants to communicate should create at
+least one object of this class. The main method provided by this
+object is request(). This method takes an C<HTTP::Request> object as
+argument and (eventually) returns a C<HTTP::Response> object.
The user agent has many other attributes that let you
configure how it will interact with the network and with your
@@ -300,11 +294,11 @@
# Create a user agent object
use LWP::UserAgent;
- $ua = new LWP::UserAgent;
- $ua->agent("AgentName/0.1 " . $ua->agent);
+ $ua = LWP::UserAgent->new;
+ $ua->agent("MyApp/0.1 ");
# Create a request
- my $req = new HTTP::Request POST => 'http://www.perl.com/cgi-bin/BugGlimpse';
+ my $req = HTTP::Request->new(POST => 'http://www.perl.com/cgi-bin/BugGlimpse');
$req->content_type('application/x-www-form-urlencoded');
$req->content('match=www&errors=0');
@@ -352,16 +346,16 @@
The library automatically adds a "Host" and a "Content-Length" header
to the HTTP request before it is sent over the network.
-For GET request you might want to add the "If-Modified-Since" header
-to make the request conditional.
+For GET request you might want to add a "If-Modified-Since" or
+"If-None-Match" header to make the request conditional.
For POST request you should add the "Content-Type" header. When you
try to emulate HTML E<lt>FORM> handling you should usually let the value
of the "Content-Type" header be "application/x-www-form-urlencoded".
See L<lwpcook> for examples of this.
-The libwww-perl HTTP implementation currently support the HTTP/1.0
-protocol. HTTP/0.9 servers are also handled correctly.
+The libwww-perl HTTP implementation currently support the HTTP/1.1
+and HTTP/1.0 protocol.
The library allows you to access proxy server through HTTP. This
means that you can set up the library to forward all types of request
@@ -524,6 +518,8 @@
WWW::RobotRules -- Parse robots.txt files
WWW::RobotRules::AnyDBM_File -- Persistent RobotRules
+ Net::HTTP -- Low level HTTP client
+
The following modules provide various functions and definitions.
LWP -- This file. Library version number and documentation.
@@ -534,6 +530,7 @@
HTTP::Date -- Date parsing module for HTTP date formats
HTTP::Negotiate -- HTTP content negotiation calculation
File::Listing -- Parse directory listings
+ HTML::Form -- Processing for <form>s in HTML documents
=head1 MORE DOCUMENTATION
@@ -544,6 +541,43 @@
look at how the scripts C<lwp-request>, C<lwp-rget> and C<lwp-mirror>
are implemented.
+=head1 ENVIRONMENT
+
+The following environment variables are used by LWP:
+
+=over
+
+=item HOME
+
+The C<LWP::MediaTypes> functions will look for the F<.media.types> and
+F<.mime.types> files relative to you home directory.
+
+=item http_proxy
+
+=item ftp_proxy
+
+=item xxx_proxy
+
+=item no_proxy
+
+These environment variables can be set to enable communication through
+a proxy server. See the description of the C<env_proxy> method in
+L<LWP::UserAgent>.
+
+=item PERL_LWP_USE_HTTP_10
+
+Enable the old HTTP/1.0 protocol driver instead of the new HTTP/1.1
+driver. You might want to set this to a TRUE value if you discover
+that your old LWP applications fails after you installed LWP-5.60 or
+better.
+
+=item PERL_HTTP_URI_CLASS
+
+Used to decide what URI objects to instantiate. The default is C<URI>.
+You might want to set it to C<URI::URL> for compatiblity with old times.
+
+=back
+
=head1 BUGS
The library can not handle multiple simultaneous requests yet. Also,
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP/Authen/Digest.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/LWP/Authen/Digest.pm
--- perl/macos/bundled_lib/blib/lib/LWP/Authen/Digest.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/LWP/Authen/Digest.pm Tue Jan 15 08:00:05 2002
@@ -1,7 +1,7 @@
package LWP::Authen::Digest;
use strict;
-require MD5;
+require Digest::MD5;
sub authenticate
{
@@ -18,7 +18,7 @@
my $uri = $request->url->path_query;
$uri = "/" unless length $uri;
- my $md5 = new MD5;
+ my $md5 = Digest::MD5->new;
my(@digest);
$md5->add(join(":", $user, $auth_param->{realm}, $pass));
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP/Protocol/http.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/LWP/Protocol/http.pm
--- perl/macos/bundled_lib/blib/lib/LWP/Protocol/http.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/LWP/Protocol/http.pm Tue Jan 15 08:00:05 2002
@@ -1,4 +1,4 @@
-# $Id: http.pm,v 1.57 2001/10/26 18:08:02 gisle Exp $
+# $Id: http.pm,v 1.63 2001/12/14 19:33:52 gisle Exp $
#
package LWP::Protocol::http;
@@ -17,34 +17,6 @@
my $CRLF = "\015\012";
-{
- package LWP::Protocol::MyHTTP;
- use vars qw(@ISA);
- @ISA = qw(Net::HTTP);
-
- sub sysread {
- my $self = shift;
- if (my $timeout = ${*$self}{io_socket_timeout}) {
- die "read timeout" unless $self->can_read($timeout);
- }
- sysread($self, $_[0], $_[1], $_[2] || 0);
- }
-
- sub can_read {
- my($self, $timeout) = @_;
- my $fbits = '';
- vec($fbits, fileno($self), 1) = 1;
- my $nfound = select($fbits, undef, undef, $timeout);
- die "select failed: $!" unless defined $nfound;
- return $nfound > 0;
- }
-
- sub ping {
- my $self = shift;
- !$self->can_read(0);
- }
-}
-
sub _new_socket
{
my($self, $host, $port, $timeout) = @_;
@@ -60,14 +32,14 @@
}
local($^W) = 0; # IO::Socket::INET can be noisy
- my $sock = $self->_conn_class->new(PeerAddr => $host,
- PeerPort => $port,
- Proto => 'tcp',
- Timeout => $timeout,
- KeepAlive => !!$conn_cache,
- SendTE => 1,
- $self->_extra_sock_opts($host, $port),
- );
+ my $sock = $self->socket_class->new(PeerAddr => $host,
+ PeerPort => $port,
+ Proto => 'tcp',
+ Timeout => $timeout,
+ KeepAlive => !!$conn_cache,
+ SendTE => 1,
+ $self->_extra_sock_opts($host, $port),
+ );
unless ($sock) {
# IO::Socket::INET leaves additional error messages in $@
@@ -81,9 +53,10 @@
$sock;
}
-sub _conn_class
+sub socket_class
{
- "LWP::Protocol::MyHTTP";
+ my $self = shift;
+ (ref($self) || $self) . "::Socket";
}
sub _extra_sock_opts # to be overridden by subclass
@@ -111,7 +84,7 @@
# Extract 'Host' header
my $hhost = $url->authority;
$hhost =~ s/^([^\@]*)\@//; # get rid of potential "user:pass@"
- $h->header('Host' => $hhost) unless defined $h->header('Host');
+ $h->init_header('Host' => $hhost);
# add authorization header if we need them. HTTP URLs do
# not really support specification of user and password, but
@@ -182,7 +155,9 @@
$self->_check_sock($request, $socket);
my @h;
- my $request_headers = $request->headers;
+ my $request_headers = $request->headers->clone;
+ $self->_fixup_header($request_headers, $url, $proxy);
+
$request_headers->scan(sub {
my($k, $v) = @_;
$v =~ s/\n/ /g;
@@ -232,7 +207,7 @@
#LWP::Debug::conns($req_buf);
}
- my($code, $mess);
+ my($code, $mess, @junk);
my $drop_connection;
if ($has_content) {
@@ -289,7 +264,9 @@
$socket->_rbuf($buf);
if ($buf =~ /\015?\012\015?\012/) {
# a whole response present
- ($code, $mess, @h) = $socket->read_response_headers;
+ ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
+ junk_out => \@junk,
+ );
if ($code eq "100") {
$write_wait = 0;
undef($code);
@@ -323,9 +300,9 @@
}
}
- ($code, $mess, @h) = $socket->read_response_headers
+ ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
unless $code;
- ($code, $mess, @h) = $socket->read_response_headers
+ ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
if $code eq "100";
my $response = HTTP::Response->new($code, $mess);
@@ -335,6 +312,7 @@
my($k, $v) = splice(@h, 0, 2);
$response->push_header($k, $v);
}
+ $response->push_header("Client-Junk" => \@junk) if @junk;
$response->request($request);
$self->_get_sock_info($response, $socket);
@@ -344,9 +322,10 @@
return $response;
}
- #$response->remove_header('Transfer-Encoding');
- $response->push_header('Client-Warning', 'LWP HTTP/1.1 support is experimental');
- $response->push_header('Client-Request-Num', ++${*$socket}{'myhttp_req_count'});
+ if (my @te = $response->remove_header('Transfer-Encoding')) {
+ $response->push_header('Client-Transfer-Encoding', \@te);
+ }
+ $response->push_header('Client-Response-Num', $socket->increment_response_count);
my $complete;
$response = $self->collect($arg, $response, sub {
@@ -386,4 +365,45 @@
$response;
}
+
+#-----------------------------------------------------------
+package LWP::Protocol::http::SocketMethods;
+
+sub sysread {
+ my $self = shift;
+ if (my $timeout = ${*$self}{io_socket_timeout}) {
+ die "read timeout" unless $self->can_read($timeout);
+ }
+ else {
+ # since we have made the socket non-blocking we
+ # use select to wait for some data to arrive
+ $self->can_read(undef) || die "Assert";
+ }
+ sysread($self, $_[0], $_[1], $_[2] || 0);
+}
+
+sub can_read {
+ my($self, $timeout) = @_;
+ my $fbits = '';
+ vec($fbits, fileno($self), 1) = 1;
+ my $nfound = select($fbits, undef, undef, $timeout);
+ die "select failed: $!" unless defined $nfound;
+ return $nfound > 0;
+}
+
+sub ping {
+ my $self = shift;
+ !$self->can_read(0);
+}
+
+sub increment_response_count {
+ my $self = shift;
+ return ++${*$self}{'myhttp_response_count'};
+}
+
+#-----------------------------------------------------------
+package LWP::Protocol::http::Socket;
+use vars qw(@ISA);
+@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
+
1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP/Protocol/https.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/LWP/Protocol/https.pm
--- perl/macos/bundled_lib/blib/lib/LWP/Protocol/https.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/LWP/Protocol/https.pm Tue Jan 15 08:00:05 2002
@@ -1,59 +1,47 @@
#
-# $Id: https.pm,v 1.10 2001/10/26 18:29:27 gisle Exp $
+package LWP::Protocol::https;
+
+# $Id: https.pm,v 1.11 2001/11/17 02:10:28 gisle Exp $
use strict;
-package LWP::Protocol::https;
-
use vars qw(@ISA);
-
require LWP::Protocol::http;
-require LWP::Protocol::https10;
-
@ISA = qw(LWP::Protocol::http);
-my $SSL_CLASS = $LWP::Protocol::https10::SSL_CLASS;
-#we need this to setup a proper @ISA tree
+sub _check_sock
{
- package LWP::Protocol::MyHTTPS;
- use vars qw(@ISA);
- @ISA = ($SSL_CLASS, 'LWP::Protocol::MyHTTP');
-
- #we need to call both Net::SSL::configure and Net::HTTP::configure
- #however both call SUPER::configure (which is IO::Socket::INET)
- #to avoid calling that twice we override Net::HTTP's
- #_http_socket_configure
-
- sub configure {
- my $self = shift;
- for my $class (@ISA) {
- my $cfg = $class->can('configure');
- $cfg->($self, @_);
- }
- $self;
+ my($self, $req, $sock) = @_;
+ my $check = $req->header("If-SSL-Cert-Subject");
+ if (defined $check) {
+ my $cert = $sock->get_peer_certificate ||
+ die "Missing SSL certificate";
+ my $subject = $cert->subject_name;
+ die "Bad SSL certificate subject: '$subject' !~ /$check/"
+ unless $subject =~ /$check/;
+ $req->remove_header("If-SSL-Cert-Subject"); # don't pass it on
}
+}
- sub _http_socket_configure {
- $_[0];
+sub _get_sock_info
+{
+ my $self = shift;
+ $self->SUPER::_get_sock_info(@_);
+ my($res, $sock) = @_;
+ $res->header("Client-SSL-Cipher" => $sock->get_cipher);
+ my $cert = $sock->get_peer_certificate;
+ if ($cert) {
+ $res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
+ $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
}
-
- # The underlying SSLeay classes fails to work if the socket is
- # placed in non-blocking mode. This override of the blocking
- # method makes sure it stays the way it was created.
- sub blocking { } # noop
+ $res->header("Client-SSL-Warning" => "Peer certificate not verified");
}
-sub _conn_class {
- "LWP::Protocol::MyHTTPS";
-}
+#-----------------------------------------------------------
+package LWP::Protocol::https::Socket;
-{
- #if we inherit from LWP::Protocol::https10 we inherit from
- #LWP::Protocol::http10, so just setup aliases for these two
- no strict 'refs';
- for (qw(_check_sock _get_sock_info)) {
- *{"$_"} = \&{"LWP::Protocol::https10::$_"};
- }
-}
+use vars qw(@ISA);
+require Net::HTTPS;
+@ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods);
1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/LWP/UserAgent.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/LWP/UserAgent.pm
--- perl/macos/bundled_lib/blib/lib/LWP/UserAgent.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/LWP/UserAgent.pm Tue Jan 15 08:00:05 2002
@@ -1,4 +1,4 @@
-# $Id: UserAgent.pm,v 1.99 2001/10/26 18:05:22 gisle Exp $
+# $Id: UserAgent.pm,v 2.1 2001/12/11 21:11:29 gisle Exp $
package LWP::UserAgent;
use strict;
@@ -103,7 +103,7 @@
require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.99 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);
use HTTP::Request ();
use HTTP::Response ();
@@ -284,11 +284,11 @@
local($SIG{__DIE__}); # protect agains user defined die handlers
# Check that we have a METHOD and a URL first
- return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, "Method missing")
+ return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "Method missing")
unless $method;
- return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, "URL missing")
+ return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "URL missing")
unless $url;
- return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, "URL must be absolute")
+ return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "URL must be absolute")
unless $url->scheme;
LWP::Debug::trace("$method $url");
@@ -332,8 +332,7 @@
$protocol = eval { LWP::Protocol::create($scheme, $self) };
if ($@) {
$@ =~ s/ at .* line \d+.*//s; # remove file/line number
-
- return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED, $@);
+ return _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
}
}
@@ -463,7 +462,7 @@
}
$referral->url($referral_uri);
- $referral->remove_header('Host');
+ $referral->remove_header('Host', 'Cookie');
return $response unless $self->redirect_ok($referral);
@@ -1125,6 +1124,14 @@
undef;
}
+sub _new_response {
+ my($request, $code, $message) = @_;
+ my $response = HTTP::Response->new($code, $message);
+ $response->request($request);
+ $response->header("Client-Date" => HTTP::Date::time2str(time));
+ return $response;
+}
+
1;
=back
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Address.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Address.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Address.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Address.pm Tue Jan 15 08:00:05 2002
@@ -11,7 +11,7 @@
use vars qw($VERSION);
use locale;
-$VERSION = "1.40";
+$VERSION = "1.42";
sub Version { $VERSION }
#
@@ -154,6 +154,8 @@
sub parse {
my $pkg = shift;
+ my @line = grep { defined $_} @_;
+ my $line = join '', @line;
local $_;
@@ -162,10 +164,10 @@
my @address = ();
my @objs = ();
my $depth = 0;
- my $idx = 0;
- my $tokens = _tokenise(grep { defined $_} @_);
- my $len = scalar(@{$tokens});
- my $next = _find_next($idx,$tokens,$len);
+ my $idx = 0;
+ my $tokens = _tokenise(@line);
+ my $len = @$tokens;
+ my $next = _find_next($idx,$tokens,$len);
for( ; $idx < $len ; $idx++) {
$_ = $tokens->[$idx];
@@ -186,7 +188,7 @@
}
}
elsif($_ eq ',') {
- warn "Unmatched '<>'" if($depth);
+ warn "Unmatched '<>' in $line" if($depth);
my $o = _complete($pkg,\@phrase, \@address, \@comment);
push(@objs, $o) if(defined $o);
$depth = 0;
@@ -198,11 +200,11 @@
elsif($next eq "<") {
push(@phrase,$_);
}
- elsif($_ =~ /\A[\Q.\@:;\E]\Z/ || !scalar(@address) || $address[$#address] =~ /\A[\Q.\@:;\E]\Z/) {
+ elsif( /\A[\Q.\@:;\E]\Z/ || !@address || $address[-1] =~ /\A[\Q.\@:;\E]\Z/) {
push(@address,$_);
}
else {
- warn "Unmatched '<>'" if($depth);
+ warn "Unmatched '<>' in $line" if($depth);
my $o = _complete($pkg,\@phrase, \@address, \@comment);
push(@objs, $o) if(defined $o);
$depth = 0;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Cap.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Cap.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Cap.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Cap.pm Tue Jan 15 08:00:05 2002
@@ -4,7 +4,7 @@
use vars qw($VERSION $useCache);
-$VERSION = "1.40";
+$VERSION = "1.42";
sub Version { $VERSION; }
=head1 NAME
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Field.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Field.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Field.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Field.pm Tue Jan 15 08:00:05 2002
@@ -12,7 +12,7 @@
use strict;
use vars qw($AUTOLOAD $VERSION);
-$VERSION = "1.40";
+$VERSION = "1.42";
unless(defined &UNIVERSAL::can) {
*UNIVERSAL::can = sub {
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Field/AddrList.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Field/AddrList.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Field/AddrList.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Field/AddrList.pm Tue Jan 15 08:00:05 2002
@@ -49,7 +49,7 @@
use Mail::Address;
@ISA = qw(Mail::Field);
-$VERSION = '1.40';
+$VERSION = '1.42';
# install header interpretation, see Mail::Field
INIT: {
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Field/Date.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Field/Date.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Field/Date.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Field/Date.pm Tue Jan 15 08:00:05 2002
@@ -15,7 +15,7 @@
use Date::Parse qw(str2time);
@ISA = qw(Mail::Field);
-$VERSION = '1.40';
+$VERSION = '1.42';
bless([])->register('Date');
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Filter.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Filter.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Filter.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Filter.pm Tue Jan 15 08:00:05 2002
@@ -10,7 +10,7 @@
use strict;
use vars qw($VERSION);
-$VERSION = "1.40";
+$VERSION = "1.42";
sub new {
my $self = shift;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Header.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Header.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Header.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Header.pm Tue Jan 15 08:00:05 2002
@@ -19,7 +19,7 @@
use Carp;
use vars qw($VERSION $FIELD_NAME);
-$VERSION = "1.40";
+$VERSION = "1.42";
my $MAIL_FROM = 'KEEP';
my %HDR_LENGTHS = ();
@@ -112,7 +112,7 @@
if(length($_[0]) > $ml)
{
- if ($_[0] =~ /^([-\w]+)/ and exists $STRUCTURE{ lc $1 } )
+ if ($_[0] =~ /^([-\w]+)/ && exists $STRUCTURE{ lc $1 } )
{
#Split the line up
# first bias towards splitting at a , or a ; >4/5 along the line
@@ -135,14 +135,8 @@
}
else
{
- my $dif = $max-$min;
-
- $_[0] =~ s/(?:^|\G)
- (?:
- (.{$min,$max})\s+
- |(.{$min,$max})
- )
- /$+\n /xg;
+ $_[0] =~ s/(.{$min,$max})\s+|(.{$max})/$+\n /g;
+ $_[0] =~ s/\s*$/\n/s;
}
}
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Internet.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Internet.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Internet.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Internet.pm Tue Jan 15 08:00:05 2002
@@ -16,7 +16,7 @@
use vars qw($VERSION);
BEGIN {
- $VERSION = "1.40";
+ $VERSION = "1.42";
*AUTOLOAD = \&AutoLoader::AUTOLOAD;
unless(defined &UNIVERSAL::isa) {
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Mailer.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Mailer.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Mailer.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Mailer.pm Tue Jan 15 08:00:05 2002
@@ -47,6 +47,13 @@
$mailer = new Mail::Mailer 'smtp', Server => $server;
+The smtp mailer does not handle C<Cc> and C<Bcc> lines, neither their
+C<Resent-*> fellows.
+
+=item C<qmail>
+
+Use qmail's qmail-inject program to deliver the mail.
+
=item C<test>
Used for debugging, this calls C</bin/echo> to display the data. No
@@ -124,7 +131,7 @@
use Config;
use strict;
-$VERSION = "1.40";
+$VERSION = "1.42";
sub Version { $VERSION }
@@ -140,6 +147,7 @@
'sendmail' => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail',
'smtp' => undef,
+ 'qmail' => '/usr/sbin/qmail-inject;/var/qmail/bin/qmail-inject',
'test' => 'test'
);
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Mailer/test.pm#2 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Mailer/test.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Mailer/test.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Mailer/test.pm Tue Jan 15 08:00:05 2002
@@ -7,7 +7,7 @@
sub exec {
my($self, $exe, $args, $to) = @_;
- exec('sh', '-c', "echo to: " . join(" ",@{$to}) . "; cat");
+ exec('sh', '-c', 'echo "to: ' . join(" ",@{$to}) . '"; cat');
}
1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Send.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Send.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Send.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Send.pm Tue Jan 15 08:00:05 2002
@@ -8,7 +8,7 @@
use vars qw($VERSION);
require Mail::Mailer;
-$VERSION = "1.40";
+$VERSION = "1.42";
sub Version { $VERSION }
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Util.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Util.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Util.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Util.pm Tue Jan 15 08:00:05 2002
@@ -14,7 +14,7 @@
BEGIN {
require 5.000;
- $VERSION = "1.40";
+ $VERSION = "1.42";
*AUTOLOAD = \&AutoLoader::AUTOLOAD;
@ISA = qw(Exporter);
@@ -137,15 +137,15 @@
if(defined $config && open(CF,$config)) {
my %var;
while(<CF>) {
- if(/\AD([a-zA-Z])([\w.]+)/) {
- my($v,$arg) = ($1,$2);
- $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$' . $1/eg;
+ if(my ($v, $arg) = /^D([a-zA-Z])([\w.\$\-]+)/) {
+ $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$'.$1/eg;
$var{$v} = $arg;
}
}
close(CF);
- $domain = $var{'j'} if defined $var{'j'};
- $domain = $var{'M'} if defined $var{'M'};
+ $domain = $var{j} if defined $var{j};
+ $domain = $var{M} if defined $var{M};
+ $domain = $var{S} if defined $var{S};
return $domain
if(defined $domain);
}
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/NEXT.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/NEXT.pm
--- perl/macos/bundled_lib/blib/lib/NEXT.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/NEXT.pm Tue Jan 15 08:00:05 2002
@@ -1,13 +1,14 @@
package NEXT;
+$VERSION = '0.50';
use Carp;
use strict;
sub ancestors
{
- my @inlist = @_;
+ my @inlist = shift;
my @outlist = ();
- while (@inlist) {
- push @outlist, shift @inlist;
+ while (my $next = shift @inlist) {
+ push @outlist, $next;
no strict 'refs';
unshift @inlist, @{"$outlist[-1]::ISA"};
}
@@ -25,11 +26,13 @@
croak "Can't call $wanted from $caller"
unless $caller_method eq $wanted_method;
- local $NEXT::NEXT{$self,$wanted_method} =
- $NEXT::NEXT{$self,$wanted_method};
+ local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
+ ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
+
- unless (@{$NEXT::NEXT{$self,$wanted_method}||[]}) {
- my @forebears = ancestors ref $self;
+ unless ($NEXT::NEXT{$self,$wanted_method}) {
+ my @forebears =
+ ancestors ref $self || $self, $wanted_class;
while (@forebears) {
last if shift @forebears eq $caller_class
}
@@ -38,22 +41,34 @@
map { *{"${_}::$caller_method"}{CODE}||() } @forebears
unless $wanted_method eq 'AUTOLOAD';
@{$NEXT::NEXT{$self,$wanted_method}} =
- map { (*{"${_}::AUTOLOAD"}{CODE}) ?
- "${_}::AUTOLOAD" : () } @forebears
+ map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
}
my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
- return unless defined $call_method;
- if (ref $call_method eq 'CODE') {
- return shift()->$call_method(@_)
+ while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
+ && $NEXT::SEEN->{$self,$call_method}++) {
+ $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
}
- else { # AN AUTOLOAD
- no strict 'refs';
- ${$call_method} = $caller_method eq 'AUTOLOAD' && ${"${caller_class}::AUTOLOAD"} || $wanted;
- return $call_method->(@_);
- }
+ unless (defined $call_method) {
+ return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
+ (local $Carp::CarpLevel)++;
+ croak qq(Can't locate object method "$wanted_method" ),
+ qq(via package "$caller_class");
+ };
+ return shift()->$call_method(@_) if ref $call_method eq 'CODE';
+ no strict 'refs';
+ ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
+ if $wanted_method eq 'AUTOLOAD';
+ $$call_method = $caller_class."::NEXT::".$wanted_method;
+ return $call_method->(@_);
}
+no strict 'vars';
+package NEXT::UNSEEN; @ISA = 'NEXT';
+package NEXT::ACTUAL; @ISA = 'NEXT';
+package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
+package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
+
1;
__END__
@@ -65,36 +80,36 @@
=head1 SYNOPSIS
- use NEXT;
+ use NEXT;
- package A;
- sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
- sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
+ package A;
+ sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
+ sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
- package B;
- use base qw( A );
- sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
+ package B;
+ use base qw( A );
+ sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
- package C;
- sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
- sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
+ package C;
+ sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
+ sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
- package D;
- use base qw( B C );
- sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
- sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
+ package D;
+ use base qw( B C );
+ sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
+ sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
- package main;
+ package main;
- my $obj = bless {}, "D";
+ my $obj = bless {}, "D";
- $obj->method(); # Calls D::method, A::method, C::method
- $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
+ $obj->method(); # Calls D::method, A::method, C::method
+ $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
- # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
+ # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
=head1 DESCRIPTION
@@ -126,10 +141,150 @@
hope that some other C<AUTOLOAD> (above it, or to its left) might
do better.
+By default, if a redispatch attempt fails to find another method
+elsewhere in the objects class hierarchy, it quietly gives up and does
+nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
+is also unlike the (generally annoying) behaviour of C<SUPER>, which
+throws an exception if it cannot redispatch.
+
Note that it is a fatal error for any method (including C<AUTOLOAD>)
-to attempt to redispatch any method except itself. For example:
+to attempt to redispatch any method that does not have the
+same name. For example:
+
+ sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
+
+
+=head2 Enforcing redispatch
+
+It is possible to make C<NEXT> redispatch more demandingly (i.e. like
+C<SUPER> does), so that the redispatch throws an exception if it cannot
+find a "next" method to call.
+
+To do this, simple invoke the redispatch as:
+
+ $self->NEXT::ACTUAL::method();
+
+rather than:
+
+ $self->NEXT::method();
+
+The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
+or it should throw an exception.
+
+C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
+decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
+semantics:
+
+ sub AUTOLOAD {
+ if ($AUTOLOAD =~ /foo|bar/) {
+ # handle here
+ }
+ else { # try elsewhere
+ shift()->NEXT::ACTUAL::AUTOLOAD(@_);
+ }
+ }
+
+By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
+method call, an exception will be thrown (as usually happens in the absence of
+a suitable C<AUTOLOAD>).
+
+
+=head2 Avoiding repetitions
+
+If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
+
+ # A B
+ # / \ /
+ # C D
+ # \ /
+ # E
+
+ use NEXT;
+
+ package A;
+ sub foo { print "called A::foo\n"; shift->NEXT::foo() }
+
+ package B;
+ sub foo { print "called B::foo\n"; shift->NEXT::foo() }
+
+ package C; @ISA = qw( A );
+ sub foo { print "called C::foo\n"; shift->NEXT::foo() }
+
+ package D; @ISA = qw(A B);
+ sub foo { print "called D::foo\n"; shift->NEXT::foo() }
+
+ package E; @ISA = qw(C D);
+ sub foo { print "called E::foo\n"; shift->NEXT::foo() }
+
+ E->foo();
+
+then derived classes may (re-)inherit base-class methods through two or
+more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
+through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
+will invoke the multiply inherited method as many times as it is
+inherited. For example, the above code prints:
+
+ called E::foo
+ called C::foo
+ called A::foo
+ called D::foo
+ called A::foo
+ called B::foo
+
+(i.e. C<A::foo> is called twice).
+
+In some cases this I<may> be the desired effect within a diamond hierarchy,
+but in others (e.g. for destructors) it may be more appropriate to
+call each method only once during a sequence of redispatches.
+
+To cover such cases, you can redispatch methods via:
+
+ $self->NEXT::UNSEEN::method();
+
+rather than:
+
+ $self->NEXT::method();
+
+This causes the redispatcher to skip any classes in the hierarchy that it has
+already visited in an earlier redispatch. So, for example, if the
+previous example were rewritten:
+
+ package A;
+ sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ package B;
+ sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ package C; @ISA = qw( A );
+ sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ package D; @ISA = qw(A B);
+ sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ package E; @ISA = qw(C D);
+ sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ E->foo();
+
+then it would print:
+
+ called E::foo
+ called C::foo
+ called A::foo
+ called D::foo
+ called B::foo
+
+and omit the second call to C<A::foo>.
+
+Note that you can also use:
+
+ $self->NEXT::UNSEEN::ACTUAL::method();
+
+or:
+
+ $self->NEXT::ACTUAL::UNSEEN::method();
- sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
+to get both unique invocation I<and> exception-on-failure.
=head1 AUTHOR
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/Config.pm#4 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/Config.pm
--- perl/macos/bundled_lib/blib/lib/Net/Config.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/Config.pm Tue Jan 15 08:00:05 2002
@@ -13,7 +13,7 @@
@EXPORT = qw(%NetConfig);
@ISA = qw(Net::LocalCfg Exporter);
-$VERSION = "1.08"; # $Id: //depot/libnet/Net/Config.pm#13 $
+$VERSION = "1.09"; # $Id: //depot/libnet/Net/Config.pm#16 $
eval { local $SIG{__DIE__}; require Net::LocalCfg };
@@ -36,24 +36,24 @@
#
# Try to get as much configuration info as possible from InternetConfig
#
-1 && eval <<'TRY_INTERNET_CONFIG';
+$^O eq 'MacOS' and eval <<TRY_INTERNET_CONFIG;
use Mac::InternetConfig;
{
my %nc = (
- nntp_hosts => [ $InternetConfig{ kICNNTPHost()} ],
- pop3_hosts => [ $InternetConfig{ kICMailAccount()} =~ /@(.*)/ ],
- smtp_hosts => [ $InternetConfig{ kICSMTPHost()} ],
- ftp_testhost => [ $InternetConfig{ kICFTPHost()} ],
- ph_hosts => [ $InternetConfig{ kICPhHost()} ],
- ftp_ext_passive => $InternetConfig{"646F676F€UsePassiveMode"} || 0,
- ftp_int_passive => $InternetConfig{"646F676F€UsePassiveMode"} || 0,
+ nntp_hosts => [ \$InternetConfig{ kICNNTPHost() } ],
+ pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ],
+ smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ],
+ ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef,
+ ph_hosts => [ \$InternetConfig{ kICPhHost() } ],
+ ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
+ ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
socks_hosts =>
- $InternetConfig{kICUseSocks()} ? [ $InternetConfig{kICSocksHost()} ] : [],
+ \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [],
ftp_firewall =>
- $InternetConfig{kICUseFTPProxy()} ? [ $InternetConfig{kICFTPProxyHost()} ] : [],
+ \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [],
);
-@NetConfig{keys %nc} = values %nc;
+\@NetConfig{keys %nc} = values %nc;
}
TRY_INTERNET_CONFIG
@@ -80,7 +80,7 @@
my ($k,$v);
while(($k,$v) = each %NetConfig) {
$NetConfig{$k} = [ $v ]
- if($k =~ /_hosts$/ && !ref($v));
+ if($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
}
# Take a hostname and determine if it is inside the firewall
@@ -193,7 +193,7 @@
=item ftp_firewall
-If you have an FTP proxy firewall (B<NOT> a HTTP or SOCKS firewall)
+If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall)
then this value should be set to the firewall hostname. If your firewall
does not listen to port 21, then this value should be set to
C<"hostname:port"> (eg C<"hostname:99">)
@@ -309,6 +309,6 @@
=for html <hr>
-I<$Id: //depot/libnet/Net/Config.pm#13 $>
+I<$Id: //depot/libnet/Net/Config.pm#16 $>
=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/Domain.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/Domain.pm
--- perl/macos/bundled_lib/blib/lib/Net/Domain.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/Domain.pm Tue Jan 15 08:00:05 2002
@@ -16,7 +16,7 @@
@ISA = qw(Exporter);
@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
-$VERSION = "2.16"; # $Id: //depot/libnet/Net/Domain.pm#18 $
+$VERSION = "2.17"; # $Id: //depot/libnet/Net/Domain.pm#19 $
my($host,$domain,$fqdn) = (undef,undef,undef);
@@ -127,6 +127,7 @@
# those on dialup systems.
local *RES;
+ local($_);
if(open(RES,"/etc/resolv.conf")) {
while(<RES>) {
@@ -143,7 +144,6 @@
my $host = _hostname();
my(@hosts);
- local($_);
@hosts = ($host,"localhost");
@@ -331,6 +331,6 @@
=for html <hr>
-I<$Id: //depot/libnet/Net/Domain.pm#18 $>
+I<$Id: //depot/libnet/Net/Domain.pm#19 $>
=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/FTP.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/FTP.pm
--- perl/macos/bundled_lib/blib/lib/Net/FTP.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/FTP.pm Tue Jan 15 08:00:05 2002
@@ -22,7 +22,7 @@
use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
# use AutoLoader qw(AUTOLOAD);
-$VERSION = "2.61"; # $Id: //depot/libnet/Net/FTP.pm#61 $
+$VERSION = "2.62"; # $Id: //depot/libnet/Net/FTP.pm#64 $
@ISA = qw(Exporter Net::Cmd IO::Socket::INET);
# Someday I will "use constant", when I am not bothered to much about
@@ -142,11 +142,7 @@
$ftp->close;
}
-sub DESTROY
-{
- my $ftp = shift;
- defined(fileno($ftp)) && $ftp->quit
-}
+sub DESTROY {}
sub ascii { shift->type('A',@_); }
sub binary { shift->type('I',@_); }
@@ -310,7 +306,7 @@
($ruser,$pass,$acct) = $rc->lpa()
if ($rc);
- $pass = "-" . (eval { (getpwuid($>))[0] } || $ENV{NAME} ) . '@'
+ $pass = '-anonymous@'
if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
}
@@ -1200,7 +1196,7 @@
use Net::FTP;
$ftp = Net::FTP->new("some.host.name", Debug => 0);
- $ftp->login("anonymous",'[email protected]');
+ $ftp->login("anonymous",'-anonymous@');
$ftp->cwd("/pub");
$ftp->get("that.file");
$ftp->quit;
@@ -1247,17 +1243,17 @@
=item new (HOST [,OPTIONS])
This is the constructor for a new Net::FTP object. C<HOST> is the
-name of the remote host to which a FTP connection is required.
+name of the remote host to which an FTP connection is required.
C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:
-B<Firewall> - The name of a machine which acts as a FTP firewall. This can be
+B<Firewall> - The name of a machine which acts as an FTP firewall. This can be
overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
given host cannot be directly connected to, then the
connection is made to the firewall machine and the string C<@hostname> is
appended to the login identifier. This kind of setup is also refered to
-as a ftp proxy.
+as an ftp proxy.
B<FirewallType> - The type of firewall running on the machine indicated by
B<Firewall>. This can be overridden by an environment variable
@@ -1394,7 +1390,7 @@
=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )
Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
-a filename or a filehandle. If not specified the the file will be stored in
+a filename or a filehandle. If not specified, the file will be stored in
the current directory with the same leafname as the remote file.
If C<WHERE> is given then the first C<WHERE> bytes of the file will
@@ -1476,7 +1472,7 @@
=item nlst ( [ DIR ] )
-Send a C<NLST> command to the server, with an optional parameter.
+Send an C<NLST> command to the server, with an optional parameter.
=item list ( [ DIR ] )
@@ -1517,7 +1513,7 @@
=item port ( [ PORT ] )
Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
-to the server. If not the a listen socket is created and the correct information
+to the server. If not, then a listen socket is created and the correct information
sent to the server.
=item pasv ()
@@ -1593,7 +1589,7 @@
Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given the the timeout value from the command connection will be used.
+given, the timeout value from the command connection will be used.
Returns the number of bytes read before any <CRLF> translation.
@@ -1601,7 +1597,7 @@
Write C<SIZE> bytes of data from C<BUFFER> to the server, also
performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given the the timeout value from the command connection will be used.
+given, the timeout value from the command connection will be used.
Returns the number of bytes written before any <CRLF> translation.
@@ -1718,6 +1714,6 @@
=for html <hr>
-I<$Id: //depot/libnet/Net/FTP.pm#61 $>
+I<$Id: //depot/libnet/Net/FTP.pm#64 $>
=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/FTP/E.pm#2 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/FTP/E.pm
--- perl/macos/bundled_lib/blib/lib/Net/FTP/E.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/FTP/E.pm Tue Jan 15 08:00:05 2002
@@ -3,5 +3,6 @@
require Net::FTP::I;
@ISA = qw(Net::FTP::I);
+$VERSION = "0.01";
1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/FTP/L.pm#2 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/FTP/L.pm
--- perl/macos/bundled_lib/blib/lib/Net/FTP/L.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/FTP/L.pm Tue Jan 15 08:00:05 2002
@@ -3,5 +3,6 @@
require Net::FTP::I;
@ISA = qw(Net::FTP::I);
+$VERSION = "0.01";
1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/HTTP.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/HTTP.pm
--- perl/macos/bundled_lib/blib/lib/Net/HTTP.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/HTTP.pm Tue Jan 15 08:00:05 2002
@@ -1,479 +1,26 @@
package Net::HTTP;
-# $Id: HTTP.pm,v 1.36 2001/10/26 18:06:26 gisle Exp $
-
-require 5.005; # 4-arg substr
+# $Id: HTTP.pm,v 1.39 2001/12/03 22:04:54 gisle Exp $
use strict;
use vars qw($VERSION @ISA);
-$VERSION = "0.03";
+$VERSION = "0.04";
eval { require IO::Socket::INET } || require IO::Socket;
-@ISA=qw(IO::Socket::INET);
+require Net::HTTP::Methods;
-my $CRLF = "\015\012"; # "\r\n" is not portable
+@ISA=qw(IO::Socket::INET Net::HTTP::Methods);
sub configure {
my($self, $cnf) = @_;
-
- die "Listen option not allowed" if $cnf->{Listen};
- my $host = delete $cnf->{Host};
- my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
- if ($host) {
- $cnf->{PeerHost} = $host unless $peer;
- }
- else {
- $host = $peer;
- $host =~ s/:.*//;
- }
- $cnf->{PeerPort} = 80 unless $cnf->{PeerPort};
-
- my $keep_alive = delete $cnf->{KeepAlive};
- my $http_version = delete $cnf->{HTTPVersion};
- $http_version = "1.1" unless defined $http_version;
- my $peer_http_version = delete $cnf->{PeerHTTPVersion};
- $peer_http_version = "1.0" unless defined $peer_http_version;
- my $send_te = delete $cnf->{SendTE};
-
- my $sock = $self->_http_socket_configure($cnf);
- if ($sock) {
- unless ($host =~ /:/) {
- my $p = $sock->peerport;
- $host .= ":$p"; # if $p != 80;
- }
- $sock->host($host);
- $sock->keep_alive($keep_alive);
- $sock->send_te($send_te);
- $sock->http_version($http_version);
- $sock->peer_http_version($peer_http_version);
-
- ${*$self}{'http_buf'} = "";
- }
- return $sock;
+ $self->http_configure($cnf);
}
-sub _http_socket_configure {
- my $self = shift;
- $self->SUPER::configure(@_);
-}
-
-sub host {
- my $self = shift;
- my $old = ${*$self}{'http_host'};
- ${*$self}{'http_host'} = shift if @_;
- $old;
-}
-
-sub keep_alive {
- my $self = shift;
- my $old = ${*$self}{'http_keep_alive'};
- ${*$self}{'http_keep_alive'} = shift if @_;
- $old;
-}
-
-sub send_te {
- my $self = shift;
- my $old = ${*$self}{'http_send_te'};
- ${*$self}{'http_send_te'} = shift if @_;
- $old;
-}
-
-sub http_version {
- my $self = shift;
- my $old = ${*$self}{'http_version'};
- if (@_) {
- my $v = shift;
- $v = "1.0" if $v eq "1"; # float
- unless ($v eq "1.0" or $v eq "1.1") {
- require Carp;
- Carp::croak("Unsupported HTTP version '$v'");
- }
- ${*$self}{'http_version'} = $v;
- }
- $old;
-}
-
-sub peer_http_version {
- my $self = shift;
- my $old = ${*$self}{'http_peer_version'};
- ${*$self}{'http_peer_version'} = shift if @_;
- $old;
+sub http_connect {
+ my($self, $cnf) = @_;
+ $self->SUPER::configure($cnf);
}
-
-sub format_request {
- my $self = shift;
- my $method = shift;
- my $uri = shift;
-
- my $content = (@_ % 2) ? pop : "";
-
- for ($method, $uri) {
- require Carp;
- Carp::croak("Bad method or uri") if /\s/ || !length;
- }
-
- push(@{${*$self}{'http_request_method'}}, $method);
- my $ver = ${*$self}{'http_version'};
- my $peer_ver = ${*$self}{'http_peer_version'} || "1.0";
-
- my @h;
- my @connection;
- my %given = (host => 0, "content-length" => 0, "te" => 0);
- while (@_) {
- my($k, $v) = splice(@_, 0, 2);
- my $lc_k = lc($k);
- if ($lc_k eq "connection") {
- push(@connection, split(/\s*,\s*/, $v));
- next;
- }
- if (exists $given{$lc_k}) {
- $given{$lc_k}++;
- }
- push(@h, "$k: $v");
- }
-
- if (length($content) && !$given{'content-length'}) {
- push(@h, "Content-Length: " . length($content));
- }
-
- my @h2;
- if ($given{te}) {
- push(@connection, "TE") unless grep lc($_) eq "te", @connection;
- }
- elsif ($self->send_te && zlib_ok()) {
- # gzip is less wanted since the Compress::Zlib interface for
- # it does not really allow chunked decoding to take place easily.
- push(@h2, "TE: deflate,gzip;q=0.3");
- push(@connection, "TE");
- }
-
- unless (grep lc($_) eq "close", @connection) {
- if ($self->keep_alive) {
- if ($peer_ver eq "1.0") {
- # from looking at Netscape's headers
- push(@h2, "Keep-Alive: 300");
- unshift(@connection, "Keep-Alive");
- }
- }
- else {
- push(@connection, "close") if $ver ge "1.1";
- }
- }
- push(@h2, "Connection: " . join(", ", @connection)) if @connection;
- push(@h2, "Host: ${*$self}{'http_host'}") unless $given{host};
-
- return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
-}
-
-
-sub write_request {
- my $self = shift;
- print $self $self->format_request(@_);
-}
-
-sub format_chunk {
- my $self = shift;
- return $_[0] unless defined($_[0]) && length($_[0]);
- return hex(length($_[0])) . $CRLF . $_[0] . $CRLF;
-}
-
-sub write_chunk {
- my $self = shift;
- return 1 unless defined($_[0]) && length($_[0]);
- print $self hex(length($_[0])), $CRLF, $_[0], $CRLF;
-}
-
-sub format_chunk_eof {
- my $self = shift;
- my @h;
- while (@_) {
- push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
- }
- return join("", "0$CRLF", @h, $CRLF);
-}
-
-sub write_chunk_eof {
- my $self = shift;
- print $self $self->format_chunk_eof(@_);
-}
-
-
-sub my_read {
- die if @_ > 3;
- my $self = shift;
- my $len = $_[1];
- for (${*$self}{'http_buf'}) {
- if (length) {
- $_[0] = substr($_, 0, $len, "");
- return length($_[0]);
- }
- else {
- return $self->sysread($_[0], $len);
- }
- }
-}
-
-
-sub my_readline {
- my $self = shift;
- for (${*$self}{'http_buf'}) {
- my $pos;
- while (1) {
- $pos = index($_, "\012");
- last if $pos >= 0;
- my $n = $self->sysread($_, 1024, length);
- if (!$n) {
- return undef unless length;
- return substr($_, 0, length, "");
- }
- }
- my $line = substr($_, 0, $pos+1, "");
- $line =~ s/\015?\012\z//;
- return $line;
- }
-}
-
-
-sub _rbuf {
- my $self = shift;
- if (@_) {
- for (${*$self}{'http_buf'}) {
- my $old;
- $old = $_ if defined wantarray;
- $_ = shift;
- return $old;
- }
- }
- else {
- return ${*$self}{'http_buf'};
- }
-}
-
-sub _rbuf_length {
- my $self = shift;
- return length ${*$self}{'http_buf'};
-}
-
-
-sub read_header_lines {
- my $self = shift;
- my @headers;
- while (my $line = my_readline($self)) {
- if ($line =~ /^(\S+)\s*:\s*(.*)/s) {
- push(@headers, $1, $2);
- }
- elsif (@headers && $line =~ s/^\s+//) {
- $headers[-1] .= " " . $line;
- }
- else {
- die "Bad header: $line\n";
- }
- }
- return @headers;
-}
-
-
-sub read_response_headers {
- my $self = shift;
- my $status = my_readline($self);
- die "EOF instead of reponse status line" unless defined $status;
- my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
- die "Bad response status line: '$status'"
- if !$peer_ver || $peer_ver !~ s,^HTTP/,,;
- ${*$self}{'http_peer_version'} = $peer_ver;
- ${*$self}{'http_status'} = $code;
- my @headers = $self->read_header_lines;
-
- # pick out headers that read_entity_body might need
- my @te;
- my $content_length;
- for (my $i = 0; $i < @headers; $i += 2) {
- my $h = lc($headers[$i]);
- if ($h eq 'transfer-encoding') {
- push(@te, $headers[$i+1]);
- }
- elsif ($h eq 'content-length') {
- $content_length = $headers[$i+1];
- }
- }
- ${*$self}{'http_te'} = join(",", @te);
- ${*$self}{'http_content_length'} = $content_length;
- ${*$self}{'http_first_body'}++;
- delete ${*$self}{'http_trailers'};
- return $code unless wantarray;
- return ($code, $message, @headers);
-}
-
-
-sub read_entity_body {
- my $self = shift;
- my $buf_ref = \$_[0];
- my $size = $_[1];
-
- my $chunked;
- my $bytes;
-
- if (${*$self}{'http_first_body'}) {
- ${*$self}{'http_first_body'} = 0;
- delete ${*$self}{'http_chunked'};
- delete ${*$self}{'http_bytes'};
- my $method = shift(@{${*$self}{'http_request_method'}});
- my $status = ${*$self}{'http_status'};
- if ($method eq "HEAD" || $status =~ /^(?:1|[23]04)/) {
- # these responses are always empty
- $bytes = 0;
- }
- elsif (my $te = ${*$self}{'http_te'}) {
- my @te = split(/\s*,\s*/, $te);
- die "Chunked must be last Transfer-Encoding '$te'"
- unless pop(@te) eq "chunked";
-
- for (@te) {
- if ($_ eq "deflate" && zlib_ok()) {
- #require Compress::Zlib;
- my $i = Compress::Zlib::inflateInit();
- die "Can't make inflator" unless $i;
- $_ = sub { scalar($i->inflate($_[0])) }
- }
- elsif ($_ eq "gzip" && zlib_ok()) {
- #require Compress::Zlib;
- my @buf;
- $_ = sub {
- push(@buf, $_[0]);
- return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
- return "";
- };
- }
- elsif ($_ eq "identity") {
- $_ = sub { $_[0] };
- }
- else {
- die "Can't handle transfer encoding '$te'";
- }
- }
-
- @te = reverse(@te);
-
- ${*$self}{'http_te2'} = @te ? \@te : "";
- $chunked = -1;
- }
- elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
- $bytes = $content_length;
- }
- else {
- # XXX Multi-Part types are self delimiting, but RFC 2616 says we
- # only has to deal with 'multipart/byteranges'
-
- # Read until EOF
- }
- }
- else {
- $chunked = ${*$self}{'http_chunked'};
- $bytes = ${*$self}{'http_bytes'};
- }
-
- if (defined $chunked) {
- # The state encoded in $chunked is:
- # $chunked == 0: read CRLF after chunk, then chunk header
- # $chunked == -1: read chunk header
- # $chunked > 0: bytes left in current chunk to read
-
- if ($chunked <= 0) {
- my $line = my_readline($self);
- if ($chunked == 0) {
- die "Not empty: '$line'" unless $line eq "";
- $line = my_readline($self);
- }
- $line =~ s/;.*//; # ignore potential chunk parameters
- $line =~ s/\s+$//; # avoid warnings from hex()
- $chunked = hex($line);
- if ($chunked == 0) {
- ${*$self}{'http_trailers'} = [$self->read_header_lines];
- $$buf_ref = "";
-
- my $n = 0;
- if (my $transforms = delete ${*$self}{'http_te2'}) {
- for (@$transforms) {
- $$buf_ref = &$_($$buf_ref, 1);
- }
- $n = length($$buf_ref);
- }
-
- # in case somebody tries to read more, make sure we continue
- # to return EOF
- delete ${*$self}{'http_chunked'};
- ${*$self}{'http_bytes'} = 0;
-
- return $n;
- }
- }
-
- my $n = $chunked;
- $n = $size if $size && $size < $n;
- $n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
-
- ${*$self}{'http_chunked'} = $chunked - $n;
-
- if ($n > 0) {
- if (my $transforms = ${*$self}{'http_te2'}) {
- for (@$transforms) {
- $$buf_ref = &$_($$buf_ref, 0);
- }
- $n = length($$buf_ref);
- $n = -1 if $n == 0;
- }
- }
- return $n;
- }
- elsif (defined $bytes) {
- unless ($bytes) {
- $$buf_ref = "";
- return 0;
- }
- my $n = $bytes;
- $n = $size if $size && $size < $n;
- $n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
- ${*$self}{'http_bytes'} = $bytes - $n;
- return $n;
- }
- else {
- # read until eof
- $size ||= 8*1024;
- return my_read($self, $$buf_ref, $size);
- }
-}
-
-sub get_trailers {
- my $self = shift;
- @{${*$self}{'http_trailers'} || []};
-}
-
-BEGIN {
-my $zlib_ok;
-
-sub zlib_ok {
- return $zlib_ok if defined $zlib_ok;
-
- # Try to load Compress::Zlib.
- local $@;
- local $SIG{__DIE__};
- $zlib_ok = 0;
-
- eval {
- require Compress::Zlib;
- Compress::Zlib->VERSION(1.10);
- $zlib_ok++;
- };
- #warn $@ if $@ && $^W;
-}
-
-} # BEGIN
-
-
-
1;
__END__
@@ -527,6 +74,8 @@
SendTE: Initial send_te attribute_value
HTTPVersion: Initial http_version attribute value
PeerHTTPVersion: Initial peer_http_version attribute value
+ MaxLineLength: Initial max_line_length attribute value
+ MaxHeaderLines: Initial max_header_lines attribute value
=item $s->host
@@ -561,6 +110,16 @@
initially be "1.0", but will be updated by a successful
read_response_headers() method call.
+=item $s->max_line_length
+
+Get/set a limit on the length of response line and response header
+lines. The default is 4096. A value of 0 means no limit.
+
+=item $s->max_header_length
+
+Get/set a limit on the number of headers lines that a response can
+have. The default is 128. A value of 0 means no limit.
+
=item $s->format_request($method, $uri, %headers, [$content])
Format a request message and return it as a string. If the headers do
@@ -603,7 +162,7 @@
Returns the string to be written for signaling EOF.
-=item ($code, $mess, %headers) = $s->read_response_headers
+=item ($code, $mess, %headers) = $s->read_response_headers( %opts )
Read response headers from server. The $code is the 3 digit HTTP
status code (see L<HTTP::Status>) and $mess is the textual message
@@ -618,6 +177,16 @@
The method will raise exceptions (die) if the server does not speak
proper HTTP.
+Options might be passed in as key/value pairs. There are currently
+only two options supported; C<laxed> and C<junk_out>.
+
+The C<laxed> option will make C<read_response_headers> more forgiving
+towards servers that have not learned how to speak HTTP properly. The
+<laxed> option is a boolean flag, and is enabled by passing in a TRUE
+value. The C<junk_out> option can be used to capture bad header lines
+when C<laxed> is enabled. The value should be an array reference.
+Bad header lines will be pushed onto the array.
+
=item $n = $s->read_entity_body($buf, $size);
Reads chunks of the entity body content. Basically the same interface
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/NNTP.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/NNTP.pm
--- perl/macos/bundled_lib/blib/lib/Net/NNTP.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/NNTP.pm Tue Jan 15 08:00:05 2002
@@ -14,7 +14,7 @@
use Time::Local;
use Net::Config;
-$VERSION = "2.20"; # $Id: //depot/libnet/Net/NNTP.pm#13 $
+$VERSION = "2.20"; # $Id: //depot/libnet/Net/NNTP.pm#14 $
@ISA = qw(Net::Cmd IO::Socket::INET);
sub new
@@ -1016,7 +1016,7 @@
bracket.
The final operation uses the backslash character to
-invalidate the special meaning of the a open square bracket C<[>,
+invalidate the special meaning of an open square bracket C<[>,
the asterisk, backslash or the question mark. Two backslashes in
sequence will result in the evaluation of the backslash as a
character with no special meaning.
@@ -1064,6 +1064,6 @@
=for html <hr>
-I<$Id: //depot/libnet/Net/NNTP.pm#13 $>
+I<$Id: //depot/libnet/Net/NNTP.pm#14 $>
=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/POP3.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/POP3.pm
--- perl/macos/bundled_lib/blib/lib/Net/POP3.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/POP3.pm Tue Jan 15 08:00:05 2002
@@ -13,7 +13,7 @@
use Carp;
use Net::Config;
-$VERSION = "2.22"; # $Id: //depot/libnet/Net/POP3.pm#19 $
+$VERSION = "2.22"; # $Id: //depot/libnet/Net/POP3.pm#20 $
@ISA = qw(Net::Cmd IO::Socket::INET);
@@ -417,7 +417,7 @@
=item login ( [ USER [, PASS ]] )
-Send both the the USER and PASS commands. If C<PASS> is not given the
+Send both the USER and PASS commands. If C<PASS> is not given the
C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
and username. If the username is not specified then the current user name
will be used.
@@ -520,6 +520,6 @@
=for html <hr>
-I<$Id: //depot/libnet/Net/POP3.pm#19 $>
+I<$Id: //depot/libnet/Net/POP3.pm#20 $>
=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/SMTP.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/SMTP.pm
--- perl/macos/bundled_lib/blib/lib/Net/SMTP.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/SMTP.pm Tue Jan 15 08:00:05 2002
@@ -16,7 +16,7 @@
use Net::Cmd;
use Net::Config;
-$VERSION = "2.17"; # $Id: //depot/libnet/Net/SMTP.pm#17 $
+$VERSION = "2.19"; # $Id: //depot/libnet/Net/SMTP.pm#20 $
@ISA = qw(Net::Cmd IO::Socket::INET);
@@ -92,15 +92,35 @@
$self->_ETRN(@_);
}
+sub auth { # auth(username, password) by mengwong 20011106. the only supported mechanism at this time is PLAIN.
+ #
+ # my $auth = $smtp->supports("AUTH");
+ # $smtp->auth("username", "password") or die $smtp->message;
+ #
+
+ require MIME::Base64;
+
+ my $self = shift;
+ my ($username, $password) = @_;
+ die "auth(username, password)" if not length $username;
+
+ my $mechanisms = $self->supports('AUTH',500,["Command unknown: 'AUTH'"]);
+ return unless defined $mechanisms;
+
+ if (not grep { uc $_ eq "PLAIN" } split ' ', $mechanisms) {
+ $self->set_status(500, ["PLAIN mechanism not supported; server supports $mechanisms"]);
+ return;
+ }
+ my $authstring = MIME::Base64::encode_base64(join "\0", ($username)x2, $password);
+ $authstring =~ s/\n//g; # wrap long lines
+
+ $self->_AUTH("PLAIN $authstring");
+}
+
sub hello
{
my $me = shift;
- my $domain = shift ||
- eval {
- require Net::Domain;
- Net::Domain::hostfqdn();
- } ||
- "";
+ my $domain = shift || "localhost.localdomain";
my $ok = $me->_EHLO($domain);
my @msg = $me->message;
@@ -376,6 +396,7 @@
sub _DATA { shift->command("DATA")->response() == CMD_MORE }
sub _TURN { shift->unsupported(@_); }
sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
+sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
1;
@@ -444,7 +465,7 @@
=item new Net::SMTP [ HOST, ] [ OPTIONS ]
This is the constructor for a new Net::SMTP object. C<HOST> is the
-name of the remote host to which a SMTP connection is required.
+name of the remote host to which an SMTP connection is required.
If C<HOST> is not given, then the C<SMTP_Host> specified in C<Net::Config>
will be used.
@@ -503,6 +524,12 @@
Request a queue run for the DOMAIN given.
+=item auth ( USERNAME, PASSWORD )
+
+Attempt SASL authentication. At this time only the PLAIN mechanism is supported.
+
+At some point in the future support for using Authen::SASL will be added
+
=item mail ( ADDRESS [, OPTIONS] )
=item send ( ADDRESS )
@@ -609,6 +636,6 @@
=for html <hr>
-I<$Id: //depot/libnet/Net/SMTP.pm#17 $>
+I<$Id: //depot/libnet/Net/SMTP.pm#20 $>
=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/libnetFAQ.pod#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/libnetFAQ.pod
--- perl/macos/bundled_lib/blib/lib/Net/libnetFAQ.pod.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/libnetFAQ.pod Tue Jan 15 08:00:05 2002
@@ -6,8 +6,8 @@
=head2 Where to get this document
-This document is distributed with the libnet disribution, and is also
-avaliable on the libnet web page at
+This document is distributed with the libnet distribution, and is also
+available on the libnet web page at
http://www.pobox.com/~gbarr/libnet/
@@ -20,7 +20,7 @@
Copyright (c) 1997-1998 Graham Barr. All rights reserved.
This document is free; you can redistribute it and/or modify it
-under the terms of the Artistic Licence.
+under the terms of the Artistic License.
=head2 Disclaimer
@@ -35,7 +35,7 @@
=head2 What is libnet ?
libnet is a collection of perl5 modules which all related to network
-programming. The majority of the modules avaliable provided the
+programming. The majority of the modules available provided the
client side of popular server-client protocols that are used in
the internet community.
@@ -55,7 +55,7 @@
=head2 What machines support libnet ?
-libnet itself is an entirly perl-code distribution so it should work
+libnet itself is an entirely perl-code distribution so it should work
on any machine that perl runs on. However IO may not work
with some machines and earlier releases of perl. But this
should not be the case with perl version 5.004 or later.
@@ -65,16 +65,16 @@
The latest libnet release is always on CPAN, you will find it
in
- http://www.perl.com/CPAN/modules/by-module/Net/
+ http://www.cpan.org/modules/by-module/Net/
-The latest release and information is also avaliable on the libnet web page
+The latest release and information is also available on the libnet web page
at
http://www.pobox.com/~gbarr/libnet/
=head1 Using Net::FTP
-=head2 How do I download files from a FTP server ?
+=head2 How do I download files from an FTP server ?
An example taken from an article posted to comp.lang.perl.misc
@@ -135,9 +135,9 @@
=head2 Can I do a reget operation like the ftp command ?
-=head2 How do I get a directory listing from a FTP server ?
+=head2 How do I get a directory listing from an FTP server ?
-=head2 Changeing directory to "" does not fail ?
+=head2 Changing directory to "" does not fail ?
Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
without any arguments. Turn on Debug (I<See below>) and you will see what is
@@ -155,19 +155,19 @@
=head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
The Firewall option is only for support of one type of firewall. The type
-supported is a ftp proxy.
+supported is an ftp proxy.
To use Net::FTP, or any other module in the libnet distribution,
through a SOCKS firewall you must create a socks-ified perl executable
by compiling perl with the socks library.
-=head2 I am behind a FTP proxy firewall, but cannot access machines outside ?
+=head2 I am behind an FTP proxy firewall, but cannot access machines outside ?
-Net::FTP implements the most popular ftp proxy firewall approach. The sceme
-implemented is that where you loginin to the firewall with C<user@hostname>
+Net::FTP implements the most popular ftp proxy firewall approach. The scheme
+implemented is that where you log in to the firewall with C<user@hostname>
I have heard of one other type of firewall which requires a login to the
-firewall with an accont, then a second login with C<user@hostname>. You can
+firewall with an account, then a second login with C<user@hostname>. You can
still use Net::FTP to traverse these firewalls, but a more manual approach
must be taken, eg
@@ -178,7 +178,7 @@
=head2 My ftp proxy firewall does not listen on port 21
FTP servers usually listen on the same port number, port 21, as any other
-FTP server. But there is no reason why thi has to be the case.
+FTP server. But there is no reason why this has to be the case.
If you pass a port number to Net::FTP then it assumes this is the port
number of the final destination. By default Net::FTP will always try
@@ -201,7 +201,7 @@
=head2 I have seen scripts call a method message, but cannot find it documented ?
Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
-all the methods described in Net::Cmd are also avaliable on Net::FTP
+all the methods described in Net::Cmd are also available on Net::FTP
objects.
=head2 Why does Net::FTP not implement mput and mget methods
@@ -241,14 +241,14 @@
=head2 The verify method always returns true ?
-Well it may seem thay way, but it does not. The verify method returns true
-if the command suceeded. If you pass verify an address which the
-server would normally have to forward to another machine the the command
-will suceed with something like
+Well it may seem that way, but it does not. The verify method returns true
+if the command succeeded. If you pass verify an address which the
+server would normally have to forward to another machine, the command
+will succeed with something like
252 Couldn't verify <someone@there> but will attempt delivery anyway
-This command will only fail if you pass it an address in a domain the
+This command will fail only if you pass it an address in a domain
the server directly delivers for, and that address does not exist.
=head1 Debugging scripts
@@ -259,7 +259,7 @@
constructor, in most cases one option is called C<Debug>. Passing
this option with a non-zero value will turn on a protocol trace, which
will be sent to STDERR. This trace can be useful to see what commands
-are being sent to the remote server and what responces are being
+are being sent to the remote server and what responses are being
received back.
#!/your/path/to/perl
@@ -287,14 +287,14 @@
Net::FTP=GLOB(0x8152974)>>> QUIT
Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
-The first few lines tell you the modules that Net::FTP uses and thier versions,
-this is usefule data to me when a user reports a bug. The last seven lines
+The first few lines tell you the modules that Net::FTP uses and their versions,
+this is useful data to me when a user reports a bug. The last seven lines
show the communication with the server. Each line has three parts. The first
part is the object itself, this is useful for separating the output
-if you are using mutiple objects. The second part is either C<<<<<> to
+if you are using multiple objects. The second part is either C<<<<<> to
show data coming from the server or C<>>>>> to show data
going to the server. The remainder of the line is the command
-being sent or responce being received.
+being sent or response being received.
=head1 AUTHOR AND COPYRIGHT
@@ -303,5 +303,5 @@
=for html <hr>
-I<$Id: //depot/libnet/Net/libnetFAQ.pod#4 $>
+I<$Id: //depot/libnet/Net/libnetFAQ.pod#5 $>
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Switch.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Switch.pm
--- perl/macos/bundled_lib/blib/lib/Switch.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Switch.pm Tue Jan 15 08:00:05 2002
@@ -4,7 +4,7 @@
use vars qw($VERSION);
use Carp;
-$VERSION = '2.05';
+$VERSION = '2.06';
# LOAD FILTERING MODULE...
@@ -74,6 +74,16 @@
return !$ishash;
}
+
+my $EOP = qr/\n\n|\Z/;
+my $CUT = qr/\n=cut.*$EOP/;
+my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $EOP
+ | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
+ | ^__(DATA|END)__\n.*
+ /smx;
+
my $casecounter = 1;
sub filter_blocks
{
@@ -89,12 +99,15 @@
$text .= q{use Switch 'noimport'};
next component;
}
- my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
+ my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
if (defined $pos[0])
{
$text .= " " . substr($source,$pos[2],$pos[18]-$pos[2]);
next component;
}
+ if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
+ next component;
+ }
@pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
if (defined $pos[0])
{
@@ -149,7 +162,7 @@
$code =~ s {^\s*@} { \@};
$text .= " $code)";
}
- elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1)) {
+ elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
$code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
$code =~ s {^\s*m} { qr} ||
@@ -186,7 +199,7 @@
next component;
}
- $source =~ m/\G(\s*(\w+|#.*\n|\W))/gc;
+ $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
$text .= $1;
}
$text;
@@ -341,7 +354,8 @@
return 1;
}
-sub case($) { $::_S_W_I_T_C_H->(@_); }
+sub case($) { local $SIG{__WARN__} = \&carp;
+ $::_S_W_I_T_C_H->(@_); }
# IMPLEMENT __
@@ -473,8 +487,8 @@
=head1 VERSION
-This document describes version 2.05 of Switch,
-released September 3, 2001.
+This document describes version 2.06 of Switch,
+released November 14, 2001.
=head1 SYNOPSIS
@@ -825,6 +839,12 @@
There are undoubtedly serious bugs lurking somewhere in code this funky :-)
Bug reports and other feedback are most welcome.
+=head1 LIMITATION
+
+Due to the heuristic nature of Switch.pm's source parsing, the presence
+of regexes specified with raw C<?...?> delimiters may cause mysterious
+errors. The workaround is to use C<m?...?> instead.
+
=head1 COPYRIGHT
Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Text/Balanced.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Text/Balanced.pm
--- perl/macos/bundled_lib/blib/lib/Text/Balanced.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Text/Balanced.pm Tue Jan 15 08:00:05 2002
@@ -10,7 +10,7 @@
use SelfLoader;
use vars qw { $VERSION @ISA %EXPORT_TAGS };
-$VERSION = '1.86';
+$VERSION = '1.89';
@ISA = qw ( Exporter );
%EXPORT_TAGS = ( ALL => [ qw(
@@ -429,6 +429,9 @@
sub _match_variable($$)
{
+# $#
+# $^
+# $$
my ($textref, $pre) = @_;
my $startpos = pos($$textref) = pos($$textref)||0;
unless ($$textref =~ m/\G($pre)/gc)
@@ -437,19 +440,24 @@
return;
}
my $varpos = pos($$textref);
- unless ($$textref =~ m/\G(\$#?|[*\@\%]|\\&)+/gc)
+ unless ($$textref =~ m{\G\$\s*(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci)
{
+ unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc)
+ {
_failmsg "Did not find leading dereferencer", pos $$textref;
pos $$textref = $startpos;
return;
- }
+ }
+ my $deref = $1;
- unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci
- or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0))
- {
+ unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci
+ or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0)
+ or $deref eq '$#' or $deref eq '$$' )
+ {
_failmsg "Bad identifier after dereferencer", pos $$textref;
pos $$textref = $startpos;
return;
+ }
}
while (1)
@@ -854,13 +862,13 @@
my ($lastpos, $firstpos);
my @fields = ();
- for ($$textref)
+ #for ($$textref)
{
my @func = defined $_[1] ? @{$_[1]} : @{$def_func};
my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000;
my $igunk = $_[3];
- pos ||= 0;
+ pos $$textref ||= 0;
unless (wantarray)
{
@@ -888,51 +896,57 @@
}
}
- FIELD: while (pos() < length())
+ FIELD: while (pos($$textref) < length($$textref))
{
my $field;
+ my @bits;
foreach my $i ( 0..$#func )
{
+ my $pref;
$func = $func[$i];
$class = $class[$i];
- $lastpos = pos;
+ $lastpos = pos $$textref;
if (ref($func) eq 'CODE')
- { ($field) = $func->($_) }
+ { ($field,undef,$pref) = @bits = $func->($$textref) }
elsif (ref($func) eq 'Text::Balanced::Extractor')
- { $field = $func->extract($_) }
- elsif( m/\G$func/gc )
- { $field = defined($1) ? $1 : $& }
-
+ { @bits = $field = $func->extract($$textref) }
+ elsif( $$textref =~ m/\G$func/gc )
+ { @bits = $field = defined($1) ? $1 : $& }
+ $pref ||= "";
if (defined($field) && length($field))
{
- if (defined($unkpos) && !$igunk)
- {
- push @fields, substr($_, $unkpos, $lastpos-$unkpos);
- $firstpos = $unkpos unless defined $firstpos;
- undef $unkpos;
- last FIELD if @fields == $max;
+ if (!$igunk) {
+ $unkpos = pos $$textref
+ if length($pref) && !defined($unkpos);
+ if (defined $unkpos)
+ {
+ push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref;
+ $firstpos = $unkpos unless defined $firstpos;
+ undef $unkpos;
+ last FIELD if @fields == $max;
+ }
}
- push @fields, $class
- ? bless(\$field, $class)
+ push @fields, $class
+ ? bless (\$field, $class)
: $field;
$firstpos = $lastpos unless defined $firstpos;
- $lastpos = pos;
+ $lastpos = pos $$textref;
last FIELD if @fields == $max;
next FIELD;
}
}
- if (/\G(.)/gcs)
+ if ($$textref =~ /\G(.)/gcs)
{
- $unkpos = pos()-1
+ $unkpos = pos($$textref)-1
unless $igunk || defined $unkpos;
}
}
if (defined $unkpos)
{
- push @fields, substr($_, $unkpos);
+ push @fields, substr($$textref, $unkpos);
$firstpos = $unkpos unless defined $firstpos;
- $lastpos = length;
+ $lastpos = length $$textref;
}
last;
}
@@ -1925,13 +1939,18 @@
=back
The extraction process works by applying each extractor in
-sequence to the text string. If the extractor is a subroutine it
-is called in a list
-context and is expected to return a list of a single element, namely
-the extracted text.
-Note that the value returned by an extractor subroutine need not bear any
-relationship to the corresponding substring of the original text (see
-examples below).
+sequence to the text string.
+
+If the extractor is a subroutine it is called in a list context and is
+expected to return a list of a single element, namely the extracted
+text. It may optionally also return two further arguments: a string
+representing the text left after extraction (like $' for a pattern
+match), and a string representing any prefix skipped before the
+extraction (like $` in a pattern match). Note that this is designed
+to facilitate the use of other Text::Balanced subroutines with
+C<extract_multiple>. Note too that the value returned by an extractor
+subroutine need not bear any relationship to the corresponding substring
+of the original text (see examples below).
If the extractor is a precompiled regular expression or a string,
it is matched against the text in a scalar context with a leading
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/URI/Escape.pm#3 (text) ====
Index: perl/macos/bundled_lib/blib/lib/URI/Escape.pm
--- perl/macos/bundled_lib/blib/lib/URI/Escape.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/URI/Escape.pm Tue Jan 15 08:00:05 2002
@@ -1,5 +1,5 @@
#
-# $Id: Escape.pm,v 3.19 2001/08/24 17:25:43 gisle Exp $
+# $Id: Escape.pm,v 3.20 2001/10/26 22:55:26 gisle Exp $
#
package URI::Escape;
@@ -114,7 +114,7 @@
@ISA = qw(Exporter);
@EXPORT = qw(uri_escape uri_unescape);
@EXPORT_OK = qw(%escapes);
-$VERSION = sprintf("%d.%02d", q$Revision: 3.19 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 3.20 $ =~ /(\d+)\.(\d+)/);
use Carp ();
@@ -133,8 +133,7 @@
unless (exists $subst{$patn}) {
# Because we can't compile the regex we fake it with a cached sub
(my $tmp = $patn) =~ s,/,\\/,g;
- $subst{$patn} =
- eval "sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1}/g; }";
+ eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1}/g; }";
Carp::croak("uri_escape: $@") if $@;
}
&{$subst{$patn}}($text);
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/URI/ftp.pm#2 (text) ====
Index: perl/macos/bundled_lib/blib/lib/URI/ftp.pm
--- perl/macos/bundled_lib/blib/lib/URI/ftp.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/URI/ftp.pm Tue Jan 15 08:00:05 2002
@@ -5,8 +5,6 @@
@ISA=qw(URI::_server URI::_userpass);
use strict;
-use vars qw($whoami $fqdn);
-use URI::Escape qw(uri_unescape);
sub default_port { 21 }
@@ -31,25 +29,14 @@
my $user = $self->user;
if ($user eq 'anonymous' || $user eq 'ftp') {
# anonymous ftp login password
- unless (defined $fqdn) {
- eval {
- require Net::Domain;
- $fqdn = Net::Domain::hostfqdn();
- };
- if ($@) {
- $fqdn = '';
- }
- }
- unless (defined $whoami) {
- $whoami = $ENV{USER} || $ENV{LOGNAME} || $ENV{USERNAME};
- unless ($whoami) {
- if ($^O eq 'MSWin32') { $whoami = Win32::LoginName() }
- else {
- $whoami = getlogin || getpwuid($<) || 'unknown';
- }
- }
- }
- $pass = "$whoami\@$fqdn";
+ # If there is no ftp anonymous password specified
+ # then we'll just use 'anonymous@'
+ # We don't try to send the read e-mail address because:
+ # - We want to remain anonymous
+ # - We want to stop SPAM
+ # - We don't want to let ftp sites to discriminate by the user,
+ # host, country or ftp client being used.
+ $pass = 'anonymous@';
}
}
$pass;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/lwpcook.pod#2 (text) ====
Index: perl/macos/bundled_lib/blib/lib/lwpcook.pod
--- perl/macos/bundled_lib/blib/lib/lwpcook.pod.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/lwpcook.pod Tue Jan 15 08:00:05 2002
@@ -1,6 +1,6 @@
=head1 NAME
-lwpcook - libwww-perl cookbook
+lwpcook - The libwww-perl cookbook
=head1 DESCRIPTION
@@ -20,11 +20,11 @@
the document specified by its URL argument:
use LWP::Simple;
- $doc = get 'http://www.sn.no/libwww-perl/';
+ $doc = get 'http://www.linpro.no/lwp/';
or, as a perl one-liner using the getprint() function:
- perl -MLWP::Simple -e 'getprint "http://www.sn.no/libwww-perl/"'
+ perl -MLWP::Simple -e 'getprint "http://www.linpro.no/lwp/"'
or, how about fetching the latest perl by running this command:
@@ -151,16 +151,15 @@
use LWP::UserAgent;
$ua = LWP::UserAgent->new;
- $ua->proxy(['http', 'ftp'] => 'http://proxy.myorg.com');
+ $ua->proxy(['http', 'ftp'] => 'http://username:[email protected]');
$req = HTTP::Request->new('GET',"http://www.perl.com");
- $req->proxy_authorization_basic("proxy_user", "proxy_password");
$res = $ua->request($req);
print $res->content if $res->is_success;
-Replace C<proxy.myorg.com>, C<proxy_user> and
-C<proxy_password> with something suitable for your site.
+Replace C<proxy.myorg.com>, C<username> and
+C<password> with something suitable for your site.
=head1 ACCESS TO PROTECTED DOCUMENTS
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/filter.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/filter.t
--- perl/macos/bundled_lib/t/Filter/Simple/filter.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/filter.t Tue Jan 15 08:00:05 2002
@@ -1,9 +1,12 @@
BEGIN {
- chdir('t') if -d 't';
- @INC = 'lib';
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(lib ../lib);
+ }
}
use FilterTest qr/not ok/ => "ok", fail => "ok";
+
print "1..6\n";
sub fail { print "fail ", $_[0], "\n" }
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Switch/t/nested.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Switch/t/nested.t
--- perl/macos/bundled_lib/t/Switch/t/nested.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Switch/t/nested.t Tue Jan 15 08:00:05 2002
@@ -7,6 +7,15 @@
{
switch ([$count])
{
+
+=pod
+
+=head1 Test
+
+We also test if Switch is POD-friendly here
+
+=cut
+
case qr/\d/ {
switch ($count) {
case 1 { print "ok 1\n" }
@@ -16,3 +25,11 @@
case 'four' { print "ok 4\n" }
}
}
+
+__END__
+
+=head1 Another test
+
+Still friendly???
+
+=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extbrk.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/extbrk.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/extbrk.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Text/Balanced/t/extbrk.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,10 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extcbk.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/extcbk.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/extcbk.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Text/Balanced/t/extcbk.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,10 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extdel.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/extdel.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/extdel.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Text/Balanced/t/extdel.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,10 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extmul.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/extmul.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/extmul.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Text/Balanced/t/extmul.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,10 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
@@ -172,7 +179,7 @@
# TESTS 38-40
$text = $stdtext2;
expect [ extract_multiple($text,[\&extract_bracketed]) ],
- [ substr($stdtext2,0,15), substr($stdtext2,16,7), substr($stdtext2,23) ];
+ [ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ];
expect [ pos $text], [ 24 ];
expect [ $text ], [ $stdtext2 ];
@@ -180,7 +187,7 @@
# TESTS 41-43
$text = $stdtext2;
expect [ scalar extract_multiple($text,[\&extract_bracketed]) ],
- [ substr($stdtext2,0,15) ];
+ [ substr($stdtext2,0,16) ];
expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext2,15) ];
@@ -206,7 +213,7 @@
# TESTS 50-52
$text = $stdtext2;
expect [ extract_multiple($text,[\&extract_quotelike]) ],
- [ substr($stdtext2,0,6), substr($stdtext2,7,5), substr($stdtext2,12) ];
+ [ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ];
expect [ pos $text], [ length($text) ];
expect [ $text ], [ $stdtext2 ];
@@ -214,7 +221,7 @@
# TESTS 53-55
$text = $stdtext2;
expect [ scalar extract_multiple($text,[\&extract_quotelike]) ],
- [ substr($stdtext2,0,6) ];
+ [ substr($stdtext2,0,7) ];
expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext2,6) ];
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extqlk.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/extqlk.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/extqlk.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Text/Balanced/t/extqlk.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,10 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
#! /usr/local/bin/perl -ws
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/exttag.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/exttag.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/exttag.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Text/Balanced/t/exttag.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,10 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/extvar.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/extvar.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/extvar.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Text/Balanced/t/extvar.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,10 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
@@ -6,7 +13,7 @@
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
-BEGIN { $| = 1; print "1..81\n"; }
+BEGIN { $| = 1; print "1..181\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( extract_variable );
$loaded = 1;
@@ -58,6 +65,7 @@
$a (1..3) { print $a };
# USING: extract_variable($str);
+$obj->nextval;
*var;
*$var;
*{var};
@@ -91,6 +99,55 @@
$#array;
$#{array};
$var[$#var];
+$1;
+$11;
+$&;
+$`;
+$';
+$+;
+$*;
+$.;
+$/;
+$|;
+$,;
+$";
+$;;
+$#;
+$%;
+$=;
+$-;
+$~;
+$^;
+$:;
+$^L;
+$^A;
+$?;
+$!;
+$^E;
+$@;
+$$;
+$<;
+$>;
+$(;
+$);
+$[;
+$];
+$^C;
+$^D;
+$^F;
+$^H;
+$^I;
+$^M;
+$^O;
+$^P;
+$^R;
+$^S;
+$^T;
+$^V;
+$^W;
+${^WARNING_BITS};
+${^WIDE_SYSTEM_CALLS};
+$^X;
# THESE SHOULD FAIL
$a->;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Text/Balanced/t/gentag.t#2 (text) ====
Index: perl/macos/bundled_lib/t/Text/Balanced/t/gentag.t
--- perl/macos/bundled_lib/t/Text/Balanced/t/gentag.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Text/Balanced/t/gentag.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,10 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/config.t#2 (text) ====
Index: perl/macos/bundled_lib/t/libnet/config.t
--- perl/macos/bundled_lib/t/libnet/config.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libnet/config.t Tue Jan 15 08:00:05 2002
@@ -5,8 +5,45 @@
chdir 't' if -d 't';
@INC = '../lib';
}
+ undef *{Socket::inet_aton};
+ undef *{Socket::inet_ntoa};
+ if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
+ }
+ $INC{'Socket.pm'} = 1;
}
+package Socket;
+
+sub import {
+ my $pkg = caller();
+ no strict 'refs';
+ *{ $pkg . '::inet_aton' } = \&inet_aton;
+ *{ $pkg . '::inet_ntoa' } = \&inet_ntoa;
+}
+
+my $fail = 0;
+my %names;
+
+sub set_fail {
+ $fail = shift;
+}
+
+sub inet_aton {
+ return if $fail;
+ my $num = unpack('N', pack('C*', split(/\./, $_[0])));
+ $names{$num} = $_[0];
+ return $num;
+}
+
+sub inet_ntoa {
+ return if $fail;
+ return $names{$_[0]};
+}
+
+package main;
+
+
(my $libnet_t = __FILE__) =~ s/config.t/libnet_t.pl/;
require $libnet_t;
@@ -16,14 +53,16 @@
ok( exists $INC{'Net/Config.pm'}, 'Net::Config should have been used' );
ok( keys %NetConfig, '%NetConfig should be imported' );
+Socket::set_fail(1);
undef $NetConfig{'ftp_firewall'};
is( Net::Config->requires_firewall(), 0,
'requires_firewall() should return 0 without ftp_firewall defined' );
$NetConfig{'ftp_firewall'} = 1;
-is( Net::Config->requires_firewall(''), -1,
+is( Net::Config->requires_firewall('a.host.not.there'), -1,
'... should return -1 without a valid hostname' );
+Socket::set_fail(0);
delete $NetConfig{'local_netmask'};
is( Net::Config->requires_firewall('127.0.0.1'), 0,
'... should return 0 without local_netmask defined' );
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/ftp.t#3 (text) ====
Index: perl/macos/bundled_lib/t/libnet/ftp.t
--- perl/macos/bundled_lib/t/libnet/ftp.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libnet/ftp.t Tue Jan 15 08:00:05 2002
@@ -5,6 +5,9 @@
chdir 't' if -d 't';
@INC = '../lib';
}
+ if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
+ }
}
use Net::Config;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/hostname.t#3 (text) ====
Index: perl/macos/bundled_lib/t/libnet/hostname.t
--- perl/macos/bundled_lib/t/libnet/hostname.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libnet/hostname.t Tue Jan 15 08:00:05 2002
@@ -5,6 +5,9 @@
chdir 't' if -d 't';
@INC = '../lib';
}
+ if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
+ }
}
use Net::Domain qw(hostname domainname hostdomain);
@@ -15,7 +18,7 @@
exit 0;
}
-print "1..1\n";
+print "1..2\n";
$domain = domainname();
@@ -25,3 +28,13 @@
else {
print "not ok 1\n";
}
+
+# This check thats hostanme does not overwrite $_
+my @domain = qw(foo.example.com bar.example.jp);
+my @copy = @domain;
+
+my @dummy = grep { hostname eq $_ } @domain;
+
+($domain[0] && $domain[0] eq $copy[0])
+ ? print "ok 2\n"
+ : print "not ok 2\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/nntp.t#3 (text) ====
Index: perl/macos/bundled_lib/t/libnet/nntp.t
--- perl/macos/bundled_lib/t/libnet/nntp.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libnet/nntp.t Tue Jan 15 08:00:05 2002
@@ -5,6 +5,9 @@
chdir 't' if -d 't';
@INC = '../lib';
}
+ if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
+ }
}
use Net::Config;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/require.t#3 (text) ====
Index: perl/macos/bundled_lib/t/libnet/require.t
--- perl/macos/bundled_lib/t/libnet/require.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libnet/require.t Tue Jan 15 08:00:05 2002
@@ -5,6 +5,9 @@
chdir 't' if -d 't';
@INC = '../lib';
}
+ if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
+ }
}
print "1..9\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/smtp.t#3 (text) ====
Index: perl/macos/bundled_lib/t/libnet/smtp.t
--- perl/macos/bundled_lib/t/libnet/smtp.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libnet/smtp.t Tue Jan 15 08:00:05 2002
@@ -5,6 +5,9 @@
chdir 't' if -d 't';
@INC = '../lib';
}
+ if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
+ }
}
use Net::Config;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/base/headers.t#2 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/base/headers.t
--- perl/macos/bundled_lib/t/libwww-perl/base/headers.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/base/headers.t Tue Jan 15 08:00:05 2002
@@ -122,7 +122,8 @@
$h->header("ABC-ABC") eq "bar";
print "ok 10\n";
-$h->remove_header("Abc_Abc");
-print "not " unless !defined($h->header("abc_abc")) &&
+print "not " unless $h->remove_header("Abc_Abc") &&
+ !defined($h->header("abc_abc")) &&
$h->header("ABC-ABC") eq "bar";
print "ok 11\n";
+
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/base/negotiate.t#2 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/base/negotiate.t
--- perl/macos/bundled_lib/t/libwww-perl/base/negotiate.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/base/negotiate.t Tue Jan 15 08:00:05 2002
@@ -1,4 +1,4 @@
-print "1..3\n";
+print "1..4\n";
use HTTP::Request;
use HTTP::Negotiate;
@@ -63,6 +63,24 @@
]
);
+$variants = [
+ ['var-en', undef, 'text/html', undef, undef, 'en', undef],
+ ['var-de', undef, 'text/html', undef, undef, 'de', undef],
+ ['var-ES', undef, 'text/html', undef, undef, 'ES', undef],
+ ['provoke-warning', undef, undef, undef, undef, 'x-no-content-type', undef],
+ ];
+
+$HTTP::Negotiate::DEBUG=1;
+$ENV{HTTP_ACCEPT_LANGUAGE}='DE,en,fr;Q=0.5,es;q=0.1';
+
+$a = choose($variants);
+
+if ($a eq 'var-de') {
+ ok;
+}
+else {
+ not_ok
+}
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-b.t#2 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-b.t
--- perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-b.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-b.t Tue Jan 15 08:00:05 2002
@@ -46,6 +46,6 @@
#print $res->as_string;
print "not " unless $res->content =~ /Your browser made it!/ &&
- $res->header("Client-Request-Num") == 5;
+ $res->header("Client-Response-Num") == 5;
print "ok 3\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-d.t#2 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-d.t
--- perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-d.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-auth-d.t Tue Jan 15 08:00:05 2002
@@ -28,6 +28,6 @@
#print $res->as_string;
print "not " unless $res->content =~ /Your browser made it!/ &&
- $res->header("Client-Request-Num") == 5;
+ $res->header("Client-Response-Num") == 5;
print "ok 1\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-chunk.t#3 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-chunk.t
--- perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-chunk.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-chunk.t Tue Jan 15 08:00:05 2002
@@ -11,7 +11,7 @@
print "not " unless $res->is_success && $res->content_type eq "text/plain";
print "ok 1\n";
-print "not " unless $res->header("Transfer-Encoding") eq "chunked";
+print "not " unless $res->header("Client-Transfer-Encoding") eq "chunked";
print "ok 2\n";
for (${$res->content_ref}) {
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-md5.t#2 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-md5.t
--- perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-md5.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-md5.t Tue Jan 15 08:00:05 2002
@@ -22,5 +22,5 @@
$res = $ua->request($req);
print $res->as_string;
-print "not " unless $res->code eq "304" && $res->header("Client-Request-Num") == 2;
+print "not " unless $res->code eq "304" && $res->header("Client-Response-Num") == 2;
print "ok 2\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/jigsaw-te.t#2 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-te.t
--- perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-te.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/live/jigsaw-te.t Tue Jan 15 08:00:05 2002
@@ -1,3 +1,20 @@
+#!perl -w
+
+my $zlib_ok;
+for (("", "live/", "t/live/")) {
+ if (-f $_ . "ZLIB_OK") {
+ $zlib_ok++;
+ last;
+ }
+}
+
+unless ($zlib_ok) {
+ print "1..0\n";
+ print "Apparently no working ZLIB installed\n";
+ exit;
+}
+
+
print "1..4\n";
use strict;
@@ -29,5 +46,3 @@
$res->content("");
print $res->as_string;
}
-
-
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/validator.t#2 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/live/validator.t
--- perl/macos/bundled_lib/t/libwww-perl/live/validator.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/live/validator.t Tue Jan 15 08:00:05 2002
@@ -45,6 +45,6 @@
#$res->content(""); print $res->as_string;
-print "not " unless $res->header("Client-Request-Num") == 2 &&
+print "not " unless $res->header("Client-Response-Num") == 2 &&
$res->header("Connection") eq "close";
print "ok 2\n";
==== //depot/maint-5.6/macperl/macos/lib/Mac/AppleEvents/Simple.pm#3 (text) ====
Index: perl/macos/lib/Mac/AppleEvents/Simple.pm
--- perl/macos/lib/Mac/AppleEvents/Simple.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/lib/Mac/AppleEvents/Simple.pm Tue Jan 15 08:00:05 2002
@@ -22,8 +22,8 @@
@EXPORT_OK = (@EXPORT, @Mac::AppleEvents::EXPORT);
%EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
-$REVISION = '$Id: Simple.pm,v 1.4 2000/09/15 00:21:12 pudge Exp $';
-$VERSION = '1.00';
+$REVISION = '$Id: Simple.pm,v 1.6 2002/01/15 15:48:26 pudge Exp $';
+$VERSION = '1.01';
$DEBUG ||= 0;
$SWITCH ||= 0;
$WARN ||= 0;
@@ -709,10 +709,14 @@
=over 4
-=item v1.01,
+=item v1.01, Monday, January 14, 2002
+
+Make _getdata smarter.
Added utxt coercion to text. Catch errors in coercion.
+Change license to be that of Perl.
+
=item v1.00, Monday, September 11, 2000
Added C<handle_event> function.
@@ -840,9 +844,9 @@
Chris Nandor E<lt>[email protected]<gt>, http://pudge.net/
-Copyright (c) 1998-2000 Chris Nandor. All rights reserved. This program
-is free software; you can redistribute it and/or modify it under the terms
-of the Artistic License, distributed with Perl.
+Copyright (c) 1998-2002 Chris Nandor. All rights reserved. This program
+is free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
=head1 SEE ALSO
@@ -855,4 +859,4 @@
=head1 VERSION
-v1.00, Monday, September 11, 2000
+v1.01, Monday, January 14, 2002
==== //depot/maint-5.6/macperl/macos/lib/Mac/Glue.pm#4 (text) ====
Index: perl/macos/lib/Mac/Glue.pm
--- perl/macos/lib/Mac/Glue.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/lib/Mac/Glue.pm Tue Jan 15 08:00:05 2002
@@ -38,8 +38,8 @@
);
#=============================================================================#
-# $Id: Glue.pm,v 1.4 2001/11/13 03:47:40 pudge Exp $
-($REVISION) = ' $Revision: 1.4 $ ' =~ /\$Revision:\s+([^\s]+)/;
+# $Id: Glue.pm,v 1.5 2002/01/15 14:12:43 pudge Exp $
+($REVISION) = ' $Revision: 1.5 $ ' =~ /\$Revision:\s+([^\s]+)/;
$VERSION = '1.01';
@ISA = 'Exporter';
@EXPORT = ();
@@ -1932,6 +1932,19 @@
=over 4
+=item v1.01, Tuesday, January 15, 2002
+
+Clean up a bit for 5.6.
+
+Add ADDRESS method.
+
+Add checking for enumerators and classes.
+
+Make error handler work as hashref parameter list.
+
+Change license to be that of Perl.
+
+
=item v1.00, Tuesday, September 12, 2000
Added error handling via ERRORS parameter / method.
@@ -2150,9 +2163,9 @@
Chris Nandor E<lt>[email protected]<gt>, http://pudge.net/
-Copyright (c) 1998-2001 Chris Nandor. All rights reserved. This program
-is free software; you can redistribute it and/or modify it under the terms
-of the Artistic License, distributed with Perl.
+Copyright (c) 1998-2002 Chris Nandor. All rights reserved. This program
+is free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
=head1 THANKS
@@ -2196,4 +2209,4 @@
=head1 VERSION
-v1.00, Tuesday, September 12, 2000
+v1.01, Tuesday, January 15, 2002
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/constants.h#1 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/constants.h
--- perl/macos/bundled_ext/Compress/Zlib/constants.h.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/constants.h Tue Jan 15 08:00:05 2002
@@ -0,0 +1,497 @@
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+static int
+constant_7 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ OS_CODE Z_ASCII Z_ERRNO */
+ /* Offset 5 gives the best switch position. */
+ switch (name[5]) {
+ case 'D':
+ if (memEQ(name, "OS_CODE", 7)) {
+ /* ^ */
+#ifdef OS_CODE
+ *iv_return = OS_CODE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "Z_ASCII", 7)) {
+ /* ^ */
+#ifdef Z_ASCII
+ *iv_return = Z_ASCII;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "Z_ERRNO", 7)) {
+ /* ^ */
+#ifdef Z_ERRNO
+ *iv_return = Z_ERRNO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_9 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DEF_WBITS MAX_WBITS Z_UNKNOWN */
+ /* Offset 2 gives the best switch position. */
+ switch (name[2]) {
+ case 'F':
+ if (memEQ(name, "DEF_WBITS", 9)) {
+ /* ^ */
+#ifdef DEF_WBITS
+ *iv_return = DEF_WBITS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "Z_UNKNOWN", 9)) {
+ /* ^ */
+#ifdef Z_UNKNOWN
+ *iv_return = Z_UNKNOWN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'X':
+ if (memEQ(name, "MAX_WBITS", 9)) {
+ /* ^ */
+#ifdef MAX_WBITS
+ *iv_return = MAX_WBITS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_10 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ Z_DEFLATED Z_FILTERED Z_NO_FLUSH */
+ /* Offset 7 gives the best switch position. */
+ switch (name[7]) {
+ case 'R':
+ if (memEQ(name, "Z_FILTERED", 10)) {
+ /* ^ */
+#ifdef Z_FILTERED
+ *iv_return = Z_FILTERED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "Z_DEFLATED", 10)) {
+ /* ^ */
+#ifdef Z_DEFLATED
+ *iv_return = Z_DEFLATED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "Z_NO_FLUSH", 10)) {
+ /* ^ */
+#ifdef Z_NO_FLUSH
+ *iv_return = Z_NO_FLUSH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_11 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ Z_BUF_ERROR Z_MEM_ERROR Z_NEED_DICT */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'E':
+ if (memEQ(name, "Z_NEED_DICT", 11)) {
+ /* ^ */
+#ifdef Z_NEED_DICT
+ *iv_return = Z_NEED_DICT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "Z_BUF_ERROR", 11)) {
+ /* ^ */
+#ifdef Z_BUF_ERROR
+ *iv_return = Z_BUF_ERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "Z_MEM_ERROR", 11)) {
+ /* ^ */
+#ifdef Z_MEM_ERROR
+ *iv_return = Z_MEM_ERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_12 (pTHX_ const char *name, IV *iv_return, const char **pv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ ZLIB_VERSION Z_BEST_SPEED Z_DATA_ERROR Z_FULL_FLUSH Z_STREAM_END
+ Z_SYNC_FLUSH */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'L':
+ if (memEQ(name, "Z_FULL_FLUSH", 12)) {
+ /* ^ */
+#ifdef Z_FULL_FLUSH
+ *iv_return = Z_FULL_FLUSH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "Z_SYNC_FLUSH", 12)) {
+ /* ^ */
+#ifdef Z_SYNC_FLUSH
+ *iv_return = Z_SYNC_FLUSH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "Z_STREAM_END", 12)) {
+ /* ^ */
+#ifdef Z_STREAM_END
+ *iv_return = Z_STREAM_END;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "Z_BEST_SPEED", 12)) {
+ /* ^ */
+#ifdef Z_BEST_SPEED
+ *iv_return = Z_BEST_SPEED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "Z_DATA_ERROR", 12)) {
+ /* ^ */
+#ifdef Z_DATA_ERROR
+ *iv_return = Z_DATA_ERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "ZLIB_VERSION", 12)) {
+ /* ^ */
+#ifdef ZLIB_VERSION
+ *pv_return = ZLIB_VERSION;
+ return PERL_constant_ISPV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant (pTHX_ const char *name, STRLEN len, IV *iv_return, const char **pv_return) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!/home/paul/perl/install/redhat6.1/bleed/bin/perl5.7.2 -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw(IV PV)};
+my @names = (qw(DEF_WBITS MAX_MEM_LEVEL MAX_WBITS OS_CODE Z_ASCII
+ Z_BEST_COMPRESSION Z_BEST_SPEED Z_BINARY Z_BUF_ERROR
+ Z_DATA_ERROR Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY Z_DEFLATED
+ Z_ERRNO Z_FILTERED Z_FINISH Z_FULL_FLUSH Z_HUFFMAN_ONLY
+ Z_MEM_ERROR Z_NEED_DICT Z_NO_COMPRESSION Z_NO_FLUSH Z_NULL Z_OK
+ Z_PARTIAL_FLUSH Z_STREAM_END Z_STREAM_ERROR Z_SYNC_FLUSH
+ Z_UNKNOWN Z_VERSION_ERROR),
+ {name=>"ZLIB_VERSION", type=>"PV"});
+
+print constant_types(); # macro defs
+foreach (C_constant ("Zlib", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("Zlib", $types);
+__END__
+ */
+
+ switch (len) {
+ case 4:
+ if (memEQ(name, "Z_OK", 4)) {
+#ifdef Z_OK
+ *iv_return = Z_OK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 6:
+ if (memEQ(name, "Z_NULL", 6)) {
+#ifdef Z_NULL
+ *iv_return = Z_NULL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 7:
+ return constant_7 (aTHX_ name, iv_return);
+ break;
+ case 8:
+ /* Names all of length 8. */
+ /* Z_BINARY Z_FINISH */
+ /* Offset 6 gives the best switch position. */
+ switch (name[6]) {
+ case 'R':
+ if (memEQ(name, "Z_BINARY", 8)) {
+ /* ^ */
+#ifdef Z_BINARY
+ *iv_return = Z_BINARY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "Z_FINISH", 8)) {
+ /* ^ */
+#ifdef Z_FINISH
+ *iv_return = Z_FINISH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ break;
+ case 9:
+ return constant_9 (aTHX_ name, iv_return);
+ break;
+ case 10:
+ return constant_10 (aTHX_ name, iv_return);
+ break;
+ case 11:
+ return constant_11 (aTHX_ name, iv_return);
+ break;
+ case 12:
+ return constant_12 (aTHX_ name, iv_return, pv_return);
+ break;
+ case 13:
+ if (memEQ(name, "MAX_MEM_LEVEL", 13)) {
+#ifdef MAX_MEM_LEVEL
+ *iv_return = MAX_MEM_LEVEL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 14:
+ /* Names all of length 14. */
+ /* Z_HUFFMAN_ONLY Z_STREAM_ERROR */
+ /* Offset 3 gives the best switch position. */
+ switch (name[3]) {
+ case 'T':
+ if (memEQ(name, "Z_STREAM_ERROR", 14)) {
+ /* ^ */
+#ifdef Z_STREAM_ERROR
+ *iv_return = Z_STREAM_ERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "Z_HUFFMAN_ONLY", 14)) {
+ /* ^ */
+#ifdef Z_HUFFMAN_ONLY
+ *iv_return = Z_HUFFMAN_ONLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ break;
+ case 15:
+ /* Names all of length 15. */
+ /* Z_PARTIAL_FLUSH Z_VERSION_ERROR */
+ /* Offset 5 gives the best switch position. */
+ switch (name[5]) {
+ case 'S':
+ if (memEQ(name, "Z_VERSION_ERROR", 15)) {
+ /* ^ */
+#ifdef Z_VERSION_ERROR
+ *iv_return = Z_VERSION_ERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "Z_PARTIAL_FLUSH", 15)) {
+ /* ^ */
+#ifdef Z_PARTIAL_FLUSH
+ *iv_return = Z_PARTIAL_FLUSH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ break;
+ case 16:
+ if (memEQ(name, "Z_NO_COMPRESSION", 16)) {
+#ifdef Z_NO_COMPRESSION
+ *iv_return = Z_NO_COMPRESSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 18:
+ /* Names all of length 18. */
+ /* Z_BEST_COMPRESSION Z_DEFAULT_STRATEGY */
+ /* Offset 14 gives the best switch position. */
+ switch (name[14]) {
+ case 'S':
+ if (memEQ(name, "Z_BEST_COMPRESSION", 18)) {
+ /* ^ */
+#ifdef Z_BEST_COMPRESSION
+ *iv_return = Z_BEST_COMPRESSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "Z_DEFAULT_STRATEGY", 18)) {
+ /* ^ */
+#ifdef Z_DEFAULT_STRATEGY
+ *iv_return = Z_DEFAULT_STRATEGY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ break;
+ case 21:
+ if (memEQ(name, "Z_DEFAULT_COMPRESSION", 21)) {
+#ifdef Z_DEFAULT_COMPRESSION
+ *iv_return = Z_DEFAULT_COMPRESSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
==== //depot/maint-5.6/macperl/macos/bundled_ext/Compress/Zlib/constants.xs#1 (text) ====
Index: perl/macos/bundled_ext/Compress/Zlib/constants.xs
--- perl/macos/bundled_ext/Compress/Zlib/constants.xs.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Compress/Zlib/constants.xs Tue Jan 15 08:00:05 2002
@@ -0,0 +1,87 @@
+void
+constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ IV iv;
+ /* NV nv; Uncomment this if you need to return NVs */
+ const char *pv;
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ /* Change this to constant(aTHX_ s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ type = constant(aTHX_ s, len, &iv, &pv);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid Zlib macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined Zlib macro %s, used", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break;
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break;
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing Zlib macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
==== //depot/maint-5.6/macperl/macos/bundled_ext/Filter/Util/Call/ppport.h#1 (text) ====
Index: perl/macos/bundled_ext/Filter/Util/Call/ppport.h
--- perl/macos/bundled_ext/Filter/Util/Call/ppport.h.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Filter/Util/Call/ppport.h Tue Jan 15 08:00:05 2002
@@ -0,0 +1,282 @@
+/* This file is Based on output from
+ * Perl/Pollution/Portability Version 2.0000 */
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef PERL_REVISION
+# ifndef __PATCHLEVEL_H_INCLUDED__
+# include "patchlevel.h"
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+#ifndef ERRSV
+# define ERRSV perl_get_sv("@",FALSE)
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_defgv defgv
+# define PL_dirty dirty
+# define PL_hints hints
+# define PL_na na
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfp rsfp
+# define PL_stdingv stdingv
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+/* Replace: 0 */
+#endif
+
+#ifndef pTHX
+# define pTHX
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef PTR2IV
+# define PTR2IV(d) (IV)(d)
+#endif
+
+#ifndef INT2PTR
+# define INT2PTR(any,d) (any)(d)
+#endif
+
+#ifndef dTHR
+# ifdef WIN32
+# define dTHR extern int Perl___notused
+# else
+# define dTHR extern int errno
+# endif
+#endif
+
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
+#endif
+
+#ifndef newRV_inc
+/* Replace: 1 */
+# define newRV_inc(sv) newRV(sv)
+/* Replace: 0 */
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef newRV_noinc
+# ifdef __GNUC__
+# define newRV_noinc(sv) \
+ ({ \
+ SV *nsv = (SV*)newRV(sv); \
+ SvREFCNT_dec(sv); \
+ nsv; \
+ })
+# else
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+static SV * newRV_noinc (SV * sv)
+{
+ SV *nsv = (SV*)newRV(sv);
+ SvREFCNT_dec(sv);
+ return nsv;
+}
+# else
+# define newRV_noinc(sv) \
+ ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
+# endif
+# endif
+#endif
+
+/* Provide: newCONSTSUB */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
+
+#if defined(NEED_newCONSTSUB)
+static
+#else
+extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
+#endif
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+void
+newCONSTSUB(stash,name,sv)
+HV *stash;
+char *name;
+SV *sv;
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
+ /* before 5.003_22 */
+ start_subparse(),
+#else
+# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
+ /* 5.003_22 */
+ start_subparse(0),
+# else
+ /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+# endif
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+
+#endif /* newCONSTSUB */
+
+
+#ifndef START_MY_CXT
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if PERL_REVISION == 5 && \
+ (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* single interpreter */
+
+#ifndef NOOP
+# define NOOP (void)0
+#endif
+
+#ifdef HASATTRIBUTE
+# define PERL_UNUSED_DECL __attribute__((unused))
+#else
+# define PERL_UNUSED_DECL
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif
+
+#endif /* START_MY_CXT */
+
+
+#endif /* _P_P_PORTABILITY_H_ */
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/compat-0.6.t#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/compat-0.6.t
--- perl/macos/bundled_ext/Storable/t/compat-0.6.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/compat-0.6.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,143 @@
+#!./perl
+
+# $Id: compat-0.6.t,v 1.0.1.1 2001/02/17 12:26:21 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: compat-0.6.t,v $
+# Revision 1.0.1.1 2001/02/17 12:26:21 ram
+# patch8: added EBCDIC version of the test, from Peter Prymmer
+#
+# Revision 1.0 2000/09/01 19:40:41 ram
+# Baseline for first official release.
+#
+
+require 't/dump.pl';
+sub ok;
+
+print "1..8\n";
+
+use Storable qw(freeze nfreeze thaw);
+
+package TIED_HASH;
+
+sub TIEHASH {
+ my $self = bless {}, shift;
+ return $self;
+}
+
+sub FETCH {
+ my $self = shift;
+ my ($key) = @_;
+ $main::hash_fetch++;
+ return $self->{$key};
+}
+
+sub STORE {
+ my $self = shift;
+ my ($key, $val) = @_;
+ $self->{$key} = $val;
+}
+
+package SIMPLE;
+
+sub make {
+ my $self = bless [], shift;
+ my ($x) = @_;
+ $self->[0] = $x;
+ return $self;
+}
+
+package ROOT;
+
+sub make {
+ my $self = bless {}, shift;
+ my $h = tie %hash, TIED_HASH;
+ $self->{h} = $h;
+ $self->{ref} = \%hash;
+ my @pool;
+ for (my $i = 0; $i < 5; $i++) {
+ push(@pool, SIMPLE->make($i));
+ }
+ $self->{obj} = \@pool;
+ my @a = ('string', $h, $self);
+ $self->{a} = \@a;
+ $self->{num} = [1, 0, -3, -3.14159, 456, 4.5];
+ $h->{key1} = 'val1';
+ $h->{key2} = 'val2';
+ return $self;
+};
+
+sub num { $_[0]->{num} }
+sub h { $_[0]->{h} }
+sub ref { $_[0]->{ref} }
+sub obj { $_[0]->{obj} }
+
+package main;
+
+my $is_EBCDIC = (ord('A') == 193) ? 1 : 0;
+
+my $r = ROOT->make;
+
+my $data = '';
+if (!$is_EBCDIC) { # ASCII machine
+ while (<DATA>) {
+ next if /^#/;
+ $data .= unpack("u", $_);
+ }
+} else {
+ while (<DATA>) {
+ next if /^#$/; # skip comments
+ next if /^#\s+/; # skip comments
+ next if /^[^#]/; # skip uuencoding for ASCII machines
+ s/^#//; # prepare uuencoded data for EBCDIC machines
+ $data .= unpack("u", $_);
+ }
+}
+
+my $expected_length = $is_EBCDIC ? 217 : 278;
+ok 1, length $data == $expected_length;
+
+my $y = thaw($data);
+ok 2, 1;
+ok 3, ref $y eq 'ROOT';
+
+$Storable::canonical = 1; # Prevent "used once" warning
+$Storable::canonical = 1;
+ok 4, nfreeze($y) eq nfreeze($r);
+
+ok 5, $y->ref->{key1} eq 'val1';
+ok 6, $y->ref->{key2} eq 'val2';
+ok 7, $hash_fetch == 2;
+
+my $num = $r->num;
+my $ok = 1;
+for (my $i = 0; $i < @$num; $i++) {
+ do { $ok = 0; last } unless $num->[$i] == $y->num->[$i];
+}
+ok 8, $ok;
+
+__END__
+#
+# using Storable-0.6@11, output of: print pack("u", nfreeze(ROOT->make));
+# original size: 278 bytes
+#
+M`P,````%!`(````&"(%8"(!8"'U8"@@M,RXQ-#$U.5@)```!R%@*`S0N-5A8
+M6`````-N=6T$`P````(*!'9A;#%8````!&ME>3$*!'9A;#)8````!&ME>3)B
+M"51)141?2$%32%A8`````6@$`@````,*!G-T<FEN9U@$``````I8!```````
+M6%A8`````6$$`@````4$`@````$(@%AB!E-)35!,15A8!`(````!"(%88@93
+M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8
+M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E
+(9F($4D]/5%@`
+#
+# using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make));
+# on OS/390 (cp 1047) original size: 217 bytes
+#
+#M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H
+#M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D)
+#M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("````
+#M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00`````
+#E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0``
==== //depot/maint-5.6/macperl/macos/bundled_ext/Storable/t/dump.pl#3 (text) ====
Index: perl/macos/bundled_ext/Storable/t/dump.pl
--- perl/macos/bundled_ext/Storable/t/dump.pl.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_ext/Storable/t/dump.pl Tue Jan 15 08:00:05 2002
@@ -0,0 +1,146 @@
+;# $Id: dump.pl,v 1.0 2000/09/01 19:40:41 ram Exp $
+;#
+;# Copyright (c) 1995-2000, Raphael Manfredi
+;#
+;# You may redistribute only under the same terms as Perl 5, as specified
+;# in the README file that comes with the distribution.
+;#
+;# $Log: dump.pl,v $
+;# Revision 1.0 2000/09/01 19:40:41 ram
+;# Baseline for first official release.
+;#
+
+sub ok {
+ my ($num, $ok) = @_;
+ print "not " unless $ok;
+ print "ok $num\n";
+}
+
+package dump;
+use Carp;
+
+%dump = (
+ 'SCALAR' => 'dump_scalar',
+ 'ARRAY' => 'dump_array',
+ 'HASH' => 'dump_hash',
+ 'REF' => 'dump_ref',
+);
+
+# Given an object, dump its transitive data closure
+sub main'dump {
+ my ($object) = @_;
+ croak "Not a reference!" unless ref($object);
+ local %dumped;
+ local %object;
+ local $count = 0;
+ local $dumped = '';
+ &recursive_dump($object, 1);
+ return $dumped;
+}
+
+# This is the root recursive dumping routine that may indirectly be
+# called by one of the routine it calls...
+# The link parameter is set to false when the reference passed to
+# the routine is an internal temporay variable, implying the object's
+# address is not to be dumped in the %dumped table since it's not a
+# user-visible object.
+sub recursive_dump {
+ my ($object, $link) = @_;
+
+ # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).
+ # Then extract the bless, ref and address parts of that string.
+
+ my $what = "$object"; # Stringify
+ my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
+ ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;
+
+ # Special case for references to references. When stringified,
+ # they appear as being scalars. However, ref() correctly pinpoints
+ # them as being references indirections. And that's it.
+
+ $ref = 'REF' if ref($object) eq 'REF';
+
+ # Make sure the object has not been already dumped before.
+ # We don't want to duplicate data. Retrieval will know how to
+ # relink from the previously seen object.
+
+ if ($link && $dumped{$addr}++) {
+ my $num = $object{$addr};
+ $dumped .= "OBJECT #$num seen\n";
+ return;
+ }
+
+ my $objcount = $count++;
+ $object{$addr} = $objcount;
+
+ # Call the appropriate dumping routine based on the reference type.
+ # If the referenced was blessed, we bless it once the object is dumped.
+ # The retrieval code will perform the same on the last object retrieved.
+
+ croak "Unknown simple type '$ref'" unless defined $dump{$ref};
+
+ &{$dump{$ref}}($object); # Dump object
+ &bless($bless) if $bless; # Mark it as blessed, if necessary
+
+ $dumped .= "OBJECT $objcount\n";
+}
+
+# Indicate that current object is blessed
+sub bless {
+ my ($class) = @_;
+ $dumped .= "BLESS $class\n";
+}
+
+# Dump single scalar
+sub dump_scalar {
+ my ($sref) = @_;
+ my $scalar = $$sref;
+ unless (defined $scalar) {
+ $dumped .= "UNDEF\n";
+ return;
+ }
+ my $len = length($scalar);
+ $dumped .= "SCALAR len=$len $scalar\n";
+}
+
+# Dump array
+sub dump_array {
+ my ($aref) = @_;
+ my $items = 0 + @{$aref};
+ $dumped .= "ARRAY items=$items\n";
+ foreach $item (@{$aref}) {
+ unless (defined $item) {
+ $dumped .= 'ITEM_UNDEF' . "\n";
+ next;
+ }
+ $dumped .= 'ITEM ';
+ &recursive_dump(\$item, 1);
+ }
+}
+
+# Dump hash table
+sub dump_hash {
+ my ($href) = @_;
+ my $items = scalar(keys %{$href});
+ $dumped .= "HASH items=$items\n";
+ foreach $key (sort keys %{$href}) {
+ $dumped .= 'KEY ';
+ &recursive_dump(\$key, undef);
+ unless (defined $href->{$key}) {
+ $dumped .= 'VALUE_UNDEF' . "\n";
+ next;
+ }
+ $dumped .= 'VALUE ';
+ &recursive_dump(\$href->{$key}, 1);
+ }
+}
+
+# Dump reference to reference
+sub dump_ref {
+ my ($rref) = @_;
+ my $deref = $$rref; # Follow reference to reference
+ $dumped .= 'REF ';
+ &recursive_dump($deref, 1); # $dref is a reference
+}
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Mail/Mailer/qmail.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Mail/Mailer/qmail.pm
--- perl/macos/bundled_lib/blib/lib/Mail/Mailer/qmail.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Mail/Mailer/qmail.pm Tue Jan 15 08:00:05 2002
@@ -0,0 +1,9 @@
+package Mail::Mailer::qmail;
+use vars qw(@ISA);
+require Mail::Mailer::rfc822;
+@ISA = qw(Mail::Mailer::rfc822);
+
+sub exec {
+ my($self, $exe, $args, $to) = @_;
+ exec(( $exe ));
+}
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/HTTP/Methods.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/HTTP/Methods.pm
--- perl/macos/bundled_lib/blib/lib/Net/HTTP/Methods.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/HTTP/Methods.pm Tue Jan 15 08:00:05 2002
@@ -0,0 +1,513 @@
+package Net::HTTP::Methods;
+
+# $Id: Methods.pm,v 1.7 2001/12/05 16:58:05 gisle Exp $
+
+require 5.005; # 4-arg substr
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = "0.02";
+
+my $CRLF = "\015\012"; # "\r\n" is not portable
+
+sub new {
+ my($class, %cnf) = @_;
+ require Symbol;
+ my $self = bless Symbol::gensym(), $class;
+ return $self->http_configure(\%cnf);
+}
+
+sub http_configure {
+ my($self, $cnf) = @_;
+
+ die "Listen option not allowed" if $cnf->{Listen};
+ my $host = delete $cnf->{Host};
+ my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
+ if ($host) {
+ $cnf->{PeerAddr} = $host unless $peer;
+ }
+ else {
+ $host = $peer;
+ $host =~ s/:.*//;
+ }
+ $cnf->{PeerPort} = $self->http_default_port unless $cnf->{PeerPort};
+ $cnf->{Proto} = 'tcp';
+
+ my $keep_alive = delete $cnf->{KeepAlive};
+ my $http_version = delete $cnf->{HTTPVersion};
+ $http_version = "1.1" unless defined $http_version;
+ my $peer_http_version = delete $cnf->{PeerHTTPVersion};
+ $peer_http_version = "1.0" unless defined $peer_http_version;
+ my $send_te = delete $cnf->{SendTE};
+ my $max_line_length = delete $cnf->{MaxLineLength};
+ $max_line_length = 4*1024 unless defined $max_line_length;
+ my $max_header_lines = delete $cnf->{MaxHeaderLines};
+ $max_header_lines = 128 unless defined $max_header_lines;
+
+ return undef unless $self->http_connect($cnf);
+
+ unless ($host =~ /:/) {
+ my $p = $self->peerport;
+ $host .= ":$p";
+ }
+ $self->host($host);
+ $self->keep_alive($keep_alive);
+ $self->send_te($send_te);
+ $self->http_version($http_version);
+ $self->peer_http_version($peer_http_version);
+ $self->max_line_length($max_line_length);
+ $self->max_header_lines($max_header_lines);
+
+ ${*$self}{'http_buf'} = "";
+
+ return $self;
+}
+
+sub http_default_port {
+ 80;
+}
+
+# set up property accessors
+for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
+ my $prop_name = "http_" . $method;
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ my $old = ${*$self}{$prop_name};
+ ${*$self}{$prop_name} = shift if @_;
+ return $old;
+ };
+}
+
+# we want this one to be a bit smarter
+sub http_version {
+ my $self = shift;
+ my $old = ${*$self}{'http_version'};
+ if (@_) {
+ my $v = shift;
+ $v = "1.0" if $v eq "1"; # float
+ unless ($v eq "1.0" or $v eq "1.1") {
+ require Carp;
+ Carp::croak("Unsupported HTTP version '$v'");
+ }
+ ${*$self}{'http_version'} = $v;
+ }
+ $old;
+}
+
+sub format_request {
+ my $self = shift;
+ my $method = shift;
+ my $uri = shift;
+
+ my $content = (@_ % 2) ? pop : "";
+
+ for ($method, $uri) {
+ require Carp;
+ Carp::croak("Bad method or uri") if /\s/ || !length;
+ }
+
+ push(@{${*$self}{'http_request_method'}}, $method);
+ my $ver = ${*$self}{'http_version'};
+ my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
+
+ my @h;
+ my @connection;
+ my %given = (host => 0, "content-length" => 0, "te" => 0);
+ while (@_) {
+ my($k, $v) = splice(@_, 0, 2);
+ my $lc_k = lc($k);
+ if ($lc_k eq "connection") {
+ push(@connection, split(/\s*,\s*/, $v));
+ next;
+ }
+ if (exists $given{$lc_k}) {
+ $given{$lc_k}++;
+ }
+ push(@h, "$k: $v");
+ }
+
+ if (length($content) && !$given{'content-length'}) {
+ push(@h, "Content-Length: " . length($content));
+ }
+
+ my @h2;
+ if ($given{te}) {
+ push(@connection, "TE") unless grep lc($_) eq "te", @connection;
+ }
+ elsif ($self->send_te && zlib_ok()) {
+ # gzip is less wanted since the Compress::Zlib interface for
+ # it does not really allow chunked decoding to take place easily.
+ push(@h2, "TE: deflate,gzip;q=0.3");
+ push(@connection, "TE");
+ }
+
+ unless (grep lc($_) eq "close", @connection) {
+ if ($self->keep_alive) {
+ if ($peer_ver eq "1.0") {
+ # from looking at Netscape's headers
+ push(@h2, "Keep-Alive: 300");
+ unshift(@connection, "Keep-Alive");
+ }
+ }
+ else {
+ push(@connection, "close") if $ver ge "1.1";
+ }
+ }
+ push(@h2, "Connection: " . join(", ", @connection)) if @connection;
+ push(@h2, "Host: ${*$self}{'http_host'}") unless $given{host};
+
+ return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
+}
+
+
+sub write_request {
+ my $self = shift;
+ $self->print($self->format_request(@_));
+}
+
+sub format_chunk {
+ my $self = shift;
+ return $_[0] unless defined($_[0]) && length($_[0]);
+ return hex(length($_[0])) . $CRLF . $_[0] . $CRLF;
+}
+
+sub write_chunk {
+ my $self = shift;
+ return 1 unless defined($_[0]) && length($_[0]);
+ $self->print(hex(length($_[0])) . $CRLF . $_[0] . $CRLF);
+}
+
+sub format_chunk_eof {
+ my $self = shift;
+ my @h;
+ while (@_) {
+ push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
+ }
+ return join("", "0$CRLF", @h, $CRLF);
+}
+
+sub write_chunk_eof {
+ my $self = shift;
+ $self->print($self->format_chunk_eof(@_));
+}
+
+
+sub my_read {
+ die if @_ > 3;
+ my $self = shift;
+ my $len = $_[1];
+ for (${*$self}{'http_buf'}) {
+ if (length) {
+ $_[0] = substr($_, 0, $len, "");
+ return length($_[0]);
+ }
+ else {
+ return $self->sysread($_[0], $len);
+ }
+ }
+}
+
+
+sub my_readline {
+ my $self = shift;
+ for (${*$self}{'http_buf'}) {
+ my $max_line_length = ${*$self}{'http_max_line_length'};
+ my $pos;
+ while (1) {
+ # find line ending
+ $pos = index($_, "\012");
+ last if $pos >= 0;
+ die "Line too long (limit is $max_line_length)"
+ if $max_line_length && length($_) > $max_line_length;
+
+ # need to read more data to find a line ending
+ my $n = $self->sysread($_, 1024, length);
+ if (!$n) {
+ return undef unless length;
+ return substr($_, 0, length, "");
+ }
+ }
+ die "Line too long ($pos; limit is $max_line_length)"
+ if $max_line_length && $pos > $max_line_length;
+
+ my $line = substr($_, 0, $pos+1, "");
+ $line =~ s/(\015?\012)\z// || die "Assert";
+ return wantarray ? ($line, $1) : $line;
+ }
+}
+
+
+sub _rbuf {
+ my $self = shift;
+ if (@_) {
+ for (${*$self}{'http_buf'}) {
+ my $old;
+ $old = $_ if defined wantarray;
+ $_ = shift;
+ return $old;
+ }
+ }
+ else {
+ return ${*$self}{'http_buf'};
+ }
+}
+
+sub _rbuf_length {
+ my $self = shift;
+ return length ${*$self}{'http_buf'};
+}
+
+
+sub _read_header_lines {
+ my $self = shift;
+ my $junk_out = shift;
+
+ my @headers;
+ my $line_count = 0;
+ my $max_header_lines = ${*$self}{'http_max_header_lines'};
+ while (my $line = my_readline($self)) {
+ if ($line =~ /^(\S+)\s*:\s*(.*)/s) {
+ push(@headers, $1, $2);
+ }
+ elsif (@headers && $line =~ s/^\s+//) {
+ $headers[-1] .= " " . $line;
+ }
+ elsif ($junk_out) {
+ push(@$junk_out, $line);
+ }
+ else {
+ die "Bad header: '$line'\n";
+ }
+ if ($max_header_lines) {
+ $line_count++;
+ if ($line_count >= $max_header_lines) {
+ die "Too many header lines (limit is $max_header_lines)";
+ }
+ }
+ }
+ return @headers;
+}
+
+
+sub read_response_headers {
+ my($self, %opt) = @_;
+ my $laxed = $opt{laxed};
+
+ my($status, $eol) = my_readline($self);
+ die "EOF instead of reponse status line" unless defined $status;
+
+ my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
+ if (!$peer_ver || $peer_ver !~ s,^HTTP/,,) {
+ die "Bad response status line: '$status'" unless $laxed;
+ # assume HTTP/0.9
+ ${*$self}{'http_peer_http_version'} = "0.9";
+ ${*$self}{'http_status'} = "200";
+ substr(${*$self}{'http_buf'}, 0, 0) = $status . $eol;
+ return (200, "Assumed OK");
+ };
+
+ ${*$self}{'http_peer_http_version'} = $peer_ver;
+
+ unless ($code =~ /^[1-9]\d\d$/) {
+ die "Bad response code: '$status'";
+ }
+ ${*$self}{'http_status'} = $code;
+
+ my $junk_out;
+ if ($laxed) {
+ $junk_out = $opt{junk_out} || [];
+ }
+ my @headers = $self->_read_header_lines($junk_out);
+
+ # pick out headers that read_entity_body might need
+ my @te;
+ my $content_length;
+ for (my $i = 0; $i < @headers; $i += 2) {
+ my $h = lc($headers[$i]);
+ if ($h eq 'transfer-encoding') {
+ push(@te, $headers[$i+1]);
+ }
+ elsif ($h eq 'content-length') {
+ $content_length = $headers[$i+1];
+ }
+ }
+ ${*$self}{'http_te'} = join(",", @te);
+ ${*$self}{'http_content_length'} = $content_length;
+ ${*$self}{'http_first_body'}++;
+ delete ${*$self}{'http_trailers'};
+ return $code unless wantarray;
+ return ($code, $message, @headers);
+}
+
+
+sub read_entity_body {
+ my $self = shift;
+ my $buf_ref = \$_[0];
+ my $size = $_[1];
+ die "Offset not supported yet" if $_[2];
+
+ my $chunked;
+ my $bytes;
+
+ if (${*$self}{'http_first_body'}) {
+ ${*$self}{'http_first_body'} = 0;
+ delete ${*$self}{'http_chunked'};
+ delete ${*$self}{'http_bytes'};
+ my $method = shift(@{${*$self}{'http_request_method'}});
+ my $status = ${*$self}{'http_status'};
+ if ($method eq "HEAD" || $status =~ /^(?:1|[23]04)/) {
+ # these responses are always empty
+ $bytes = 0;
+ }
+ elsif (my $te = ${*$self}{'http_te'}) {
+ my @te = split(/\s*,\s*/, lc($te));
+ die "Chunked must be last Transfer-Encoding '$te'"
+ unless pop(@te) eq "chunked";
+
+ for (@te) {
+ if ($_ eq "deflate" && zlib_ok()) {
+ #require Compress::Zlib;
+ my $i = Compress::Zlib::inflateInit();
+ die "Can't make inflator" unless $i;
+ $_ = sub { scalar($i->inflate($_[0])) }
+ }
+ elsif ($_ eq "gzip" && zlib_ok()) {
+ #require Compress::Zlib;
+ my @buf;
+ $_ = sub {
+ push(@buf, $_[0]);
+ return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
+ return "";
+ };
+ }
+ elsif ($_ eq "identity") {
+ $_ = sub { $_[0] };
+ }
+ else {
+ die "Can't handle transfer encoding '$te'";
+ }
+ }
+
+ @te = reverse(@te);
+
+ ${*$self}{'http_te2'} = @te ? \@te : "";
+ $chunked = -1;
+ }
+ elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
+ $bytes = $content_length;
+ }
+ else {
+ # XXX Multi-Part types are self delimiting, but RFC 2616 says we
+ # only has to deal with 'multipart/byteranges'
+
+ # Read until EOF
+ }
+ }
+ else {
+ $chunked = ${*$self}{'http_chunked'};
+ $bytes = ${*$self}{'http_bytes'};
+ }
+
+ if (defined $chunked) {
+ # The state encoded in $chunked is:
+ # $chunked == 0: read CRLF after chunk, then chunk header
+ # $chunked == -1: read chunk header
+ # $chunked > 0: bytes left in current chunk to read
+
+ if ($chunked <= 0) {
+ my $line = my_readline($self);
+ if ($chunked == 0) {
+ die "Not empty: '$line'" unless $line eq "";
+ $line = my_readline($self);
+ }
+ $line =~ s/;.*//; # ignore potential chunk parameters
+ $line =~ s/\s+$//; # avoid warnings from hex()
+ $chunked = hex($line);
+ if ($chunked == 0) {
+ ${*$self}{'http_trailers'} = [$self->_read_header_lines];
+ $$buf_ref = "";
+
+ my $n = 0;
+ if (my $transforms = delete ${*$self}{'http_te2'}) {
+ for (@$transforms) {
+ $$buf_ref = &$_($$buf_ref, 1);
+ }
+ $n = length($$buf_ref);
+ }
+
+ # in case somebody tries to read more, make sure we continue
+ # to return EOF
+ delete ${*$self}{'http_chunked'};
+ ${*$self}{'http_bytes'} = 0;
+
+ return $n;
+ }
+ }
+
+ my $n = $chunked;
+ $n = $size if $size && $size < $n;
+ $n = my_read($self, $$buf_ref, $n);
+ return undef unless defined $n;
+
+ ${*$self}{'http_chunked'} = $chunked - $n;
+
+ if ($n > 0) {
+ if (my $transforms = ${*$self}{'http_te2'}) {
+ for (@$transforms) {
+ $$buf_ref = &$_($$buf_ref, 0);
+ }
+ $n = length($$buf_ref);
+ $n = -1 if $n == 0;
+ }
+ }
+ return $n;
+ }
+ elsif (defined $bytes) {
+ unless ($bytes) {
+ $$buf_ref = "";
+ return 0;
+ }
+ my $n = $bytes;
+ $n = $size if $size && $size < $n;
+ $n = my_read($self, $$buf_ref, $n);
+ return undef unless defined $n;
+ ${*$self}{'http_bytes'} = $bytes - $n;
+ return $n;
+ }
+ else {
+ # read until eof
+ $size ||= 8*1024;
+ return my_read($self, $$buf_ref, $size);
+ }
+}
+
+sub get_trailers {
+ my $self = shift;
+ @{${*$self}{'http_trailers'} || []};
+}
+
+BEGIN {
+my $zlib_ok;
+
+sub zlib_ok {
+ return $zlib_ok if defined $zlib_ok;
+
+ # Try to load Compress::Zlib.
+ local $@;
+ local $SIG{__DIE__};
+ $zlib_ok = 0;
+
+ eval {
+ require Compress::Zlib;
+ Compress::Zlib->VERSION(1.10);
+ $zlib_ok++;
+ };
+
+ return $zlib_ok;
+}
+
+} # BEGIN
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/Net/HTTPS.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/Net/HTTPS.pm
--- perl/macos/bundled_lib/blib/lib/Net/HTTPS.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/Net/HTTPS.pm Tue Jan 15 08:00:05 2002
@@ -0,0 +1,55 @@
+package Net::HTTPS;
+
+# $Id: HTTPS.pm,v 1.2 2001/11/17 02:05:31 gisle Exp $
+
+use strict;
+use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
+
+$VERSION = "0.01";
+
+# Figure out which SSL implementation to use
+if ($IO::Socket::SSL::VERSION) {
+ $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
+}
+else {
+ eval { require Net::SSL; }; # from Crypt-SSLeay
+ if ($@) {
+ my $old_errsv = $@;
+ eval {
+ require IO::Socket::SSL;
+ };
+ if ($@) {
+ $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g;
+ die $old_errsv . $@;
+ }
+ $SSL_SOCKET_CLASS = "IO::Socket::SSL";
+ }
+ else {
+ $SSL_SOCKET_CLASS = "Net::SSL";
+ }
+}
+
+require Net::HTTP::Methods;
+
+@ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods');
+
+sub configure {
+ my($self, $cnf) = @_;
+ $self->http_configure($cnf);
+}
+
+sub http_connect {
+ my($self, $cnf) = @_;
+ $self->SUPER::configure($cnf);
+}
+
+sub http_default_port {
+ 443;
+}
+
+# The underlying SSLeay classes fails to work if the socket is
+# placed in non-blocking mode. This override of the blocking
+# method makes sure it stays the way it was created.
+sub blocking { } # noop
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/URI/ssh.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/URI/ssh.pm
--- perl/macos/bundled_lib/blib/lib/URI/ssh.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/blib/lib/URI/ssh.pm Tue Jan 15 08:00:05 2002
@@ -0,0 +1,9 @@
+package URI::ssh;
+require URI::_login;
+@ISA=qw(URI::_login);
+
+# ssh://[USER@]HOST[:PORT]/SRC
+
+sub default_port { 22 }
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/ExportTest.pm#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/ExportTest.pm
--- perl/macos/bundled_lib/t/Filter/Simple/ExportTest.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/ExportTest.pm Tue Jan 15 08:00:05 2002
@@ -0,0 +1,12 @@
+package ExportTest;
+
+use Filter::Simple;
+use base Exporter;
+
+@EXPORT_OK = qw(ok);
+
+FILTER { s/not// };
+
+sub ok { print "ok @_\n" }
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/FilterOnlyTest.pm#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/FilterOnlyTest.pm
--- perl/macos/bundled_lib/t/Filter/Simple/FilterOnlyTest.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/FilterOnlyTest.pm Tue Jan 15 08:00:05 2002
@@ -0,0 +1,11 @@
+package FilterOnlyTest;
+
+use Filter::Simple;
+
+FILTER_ONLY
+ string => sub {
+ my $class = shift;
+ while (my($pat, $str) = splice @_, 0, 2) {
+ s/$pat/$str/g;
+ }
+ };
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/FilterTest.pm#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/FilterTest.pm
--- perl/macos/bundled_lib/t/Filter/Simple/FilterTest.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/FilterTest.pm Tue Jan 15 08:00:05 2002
@@ -0,0 +1,12 @@
+package FilterTest;
+
+use Filter::Simple;
+
+FILTER {
+ my $class = shift;
+ while (my($pat, $str) = splice @_, 0, 2) {
+ s/$pat/$str/g;
+ }
+};
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/ImportTest.pm#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/ImportTest.pm
--- perl/macos/bundled_lib/t/Filter/Simple/ImportTest.pm.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/ImportTest.pm Tue Jan 15 08:00:05 2002
@@ -0,0 +1,19 @@
+package ImportTest;
+
+use base 'Exporter';
+@EXPORT = qw(say);
+
+sub say { print @_ }
+
+use Filter::Simple;
+
+sub import {
+ my $class = shift;
+ print "ok $_\n" foreach @_;
+ __PACKAGE__->export_to_level(1,$class);
+}
+
+FILTER { s/not // };
+
+
+1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/data.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/data.t
--- perl/macos/bundled_lib/t/Filter/Simple/data.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/data.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,19 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(lib ../lib);
+ }
+}
+
+use FilterOnlyTest qr/ok/ => "not ok", "bad" => "ok";
+print "1..6\n";
+
+print "bad 1\n";
+print "bad 2\n";
+print "bad 3\n";
+print <DATA>;
+
+__DATA__
+ok 4
+ok 5
+ok 6
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/export.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/export.t
--- perl/macos/bundled_lib/t/Filter/Simple/export.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/export.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,12 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(lib ../lib);
+ }
+}
+
+BEGIN { print "1..1\n" }
+
+use ExportTest 'ok';
+
+notok 1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/filter_only.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/filter_only.t
--- perl/macos/bundled_lib/t/Filter/Simple/filter_only.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/filter_only.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,31 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(lib ../lib);
+ }
+}
+
+use FilterOnlyTest qr/not ok/ => "ok", "bad" => "ok", fail => "die";
+print "1..9\n";
+
+sub fail { print "ok ", $_[0], "\n" }
+sub ok { print "ok ", $_[0], "\n" }
+
+print "not ok 1\n";
+print "bad 2\n";
+
+fail(3);
+&fail(4);
+
+print "not " unless "whatnot okapi" eq "whatokapi";
+print "ok 5\n";
+
+ok 7 unless not ok 6;
+
+no FilterOnlyTest; # THE FUN STOPS HERE
+
+print "not " unless "not ok" =~ /^not /;
+print "ok 8\n";
+
+print "not " unless "bad" =~ /bad/;
+print "ok 9\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/Filter/Simple/import.t#1 (text) ====
Index: perl/macos/bundled_lib/t/Filter/Simple/import.t
--- perl/macos/bundled_lib/t/Filter/Simple/import.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/Filter/Simple/import.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,12 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(lib ../lib);
+ }
+}
+
+BEGIN { print "1..4\n" }
+
+use ImportTest (1..3);
+
+say "not ok 4\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/actual.t#1 (text) ====
Index: perl/macos/bundled_lib/t/NEXT/actual.t
--- perl/macos/bundled_lib/t/NEXT/actual.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/NEXT/actual.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,37 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { print "1..9\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+eval { $foo->test } and print "not ";
+print "ok 9\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/actuns.t#1 (text) ====
Index: perl/macos/bundled_lib/t/NEXT/actuns.t
--- perl/macos/bundled_lib/t/NEXT/actuns.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/NEXT/actuns.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,37 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { print "1..5\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+eval { $foo->test } and print "not ";
+print "ok 5\n";
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/next.t#1 (text) ====
Index: perl/macos/bundled_lib/t/NEXT/next.t
--- perl/macos/bundled_lib/t/NEXT/next.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/NEXT/next.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,106 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { print "1..25\n"; }
+
+use NEXT;
+
+print "ok 1\n";
+
+package A;
+sub A::method { return ( 3, $_[0]->NEXT::method() ) }
+sub A::DESTROY { $_[0]->NEXT::DESTROY() }
+
+package B;
+use base qw( A );
+sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() )
+ if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
+sub B::DESTROY { $_[0]->NEXT::DESTROY() }
+
+package C;
+sub C::DESTROY { print "ok 23\n"; $_[0]->NEXT::DESTROY() }
+
+package D;
+@D::ISA = qw( B C E );
+sub D::method { return ( 2, $_[0]->NEXT::method() ) }
+sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) }
+sub D::DESTROY { print "ok 22\n"; $_[0]->NEXT::DESTROY() }
+sub D::oops { $_[0]->NEXT::method() }
+sub D::secondary { return ( 17, 18, map { $_+10 } $_[0]->NEXT::secondary() ) }
+
+package E;
+@E::ISA = qw( F G );
+sub E::method { return ( 4, $_[0]->NEXT::method(), $_[0]->NEXT::method() ) }
+sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() )
+ if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
+sub E::DESTROY { print "ok 24\n"; $_[0]->NEXT::DESTROY() }
+
+package F;
+sub F::method { return ( 5 ) }
+sub F::AUTOLOAD { return ( 11 ) if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
+sub F::DESTROY { print "ok 25\n" }
+
+package G;
+sub G::method { return ( 6 ) }
+sub G::AUTOLOAD { print "not "; return }
+sub G::DESTROY { print "not ok 21"; return }
+
+package main;
+
+my $obj = bless {}, "D";
+
+my @vals;
+
+# TEST NORMAL REDISPATCH (ok 2..6)
+@vals = $obj->method();
+print map "ok $_\n", @vals;
+
+# RETEST NORMAL REDISPATCH SHOULD BE THE SAME (ok 7)
+@vals = $obj->method();
+print "not " unless join("", @vals) == "23456";
+print "ok 7\n";
+
+# TEST AUTOLOAD REDISPATCH (ok 8..11)
+@vals = $obj->missing_method();
+print map "ok $_\n", @vals;
+
+# NAMED METHOD CAN'T REDISPATCH TO NAMED METHOD OF DIFFERENT NAME (ok 12)
+eval { $obj->oops() } && print "not ";
+print "ok 12\n";
+
+# AUTOLOAD'ED METHOD CAN'T REDISPATCH TO NAMED METHOD (ok 13)
+
+eval {
+ local *C::AUTOLOAD = sub { $_[0]->NEXT::method() };
+ *C::AUTOLOAD = *C::AUTOLOAD;
+ eval { $obj->missing_method(); } && print "not ";
+};
+print "ok 13\n";
+
+# NAMED METHOD CAN'T REDISPATCH TO AUTOLOAD'ED METHOD (ok 14)
+eval {
+ *C::method = sub{ $_[0]->NEXT::AUTOLOAD() };
+ *C::method = *C::method;
+ eval { $obj->method(); } && print "not ";
+};
+print "ok 14\n";
+
+# BASE CLASS METHODS ONLY REDISPATCHED WITHIN HIERARCHY (ok 15..16)
+my $ob2 = bless {}, "B";
+@val = $ob2->method();
+print "not " unless @val==1 && $val[0]==3;
+print "ok 15\n";
+
+@val = $ob2->missing_method();
+print "not " unless @val==1 && $val[0]==9;
+print "ok 16\n";
+
+# TEST SECONDARY AUTOLOAD REDISPATCH (ok 17..21)
+@vals = $obj->secondary();
+print map "ok $_\n", @vals;
+
+# CAN REDISPATCH DESTRUCTORS (ok 22..25)
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/NEXT/unseen.t#1 (text) ====
Index: perl/macos/bundled_lib/t/NEXT/unseen.t
--- perl/macos/bundled_lib/t/NEXT/unseen.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/NEXT/unseen.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,36 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { print "1..4\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+$foo->test;
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libnet/netrc.t#1 (text) ====
Index: perl/macos/bundled_lib/t/libnet/netrc.t
--- perl/macos/bundled_lib/t/libnet/netrc.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libnet/netrc.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,150 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
+ print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
+ }
+}
+
+use strict;
+
+use Cwd;
+print "1..20\n";
+
+# for testing _readrc
+$ENV{HOME} = Cwd::cwd();
+
+# avoid "used only once" warning
+local (*CORE::GLOBAL::getpwuid, *CORE::GLOBAL::stat);
+
+*CORE::GLOBAL::getpwuid = sub ($) {
+ ((undef) x 7, Cwd::cwd());
+};
+
+# for testing _readrc
+my @stat;
+*CORE::GLOBAL::stat = sub (*) {
+ return @stat;
+};
+
+# for testing _readrc
+$INC{'FileHandle.pm'} = 1;
+
+(my $libnet_t = __FILE__) =~ s/\w+.t$/libnet_t.pl/;
+require $libnet_t;
+
+# now that the tricks are out of the way...
+eval { require Net::Netrc; };
+ok( !$@, 'should be able to require() Net::Netrc safely' );
+ok( exists $INC{'Net/Netrc.pm'}, 'should be able to use Net::Netrc' );
+
+SKIP: {
+ skip('incompatible stat() handling for OS', 4), next SKIP
+ if ($^O =~ /os2|win32|macos|cygwin/i or $] < 5.005);
+
+ my $warn;
+ local $SIG{__WARN__} = sub {
+ $warn = shift;
+ };
+
+ # add write access for group/other
+ $stat[2] = 077;
+ ok( !defined(Net::Netrc::_readrc()),
+ '_readrc() should not read world-writable file' );
+ ok( $warn =~ /^Bad permissions:/, '... and should warn about it' );
+
+ # the owner field should still not match
+ $stat[2] = 0;
+
+ if ($<) {
+ ok( !defined(Net::Netrc::_readrc()),
+ '_readrc() should not read file owned by someone else' );
+ ok( $warn =~ /^Not owner:/, '... and should warn about it' );
+ } else {
+ skip("testing as root",2);
+ }
+}
+
+# this field must now match, to avoid the last-tested warning
+$stat[4] = $<;
+
+# this curious mix of spaces and quotes tests a regex at line 79 (version 2.11)
+FileHandle::set_lines(split(/\n/, <<LINES));
+macdef bar
+login baz
+ machine "foo"
+login nigol "password" drowssap
+machine foo "login" l2
+ password p2
+account tnuocca
+default login "baz" password p2
+default "login" baz password p3
+macdef
+LINES
+
+# having set several lines and the uid, this should succeed
+is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
+
+# on 'foo', the login is 'nigol'
+is( Net::Netrc->lookup('foo')->{login}, 'nigol',
+ 'lookup() should find value by host name' );
+
+# on 'foo' with login 'l2', the password is 'p2'
+is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2',
+ 'lookup() should find value by hostname and login name' );
+
+# the default password is 'p3', as later declarations have priority
+is( Net::Netrc->lookup()->{password}, 'p3',
+ 'lookup() should find default value' );
+
+# lookup() ignores the login parameter when using default data
+is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3',
+ 'lookup() should ignore passed login when searching default' );
+
+# lookup() goes to default data if hostname cannot be found in config data
+is( Net::Netrc->lookup('abadname')->{login}, 'baz',
+ 'lookup() should use default for unknown machine name' );
+
+# now test these accessors
+my $instance = bless({}, 'Net::Netrc');
+for my $accessor (qw( login account password )) {
+ is( $instance->$accessor(), undef,
+ "$accessor() should return undef if $accessor is not set" );
+ $instance->{$accessor} = $accessor;
+ is( $instance->$accessor(), $accessor,
+ "$accessor() should return value when $accessor is set" );
+}
+
+# and the three-for-one accessor
+is( scalar( () = $instance->lpa()), 3,
+ 'lpa() should return login, password, account');
+is( join(' ', $instance->lpa), 'login password account',
+ 'lpa() should return appropriate values for l, p, and a' );
+
+package FileHandle;
+
+sub new {
+ tie *FH, 'FileHandle', @_;
+ bless \*FH, $_[0];
+}
+
+sub TIEHANDLE {
+ my ($class, $file, $mode) = @_[0,2,3];
+ bless({ file => $file, mode => $mode }, $class);
+}
+
+my @lines;
+sub set_lines {
+ @lines = @_;
+}
+
+sub READLINE {
+ shift @lines;
+}
+
+sub close { 1 }
+
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/base/http.t#1 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/base/http.t
--- perl/macos/bundled_lib/t/libwww-perl/base/http.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/base/http.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,190 @@
+#!./perl -w
+
+print "1..12\n";
+
+use strict;
+#use Data::Dump ();
+
+my $CRLF = "\015\012";
+my $LF = "\012";
+
+{
+ package HTTP;
+ use vars qw(@ISA);
+ require Net::HTTP::Methods;
+ @ISA=qw(Net::HTTP::Methods);
+
+ my %servers = (
+ a => { "/" => "HTTP/1.0 200 OK${CRLF}Content-Type: text/plain${CRLF}Content-Length: 6${CRLF}${CRLF}Hello\n",
+ "/bad1" => "HTTP/1.0 200 OK${LF}Server: foo${LF}HTTP/1.0 200 OK${LF}Content-type: text/foo${LF}${LF}abc\n",
+ "/09" => "Hello${CRLF}World!${CRLF}",
+ "/chunked" => "HTTP/1.1 200 OK${CRLF}Transfer-Encoding: chunked${CRLF}${CRLF}0002; foo=3; bar${CRLF}He${CRLF}1${CRLF}l${CRLF}2${CRLF}lo${CRLF}0000${CRLF}Content-MD5: xxx${CRLF}${CRLF}",
+ "/head" => "HTTP/1.1 200 OK${CRLF}Content-Length: 16${CRLF}Content-Type: text/plain${CRLF}${CRLF}",
+ },
+ );
+
+ sub http_connect {
+ my($self, $cnf) = @_;
+ my $server = $servers{$cnf->{PeerAddr}} || return undef;
+ ${*$self}{server} = $server;
+ ${*$self}{read_chunk_size} = $cnf->{ReadChunkSize};
+ return $self;
+ }
+
+ sub peerport {
+ return 80;
+ }
+
+ sub print {
+ my $self = shift;
+ #Data::Dump::dump("PRINT", @_);
+ my $in = shift;
+ my($method, $uri) = split(' ', $in);
+
+ my $out;
+ if ($method eq "TRACE") {
+ my $len = length($in);
+ $out = "HTTP/1.0 200 OK${CRLF}Content-Length: $len${CRLF}" .
+ "Content-Type: message/http${CRLF}${CRLF}" .
+ $in;
+ }
+ else {
+ $out = ${*$self}{server}{$uri};
+ $out = "HTTP/1.0 404 Not found${CRLF}${CRLF}" unless defined $out;
+ }
+
+ ${*$self}{out} .= $out;
+ return 1;
+ }
+
+ sub sysread {
+ my $self = shift;
+ #Data::Dump::dump("SYSREAD", @_);
+ my $length = $_[1];
+ my $offset = $_[2] || 0;
+
+ if (my $read_chunk_size = ${*$self}{read_chunk_size}) {
+ $length = $read_chunk_size if $read_chunk_size < $length;
+ }
+
+ my $data = substr(${*$self}{out}, 0, $length, "");
+ return 0 unless length($data);
+
+ $_[0] = "" unless defined $_[0];
+ substr($_[0], $offset) = $data;
+ return length($data);
+ }
+
+ # ----------------
+
+ sub request {
+ my($self, $method, $uri, $headers, $opt) = @_;
+ $headers ||= [];
+ $opt ||= {};
+
+ my($code, $message, @h);
+ my $buf = "";
+ eval {
+ $self->write_request($method, $uri, @$headers) || die "Can't write request";
+ ($code, $message, @h) = $self->read_response_headers(%$opt);
+
+ my $tmp;
+ my $n;
+ while ($n = $self->read_entity_body($tmp, 32)) {
+ #Data::Dump::dump($tmp, $n);
+ $buf .= $tmp;
+ }
+
+ push(@h, $self->get_trailers);
+
+ };
+
+ my %res = ( code => $code,
+ message => $message,
+ headers => \@h,
+ content => $buf,
+ );
+
+ if ($@) {
+ $res{error} = $@;
+ }
+
+ return \%res;
+ }
+}
+
+# Start testing
+my $h;
+my $res;
+
+$h = HTTP->new(Host => "a", KeepAlive => 1) || die;
+$res = $h->request(GET => "/");
+
+#Data::Dump::dump($res);
+
+print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello\n";
+print "ok 1\n";
+
+$res = $h->request(GET => "/404");
+print "not " unless $res->{code} eq "404";
+print "ok 2\n";
+
+$res = $h->request(TRACE => "/foo");
+print "not " unless $res->{code} eq "200" &&
+ $res->{content} eq "TRACE /foo HTTP/1.1${CRLF}Keep-Alive: 300${CRLF}Connection: Keep-Alive${CRLF}Host: a:80${CRLF}${CRLF}";
+print "ok 3\n";
+
+# try to turn off keep alive
+$h->keep_alive(0);
+$res = $h->request(TRACE => "/foo");
+print "not " unless $res->{code} eq "200" &&
+ $res->{content} eq "TRACE /foo HTTP/1.1${CRLF}Connection: close${CRLF}Host: a:80${CRLF}${CRLF}";
+print "ok 4\n";
+
+# try a bad one
+$res = $h->request(GET => "/bad1", [], {laxed => 1});
+print "not " unless $res->{code} eq "200" && $res->{message} eq "OK" &&
+ "@{$res->{headers}}" eq "Server foo Content-type text/foo" &&
+ $res->{content} eq "abc\n";
+print "ok 5\n";
+
+$res = $h->request(GET => "/bad1");
+print "not " unless $res->{error} =~ /Bad header/ && !$res->{code};
+print "ok 6\n";
+$h = undef; # it is in a bad state now
+
+$h = HTTP->new(Host => "a") || die; # reconnect
+$res = $h->request(GET => "/09", [], {laxed => 1});
+print "not " unless $res->{code} eq "200" && $res->{message} eq "Assumed OK" &&
+ $res->{content} eq "Hello${CRLF}World!${CRLF}" &&
+ $h->peer_http_version eq "0.9";
+print "ok 7\n";
+
+$res = $h->request(GET => "/09");
+print "not " unless $res->{error} =~ /^Bad response status line: 'Hello'/;
+print "ok 8\n";
+$h = undef; # it's in a bad state again
+
+$h = HTTP->new(Host => "a", KeepAlive => 1, ReadChunkSize => 1) || die; # reconnect
+$res = $h->request(GET => "/chunked");
+print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello" &&
+ "@{$res->{headers}}" eq "Transfer-Encoding chunked Content-MD5 xxx";
+print "ok 9\n";
+
+# once more
+$res = $h->request(GET => "/chunked");
+print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello" &&
+ "@{$res->{headers}}" eq "Transfer-Encoding chunked Content-MD5 xxx";
+print "ok 10\n";
+
+# test head
+$res = $h->request(HEAD => "/head");
+print "not " unless $res->{code} eq "200" && $res->{content} eq "" &&
+ "@{$res->{headers}}" eq "Content-Length 16 Content-Type text/plain";
+print "ok 11\n";
+
+$res = $h->request(GET => "/");
+print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello\n";
+print "ok 12\n";
+#use Data::Dump; Data::Dump::dump($res);
+
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/libwww-perl/live/activestate.t#1 (text) ====
Index: perl/macos/bundled_lib/t/libwww-perl/live/activestate.t
--- perl/macos/bundled_lib/t/libwww-perl/live/activestate.t.~1~ Tue Jan 15 08:00:05 2002
+++ perl/macos/bundled_lib/t/libwww-perl/live/activestate.t Tue Jan 15 08:00:05 2002
@@ -0,0 +1,45 @@
+print "1..2\n";
+
+use strict;
+use Net::HTTP;
+
+
+my $s = Net::HTTP->new(Host => "ftp.activestate.com",
+ KeepAlive => 1,
+ Timeout => 15,
+ PeerHTTPVersion => "1.1",
+ MaxLineLength => 512) || die "$@";
+
+for (1..2) {
+ $s->write_request(TRACE => "/libwww-perl",
+ 'User-Agent' => 'Mozilla/5.0',
+ 'Accept-Language' => 'no,en',
+ Accept => '*/*');
+
+ my($code, $mess, %h) = $s->read_response_headers;
+ print "$code $mess\n";
+ my $err;
+ $err++ unless $code eq "200";
+ $err++ unless $h{'Content-Type'} eq "message/http";
+
+ my $buf;
+ while (1) {
+ my $tmp;
+ my $n = $s->read_entity_body($tmp, 20);
+ last unless $n;
+ $buf .= $tmp;
+ }
+ $buf =~ s/\r//g;
+
+ $err++ unless $buf eq "TRACE /libwww-perl HTTP/1.1
+Accept: */*
+Accept-Language: no,en
+Host: ftp.activestate.com:80
+User-Agent: Mozilla/5.0
+
+";
+
+ print "not " if $err;
+ print "ok $_\n";
+}
+
End of Patch.