This patch describes the changes made in ActivePerl build 522 over the official Perl 5.005_03 sources. Summary of changes in build 522: * Important bug fixes imported from Perl 5.6 development track. See below for descriptions of these. * Typo in CGI.pm, and a PerlEx compatibility tweak. * Make "perl -V" output reflect ActiveState build. * Add Win32::BuildNumber() for compatibility. * Add resources to perl.exe and perlcore.dll. The ActivePerl Release Notes contain an informal summary of these changes. These can be viewed at: http://www.activestate.com/ActivePerl/docs/Perl-Win32/release.htm The included patch may be applied to Perl 5.005_03 sources using the GNU patch utility. e.g: c:\perl5.005_03> patch -p1 -N < this_file --------------------------------------------------------------------------- diff -ruN perl5.005_03/MANIFEST AP522_source/MANIFEST --- perl5.005_03/MANIFEST Fri Oct 15 17:45:43 1999 +++ AP522_source/MANIFEST Mon Nov 01 15:11:31 1999 @@ -502,6 +502,7 @@ lib/File/Find.pm Routines to do a find lib/File/Path.pm Do things like `mkdir -p' and `rm -r' lib/File/Spec.pm portable operations on file names +lib/File/Spec/Functions.pm Function interface to File::Spec object methods lib/File/Spec/Mac.pm portable operations on Mac file names lib/File/Spec/OS2.pm portable operations on OS2 file names lib/File/Spec/Unix.pm portable operations on Unix file names @@ -710,6 +711,7 @@ plan9/setup.rc Plan9 port: script for easy build+install plan9/versnum Plan9 port: script to print version number pod/Makefile Make pods into something else +pod/Win32.pod Documentation for Win32 extras pod/buildtoc generate perltoc.pod pod/checkpods.PL Tool to check for common errors in pods pod/perl.pod Top level perl man page diff -ruN perl5.005_03/cop.h AP522_source/cop.h --- perl5.005_03/cop.h Fri Oct 15 17:45:44 1999 +++ AP522_source/cop.h Mon Nov 01 15:11:32 1999 @@ -72,6 +72,7 @@ /* destroy arg array */ \ av_clear(cxsub.argarray); \ AvREAL_off(cxsub.argarray); \ + AvREIFY_on(cxsub.argarray); \ } \ if (cxsub.cv) { \ if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth)) \ diff -ruN perl5.005_03/dump.c AP522_source/dump.c --- perl5.005_03/dump.c Fri Oct 15 17:45:44 1999 +++ AP522_source/dump.c Mon Nov 01 15:11:32 1999 @@ -219,6 +219,8 @@ else if (o->op_type == OP_CONST) { if (o->op_private & OPpCONST_BARE) sv_catpv(tmpsv, ",BARE"); + if (o->op_private & OPpCONST_STRICT) + sv_catpv(tmpsv, ",STRICT"); } else if (o->op_type == OP_FLIP) { if (o->op_private & OPpFLIP_LINENUM) diff -ruN perl5.005_03/eg/example.pl AP522_source/eg/example.pl --- perl5.005_03/eg/example.pl Wed Dec 31 16:00:00 1969 +++ AP522_source/eg/example.pl Mon Nov 01 15:11:32 1999 @@ -0,0 +1 @@ +print "Hello from ActivePerl!"; diff -ruN perl5.005_03/embed.h AP522_source/embed.h --- perl5.005_03/embed.h Fri Oct 15 17:45:45 1999 +++ AP522_source/embed.h Mon Nov 01 15:11:33 1999 @@ -415,6 +415,7 @@ #define ninstr Perl_ninstr #define no_aelem Perl_no_aelem #define no_dir_func Perl_no_dir_func +#define no_bareword_allowed Perl_no_bareword_allowed #define no_fh_allowed Perl_no_fh_allowed #define no_func Perl_no_func #define no_helem Perl_no_helem diff -ruN perl5.005_03/ext/SDBM_File/sdbm/dbe.c AP522_source/ext/SDBM_File/sdbm/dbe.c --- perl5.005_03/ext/SDBM_File/sdbm/dbe.c Fri Oct 15 17:45:46 1999 +++ AP522_source/ext/SDBM_File/sdbm/dbe.c Mon Nov 01 15:11:34 1999 @@ -138,7 +138,7 @@ putchar('"'); for (i = 0; i < db.dsize; i++) { - if (isprint(db.dptr[i])) + if (isprint((unsigned char)db.dptr[i])) putchar(db.dptr[i]); else { putchar('\\'); @@ -171,7 +171,10 @@ *p = '\f'; else if (*s == 't') *p = '\t'; - else if (isdigit(*s) && isdigit(*(s + 1)) && isdigit(*(s + 2))) { + else if (isdigit((unsigned char)*s) + && isdigit((unsigned char)*(s + 1)) + && isdigit((unsigned char)*(s + 2))) + { i = (*s++ - '0') << 6; i |= (*s++ - '0') << 3; i |= *s - '0'; diff -ruN perl5.005_03/global.sym AP522_source/global.sym --- perl5.005_03/global.sym Fri Oct 15 17:45:46 1999 +++ AP522_source/global.sym Mon Nov 01 15:11:35 1999 @@ -502,6 +502,7 @@ newXSUB nextargv ninstr +no_bareword_allowed no_fh_allowed no_op oopsAV diff -ruN perl5.005_03/iperlsys.h AP522_source/iperlsys.h --- perl5.005_03/iperlsys.h Fri Oct 15 17:45:47 1999 +++ AP522_source/iperlsys.h Mon Nov 01 15:11:35 1999 @@ -450,10 +450,12 @@ virtual int Putenv(const char *envstring, int &err) = 0; virtual char * LibPath(char *patchlevel) =0; virtual char * SiteLibPath(char *patchlevel) =0; + virtual int Uname(struct utsname *name, int &err) =0; }; #define PerlEnv_putenv(str) PL_piENV->Putenv((str), ErrorNo()) #define PerlEnv_getenv(str) PL_piENV->Getenv((str), ErrorNo()) +#define PerlEnv_uname(name) PL_piENV->Uname((name), ErrorNo()) #ifdef WIN32 #define PerlEnv_lib_path(str) PL_piENV->LibPath((str)) #define PerlEnv_sitelib_path(str) PL_piENV->SiteLibPath((str)) @@ -463,6 +465,7 @@ #define PerlEnv_putenv(str) putenv((str)) #define PerlEnv_getenv(str) getenv((str)) +#define PerlEnv_uname(name) uname((name)) #endif /* PERL_OBJECT */ diff -ruN perl5.005_03/lib/CGI/Carp.pm AP522_source/lib/CGI/Carp.pm --- perl5.005_03/lib/CGI/Carp.pm Fri Oct 15 17:45:47 1999 +++ AP522_source/lib/CGI/Carp.pm Mon Nov 01 15:11:35 1999 @@ -242,11 +242,13 @@ } # The mod_perl package Apache::Registry loads CGI programs by calling -# eval. These evals don't count when looking at the stack backtrace. +# eval, as does PerlEx. These evals don't count when looking at the +# stack backtrace. sub _longmess { my $message = Carp::longmess(); my $mod_perl = exists $ENV{MOD_PERL}; - $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl; + my $PerlEx = exists($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + $message =~ s,eval[^\n]+(Apache/Registry\.pm|\s*PerlEx::Precompiler).*,,s if $mod_perl || $PerlEx; return( $message ); } @@ -307,8 +309,10 @@ END ; my $mod_perl = exists $ENV{MOD_PERL}; + my $PerlEx = exists($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + print STDOUT "Content-type: text/html\n\n" - unless $mod_perl; + unless $mod_perl || $PerlEx; if ($CUSTOM_MSG) { if (ref($CUSTOM_MSG) eq 'CODE') { diff -ruN perl5.005_03/lib/CGI.pm AP522_source/lib/CGI.pm --- perl5.005_03/lib/CGI.pm Fri Oct 15 17:45:47 1999 +++ AP522_source/lib/CGI.pm Mon Nov 01 15:11:35 1999 @@ -123,7 +123,7 @@ # Turn on special checking for Doug MacEachern's modperl if (exists $ENV{'GATEWAY_INTERFACE'} && - ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) + ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//)) { $| = 1; require Apache; diff -ruN perl5.005_03/lib/ExtUtils/MM_Unix.pm AP522_source/lib/ExtUtils/MM_Unix.pm --- perl5.005_03/lib/ExtUtils/MM_Unix.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/ExtUtils/MM_Unix.pm Mon Nov 01 15:11:36 1999 @@ -1695,8 +1695,7 @@ my($install_variable,$search_prefix,$replace_prefix); - # The rule, taken from Configure, is that if prefix contains perl, - # we shape the tree + # If the prefix contains perl, Configure shapes the tree as follows: # perlprefix/lib/ INSTALLPRIVLIB # perlprefix/lib/pod/ # perlprefix/lib/site_perl/ INSTALLSITELIB @@ -1708,6 +1707,11 @@ # prefix/lib/perl5/site_perl/ INSTALLSITELIB # prefix/bin/ INSTALLBIN # prefix/lib/perl5/man/ INSTALLMAN1DIR + # + # The above results in various kinds of breakage on various + # platforms, so we cope with it as follows: if prefix/lib/perl5 + # or prefix/lib/perl5/man exist, we'll replace those instead + # of /prefix/{lib,man} $replace_prefix = qq[\$\(PREFIX\)]; for $install_variable (qw/ @@ -1716,36 +1720,45 @@ /) { $self->prefixify($install_variable,$configure_prefix,$replace_prefix); } - $search_prefix = $configure_prefix =~ /perl/ ? - $self->catdir($configure_prefix,"lib") : - $self->catdir($configure_prefix,"lib","perl5"); + my $funkylibdir = $self->catdir($configure_prefix,"lib","perl5"); + $funkylibdir = '' unless -d $funkylibdir; + $search_prefix = $funkylibdir || $self->catdir($configure_prefix,"lib"); if ($self->{LIB}) { $self->{INSTALLPRIVLIB} = $self->{INSTALLSITELIB} = $self->{LIB}; $self->{INSTALLARCHLIB} = $self->{INSTALLSITEARCH} = $self->catdir($self->{LIB},$Config{'archname'}); - } else { - $replace_prefix = $self->{PREFIX} =~ /perl/ ? - $self->catdir(qq[\$\(PREFIX\)],"lib") : - $self->catdir(qq[\$\(PREFIX\)],"lib","perl5"); + } + else { + if (-d $self->catdir($self->{PREFIX},"lib","perl5")) { + $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib", "perl5"); + } + else { + $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib"); + } for $install_variable (qw/ INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB INSTALLSITEARCH - /) { + /) + { $self->prefixify($install_variable,$search_prefix,$replace_prefix); } } - $search_prefix = $configure_prefix =~ /perl/ ? - $self->catdir($configure_prefix,"man") : - $self->catdir($configure_prefix,"lib","perl5","man"); - $replace_prefix = $self->{PREFIX} =~ /perl/ ? - $self->catdir(qq[\$\(PREFIX\)],"man") : - $self->catdir(qq[\$\(PREFIX\)],"lib","perl5","man"); + my $funkymandir = $self->catdir($configure_prefix,"lib","perl5","man"); + $funkymandir = '' unless -d $funkymandir; + $search_prefix = $funkymandir || $self->catdir($configure_prefix,"man"); + if (-d $self->catdir($self->{PREFIX},"lib","perl5", "man")) { + $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib", "perl5", "man"); + } + else { + $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"man"); + } for $install_variable (qw/ INSTALLMAN1DIR INSTALLMAN3DIR - /) { + /) + { $self->prefixify($install_variable,$search_prefix,$replace_prefix); } @@ -1846,7 +1859,7 @@ push @defpath, $component if defined $component; } $self->{PERL} ||= - $self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ], + $self->find_perl(5.0, [ $self->canonpath($^X), 'miniperl','perl','perl5',"perl$]" ], \@defpath, $Verbose ); # don't check if perl is executable, maybe they have decided to # supply switches with perl diff -ruN perl5.005_03/lib/ExtUtils/xsubpp AP522_source/lib/ExtUtils/xsubpp --- perl5.005_03/lib/ExtUtils/xsubpp Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/ExtUtils/xsubpp Mon Nov 01 15:11:36 1999 @@ -1327,8 +1327,7 @@ ##endif #XSCAPI(boot_$Module_cname) #[[ -# SetCPerlObj(pPerl); -# boot__CAPI_entry(cv); +# boot_CAPI_handler(cv, boot__CAPI_entry, pPerl); #]] ##endif /* PERL_CAPI */ EOF diff -ruN perl5.005_03/lib/File/Compare.pm AP522_source/lib/File/Compare.pm --- perl5.005_03/lib/File/Compare.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/File/Compare.pm Mon Nov 01 15:11:36 1999 @@ -6,10 +6,10 @@ require Exporter; use Carp; -$VERSION = '1.1001'; +$VERSION = '1.1002'; @ISA = qw(Exporter); @EXPORT = qw(compare); -@EXPORT_OK = qw(cmp); +@EXPORT_OK = qw(cmp compare_text); $Too_Big = 1024 * 1024 * 2; @@ -22,14 +22,12 @@ croak("Usage: compare( file1, file2 [, buffersize]) ") unless(@_ == 2 || @_ == 3); - my $from = shift; - my $to = shift; - my $closefrom=0; - my $closeto=0; - my ($size, $fromsize, $status, $fr, $tr, $fbuf, $tbuf); - local(*FROM, *TO); - local($\) = ''; + my ($from,$to,$size) = @_; + my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0); + my ($fromsize,$closefrom,$closeto); + local (*FROM, *TO); + croak("from undefined") unless (defined $from); croak("to undefined") unless (defined $to); @@ -40,9 +38,11 @@ *FROM = $from; } else { open(FROM,"<$from") or goto fail_open1; - binmode FROM; + unless ($text_mode) { + binmode FROM; + $fromsize = -s FROM; + } $closefrom = 1; - $fromsize = -s FROM; } if (ref($to) && @@ -52,32 +52,45 @@ *TO = $to; } else { open(TO,"<$to") or goto fail_open2; - binmode TO; + binmode TO unless $text_mode; $closeto = 1; } - if ($closefrom && $closeto) { + if (!$text_mode && $closefrom && $closeto) { # If both are opened files we know they differ if their size differ goto fail_inner if $fromsize != -s TO; } - if (@_) { - $size = shift(@_) + 0; - croak("Bad buffer size for compare: $size\n") unless ($size > 0); - } else { - $size = $fromsize; - $size = 1024 if ($size < 512); - $size = $Too_Big if ($size > $Too_Big); + if ($text_mode) { + local $/ = "\n"; + my ($fline,$tline); + while (defined($fline = )) { + goto fail_inner unless defined($tline = ); + if (ref $size) { + # $size contains ref to comparison function + goto fail_inner if &$size($fline, $tline); + } else { + goto fail_inner if $fline ne $tline; + } + } + goto fail_inner if defined($tline = ); } + else { + unless (defined($size) && $size > 0) { + $size = $fromsize; + $size = 1024 if $size < 512; + $size = $Too_Big if $size > $Too_Big; + } - $fbuf = ''; - $tbuf = ''; - while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { - unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) { - goto fail_inner; + my ($fr,$tr,$fbuf,$tbuf); + $fbuf = $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) { + goto fail_inner; + } } + goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0; } - goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0); close(TO) || goto fail_open2 if $closeto; close(FROM) || goto fail_open1 if $closefrom; @@ -93,7 +106,7 @@ fail_open2: if ($closefrom) { - $status = $!; + my $status = $!; $! = 0; close FROM; $! = $status unless $!; @@ -104,6 +117,18 @@ *cmp = \&compare; +sub compare_text { + my ($from,$to,$cmp) = @_; + croak("Usage: compare_text( file1, file2 [, cmp-function])") + unless @_ == 2 || @_ == 3; + croak("Third arg to compare_text() function must be a code reference") + if @_ == 3 && ref($cmp) ne 'CODE'; + + # Using a negative buffer size puts compare into text_mode too + $cmp = -1 unless defined $cmp; + compare($from, $to, $cmp); +} + 1; __END__ @@ -128,6 +153,18 @@ File::Compare::cmp is a synonym for File::Compare::compare. It is exported from File::Compare only by request. + +File::Compare::compare_text does a line by line comparison of the two +files. It stops as soon as a difference is detected. compare_text() +accepts an optional third argument: This must be a CODE reference to +a line comparison function, which returns 0 when both lines are considered +equal. For example: + + compare_text($file1, $file2) + +is basically equivalent to + + compare_text($file1, $file2, sub {$_[0] ne $_[1]} ) =head1 RETURN diff -ruN perl5.005_03/lib/File/Copy.pm AP522_source/lib/File/Copy.pm --- perl5.005_03/lib/File/Copy.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/File/Copy.pm Mon Nov 01 15:11:36 1999 @@ -64,6 +64,7 @@ && !$to_a_handle && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. + && !($from_a_handle && $^O eq 'MSWin32') ) { return syscopy($from, $to); @@ -186,6 +187,11 @@ # preserve MPE file attributes. return system('/bin/cp', '-f', $_[0], $_[1]) == 0; }; + } elsif ($^O eq 'MSWin32') { + *syscopy = sub { + return 0 unless @_ == 2; + return Win32::CopyFile(@_, 1); + }; } else { *syscopy = \© } @@ -272,9 +278,9 @@ structure. For Unix systems, this is equivalent to the simple C routine. For VMS systems, this calls the C routine (see below). For OS/2 systems, this calls the C -XSUB directly. +XSUB directly. For Win32 systems, this calls C. -=head2 Special behaviour if C is defined (VMS and OS/2) +=head2 Special behaviour if C is defined (OS/2, VMS and Win32) If both arguments to C are not file handles, then C will perform a "system copy" of diff -ruN perl5.005_03/lib/File/Spec/Functions.pm AP522_source/lib/File/Spec/Functions.pm --- perl5.005_03/lib/File/Spec/Functions.pm Wed Dec 31 16:00:00 1969 +++ AP522_source/lib/File/Spec/Functions.pm Mon Nov 01 15:11:36 1999 @@ -0,0 +1,91 @@ +package File::Spec::Functions; + +use File::Spec; +use strict; + +use vars qw(@ISA @EXPORT @EXPORT_OK); + +require Exporter; + +@ISA = qw(Exporter); + +@EXPORT = qw( + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path +); + +@EXPORT_OK = qw( + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs +); + +foreach my $meth (@EXPORT, @EXPORT_OK) { + my $sub = File::Spec->can($meth); + no strict 'refs'; + *{$meth} = sub {&$sub('File::Spec', @_)}; +} + + +1; +__END__ + +=head1 NAME + +File::Spec::Functions - portably perform operations on file names + +=head1 SYNOPSIS + + use File::Spec::Functions; + $x = catfile('a','b'); + +=head1 DESCRIPTION + +This module exports convenience functions for all of the class methods +provided by File::Spec. + +For a reference of available functions, please consult L, +which contains the entire set, and which is inherited by the modules for +other platforms. For further information, please see L, +L, L, or L. + +=head2 Exports + +The following functions are exported by default. + + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path + + +The following functions are exported only by request. + + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + +=head1 SEE ALSO + +File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, +File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker diff -ruN perl5.005_03/lib/File/Spec/Mac.pm AP522_source/lib/File/Spec/Mac.pm --- perl5.005_03/lib/File/Spec/Mac.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/File/Spec/Mac.pm Mon Nov 01 15:11:36 1999 @@ -1,26 +1,17 @@ package File::Spec::Mac; -use Exporter (); -use Config; use strict; -use File::Spec; -use vars qw(@ISA $VERSION $Is_Mac); - -$VERSION = '1.0'; - +use vars qw(@ISA); +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -$Is_Mac = $^O eq 'MacOS'; - -Exporter::import('File::Spec', '$Verbose'); - =head1 NAME File::Spec::Mac - File::Spec for MacOS =head1 SYNOPSIS -C + require File::Spec::Mac; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -37,8 +28,8 @@ =cut sub canonpath { - my($self,$path) = @_; - $path; + my ($self,$path) = @_; + return $path; } =item catdir @@ -84,20 +75,17 @@ =cut -# '; - sub catdir { shift; my @args = @_; - $args[0] =~ s/:$//; - my $result = shift @args; - for (@args) { - s/:$//; - s/^://; - $result .= ":$_"; + my $result = shift @args; + $result =~ s/:$//; + foreach (@args) { + s/:$//; + s/^://; + $result .= ":$_"; } - $result .= ":"; - $result; + return "$result:"; } =item catfile @@ -118,50 +106,69 @@ =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - $file =~ s/^://; + $file =~ s/^://; return $dir.$file; } =item curdir -Returns a string representing of the current directory. +Returns a string representing the current directory. =cut sub curdir { - return ":" ; + return ":"; +} + +=item devnull + +Returns a string representing the null device. + +=cut + +sub devnull { + return "Dev:Null"; } =item rootdir Returns a string representing the root directory. Under MacPerl, returns the name of the startup volume, since that's the closest in -concept, although other volumes aren't rooted there. On any other -platform returns '', since there's no common way to indicate "root -directory" across all Macs. +concept, although other volumes aren't rooted there. =cut sub rootdir { # -# There's no real root directory on MacOS. If you're using MacPerl, -# the name of the startup volume is returned, since that's the closest in -# concept. On other platforms, simply return '', because nothing better -# can be done. +# There's no real root directory on MacOS. The name of the startup +# volume is returned, since that's the closest in concept. # - if($Is_Mac) { - require Mac::Files; - my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, - &Mac::Files::kSystemFolderType); - $system =~ s/:.*$/:/; - return $system; - } else { - return ''; - } + require Mac::Files; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); + $system =~ s/:.*$/:/; + return $system; +} + +=item tmpdir + +Returns a string representation of the first existing directory +from the following list or '' if none exist: + + $ENV{TMPDIR} + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR}; + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; } =item updir @@ -185,11 +192,11 @@ =cut sub file_name_is_absolute { - my($self,$file) = @_; - if ($file =~ /:/) { - return ($file !~ m/^:/); - } else { - return (! -e ":$file"); + my ($self,$file) = @_; + if ($file =~ /:/) { + return ($file !~ m/^:/); + } else { + return (! -e ":$file"); } } @@ -207,14 +214,8 @@ # The concept is meaningless under the MacPerl application. # Under MPW, it has a meaning. # - my($self) = @_; - my @path; - if(exists $ENV{Commands}) { - @path = split /,/,$ENV{Commands}; - } else { - @path = (); - } - @path; + return unless exists $ENV{Commands}; + return split(/,/, $ENV{Commands}); } =back @@ -226,5 +227,3 @@ =cut 1; -__END__ - diff -ruN perl5.005_03/lib/File/Spec/OS2.pm AP522_source/lib/File/Spec/OS2.pm --- perl5.005_03/lib/File/Spec/OS2.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/File/Spec/OS2.pm Mon Nov 01 15:11:36 1999 @@ -1,36 +1,42 @@ package File::Spec::OS2; -#use Config; -#use Cwd; -#use File::Basename; use strict; -require Exporter; - -use File::Spec; use vars qw(@ISA); - -Exporter::import('File::Spec', - qw( $Verbose)); - +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -$ENV{EMXSHELL} = 'sh'; # to run `commands` +sub devnull { + return "/dev/nul"; +} sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}i); } sub path { - my($self) = @_; - my $path_sep = ";"; my $path = $ENV{PATH}; $path =~ s:\\:/:g; - my @path = split $path_sep, $path; - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + my @path = split(';',$path); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; } +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + my $self = shift; + foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) { + next unless defined && -d; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + $tmpdir =~ s:\\:/:g; + $tmpdir = $self->canonpath($tmpdir); + return $tmpdir; +} + 1; __END__ @@ -40,12 +46,10 @@ =head1 SYNOPSIS - use File::Spec::OS2; # Done internally by File::Spec if needed + require File::Spec::OS2; # Done internally by File::Spec if needed =head1 DESCRIPTION See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. - -=cut diff -ruN perl5.005_03/lib/File/Spec/Unix.pm AP522_source/lib/File/Spec/Unix.pm --- perl5.005_03/lib/File/Spec/Unix.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/File/Spec/Unix.pm Mon Nov 01 15:11:37 1999 @@ -1,31 +1,16 @@ package File::Spec::Unix; -use Exporter (); -use Config; -use File::Basename qw(basename dirname fileparse); -use DirHandle; use strict; -use vars qw(@ISA $Is_Mac $Is_OS2 $Is_VMS $Is_Win32); -use File::Spec; -Exporter::import('File::Spec', '$Verbose'); +use Cwd; -$Is_OS2 = $^O eq 'os2'; -$Is_Mac = $^O eq 'MacOS'; -$Is_Win32 = $^O eq 'MSWin32'; - -if ($Is_VMS = $^O eq 'VMS') { - require VMS::Filespec; - import VMS::Filespec qw( &vmsify ); -} - =head1 NAME File::Spec::Unix - methods used by File::Spec =head1 SYNOPSIS -C + require File::Spec::Unix; # Done automatically by File::Spec =head1 DESCRIPTION @@ -40,15 +25,31 @@ No physical check on the filesystem, but a logical cleanup of a path. On UNIX eliminated successive slashes and successive "/.". + $cpath = File::Spec->canonpath( $path ) ; + $cpath = File::Spec->canonpath( $path, $reduce_ricochet ) ; + +If $reduce_ricochet is present and true, then "dirname/.." +constructs are eliminated from the path. Without $reduce_ricochet, +if dirname is a symbolic link, then "a/dirname/../b" will often +take you to someplace other than "a/b". This is sometimes desirable. +If it's not, setting $reduce_ricochet causes the "dirname/.." to +be removed from this path, resulting in "a/b". This may make +your perl more portable and robust, unless you want to +ricochet (some scripts depend on it). + =cut sub canonpath { - my($self,$path) = @_; - $path =~ s|/+|/|g ; # xx////xx -> xx/xx - $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx + my ($self,$path,$reduce_ricochet) = @_; + $path =~ s|/+|/|g unless($^O =~ /cygwin/); # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|; # /../../xx -> xx + if ( $reduce_ricochet ) { + while ( $path =~ s@[^/]+/\.\.(?:/|$)@@ ) {}# xx/.. -> xx + } $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx - $path; + return $path; } =item catdir @@ -61,20 +62,14 @@ =cut -# '; - sub catdir { - shift; + my $self = shift; my @args = @_; - for (@args) { + foreach (@args) { # append a slash to each argument unless it has one there - $_ .= "/" if $_ eq '' or substr($_,-1) ne "/"; + $_ .= "/" if $_ eq '' || substr($_,-1) ne "/"; } - my $result = join('', @args); - # remove a trailing slash unless we are root - substr($result,-1) = "" - if length($result) > 1 && substr($result,-1) eq "/"; - $result; + return $self->canonpath(join('', @args)); } =item catfile @@ -85,29 +80,37 @@ =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - for ($dir) { - $_ .= "/" unless substr($_,length($_)-1,1) eq "/"; - } + $dir .= "/" unless substr($dir,-1) eq "/"; return $dir.$file; } =item curdir -Returns a string representing of the current directory. "." on UNIX. +Returns a string representation of the current directory. "." on UNIX. =cut sub curdir { - return "." ; + return "."; +} + +=item devnull + +Returns a string representation of the null device. "/dev/null" on UNIX. + +=cut + +sub devnull { + return "/dev/null"; } =item rootdir -Returns a string representing of the root directory. "/" on UNIX. +Returns a string representation of the root directory. "/" on UNIX. =cut @@ -115,9 +118,31 @@ return "/"; } +=item tmpdir + +Returns a string representation of the first writable directory +from the following list or "" if none are writable: + + $ENV{TMPDIR} + /tmp + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + foreach ($ENV{TMPDIR}, "/tmp") { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; +} + =item updir -Returns a string representing of the parent directory. ".." on UNIX. +Returns a string representation of the parent directory. ".." on UNIX. =cut @@ -133,7 +158,7 @@ =cut sub no_upwards { - my($self) = shift; + my $self = shift; return grep(!/^\.{1,2}$/, @_); } @@ -144,8 +169,8 @@ =cut sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m:^/: ; + my ($self,$file) = @_; + return scalar($file =~ m:^/:); } =item path @@ -155,12 +180,9 @@ =cut sub path { - my($self) = @_; - my $path_sep = ":"; - my $path = $ENV{PATH}; - my @path = split $path_sep, $path; - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + my @path = split(':', $ENV{PATH}); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; } =item join @@ -170,21 +192,245 @@ =cut sub join { - my($self) = shift @_; - $self->catfile(@_); + my $self = shift; + return $self->catfile(@_); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to volume, directory, and filename portions. On systems +with no concept of volume, returns undef for volume. + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless $no_file is true or a +trailing separator or /. or /.. is present. On Unix this means that $no_file +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + $directory = $path; + } + else { + $path =~ m|^ ( (?: .* / (?: \.\.?$ )? )? ) ([^/]*) |x; + $directory = $1; + $file = $2; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|/$| ) { + return split( m|/|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|/|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( $directory ne '' && + $file ne '' && + substr( $directory, -1 ) ne '/' && + substr( $file, 0, 1 ) ne '/' + ) { + $directory .= "/$file" ; + } + else { + $directory .= $file ; + } + + return $directory ; +} + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $destination ) ; + $rel_path = File::Spec->abs2rel( $destination, $base ) ; + +If $base is not present or '', then L is used. If $base is relative, +then it is converted to absolute form using L. This means that it +is taken to be relative to L. + +On systems with the concept of a volume, this assumes that both paths +are on the $destination volume, and ignores the $base volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is relative, it is converted to absolute form using L. +This means that it is taken to be relative to L. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path); + my @basechunks = $self->splitdir( $base); + + while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { + shift @pathchunks ; + shift @basechunks ; + } + + $path = CORE::join( '/', @pathchunks ); + $base = CORE::join( '/', @basechunks ); + + # $base now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + $base =~ s|[^/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + if ( $path ne '' && $base ne '' ) { + $path = "$base/$path" ; + } else { + $path = "$base$path" ; + } + + return $self->canonpath( $path ) ; } -=item nativename +=item rel2abs -TBW. +Converts a relative path to an absolute path. + $abs_path = $File::Spec->rel2abs( $destination ) ; + $abs_path = $File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L is used. If $base is relative, +then it is converted to absolute form using L. This means that it +is taken to be relative to L. + +On systems with the concept of a volume, this assumes that both paths +are on the $base volume, and ignores the $destination volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + =cut -sub nativename { - my($self,$name) = shift @_; - $name; +sub rel2abs($;$;) { + my ($self,$path,$base ) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Glom them together + $path = $self->catdir( $base, $path ) ; + } + + return $self->canonpath( $path ) ; } + =back =head1 SEE ALSO @@ -194,4 +440,3 @@ =cut 1; -__END__ diff -ruN perl5.005_03/lib/File/Spec/VMS.pm AP522_source/lib/File/Spec/VMS.pm --- perl5.005_03/lib/File/Spec/VMS.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/File/Spec/VMS.pm Mon Nov 01 15:11:37 1999 @@ -1,19 +1,12 @@ - package File::Spec::VMS; -use Carp qw( &carp ); -use Config; -require Exporter; -use VMS::Filespec; -use File::Basename; - -use File::Spec; -use vars qw($Revision); -$Revision = '5.3901 (6-Mar-1997)'; - +use strict; +use vars qw(@ISA); +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -Exporter::import('File::Spec', '$Verbose'); +use File::Basename; +use VMS::Filespec; =head1 NAME @@ -21,7 +14,7 @@ =head1 SYNOPSIS - use File::Spec::VMS; # Done internally by File::Spec if needed + require File::Spec::VMS; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -29,6 +22,74 @@ there. This package overrides the implementation of these methods, not the semantics. +=cut + +sub eliminate_macros { + my($self,$path) = @_; + return '' unless $path; + $self = {} unless ref $self; + my($npath) = unixify($path); + my($complex) = 0; + my($head,$macro,$tail); + + # perform m##g in scalar context so it acts as an iterator + while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) { + if ($self->{$2}) { + ($head,$macro,$tail) = ($1,$2,$3); + if (ref $self->{$macro}) { + if (ref $self->{$macro} eq 'ARRAY') { + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } + } + else { ($macro = unixify($self->{$macro})) =~ s#/$##; } + $npath = "$head$macro$tail"; + } + } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; } + $npath; +} + +sub fixpath { + my($self,$path,$force_path) = @_; + return '' unless $path; + $self = bless {} unless ref $self; + my($fixedpath,$prefix,$name); + + if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])$/) { + $fixedpath = vmspath($self->eliminate_macros($path)); + } + else { + $fixedpath = vmsify($self->eliminate_macros($path)); + } + } + elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) { + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : ''; + $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; + $fixedpath = vmspath($fixedpath) if $force_path; + } + else { + $fixedpath = $path; + $fixedpath = vmspath($fixedpath) if $force_path; + } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } + # Trim off root dirname if it's had other dirs inserted in front of it. + $fixedpath =~ s/\.000000([\]>])/$1/; + $fixedpath; +} + + =head2 Methods always loaded =over @@ -41,23 +102,22 @@ =cut sub catdir { - my($self,@dirs) = @_; - my($dir) = pop @dirs; + my ($self,@dirs) = @_; + my $dir = pop @dirs; @dirs = grep($_,@dirs); - my($rslt); + my $rslt; if (@dirs) { - my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); - my($spath,$sdir) = ($path,$dir); - $spath =~ s/.dir$//; $sdir =~ s/.dir$//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); - } - else { - if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } - else { $rslt = vmspath($dir); } + my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my ($spath,$sdir) = ($path,$dir); + $spath =~ s/.dir$//; $sdir =~ s/.dir$//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; + $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + } + else { + if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } + else { $rslt = vmspath($dir); } } - print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; - $rslt; + return $rslt; } =item catfile @@ -68,28 +128,29 @@ =cut sub catfile { - my($self,@files) = @_; - my($file) = pop @files; + my ($self,@files) = @_; + my $file = pop @files; @files = grep($_,@files); - my($rslt); + my $rslt; if (@files) { - my($path) = (@files == 1 ? $files[0] : $self->catdir(@files)); - my($spath) = $path; - $spath =~ s/.dir$//; - if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); - } + my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); + my $spath = $path; + $spath =~ s/.dir$//; + if ($spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { + $rslt = "$spath$file"; + } + else { + $rslt = $self->eliminate_macros($spath); + $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } } else { $rslt = vmsify($file); } - print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; - $rslt; + return $rslt; } =item curdir (override) -Returns a string representing of the current directory. +Returns a string representation of the current directory: '[]' =cut @@ -97,19 +158,51 @@ return '[]'; } +=item devnull (override) + +Returns a string representation of the null device: '_NLA0:' + +=cut + +sub devnull { + return "_NLA0:"; +} + =item rootdir (override) -Returns a string representing of the root directory. +Returns a string representation of the root directory: 'SYS$DISK:[000000]' =cut sub rootdir { - return ''; + return 'SYS$DISK:[000000]'; +} + +=item tmpdir (override) + +Returns a string representation of the first writable directory +from the following list or '' if none are writable: + + /sys$scratch + $ENV{TMPDIR} + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + foreach ('/sys$scratch', $ENV{TMPDIR}) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; } =item updir (override) -Returns a string representing of the parent directory. +Returns a string representation of the parent directory: '[-]' =cut @@ -125,9 +218,9 @@ =cut sub path { - my(@dirs,$dir,$i); + my (@dirs,$dir,$i); while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } - @dirs; + return @dirs; } =item file_name_is_absolute (override) @@ -137,12 +230,20 @@ =cut sub file_name_is_absolute { - my($self,$file) = @_; + my ($self,$file) = @_; # If it's a logical name, expand it. - $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; - $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; + $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file}; + return scalar($file =~ m!^/! || + $file =~ m![<\[][^.\-\]>]! || + $file =~ /:[^<\[]/); } -1; -__END__ +=back +=head1 SEE ALSO + +L + +=cut + +1; diff -ruN perl5.005_03/lib/File/Spec/Win32.pm AP522_source/lib/File/Spec/Win32.pm --- perl5.005_03/lib/File/Spec/Win32.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/File/Spec/Win32.pm Mon Nov 01 15:11:37 1999 @@ -1,12 +1,18 @@ package File::Spec::Win32; +use strict; +use Cwd; +use vars qw(@ISA); +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + =head1 NAME File::Spec::Win32 - methods for Win32 file specs =head1 SYNOPSIS - use File::Spec::Win32; # Done internally by File::Spec if needed + require File::Spec::Win32; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -16,39 +22,48 @@ =over -=cut +=item devnull -#use Config; -#use Cwd; -use File::Basename; -require Exporter; -use strict; +Returns a string representation of the null device. -use vars qw(@ISA); +=cut -use File::Spec; -Exporter::import('File::Spec', qw( $Verbose)); +sub devnull { + return "nul"; +} -@ISA = qw(File::Spec::Unix); +=item tmpdir -$ENV{EMXSHELL} = 'sh'; # to run `commands` +Returns a string representation of the first existing directory +from the following list: -sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; -} + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + /tmp + / + +=cut -sub catdir { +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; my $self = shift; - my @args = @_; - for (@args) { - # append a slash to each argument unless it has one there - $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; + foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) { + next unless defined && -d; + $tmpdir = $_; + last; } - my $result = $self->canonpath(join('', @args)); - $result; + $tmpdir = '' unless defined $tmpdir; + $tmpdir = $self->canonpath($tmpdir); + return $tmpdir; } +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}i); +} + =item catfile Concatenate one or more directory names and a filename to form a @@ -57,22 +72,20 @@ =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - $dir =~ s/(\\\.)$//; - $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\"; + $dir .= "\\" unless substr($dir,-1) eq "\\"; return $dir.$file; } sub path { local $^W = 1; - my($self) = @_; my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; my @path = split(';',$path); - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; } =item canonpath @@ -83,22 +96,303 @@ =cut sub canonpath { - my($self,$path) = @_; + my ($self,$path,$reduce_ricochet) = @_; $path =~ s/^([a-z]:)/\u$1/; $path =~ s|/|\\|g; - $path =~ s|\\+|\\|g ; # xx////xx -> xx/xx - $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx + $path =~ s|([^\\])\\+|$1\\|g; # xx////xx -> xx/xx + $path =~ s|(\\\.)+\\|\\|g; # xx/././xx -> xx/xx $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx - $path =~ s|\\$|| - unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx - $path .= '.' if $path =~ m#\\$#; - $path; + $path =~ s|\\$|| + unless $path =~ m#^([A-Z]:)?\\$#; # xx/ -> xx + return $path; } -1; -__END__ +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '\\', '\\.', '\\..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, undef ). + +Separators accepted are \ and /. + +Volumes can be drive letters or UNC sharenames (\\server\share). + +The results can be passed to L to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m@^( (?:[a-zA-Z]:|(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+)? ) + (.*) + @x; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m@^ ( (?: [a-zA-Z]: | + (?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?$)?)? ) + (.*) + @x; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|[\\/]$| ) { + return split( m|[\\/]|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+$@ && + $directory =~ m@^[^\\/]@ + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:$@ && + $volume !~ m@[\\/]$@ && + $file !~ m@^[\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $destination ) ; + $rel_path = File::Spec->abs2rel( $destination, $base ) ; + +If $base is not present or '', then L is used. If $base is relative, +then it is converted to absolute form using L. This means that it +is taken to be relative to L. + +On systems with the concept of a volume, this assumes that both paths +are on the $destination volume, and ignores the $base volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is relative, it is converted to absolute form using L. +This means that it is taken to be relative to L. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + elsif ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( undef, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '\\', @pathchunks ); + $base_directories = CORE::join( '\\', @basechunks ); + + # $base now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + $base_directories =~ s|[^/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + if ( $path ne '' && $base ne '' ) { + $path_directories = "$base_directories\\$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + return $self->canonpath( + $self->catpath( $path_volume, $path_directories, $path_file ) + ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path. + + $abs_path = $File::Spec->rel2abs( $destination ) ; + $abs_path = $File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L is used. If $base is relative, +then it is converted to absolute form using L. This means that it +is taken to be relative to L. + +Assumes that both paths are on the $base volume, and ignores the +$destination volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub rel2abs($;$;) { + my ($self,$path,$base ) = @_; + + # Clean up and split up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + + # Figure out the effective $base and clean it up. + if ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + elsif ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( $base_volume, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + =back -=cut +=head1 SEE ALSO + +L +=cut + +1; diff -ruN perl5.005_03/lib/File/Spec.pm AP522_source/lib/File/Spec.pm --- perl5.005_03/lib/File/Spec.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/File/Spec.pm Mon Nov 01 15:11:36 1999 @@ -1,48 +1,19 @@ package File::Spec; -require Exporter; - -@ISA = qw(Exporter); -# 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( - -); -@EXPORT_OK = qw($Verbose); - use strict; -use vars qw(@ISA $VERSION $Verbose); - -$VERSION = '0.6'; - -$Verbose = 0; +use vars qw(@ISA $VERSION); -require File::Spec::Unix; +$VERSION = '0.8'; +my %module = (MacOS => 'Mac', + MSWin32 => 'Win32', + os2 => 'OS2', + VMS => 'VMS'); + +my $module = $module{$^O} || 'Unix'; +require "File/Spec/$module.pm"; +@ISA = ("File::Spec::$module"); -sub load { - my($class,$OS) = @_; - if ($OS eq 'VMS') { - require File::Spec::VMS; - require VMS::Filespec; - 'File::Spec::VMS' - } elsif ($OS eq 'os2') { - require File::Spec::OS2; - 'File::Spec::OS2' - } elsif ($OS eq 'MacOS') { - require File::Spec::Mac; - 'File::Spec::Mac' - } elsif ($OS eq 'MSWin32') { - require File::Spec::Win32; - 'File::Spec::Win32' - } else { - 'File::Spec::Unix' - } -} - -@ISA = load('File::Spec', $^O); - 1; __END__ @@ -52,12 +23,16 @@ =head1 SYNOPSIS -C + use File::Spec; + + $x=File::Spec->catfile('a', 'b', 'c'); -C<$x=File::Spec-Ecatfile('a','b','c');> +which returns 'a/b/c' under Unix. Or: -which returns 'a/b/c' under Unix. + use File::Spec::Functions; + $x = catfile('a', 'b', 'c'); + =head1 DESCRIPTION This module is designed to support operations commonly performed on file @@ -78,28 +53,31 @@ File::Spec::VMS The module appropriate for the current OS is automatically loaded by -File::Spec. Since some modules (like VMS) make use of OS specific -facilities, it may not be possible to load all modules under all operating -systems. +File::Spec. Since some modules (like VMS) make use of facilities available +only under that OS, it may not be possible to load all modules under all +operating systems. Since File::Spec is object oriented, subroutines should not called directly, as in: File::Spec::catfile('a','b'); - + but rather as class methods: File::Spec->catfile('a','b'); -For a reference of available functions, please consult L, -which contains the entire set, and inherited by the modules for other -platforms. For further information, please see L, +For simple uses, L provides convenient functional +forms of these methods. + +For a list of available methods, please consult L, +which contains the entire set, and which is inherited by the modules for +other platforms. For further information, please see L, L, L, or L. =head1 SEE ALSO File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, File::Spec::Win32, -File::Spec::VMS, ExtUtils::MakeMaker +File::Spec::VMS, File::Spec::Functions, ExtUtils::MakeMaker =head1 AUTHORS @@ -109,8 +87,3 @@ support by Charles Bailey >. OS/2 support by Ilya Zakharevich >. Mac support by Paul Schinder >. - -=cut - - -1; diff -ruN perl5.005_03/lib/Pod/Html.pm AP522_source/lib/Pod/Html.pm --- perl5.005_03/lib/Pod/Html.pm Fri Oct 15 17:45:48 1999 +++ AP522_source/lib/Pod/Html.pm Mon Nov 01 15:11:37 1999 @@ -2,9 +2,10 @@ use Pod::Functions; use Getopt::Long; # package for handling command-line parameters +use File::Spec::Unix; require Exporter; use vars qw($VERSION); -$VERSION = 1.01; +$VERSION = 1.02; @ISA = Exporter; @EXPORT = qw(pod2html htmlify); use Cwd; @@ -44,6 +45,15 @@ Displays the usage message. +=item htmldir + + --htmldir=name + +Sets the directory in which the resulting HTML file is placed. This +is used to generate relative links to other files. Not passing this +causes all links to be absolute, since this is the value that tells +Pod::Html the root of the documentation tree. + =item htmlroot --htmlroot=name @@ -127,12 +137,24 @@ Specify the title of the resulting HTML file. +=item css + + --css=stylesheet + +Specify the URL of a cascading style sheet. + =item verbose --verbose Display progress messages. +=item quiet + + --quiet + +Don't display I warning messages. + =back =head1 EXAMPLE @@ -146,6 +168,10 @@ "--infile=foo.pod", "--outfile=/perl/nmanual/foo.html"); +=head1 ENVIRONMENT + +Uses $Config{pod2html} to setup default options. + =head1 AUTHOR Tom Christiansen, Etchrist@perl.comE. @@ -164,20 +190,29 @@ =cut -my $dircache = "pod2html-dircache"; -my $itemcache = "pod2html-itemcache"; +my $cache_ext = $^O eq 'VMS' ? ".tmp" : ".x~~"; +my $dircache = "pod2htmd$cache_ext"; +my $itemcache = "pod2htmi$cache_ext"; my @begin_stack = (); # begin/end stack my @libpods = (); # files to search for links from C<> directives my $htmlroot = "/"; # http-server base directory from which all # relative paths in $podpath stem. +my $htmldir = ""; # The directory to which the html pages + # will (eventually) be written. my $htmlfile = ""; # write to stdout by default +my $htmlfileurl = "" ; # The url that other files would use to + # refer to this file. This is only used + # to make relative urls that point to + # other files. my $podfile = ""; # read from stdin by default my @podpath = (); # list of directories containing library pods. my $podroot = "."; # filesystem base directory from which all # relative paths in $podpath stem. +my $css = ''; # Cascading style sheet my $recurse = 1; # recurse on subdirectories in $podpath. +my $quiet = 0; # not quiet by default my $verbose = 0; # not verbose by default my $doindex = 1; # non-zero if we should generate an index my $listlevel = 0; # current list depth @@ -196,6 +231,7 @@ my @items_seen = (); my $netscape = 0; # whether or not to use netscape directives. my $title; # title to give the pod(s) +my $header = 0; # produce block header/footer my $top = 1; # true if we are at the top of the doc. used # to prevent the first
directive. my $paragraph; # which paragraph we're processing (used @@ -208,8 +244,8 @@ my $Is83; # is dos with short filenames (8.3) sub init_globals { -$dircache = "pod2html-dircache"; -$itemcache = "pod2html-itemcache"; +$dircache = "pod2htmd$cache_ext"; +$itemcache = "pod2htmi$cache_ext"; @begin_stack = (); # begin/end stack @@ -221,7 +257,9 @@ @podpath = (); # list of directories containing library pods. $podroot = "."; # filesystem base directory from which all # relative paths in $podpath stem. +$css = ''; # Cascading style sheet $recurse = 1; # recurse on subdirectories in $podpath. +$quiet = 0; # not quiet by default $verbose = 0; # not verbose by default $doindex = 1; # non-zero if we should generate an index $listlevel = 0; # current list depth @@ -239,6 +277,7 @@ @items_seen = (); %items_named = (); $netscape = 0; # whether or not to use netscape directives. +$header = 0; # produce block header/footer $title = ''; # title to give the pod(s) $top = 1; # true if we are at the top of the doc. used # to prevent the first
directive. @@ -283,6 +322,19 @@ } $htmlfile = "-" unless $htmlfile; # stdout $htmlroot = "" if $htmlroot eq "/"; # so we don't get a // + $htmldir =~ s#/$## ; # so we don't get a // + if ( $htmlroot eq '' + && defined( $htmldir ) + && $htmldir ne '' + && substr( $htmlfile, 0, length( $htmldir ) ) eq $htmldir + ) + { + # Set the 'base' url for this file, so that we can use it + # as the location from which to calculate relative links + # to other files. If this is '', then absolute links will + # be used throughout. + $htmlfileurl= "$htmldir/" . substr( $htmlfile, length( $htmldir ) + 1); + } # read the pod a paragraph at a time warn "Scanning for sections in input file(s)\n" if $verbose; @@ -294,8 +346,7 @@ my $index = scan_headings(\%sections, @poddata); unless($index) { - warn "No pod in $podfile\n" if $verbose; - return; + warn "No headings in $podfile\n" if $verbose; } # open the output file @@ -327,20 +378,32 @@ if ($title) { $title =~ s/\s*\(.*\)//; } else { - warn "$0: no title for $podfile"; + warn "$0: no title for $podfile" unless $quiet; $podfile =~ /^(.*)(\.[^.\/]+)?$/; $title = ($podfile eq "-" ? 'No Title' : $1); warn "using $title" if $verbose; } + my $csslink = $css ? qq(\n) : ''; + $csslink =~ s,\\,/,g; + $csslink =~ s,(/.):,$1|,; + + my $block = $header ? < + +

 $title

 + + +END_OF_BLOCK + print HTML < -$title +$title$csslink - +$block END_OF_HEAD # load/reload/validate/cache %pages and %items @@ -358,7 +421,7 @@ print HTML $index; print HTML "-->\n" unless $doindex; print HTML "\n\n"; - print HTML "
\n" if $doindex; + print HTML "
\n" if $doindex and $index; # now convert this file warn "Converting input file\n" if $verbose; @@ -402,13 +465,14 @@ next if @begin_stack && $begin_stack[-1] ne 'html'; my $text = $_; process_text(\$text, 1); - print HTML "

\n$text"; + print HTML "

\n$text

\n"; } } # finish off any pending directives finish_list(); print HTML < @@ -460,15 +524,20 @@ --recurse - recurse on those subdirectories listed in podpath (default behavior). --title - title that will appear in resulting html file. + --header - produce block header/footer + --css - stylesheet URL --verbose - self-explanatory + --quiet - supress some benign warning messages END_OF_USAGE sub parse_command_line { - my ($opt_flush,$opt_help,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose); + my ($opt_flush,$opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose,$opt_css,$opt_header,$opt_quiet); + unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html}; my $result = GetOptions( 'flush' => \$opt_flush, 'help' => \$opt_help, + 'htmldir=s' => \$opt_htmldir, 'htmlroot=s' => \$opt_htmlroot, 'index!' => \$opt_index, 'infile=s' => \$opt_infile, @@ -480,7 +549,10 @@ 'norecurse' => \$opt_norecurse, 'recurse!' => \$opt_recurse, 'title=s' => \$opt_title, + 'header' => \$opt_header, + 'css=s' => \$opt_css, 'verbose' => \$opt_verbose, + 'quiet' => \$opt_quiet, ); usage("-", "invalid parameters") if not $result; @@ -489,6 +561,7 @@ $podfile = $opt_infile if defined $opt_infile; $htmlfile = $opt_outfile if defined $opt_outfile; + $htmldir = $opt_htmldir if defined $opt_outfile; @podpath = split(":", $opt_podpath) if defined $opt_podpath; @libpods = split(":", $opt_libpods) if defined $opt_libpods; @@ -503,7 +576,10 @@ $doindex = $opt_index if defined $opt_index; $recurse = $opt_recurse if defined $opt_recurse; $title = $opt_title if defined $opt_title; + $header = defined $opt_header ? 1 : 0; + $css = $opt_css if defined $opt_css; $verbose = defined $opt_verbose ? 1 : 0; + $quiet = defined $opt_quiet ? 1 : 0; $netscape = $opt_netscape if defined $opt_netscape; } @@ -542,7 +618,7 @@ sub cache_key { my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; return join('!', $dircache, $itemcache, $recurse, - @$podpath, $podroot, stat($dircache), stat($itemcache)); + @$podpath, $podroot, stat($dircache), stat($itemcache)); } # @@ -648,7 +724,9 @@ next unless defined $pages{$libpod} && $pages{$libpod}; # if there is a directory then use the .pod and .pm files within it. - if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) { + # NOTE: Only finds the first so-named directory in the tree. +# if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) { + if ($pages{$libpod} =~ /([^:]*(?" . "" . - html_escape(process_text(\$title, 0)) . ""; + html_escape(process_text(\$title, 0)) . ""; } } @@ -1098,8 +1176,32 @@ "$1$2"; } }xeg; - $rest =~ s/(:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g; +# $rest =~ s/(:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g; + $rest =~ s{ + (/>/g; $rest =~ s/"/"/g; @@ -1296,6 +1399,7 @@ $word = process_C($word, 1); } elsif ($word =~ m,^\w+://\w,) { # looks like a URL + # Don't relativize it: leave it as the author intended $word = qq($word); } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) { # looks like an e-mail address @@ -1338,8 +1442,7 @@ # sub pre_escape { my($str) = @_; - - $$str =~ s,&,&,g; + $$str =~ s/&(?!\w+;|#)/&/g; # XXX not bulletproof } # @@ -1347,6 +1450,7 @@ # sub dosify { my($str) = @_; + return lc($str) if $^O eq 'VMS'; # VMS just needs casing if ($Is83) { $str = lc $str; $str =~ s/(\.\w+)/substr ($1,0,4)/ge; @@ -1391,6 +1495,9 @@ $section = $page; $page = ""; } + + # remove trailing punctuation, like () + $section =~ s/\W*$// ; } $page83=dosify($page); @@ -1401,10 +1508,33 @@ } elsif ( $page =~ /::/ ) { $linktext = ($section ? "$section" : "$page"); $page =~ s,::,/,g; + # Search page cache for an entry keyed under the html page name, + # then look to see what directory that page might be in. NOTE: + # this will only find one page. A better solution might be to produce + # an intermediate page that is an index to all such pages. + my $page_name = $page ; + $page_name =~ s,^.*/,, ; + if ( defined( $pages{ $page_name } ) && + $pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/ + ) { + $page = $1 ; + } + else { + # NOTE: This branch assumes that all A::B pages are located in + # $htmlroot/A/B.html . This is often incorrect, since they are + # often in $htmlroot/lib/A/B.html or such like. Perhaps we could + # analyze the contents of %pages and figure out where any + # cousins of A::B are, then assume that. So, if A::B isn't found, + # but A::C is found in lib/A/C.pm, then A::B is assumed to be in + # lib/A/B.pm. This is also limited, but it's an improvement. + # Maybe a hints file so that the links point to the correct places + # non-theless? + # Also, maybe put a warn "$0: cannot resolve..." here. + } $link = "$htmlroot/$page.html"; $link .= "#" . htmlify(0,$section) if ($section); } elsif (!defined $pages{$page}) { - warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n"; + warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n" unless $quiet; $link = ""; $linktext = $page unless defined($linktext); } else { @@ -1413,7 +1543,8 @@ # if there is a directory by the name of the page, then assume that an # appropriate section will exist in the subdirectory - if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) { +# if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) { + if ($section ne "" && $pages{$page} =~ /([^:]*(?$linktext"; + # Here, we take advantage of the knowledge that $htmlfileurl ne '' + # implies $htmlroot eq ''. This means that the link in question + # needs a prefix of $htmldir if it begins with '/'. The test for + # the initial '/' is done to avoid '#'-only links, and to allow + # for other kinds of links, like file:, ftp:, etc. + my $url ; + if ( $htmlfileurl ne '' ) { + $link = "$htmldir$link" + if ( $link =~ m{^/} ) ; + + $url = relativize_url( $link, $htmlfileurl ) ; +# print( " b: [$link,$htmlfileurl,$url]\n" ) ; + } + else { + $url = $link ; + } + + $s1 = "$linktext"; } else { $s1 = "$linktext"; } @@ -1445,6 +1593,39 @@ } # +# relativize_url - convert an absolute URL to one relative to a base URL. +# Assumes both end in a filename. +# +sub relativize_url { + my ($dest,$source) = @_ ; + + my ($dest_volume,$dest_directory,$dest_file) = + File::Spec::Unix->splitpath( $dest ) ; + $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ; + + my ($source_volume,$source_directory,$source_file) = + File::Spec::Unix->splitpath( $source ) ; + $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ; + + my $rel_path = '' ; + if ( $dest ne '' ) { + $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ; + } + + if ( $rel_path ne '' && + substr( $rel_path, -1 ) ne '/' && + substr( $dest_file, 0, 1 ) ne '#' + ) { + $rel_path .= "/$dest_file" ; + } + else { + $rel_path .= "$dest_file" ; + } + + return $rel_path ; +} + +# # process_BFI - process any of the B<>, F<>, or I<> pod-escapes and # convert them to corresponding HTML directives. # @@ -1476,9 +1657,23 @@ # if there was a pod file that we found earlier with an appropriate # =item directive, then create a link to that page. if ($doref && defined $items{$s1}) { - $s1 = ($items{$s1} ? - "$str" : - "$str"); + if ( $items{$s1} ) { + my $link = "$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) ; + # Here, we take advantage of the knowledge that $htmlfileurl ne '' + # implies $htmlroot eq ''. + my $url ; + if ( $htmlfileurl ne '' ) { + $link = "$htmldir$link" ; + $url = relativize_url( $link, $htmlfileurl ) ; + } + else { + $url = $link ; + } + $s1 = "$str" ; + } + else { + $s1 = "$str" ; + } $s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,; confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/; } else { @@ -1533,6 +1728,18 @@ # sub process_X { return ''; +} + + +# +# Adapted from Nick Ing-Simmons' PodToHtml package. +sub relative_url { + my $source_file = shift ; + my $destination_file = shift; + + my $source = URI::file->new_abs($source_file); + my $uo = URI::file->new($destination_file,$source)->abs; + return $uo->rel->as_string; } diff -ruN perl5.005_03/objXSUB.h AP522_source/objXSUB.h --- perl5.005_03/objXSUB.h Fri Oct 15 17:45:43 1999 +++ AP522_source/objXSUB.h Mon Nov 01 15:11:38 1999 @@ -1395,6 +1395,8 @@ #define nextchar pPerl->nextchar #undef ninstr #define ninstr pPerl->Perl_ninstr +#undef no_bareword_allowed +#define no_bareword_allowed pPerl->Perl_no_bareword_allowed #undef no_fh_allowed #define no_fh_allowed pPerl->Perl_no_fh_allowed #undef no_op @@ -1905,6 +1907,7 @@ #define telldir PerlDir_tell #define putenv PerlEnv_putenv #define getenv PerlEnv_getenv +#define uname PerlEnv_uname #define stdin PerlIO_stdin() #define stdout PerlIO_stdout() #define stderr PerlIO_stderr() diff -ruN perl5.005_03/objpp.h AP522_source/objpp.h --- perl5.005_03/objpp.h Fri Oct 15 17:45:49 1999 +++ AP522_source/objpp.h Mon Nov 01 15:11:38 1999 @@ -861,6 +861,8 @@ #define ninstr CPerlObj::Perl_ninstr #undef not_a_number #define not_a_number CPerlObj::not_a_number +#undef no_bareword_allowed +#define no_bareword_allowed CPerlObj::Perl_no_bareword_allowed #undef no_fh_allowed #define no_fh_allowed CPerlObj::Perl_no_fh_allowed #undef no_op diff -ruN perl5.005_03/op.c AP522_source/op.c --- perl5.005_03/op.c Fri Oct 15 17:45:49 1999 +++ AP522_source/op.c Mon Nov 01 15:11:38 1999 @@ -43,6 +43,7 @@ static void bad_type _((I32 n, char *t, char *name, OP *kid)); static OP *modkids _((OP *o, I32 type)); static OP *no_fh_allowed _((OP *o)); +static void no_bareword_allowed _((OP *o)); static OP *scalarboolean _((OP *o)); static OP *too_few_arguments _((OP *o, char* name)); static OP *too_many_arguments _((OP *o, char* name)); @@ -91,6 +92,15 @@ (int)n, name, t, op_desc[kid->op_type])); } +STATIC void +no_bareword_allowed(OP *o) +{ + STRLEN n_a; + warn("Bareword \"%s\" not allowed while \"strict subs\" in use", + SvPV(cSVOPo->op_sv, n_a)); + ++PL_error_count; +} + void assertref(OP *o) { @@ -127,7 +137,7 @@ name[2] = toCTRL(name[1]); name[1] = '^'; } - croak("Can't use global %s in \"my\"",name); + yyerror(form("Can't use global %s in \"my\"",name)); } if (PL_dowarn && AvFILLp(PL_comppad_name) >= 0) { SV **svp = AvARRAY(PL_comppad_name); @@ -149,7 +159,8 @@ sv_setpv(sv, name); if (PL_in_my_stash) { if (*name != '$') - croak("Can't declare class for non-scalar %s in \"my\"",name); + yyerror(form("Can't declare class for non-scalar %s in \"my\"", + name)); SvOBJECT_on(sv); (void)SvUPGRADE(sv, SVt_PVMG); SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash); @@ -929,7 +940,9 @@ case OP_CONST: sv = cSVOPo->op_sv; - if (PL_dowarn) { + if (cSVOPo->op_private & OPpCONST_STRICT) + no_bareword_allowed(o); + else if (PL_dowarn) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; @@ -1722,13 +1735,23 @@ if (opargs[type] & OA_TARGET) o->op_targ = pad_alloc(type, SVs_PADTMP); - if ((opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) + /* integerize op, unless it happens to be C<-foo>. + * XXX should pp_i_negate() do magic string negation instead? */ + if ((opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) + && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST + && (cUNOPo->op_first->op_private & OPpCONST_BARE))) + { o->op_ppaddr = ppaddr[type = ++(o->op_type)]; + } if (!(opargs[type] & OA_FOLDCONST)) goto nope; switch (type) { + case OP_NEGATE: + /* XXX might want a ck_negate() for this */ + cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; + break; case OP_SPRINTF: case OP_UCFIRST: case OP_LCFIRST: @@ -1748,11 +1771,13 @@ goto nope; /* Don't try to run w/ errors */ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { - if (curop->op_type != OP_CONST && - curop->op_type != OP_LIST && - curop->op_type != OP_SCALAR && - curop->op_type != OP_NULL && - curop->op_type != OP_PUSHMARK) { + if ((curop->op_type != OP_CONST || + (curop->op_private & OPpCONST_BARE)) && + curop->op_type != OP_LIST && + curop->op_type != OP_SCALAR && + curop->op_type != OP_NULL && + curop->op_type != OP_PUSHMARK) + { goto nope; } } @@ -4936,6 +4961,15 @@ } } } + else if (cvop->op_type == OP_METHOD) { + if (o2->op_type == OP_CONST) + o2->op_private &= ~OPpCONST_STRICT; + else if (o2->op_type == OP_LIST) { + OP *o = ((UNOP*)o2)->op_first->op_sibling; + if (o && o->op_type == OP_CONST) + o->op_private &= ~OPpCONST_STRICT; + } + } o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; @@ -4970,6 +5004,35 @@ arg++; if (o2->op_type == OP_RV2GV) goto wrapref; /* autoconvert GLOB -> GLOBref */ + else if (o2->op_type == OP_CONST) + o2->op_private &= ~OPpCONST_STRICT; + else if (o2->op_type == OP_ENTERSUB) { + /* accidental subroutine, revert to bareword */ + OP *gvop = ((UNOP*)o2)->op_first; + if (gvop && gvop->op_type == OP_NULL) { + gvop = ((UNOP*)gvop)->op_first; + if (gvop) { + for (; gvop->op_sibling; gvop = gvop->op_sibling) + ; + if (gvop && + (gvop->op_private & OPpENTERSUB_NOPAREN) && + (gvop = ((UNOP*)gvop)->op_first) && + gvop->op_type == OP_GV) + { + GV *gv = (GV*)((SVOP*)gvop)->op_sv; + OP *sibling = o2->op_sibling; + SV *n = newSVpvn("",0); + op_free(o2); + gv_fullname3(n, gv, ""); + if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6)) + sv_chop(n, SvPVX(n)+6); + o2 = newSVOP(OP_CONST, 0, n); + prev->op_sibling = o2; + o2->op_sibling = sibling; + } + } + } + } scalar(o2); break; case '\\': @@ -5048,9 +5111,12 @@ if (kid->op_type == OP_NULL) kid = (SVOP*)kid->op_sibling; - if (kid && - kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) + if (kid && kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE)) + { o->op_flags |= OPf_SPECIAL; + kid->op_private &= ~OPpCONST_STRICT; + } } return ck_fun(o); } @@ -5081,8 +5147,11 @@ o->op_seq = PL_op_seqmax++; break; - case OP_CONCAT: case OP_CONST: + if (cSVOPo->op_private & OPpCONST_STRICT) + no_bareword_allowed(o); + /* FALL THROUGH */ + case OP_CONCAT: case OP_JOIN: case OP_UC: case OP_UCFIRST: diff -ruN perl5.005_03/op.h AP522_source/op.h --- perl5.005_03/op.h Fri Oct 15 17:45:50 1999 +++ AP522_source/op.h Mon Nov 01 15:11:38 1999 @@ -118,12 +118,15 @@ #define OPpDEREF_SV (32|64) /* Want ref to SV. */ /* OP_ENTERSUB only */ #define OPpENTERSUB_DB 16 /* Debug subroutine. */ + /* OP_RV2CV only */ #define OPpENTERSUB_AMPER 8 /* Used & form to call. */ +#define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */ /* OP_?ELEM only */ #define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */ /* for OP_RV2?V, lower bits carry hints */ /* Private for OP_CONST */ +#define OPpCONST_STRICT 8 /* bearword subject to strict 'subs' */ #define OPpCONST_ENTERED 16 /* Has been entered as symbol. */ #define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */ #define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */ diff -ruN perl5.005_03/patchlevel.h AP522_source/patchlevel.h --- perl5.005_03/patchlevel.h Fri Oct 15 17:45:51 1999 +++ AP522_source/patchlevel.h Mon Nov 01 15:11:38 1999 @@ -1,4 +1,7 @@ #ifndef __PATCHLEVEL_H_INCLUDED__ + +#include "BuildInfo.h" + #define PATCHLEVEL 5 #undef SUBVERSION /* OS/390 has a SUBVERSION in a system header */ #define SUBVERSION 3 @@ -40,6 +43,7 @@ */ static char *local_patches[] = { NULL + ,ACTIVEPERL_LOCAL_PATCHES_ENTRY ,NULL }; diff -ruN perl5.005_03/perl.h AP522_source/perl.h --- perl5.005_03/perl.h Fri Oct 15 17:45:51 1999 +++ AP522_source/perl.h Mon Nov 01 15:11:38 1999 @@ -1703,15 +1703,20 @@ #ifdef DOINIT EXT char *sig_name[] = { SIG_NAME }; EXT int sig_num[] = { SIG_NUM }; +# ifndef PERL_OBJECT EXT SV * psig_ptr[sizeof(sig_num)/sizeof(*sig_num)]; EXT SV * psig_name[sizeof(sig_num)/sizeof(*sig_num)]; +# endif #else EXT char *sig_name[]; EXT int sig_num[]; +# ifndef PERL_OBJECT EXT SV * psig_ptr[]; EXT SV * psig_name[]; +# endif #endif + /* fast case folding tables */ #ifdef DOINIT @@ -2039,6 +2044,10 @@ #undef INIT #define INIT(x) +const int perl_object_sig_num[] = { SIG_NUM }; +const int PSIG_SIZE = (sizeof(perl_object_sig_num)/sizeof(*perl_object_sig_num)); + + class CPerlObj { public: CPerlObj(IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*); @@ -2186,6 +2195,13 @@ PERLVAR(filter_debug, int) PERLVAR(super_bufptr, char*) /* PL_bufptr that was */ PERLVAR(super_bufend, char*) /* PL_bufend that was */ + +#undef psig_ptr +#undef psig_name +#define psig_ptr PL_psig_ptr +#define psig_name PL_psig_name +PERLVAR(psig_ptr[PSIG_SIZE], SV*); +PERLVAR(psig_name[PSIG_SIZE], SV*); /* * The following is a buffer where new variables must diff -ruN perl5.005_03/pod/Win32.pod AP522_source/pod/Win32.pod --- perl5.005_03/pod/Win32.pod Wed Dec 31 16:00:00 1969 +++ AP522_source/pod/Win32.pod Mon Nov 01 15:11:39 1999 @@ -0,0 +1,284 @@ +=head1 NAME + +Win32 - Interfaces to some Win32 API Functions + +=head1 DESCRIPTION + +Perl on Win32 contains several functions to access Win32 APIs. Some +are included in Perl itself (on Win32) and some are only available +after explicitly requesting the Win32 module with: + + use Win32; + +The builtin functions are marked as [CORE] and the other ones +as [EXT] in the following alphabetical listing. The C module +is not part of the Perl source distribution; it is distributed in +the libwin32 bundle of Win32::* modules on CPAN. The module is +already preinstalled in binary distributions like ActivePerl. + +=head2 Alphabetical Listing of Win32 Functions + +=over + +=item Win32::AbortSystemShutdown(MACHINE) + +[EXT] Aborts a system shutdown (started by the +InitiateSystemShutdown function) on the specified MACHINE. + +=item Win32::BuildNumber() + +[CORE] Returns the ActivePerl build number. This function is +only available in the ActivePerl binary distribution. + +=item Win32::CopyFile(FROM, TO, OVERWRITE) + +[CORE] The Win32::CopyFile() function copies an existing file to a new +file. All file information like creation time and file attributes will +be copied to the new file. However it will B copy the security +information. If the destination file already exists it will only be +overwritten when the OVERWRITE parameter is true. But even this will +not overwrite a read-only file; you have to unlink() it first +yourself. + +=item Win32::DomainName() + +[CORE] Returns the name of the Microsoft Network domain that the +owner of the current perl process is logged into. + +=item Win32::ExpandEnvironmentStrings(STRING) + +[EXT] Takes STRING and replaces all referenced environment variable +names with their defined values. References to environment variables +take the form C<%VariableName%>. Case is ignored when looking up the +VariableName in the environment. If the variable is not found then the +original C<%VariableName%> text is retained. Has the same effect +as the following: + + $string =~ s/%([^%]*)%/$ENV{$1} || "%$1%"/eg + +=item Win32::FormatMessage(ERRORCODE) + +[CORE] Converts the supplied Win32 error number (e.g. returned by +Win32::GetLastError()) to a descriptive string. Analogous to the +perror() standard-C library function. Note that C<$^E> used +in a string context has much the same effect. + + C:\> perl -e "$^E = 26; print $^E;" + The specified disk or diskette cannot be accessed + +=item Win32::FsType() + +[CORE] Returns the name of the filesystem of the currently active +drive (like 'FAT' or 'NTFS'). In list context it returns three values: +(FSTYPE, FLAGS, MAXCOMPLEN). FSTYPE is the filesystem type as +before. FLAGS is a combination of values of the following table: + + 0x00000001 supports case-sensitive filenames + 0x00000002 preserves the case of filenames + 0x00000004 supports Unicode in filenames + 0x00000008 preserves and enforces ACLs + 0x00000010 supports file-based compression + 0x00000020 supports disk quotas + 0x00000040 supports sparse files + 0x00000080 supports reparse points + 0x00000100 supports remote storage + 0x00008000 is a compressed volume (e.g. DoubleSpace) + 0x00010000 supports object identifiers + 0x00020000 supports the Encrypted File System (EFS) + +MAXCOMPLEN is the maximum length of a filename component (the part +between two backslashes) on this file system. + +=item Win32::FreeLibrary(HANDLE) + +[EXT] Unloads a previously loaded dynamic-link library. The HANDLE is +no longer valid after this call. See L for information on +dynamically loading a library. + +=item Win32::GetArchName() + +[EXT] Use of this function is deprecated. It is equivalent with +$ENV{PROCESSOR_ARCHITECTURE}. This might not work on Win9X. + +=item Win32::GetChipName() + +[EXT] Returns the processor type: 386, 486 or 586 for Intel processors, +21064 for the Alpha chip. + +=item Win32::GetCwd() + +[CORE] Returns the current active drive and directory. This function +does not return a UNC path, since the functionality required for such +a feature is not available under Windows 95. + +=item Win32::GetFullPathName(FILENAME) + +[CORE] GetFullPathName combines the FILENAME with the current drive +and directory name and returns a fully qualified (aka, absolute) +path name. In list context it returns two elements: (PATH, FILE) where +PATH is the complete pathname component (including trailing backslash) +and FILE is just the filename part. Note that no attempt is made to +convert 8.3 components in the supplied FILENAME to longnames or +vice-versa. Compare with Win32::GetShortPathName and +Win32::GetLongPathName. + +This function has been added for Perl 5.006. + +=item Win32::GetLastError() + +[CORE] Returns the last error value generated by a call to a Win32 API +function. Note that C<$^E> used in a numeric context amounts to the +same value. + +=item Win32::GetLongPathName(PATHNAME) + +[CORE] Returns a representaion of PATHNAME comprised of longname +compnents (if any). The result may not necessarily be longer +than PATHNAME. No attempt is made to convert PATHNAME to the +absolute path. Compare with Win32::GetShortPathName and +Win32::GetFullPathName. + +This function has been added for Perl 5.006. + +=item Win32::GetNextAvailDrive() + +[CORE] Returns a string in the form of ":" where is the first +available drive letter. + +=item Win32::GetOSVersion() + +[CORE] Returns the array (STRING, MAJOR, MINOR, BUILD, ID), where +the elements are, respectively: An arbitrary descriptive string, the +major version number of the operating system, the minor version +number, the build number, and a digit indicating the actual operating +system. For ID, the values are 0 for Win32s, 1 for Windows 9X and 2 +for Windows NT. In scalar context it returns just the ID. + +=item Win32::GetShortPathName(PATHNAME) + +[CORE] Returns a representation of PATHNAME comprised only of +short (8.3) path components. The result may not necessarily be +shorter than PATHNAME. Compare with Win32::GetFullPathName and +Win32::GetLongPathName. + +=item Win32::GetProcAddress(INSTANCE, PROCNAME) + +[EXT] Returns the address of a function inside a loaded library. The +information about what you can do with this address has been lost in +the mist of time. Use the Win32::API module instead of this deprecated +function. + +=item Win32::GetTickCount() + +[CORE] Returns the number of milliseconds elapsed since the last +system boot. Resolution is limited to system timer ticks (about 10ms +on WinNT and 55ms on Win9X). + +=item Win32::InitiateSystemShutdown(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) + +[EXT] Shutsdown the specified MACHINE, notifying users with the +supplied MESSAGE, within the specified TIMEOUT interval. Forces +closing of all documents without prompting the user if FORCECLOSE is +true, and reboots the machine if REBOOT is true. This function works +only on WinNT. + +=item Win32::IsWinNT() + +[CORE] Returns non zero if the Win32 subsystem is Windows NT. + +=item Win32::IsWin95() + +[CORE] Returns non zero if the Win32 subsystem is Windows 95. + +=item Win32::LoadLibrary(LIBNAME) + +[EXT] Loads a dynamic link library into memory and returns its module +handle. This handle can be used with Win32::GetProcAddress and +Win32::FreeLibrary. This function is deprecated. Use the Win32::API +module instead. + +=item Win32::LoginName() + +[CORE] Returns the username of the owner of the current perl process. + +=item Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE) + +[EXT] Looks up ACCOUNT on SYSTEM and returns the domain name the SID and +the SID type. + +=item Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE) + +[EXT] Looks up SID on SYSTEM and returns the account name, domain name, +and the SID type. + +=item Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]]) + +[EXT] Create a dialogbox containing MESSAGE. FLAGS specifies the +required icon and buttons according to the following table: + + 0 = OK + 1 = OK and Cancel + 2 = Abort, Retry, and Ignore + 3 = Yes, No and Cancel + 4 = Yes and No + 5 = Retry and Cancel + + MB_ICONSTOP "X" in a red circle + MB_ICONQUESTION question mark in a bubble + MB_ICONEXCLAMATION exclamation mark in a yellow triangle + MB_ICONINFORMATION "i" in a bubble + +TITLE specifies an optional window title. The default is "Perl". + +The function returns the menu id of the selected push button: + + 0 Error + + 1 OK + 2 Cancel + 3 Abort + 4 Retry + 5 Ignore + 6 Yes + 7 No + +=item Win32::NodeName() + +[CORE] Returns the Microsoft Network node-name of the current machine. + +=item Win32::RegisterServer(LIBRARYNAME) + +[EXT] Loads the DLL LIBRARYNAME and calls the function DllRegisterServer. + +=item Win32::SetCwd(NEWDIRECTORY) + +[CORE] Sets the current active drive and directory. This function does not +work with UNC paths, since the functionality required to required for +such a feature is not available under Windows 95. + +=item Win32::SetLastError(ERROR) + +[CORE] Sets the value of the last error encountered to ERROR. This is +that value that will be returned by the Win32::GetLastError() +function. This functions has been added for Perl 5.006. + +=item Win32::Sleep(TIME) + +[CORE] Pauses for TIME milliseconds. The timeslices are made available +to other processes and threads. + +=item Win32::Spawn(COMMAND, ARGS, PID) + +[CORE] Spawns a new process using the supplied COMMAND, passing in +arguments in the string ARGS. The pid of the new process is stored in +PID. This function is deprecated. Please use the Win32::Process module +instead. + +=item Win32::UnregisterServer(LIBRARYNAME) + +[EXT] Loads the DLL LIBRARYNAME and calls the function +DllUnregisterServer. + +=back + +=cut diff -ruN perl5.005_03/pp.c AP522_source/pp.c --- perl5.005_03/pp.c Fri Oct 15 17:45:54 1999 +++ AP522_source/pp.c Mon Nov 01 15:11:40 1999 @@ -474,6 +474,8 @@ vivify_defelem(sv); if (!(sv = LvTARG(sv))) sv = &PL_sv_undef; + else + (void)SvREFCNT_inc(sv); } else if (SvPADTMP(sv)) sv = newSVsv(sv); @@ -4365,6 +4367,7 @@ else { if (!AvREAL(ary)) { AvREAL_on(ary); + AvREIFY_off(ary); for (i = AvFILLp(ary); i >= 0; i--) AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ } diff -ruN perl5.005_03/pp_ctl.c AP522_source/pp_ctl.c --- perl5.005_03/pp_ctl.c Fri Oct 15 17:45:54 1999 +++ AP522_source/pp_ctl.c Mon Nov 01 15:11:40 1999 @@ -2816,6 +2816,7 @@ MEXTEND(mark,0); *MARK = &PL_sv_undef; } + SP = MARK; } else { /* in case LEAVE wipes old return values */ diff -ruN perl5.005_03/pp_hot.c AP522_source/pp_hot.c --- perl5.005_03/pp_hot.c Fri Oct 15 17:45:54 1999 +++ AP522_source/pp_hot.c Mon Nov 01 15:11:40 1999 @@ -2352,6 +2352,7 @@ if (AvREAL(av)) { av_clear(av); AvREAL_off(av); + AvREIFY_on(av); } #ifndef USE_THREADS cx->blk_sub.savearray = GvAV(PL_defgv); diff -ruN perl5.005_03/proto.h AP522_source/proto.h --- perl5.005_03/proto.h Fri Oct 15 17:45:54 1999 +++ AP522_source/proto.h Mon Nov 01 15:11:40 1999 @@ -753,6 +753,7 @@ I32 list_assignment _((OP *o)); void bad_type _((I32 n, char *t, char *name, OP *kid)); OP *modkids _((OP *o, I32 type)); +void no_bareword_allowed _((OP *o)); OP *no_fh_allowed _((OP *o)); OP *scalarboolean _((OP *o)); OP *too_few_arguments _((OP *o, char* name)); diff -ruN perl5.005_03/t/comp/proto.t AP522_source/t/comp/proto.t --- perl5.005_03/t/comp/proto.t Fri Oct 15 17:45:55 1999 +++ AP522_source/t/comp/proto.t Mon Nov 01 15:11:41 1999 @@ -16,7 +16,7 @@ use strict; -print "1..87\n"; +print "1..100\n"; my $i = 1; @@ -417,9 +417,42 @@ # test if the (*) prototype allows barewords, constants, scalar expressions, # globs and globrefs (just as CORE::open() does), all under stricture sub star (*&) { &{$_[1]} } +sub star2 (**&) { &{$_[2]} } +sub BAR { "quux" } +sub Bar::BAZ { "quuz" } my $star = 'FOO'; star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star(FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star("FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star($star, sub { print "ok $i\n" if $_[0] eq 'FOO' }); $i++; star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; +star(*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++; star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; +star(\*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }); $i++; +star2 FOO, BAR, sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++; +star2(Bar::BAZ, FOO, sub { print "ok $i\n" + if $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO' }); $i++; +star2 BAR(), FOO, sub { print "ok $i\n" + if $_[0] eq 'quux' and $_[1] eq 'FOO' }; $i++; +star2(FOO, BAR(), sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'quux' }); $i++; +star2 "FOO", "BAR", sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'BAR' }; $i++; +star2("FOO", "BAR", sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'BAR' }); $i++; +star2 $star, $star, sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'FOO' }; $i++; +star2($star, $star, sub { print "ok $i\n" + if $_[0] eq 'FOO' and $_[1] eq 'FOO' }); $i++; +star2 *FOO, *BAR, sub { print "ok $i\n" + if $_[0] eq \*FOO and $_[0] eq \*BAR }; $i++; +star2(*FOO, *BAR, sub { print "ok $i\n" + if $_[0] eq \*FOO and $_[0] eq \*BAR }); $i++; +star2 \*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n" + if $_[0] eq \*{'FOO'} and $_[0] eq \*{'BAR'} }; $i++; +star2(\*FOO, \*BAR, sub { no strict 'refs'; print "ok $i\n" + if $_[0] eq \*{'FOO'} and $_[0] eq \*{'BAR'} }); $i++; + diff -ruN perl5.005_03/t/io/fs.t AP522_source/t/io/fs.t --- perl5.005_03/t/io/fs.t Fri Oct 15 17:45:55 1999 +++ AP522_source/t/io/fs.t Mon Nov 01 15:11:41 1999 @@ -142,8 +142,11 @@ if (-z "Iofs.tmp") {print "ok 24\n"} else {print "not ok 24\n"} open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp"; { select FH; $| = 1; select STDOUT } - print FH "helloworld\n"; - truncate FH, 5; + { + use strict; + print FH "helloworld\n"; + truncate FH, 5; + } if ($^O eq 'dos') { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } diff -ruN perl5.005_03/t/lib/fatal.t AP522_source/t/lib/fatal.t --- perl5.005_03/t/lib/fatal.t Fri Oct 15 17:45:55 1999 +++ AP522_source/t/lib/fatal.t Mon Nov 01 15:11:42 1999 @@ -3,11 +3,12 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; - print "1..9\n"; + print "1..13\n"; } +use vars '*FOO'; use strict; -use Fatal qw(open); +use Fatal qw(open close); my $i = 1; eval { open FOO, ') =~ m|^#!./perl|; + print "not " if $@ or scalar() !~ m|^#!./perl|; + print "ok $i\n"; ++$i; + eval qq{ close FOO }; print "not " if $@; print "ok $i\n"; ++$i; - close FOO; } diff -ruN perl5.005_03/t/op/eval.t AP522_source/t/op/eval.t --- perl5.005_03/t/op/eval.t Fri Oct 15 17:45:55 1999 +++ AP522_source/t/op/eval.t Mon Nov 01 15:11:43 1999 @@ -1,6 +1,6 @@ #!./perl -print "1..36\n"; +print "1..37\n"; eval 'print "ok 1\n";'; @@ -171,3 +171,9 @@ } $x++; +# does scalar eval"" pop stack correctly? +{ + my $c = eval "(1,2)x10"; + print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n"; + $x++; +} diff -ruN perl5.005_03/t/op/magic.t AP522_source/t/op/magic.t --- perl5.005_03/t/op/magic.t Fri Oct 15 17:45:55 1999 +++ AP522_source/t/op/magic.t Mon Nov 01 15:11:43 1999 @@ -120,8 +120,9 @@ $script = "$wd/show-shebang"; if ($Is_MSWin32) { chomp($wd = `cd`); - $perl = "$wd\\perl.exe"; - $script = "$wd\\show-shebang.bat"; + $wd =~ s|\\|/|g; + $perl = "$wd/perl.exe"; + $script = "$wd/show-shebang.bat"; $headmaybe = <Bar(...) etc work under strictures +use strict; +package Foo; sub Bar { print "@_\n" } +Foo->Bar('a',1); +Bar Foo ('b',2); +Foo->Bar(qw/c 3/); +Bar Foo (qw/d 4/); +Foo::->Bar('A',1); +Bar Foo:: ('B',2); +Foo::->Bar(qw/C 3/); +Bar Foo:: (qw/D 4/); +EXPECT +Foo a 1 +Foo b 2 +Foo c 3 +Foo d 4 +Foo A 1 +Foo B 2 +Foo C 3 +Foo D 4 diff -ruN perl5.005_03/toke.c AP522_source/toke.c --- perl5.005_03/toke.c Fri Oct 15 17:45:57 1999 +++ AP522_source/toke.c Mon Nov 01 15:11:45 1999 @@ -1498,7 +1498,7 @@ */ if (PL_in_my) { if (strchr(PL_tokenbuf,':')) - croak(no_myglob,PL_tokenbuf); + yyerror(form(no_myglob,PL_tokenbuf)); yylval.opval = newOP(OP_PADANY, 0); yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); @@ -1942,8 +1942,24 @@ * Look for options. */ d = instr(s,"perl -"); - if (!d) + if (!d) { d = instr(s,"perl"); +#if defined(DOSISH) + /* avoid getting into infinite loops when shebang + * line contains "Perl" rather than "perl" */ + if (!d) { + for (d = ipathend-4; d >= ipath; --d) { + if ((*d == 'p' || *d == 'P') + && !ibcmp(d, "perl", 4)) + { + break; + } + } + if (d < ipath) + d = Nullch; + } +#endif + } #ifdef ALTERNATE_SHEBANG /* * If the ALTERNATE_SHEBANG on this system starts with a @@ -2997,11 +3013,9 @@ PL_oldoldbufptr < PL_bufptr && (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) && /* NO SKIPSPACE BEFORE HERE! */ - (PL_expect == XREF - || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF - || (PL_last_lop_op == OP_ENTERSUB - && PL_last_proto - && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) ) + (PL_expect == XREF || + ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF)) + { bool immediate_paren = *s == '('; @@ -3017,8 +3031,10 @@ /* (But it's an indir obj regardless for sort.) */ if ((PL_last_lop_op == OP_SORT || - (!immediate_paren && (!gv || !GvCVu(gv))) ) && - (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){ + (!immediate_paren && (!gv || !GvCVu(gv)))) && + (PL_last_lop_op != OP_MAPSTART && + PL_last_lop_op != OP_GREPSTART)) + { PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR; goto bareword; } @@ -3031,11 +3047,8 @@ if (*s == '(') { CLINE; if (gv && GvCVu(gv)) { - CV *cv; - if ((cv = GvCV(gv)) && SvPOK(cv)) - PL_last_proto = SvPV((SV*)cv, n_a); for (d = s + 1; *d == ' ' || *d == '\t'; d++) ; - if (*d == ')' && (sv = cv_const_sv(cv))) { + if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { s = d + 1; goto its_constant; } @@ -3044,7 +3057,6 @@ PL_expect = XOPERATOR; force_next(WORD); yylval.ival = 0; - PL_last_lop_op = OP_ENTERSUB; TOKEN('&'); } @@ -3068,8 +3080,6 @@ if (lastchar == '-') warn("Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); - PL_last_lop = PL_oldbufptr; - PL_last_lop_op = OP_ENTERSUB; /* Check for a constant sub */ cv = GvCV(gv); if ((sv = cv_const_sv(cv))) { @@ -3083,52 +3093,40 @@ /* Resolve to GV now. */ op_free(yylval.opval); yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + yylval.opval->op_private |= OPpENTERSUB_NOPAREN; + PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; /* Is there a prototype? */ if (SvPOK(cv)) { STRLEN len; - PL_last_proto = SvPV((SV*)cv, len); + char *proto = SvPV((SV*)cv, len); if (!len) TERM(FUNC0SUB); - if (strEQ(PL_last_proto, "$")) + if (strEQ(proto, "$")) OPERATOR(UNIOPSUB); - if (*PL_last_proto == '&' && *s == '{') { + if (*proto == '&' && *s == '{') { sv_setpv(PL_subname,"__ANON__"); PREBLOCK(LSTOPSUB); } - } else - PL_last_proto = NULL; + } PL_nextval[PL_nexttoke].opval = yylval.opval; PL_expect = XTERM; force_next(WORD); TOKEN(NOAMP); } - if (PL_hints & HINT_STRICT_SUBS && - lastchar != '-' && - strnNE(s,"->",2) && - PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */ - PL_last_lop_op != OP_ACCEPT && - PL_last_lop_op != OP_PIPE_OP && - PL_last_lop_op != OP_SOCKPAIR && - !(PL_last_lop_op == OP_ENTERSUB - && PL_last_proto - && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) - { - warn( - "Bareword \"%s\" not allowed while \"strict subs\" in use", - PL_tokenbuf); - ++PL_error_count; - } - /* Call it a bare word */ - bareword: - if (PL_dowarn) { - if (lastchar != '-') { - for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; - if (!*d) - warn(warn_reserved, PL_tokenbuf); + if (PL_hints & HINT_STRICT_SUBS) + yylval.opval->op_private |= OPpCONST_STRICT; + else { + bareword: + if (PL_dowarn) { + if (lastchar != '-') { + for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; + if (!*d) + warn(warn_reserved, PL_tokenbuf); + } } } diff -ruN perl5.005_03/utils/perldoc.PL AP522_source/utils/perldoc.PL --- perl5.005_03/utils/perldoc.PL Fri Oct 15 17:45:57 1999 +++ AP522_source/utils/perldoc.PL Mon Nov 01 15:11:45 1999 @@ -47,7 +47,7 @@ # man replacement, written in perl. This perldoc is strictly for reading # the perl manuals, though it too is written in perl. -if(@ARGV<1) { +if (@ARGV<1) { my $me = $0; # Editing $0 is unportable $me =~ s,.*/,,; die < 1) { +if ((my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { usage("only one of -t, -u, -m or -l") -} elsif ($Is_MSWin32 || $Is_Dos) { +} +elsif ($Is_MSWin32 + || $Is_Dos + || !(exists $ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i)) +{ $opt_t = 1 unless $opts } @@ -149,11 +153,13 @@ my @pages; if ($opt_f) { - @pages = ("perlfunc"); -} elsif ($opt_q) { - @pages = ("perlfaq1" .. "perlfaq9"); -} else { - @pages = @ARGV; + @pages = ("perlfunc"); +} +elsif ($opt_q) { + @pages = ("perlfaq1" .. "perlfaq9"); +} +else { + @pages = @ARGV; } # Does this look like a module or extension directory? @@ -164,15 +170,13 @@ require ExtUtils::testlib; } - - sub containspod { my($file, $readit) = @_; return 1 if !$readit && $file =~ /\.pod$/i; local($_); open(TEST,"<$file"); - while() { - if(/^=head/) { + while () { + if (/^=head/) { close(TEST); return 1; } @@ -186,7 +190,7 @@ my $path = join('/',$dir,$file); return $path if -f $path and -r _; if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { - # on a case-forgiving file system or if case is important + # on a case-forgiving file system or if case is important # that is it all we can do warn "Ignored $path: unreadable\n" if -f _; return ''; @@ -198,7 +202,7 @@ foreach $p (split(/\//, $file)){ my $try = "@p/$p"; stat $try; - if (-d _){ + if (-d _) { push @p, $p; if ( $p eq $global_target) { my $tmp_path = join ('/', @p); @@ -209,11 +213,14 @@ push (@global_found, $tmp_path) unless $path_f; print STDERR "Found as @p but directory\n" if $opt_v; } - } elsif (-f _ && -r _) { + } + elsif (-f _ && -r _) { return $try; - } elsif (-f _) { + } + elsif (-f _) { warn "Ignored $try: unreadable\n"; - } else { + } + else { my $found=0; my $lcp = lc $p; opendir DIR, "@p"; @@ -232,13 +239,14 @@ } return ""; } - + sub check_file { my($dir,$file) = @_; if ($opt_m) { return minus_f_nocase($dir,$file); - } else { + } + else { my $path = minus_f_nocase($dir,$file); return $path if length $path and containspod($path); } @@ -264,7 +272,7 @@ or ( $ret = check_file $dir,$s) or ( $Is_VMS and $ret = check_file $dir,"$s.com") - or ( $^O eq 'os2' and + or ( $^O eq 'os2' and $ret = check_file $dir,"$s.cmd") or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and $ret = check_file $dir,"$s.bat") @@ -273,7 +281,7 @@ ) { return $ret; } - + if ($recurse) { opendir(D,$dir); my @newdirs = map "$dir/$_", grep { @@ -291,73 +299,151 @@ return (); } +sub filter_nroff { + my @data = split /\n{2,}/, shift; + shift @data while @data and $data[0] !~ /\S/; # Go to header + shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header + pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like + # 28/Jan/99 perl 5.005, patch 53 1 + join "\n\n", @data; +} + +sub printout { + my ($file, $tmp, $filter) = @_; + my $err; + + if ($opt_t) { + open(TMP,">>$tmp") + or warn("Can't open $tmp: $!"), return; + Pod::Text::pod2text($file,*TMP); + close TMP; + } + elsif (not $opt_u) { + my $cmd = "pod2man --lax $file | nroff -man"; + $cmd .= " | col -x" if $^O =~ /hpux/; + my $rslt = `$cmd`; + $rslt = filter_nroff($rslt) if $filter; + unless (($err = $?)) { + open(TMP,">>$tmp") or warn("Can't open $tmp: $!"), return; + print TMP $rslt; + close TMP; + } + } + if ($opt_u or $err or -z $tmp) { + open(OUT,">>$tmp") or warn("Can't open $tmp: $!"), return; + open(IN,"<$file") or warn("Can't open $file: $!"), return; + my $cut = 1; + while () { + $cut = $1 eq 'cut' if /^=(\w+)/; + next if $cut; + print OUT; + } + close IN; + close OUT; + } +} + +sub page { + my ($tmp, $no_tty, @pagers) = @_; + if ($no_tty) { + open(TMP,"<$tmp") or warn("Can't open $tmp: $!"), return; + print while ; + close TMP; + } + else { + foreach my $pager (@pagers) { + system("$pager $tmp") or last; + } + } +} + +sub cleanup { + my @files = @_; + for (@files) { + 1 while unlink($_); #Possibly pointless VMSism + } +} + +sub safe_exit { + my ($val, @files) = @_; + cleanup(@files); + exit $val; +} + +sub safe_die { + my ($msg, @files) = @_; + cleanup(@files); + die $msg; +} + my @found; foreach (@pages) { - if ($podidx && open(PODIDX, $podidx)) { - my $searchfor = $_; - local($_); - $searchfor =~ s,::,/,g; - print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; - while () { - chomp; - push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; - } - close(PODIDX); - next; - } - print STDERR "Searching for $_\n" if $opt_v; - # We must look both in @INC for library modules and in PATH - # for executables, like h2xs or perldoc itself. - my @searchdirs = @INC; - if ($opt_F) { - next unless -r; - push @found, $_ if $opt_m or containspod($_); - next; - } - unless ($opt_m) { - if ($Is_VMS) { - my($i,$trn); - for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) { - push(@searchdirs,$trn); - } - push(@searchdirs,'perl_root:[lib.pod]') # installed pods - } else { - push(@searchdirs, grep(-d, split($Config{path_sep}, - $ENV{'PATH'}))); + if ($podidx && open(PODIDX, $podidx)) { + my $searchfor = $_; + local($_); + $searchfor =~ s,::,/,g; + print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; + while () { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; + } + close(PODIDX); + next; + } + print STDERR "Searching for $_\n" if $opt_v; + # We must look both in @INC for library modules and in PATH + # for executables, like h2xs or perldoc itself. + my @searchdirs = @INC; + if ($opt_F) { + next unless -r; + push @found, $_ if $opt_m or containspod($_); + next; + } + unless ($opt_m) { + if ($Is_VMS) { + my($i,$trn); + for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { + push(@searchdirs,$trn); } + push(@searchdirs,'perl_root:[lib.pod]') # installed pods + } + else { + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); } - my @files = searchfor(0,$_,@searchdirs); - if( @files ) { - print STDERR "Found as @files\n" if $opt_v; - } else { - # no match, try recursive search - - @searchdirs = grep(!/^\.$/,@INC); - - @files= searchfor(1,$_,@searchdirs) if $opt_r; - if( @files ) { - print STDERR "Loosely found as @files\n" if $opt_v; - } else { - print STDERR "No documentation found for \"$_\".\n"; - if (@global_found) { - print STDERR "However, try\n"; - for my $dir (@global_found) { - opendir(DIR, $dir) or die "$!"; - while (my $file = readdir(DIR)) { - next if ($file =~ /^\./); - $file =~ s/\.(pm|pod)$//; - print STDERR "\tperldoc $_\::$file\n"; - } - closedir DIR; - } - } + } + my @files = searchfor(0,$_,@searchdirs); + if (@files) { + print STDERR "Found as @files\n" if $opt_v; + } + else { + # no match, try recursive search + @searchdirs = grep(!/^\.$/,@INC); + @files= searchfor(1,$_,@searchdirs) if $opt_r; + if (@files) { + print STDERR "Loosely found as @files\n" if $opt_v; + } + else { + print STDERR "No documentation found for \"$_\".\n"; + if (@global_found) { + print STDERR "However, try\n"; + for my $dir (@global_found) { + opendir(DIR, $dir) or die "$!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./); + $file =~ s/\.(pm|pod)$//; + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR; } + } } - push(@found,@files); + } + push(@found,@files); } -if(!@found) { - exit ($Is_VMS ? 98962 : 1); +if (!@found) { + exit ($Is_VMS ? 98962 : 1); } if ($opt_l) { @@ -368,175 +454,143 @@ my $lines = $ENV{LINES} || 24; my $no_tty; -if( ! -t STDOUT ) { $no_tty = 1 } +if (! -t STDOUT) { $no_tty = 1 } + +# until here we could simply exit or die +# now we create temporary files that we have to clean up +# namely $tmp, $buffer my $tmp; +my $buffer; if ($Is_MSWin32) { - $tmp = "$ENV{TEMP}\\perldoc1.$$"; - push @pagers, qw( more< less notepad ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; -} elsif ($Is_VMS) { - $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; - push @pagers, qw( most more less type/page ); -} elsif ($Is_Dos) { - $tmp = "$ENV{TEMP}/perldoc1.$$"; - $tmp =~ tr!\\/!//!s; - push @pagers, qw( less.exe more.com< ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; -} else { - if ($^O eq 'os2') { - require POSIX; - $tmp = POSIX::tmpnam(); - unshift @pagers, 'less', 'cmd /c more <'; - } else { - $tmp = "/tmp/perldoc1.$$"; - } - push @pagers, qw( more less pg view cat ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + $tmp = "$ENV{TEMP}\\perldoc1.$$"; + $buffer = "$ENV{TEMP}\\perldoc1.b$$"; + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + for (@found) { s,/,\\,g } +} +elsif ($Is_VMS) { + $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; + $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$; + push @pagers, qw( most more less type/page ); +} +elsif ($Is_Dos) { + $tmp = "$ENV{TEMP}/perldoc1.$$"; + $buffer = "$ENV{TEMP}/perldoc1.b$$"; + $tmp =~ tr!\\/!//!s; + $buffer =~ tr!\\/!//!s; + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; +} +else { + if ($^O eq 'os2') { + require POSIX; + $tmp = POSIX::tmpnam(); + $buffer = POSIX::tmpnam(); + unshift @pagers, 'less', 'cmd /c more <'; + } + else { + $tmp = "/tmp/perldoc1.$$"; + $buffer = "/tmp/perldoc1.b$$"; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; +# all exit calls from here on have to be safe_exit calls (see above) +# and all die calls safe_die calls to guarantee removal of files and +# dir as needed + if ($opt_m) { - foreach my $pager (@pagers) { - system("$pager @found") or exit; - } - if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } - exit 1; -} + foreach my $pager (@pagers) { + system("$pager @found") or safe_exit(0, $tmp, $buffer); + } + if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } + # I don't get the line above. Please patch yourself as needed. + safe_exit(1, $tmp, $buffer); +} +my @pod; if ($opt_f) { - my $perlfunc = shift @found; - open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!"; - - # Functions like -r, -e, etc. are listed under `-X'. - my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) ? 'I<-X' : $opt_f ; + my $perlfunc = shift @found; + open(PFUNC, $perlfunc) + or safe_die("Can't open $perlfunc: $!", $tmp, $buffer); + + # Functions like -r, -e, etc. are listed under `-X'. + my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? 'I<-X' : $opt_f ; + + # Skip introduction + while () { + last if /^=head2 Alphabetical Listing of Perl Functions/; + } - # Skip introduction - while () { - last if /^=head2 Alphabetical Listing of Perl Functions/; - } - - # Look for our function - my $found = 0; - my @pod; - while () { - if (/^=item\s+\Q$search_string\E\b/o) { - $found = 1; - } elsif (/^=item/) { - last if $found > 1; - } - next unless $found; - push @pod, $_; - ++$found if /^\w/; # found descriptive text - } - if (@pod) { - if ($opt_t) { - open(FORMATTER, "| pod2text") || die "Can't start filter"; - print FORMATTER "=over 8\n\n"; - print FORMATTER @pod; - print FORMATTER "=back\n"; - close(FORMATTER); - } elsif (@pod < $lines-2) { - print @pod; - } else { - foreach my $pager (@pagers) { - open (PAGER, "| $pager") or next; - print PAGER @pod ; - close(PAGER) or next; - last; - } - } - } else { - die "No documentation for perl function `$opt_f' found\n"; - } - exit; + # Look for our function + my $found = 0; + my $inlist = 0; + while () { + if (/^=item\s+\Q$search_string\E\b/o) { + $found = 1; + } + elsif (/^=item/) { + last if $found > 1 and not $inlist; + } + next unless $found; + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + --$inlist; + } + push @pod, $_; + ++$found if /^\w/; # found descriptive text + } + if (!@pod) { + die "No documentation for perl function `$opt_f' found\n"; + } } if ($opt_q) { - local @ARGV = @found; # I'm lazy, sue me. - my $found = 0; - my %found_in; - my @pod; - - while (<>) { - if (/^=head2\s+.*(?:$opt_q)/oi) { - $found = 1; - push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; - } elsif (/^=head2/) { - $found = 0; - } - next unless $found; - push @pod, $_; - } - - if (@pod) { - if ($opt_t) { - open(FORMATTER, "| pod2text") || die "Can't start filter"; - print FORMATTER "=over 8\n\n"; - print FORMATTER @pod; - print FORMATTER "=back\n"; - close(FORMATTER); - } elsif (@pod < $lines-2) { - print @pod; - } else { - foreach my $pager (@pagers) { - open (PAGER, "| $pager") or next; - print PAGER @pod ; - close(PAGER) or next; - last; - } - } - } else { - die "No documentation for perl FAQ keyword `$opt_q' found\n"; - } - exit; -} - -foreach (@found) { - - my $err; - if($opt_t) { - open(TMP,">>$tmp"); - Pod::Text::pod2text($_,*TMP); - close(TMP); - } elsif(not $opt_u) { - my $cmd = "pod2man --lax $_ | nroff -man"; - $cmd .= " | col -x" if $^O =~ /hpux/; - my $rslt = `$cmd`; - unless(($err = $?)) { - open(TMP,">>$tmp"); - print TMP $rslt; - close TMP; - } + local @ARGV = @found; # I'm lazy, sue me. + my $found = 0; + my %found_in; + + while (<>) { + if (/^=head2\s+.*(?:$opt_q)/oi) { + $found = 1; + push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; } - - if( $opt_u or $err or -z $tmp) { - open(OUT,">>$tmp"); - open(IN,"<$_"); - my $cut = 1; - while () { - $cut = $1 eq 'cut' if /^=(\w+)/; - next if $cut; - print OUT; - } - close(IN); - close(OUT); + elsif (/^=head2/) { + $found = 0; } + next unless $found; + push @pod, $_; + } + if (!@pod) { + safe_die("No documentation for perl FAQ keyword `$opt_q' found\n", + $tmp, $buffer); + } } -if( $no_tty ) { - open(TMP,"<$tmp"); - print while ; - close(TMP); -} else { - foreach my $pager (@pagers) { - system("$pager $tmp") or last; - } +my $filter; + +if (@pod) { + open(TMP,">$buffer") or safe_die("Can't open '$buffer': $!", $tmp, $buffer); + print TMP "=over 8\n\n"; + print TMP @pod; + print TMP "=back\n"; + close TMP; + @found = $buffer; + $filter = 1; } -1 while unlink($tmp); #Possibly pointless VMSism +foreach (@found) { + printout($_, $tmp, $filter); +} +page($tmp, $no_tty, @pagers); -exit 0; +safe_exit(0, $tmp, $buffer); __END__ @@ -620,7 +674,7 @@ The item you want to look up. Nested modules (such as C) are specified either as C or C. You may also -give a descriptive name of a page, such as C. You make also give a +give a descriptive name of a page, such as C. You may also give a partial or wrong-case name, such as "basename" for "File::Basename", but this will be slower, if there is more then one page with the same partial name, you will only get the first one. @@ -629,7 +683,7 @@ =head1 ENVIRONMENT -Any switches in the C environment variable will be used before the +Any switches in the C environment variable will be used before the command line arguments. C also searches directories specified by the C (or C if C is not defined) and C environment variables. @@ -639,11 +693,18 @@ C before trying to find a pager on its own. (C is not used if C was told to display plain text or unformatted pod.) +One useful value for C is C. + +=head1 VERSION + +This is perldoc v2.0. + =head1 AUTHOR Kenneth Albanowski -Minor updates by Andy Dougherty +Minor updates by Andy Dougherty , +and others. =cut @@ -661,7 +722,7 @@ # Kenneth Albanowski # -added Charles Bailey's further VMS patches, and -u switch # -added -t switch, with pod2text support -# +# # Version 1.10: Thu Nov 9 07:23:47 EST 1995 # Kenneth Albanowski # -added VMS support diff -ruN perl5.005_03/win32/BuildInfo.h AP522_source/win32/BuildInfo.h --- perl5.005_03/win32/BuildInfo.h Wed Dec 31 16:00:00 1969 +++ AP522_source/win32/BuildInfo.h Mon Nov 01 15:11:46 1999 @@ -0,0 +1,22 @@ +/* BuildInfo.h + * + * (c) 1999 ActiveState Tool Corp. All rights reserved. + * + */ + +#ifndef ___BuildInfo__h___ +#define ___BuildInfo__h___ + +#define PRODUCT_BUILD_NUMBER "522" +#define PERLFILEVERSION "5,2,2,0\0" +#define PERLRC_VERSION 5,2,2,0 +#define PERLPRODUCTVERSION "Build " PRODUCT_BUILD_NUMBER "\0" +#define PERLPRODUCTNAME "ActivePerl\0" + +#define ACTIVEPERL_VERSION "Built "##__TIME__##" "##__DATE__##"\n" +#define ACTIVEPERL_LOCAL_PATCHES_ENTRY "ActivePerl Build " PRODUCT_BUILD_NUMBER +#define BINARY_BUILD_NOTICE printf("\n\ +Binary build "##PRODUCT_BUILD_NUMBER##" provided by ActiveState Tool Corp. http://www.ActiveState.com\n\ +" ACTIVEPERL_VERSION "\n"); + +#endif /* ___BuildInfo__h___ */ diff -ruN perl5.005_03/win32/GenCAPI.pl AP522_source/win32/GenCAPI.pl --- perl5.005_03/win32/GenCAPI.pl Fri Oct 15 17:45:58 1999 +++ AP522_source/win32/GenCAPI.pl Mon Nov 01 15:11:46 1999 @@ -524,6 +524,7 @@ open(HDRFILE, ">$hdrfile") or die "$0: Can't open $hdrfile: $!\n"; print HDRFILE <Perl_get_opargs(); } +void boot_CAPI_handler(CV *cv, void (*subaddr)(CV *c), void *pP) +{ +#ifndef NO_XSLO