diff options
author | Jarkko Hietaniemi <jhi@iki.fi> | 2000-01-13 16:31:34 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 2000-01-13 16:31:34 +0000 |
commit | 434d2535978fdc93cf6e9722bc7f9d272a9c2632 (patch) | |
tree | dd1640d56ae63acd3cdc1ed34863bc656a13dbc3 /lib | |
parent | d132b95fb004c5e3d94e297d3804c90cfef96fed (diff) | |
parent | 8ea97a1e700347a7b6ed9267c8c34f286f94d5d6 (diff) | |
download | perl-434d2535978fdc93cf6e9722bc7f9d272a9c2632.tar.gz |
Integrate with Sarathy.
p4raw-id: //depot/cfgperl@4798
Diffstat (limited to 'lib')
44 files changed, 1122 insertions, 395 deletions
diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index 8e15c1f60c..4bbcb33e10 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -11,7 +11,7 @@ BEGIN { @EXPORT_OK = @EXPORT_OK = qw(AUTOLOAD); $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32'; $is_vms = $^O eq 'VMS'; - $VERSION = $VERSION = '5.57'; + $VERSION = '5.57'; } AUTOLOAD { diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index 83331aab39..487ddd5717 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -2,17 +2,7 @@ package Benchmark; =head1 NAME -Benchmark - benchmark running times of code - -timethis - run a chunk of code several times - -timethese - run several chunks of code several times - -cmpthese - print results of timethese as a comparison chart - -timeit - run a chunk of code and see how long it goes - -countit - see how many times a chunk of code runs in a given time +Benchmark - benchmark running times of Perl code =head1 SYNOPSIS @@ -63,6 +53,17 @@ countit - see how many times a chunk of code runs in a given time The Benchmark module encapsulates a number of routines to help you figure out how long it takes to execute some code. +timethis - run a chunk of code several times + +timethese - run several chunks of code several times + +cmpthese - print results of timethese as a comparison chart + +timeit - run a chunk of code and see how long it goes + +countit - see how many times a chunk of code runs in a given time + + =head2 Methods =over 10 @@ -322,6 +323,10 @@ The system time of the null loop might be slightly more than the system time of the loop with the actual code and therefore the difference might end up being E<lt> 0. +=head1 SEE ALSO + +L<Devel::DProf> - a Perl code profiler + =head1 AUTHORS Jarkko Hietaniemi <F<jhi@iki.fi>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>> @@ -357,6 +362,8 @@ use Exporter; @EXPORT_OK=qw(timesum cmpthese countit clearcache clearallcache disablecache enablecache); +$VERSION = 1.00; + &init; sub init { diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 432e72da05..2f22b773c7 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -3325,7 +3325,8 @@ sub perl { $perl ||= $candidate if MM->maybe_command($candidate); unless ($perl) { my ($component,$perl_name); - DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { + DIST_PERLNAME: + foreach $perl_name ($^X, 'perl', 'perl5', "perl$Config::Config{version}") { PATH_COMPONENT: foreach $component (MM->path(), $Config::Config{'binexp'}) { next unless defined($component) && $component; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 8a99da975a..ee1bc28367 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -372,7 +372,7 @@ sub _qnx_abs_path { *abs_path = \&_qnx_abs_path; *fast_abs_path = \&_qnx_abs_path; } - elsif ($^O =~ /cygwin/) { + elsif ($^O eq 'cygwin') { *getcwd = \&cwd; *fastgetcwd = \&cwd; *fastcwd = \&cwd; @@ -794,7 +794,7 @@ highly experimental and subject to change. =head1 AUTHOR -Gurusamy Sarathy gsar@umich.edu +Gurusamy Sarathy gsar@activestate.com This code heavily adapted from an early version of perl5db.pl attributable to Larry Wall and the Perl Porters. diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm index e0ea0685f0..b649b6b77b 100644 --- a/lib/ExtUtils/Embed.pm +++ b/lib/ExtUtils/Embed.pm @@ -332,7 +332,7 @@ B<[@modules]> is an array ref, same as additional arguments mentioned above. This will generate code with an B<xs_init> function that glues the perl B<Socket::bootstrap> function -to the C B<boot_Socket> function and writes it to a file named "xsinit.c". +to the C B<boot_Socket> function and writes it to a file named F<xsinit.c>. Note that B<DynaLoader> is a special case where it must call B<boot_DynaLoader> directly. @@ -378,7 +378,7 @@ we should find B<auto/Socket/Socket.a> When looking for B<DBD::Oracle> relative to a search path, we should find B<auto/DBD/Oracle/Oracle.a> -Keep in mind, you can always supply B</my/own/path/ModuleName.a> +Keep in mind that you can always supply B</my/own/path/ModuleName.a> as an additional linker argument. B<--> E<lt>list of linker argsE<gt> @@ -392,7 +392,7 @@ When invoked with parameters the following are accepted and optional: C<ldopts($std,[@modules],[@link_args],$path)> -Where, +Where: B<$std> is boolean, equivalent to the B<-std> option. diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 47bde0deb0..d6b1375fb6 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -67,7 +67,6 @@ sub install { } $packlist->read($pack{"read"}) if (-f $pack{"read"}); my $cwd = cwd(); - my $umask = umask 0 unless $Is_VMS; my($source); MOD_INSTALL: foreach $source (sort keys %hash) { @@ -140,7 +139,6 @@ sub install { print "Writing $pack{'write'}\n"; $packlist->write($pack{'write'}); } - umask $umask unless $Is_VMS; } sub directory_not_empty ($) { @@ -193,7 +191,6 @@ sub uninstall { forceunlink($_) unless $nonono; } print "unlink $fil\n" if $verbose; - close P; forceunlink($fil) unless $nonono; } @@ -259,7 +256,6 @@ sub pm_to_blib { close(FROMTO); } - my $umask = umask 0022 unless $Is_VMS; mkpath($autodir,0,0755); foreach (keys %$fromto) { next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; @@ -280,7 +276,6 @@ sub pm_to_blib { next unless /\.pm$/; autosplit($fromto->{$_},$autodir); } - umask $umask unless $Is_VMS; } package ExtUtils::Install::Warn; @@ -343,7 +338,7 @@ There are two keys with a special meaning in the hash: "read" and target files to the file named by C<$hashref-E<gt>{write}>. If there is another file named by C<$hashref-E<gt>{read}>, the contents of this file will be merged into the written file. The read and the written file may be -identical, but on AFS it is quite likely, people are installing to a +identical, but on AFS it is quite likely that people are installing to a different directory than the one where the files later appear. install_default() takes one or less arguments. If no arguments are @@ -356,7 +351,7 @@ The argument-less form is convenient for install scripts like perl -MExtUtils::Install -e install_default Tk/Canvas -Assuming this command is executed in a directory with populated F<blib> +Assuming this command is executed in a directory with a populated F<blib> directory, it will proceed as if the F<blib> was build by MakeMaker on this machine. This is useful for binary distributions. diff --git a/lib/ExtUtils/Installed.pm b/lib/ExtUtils/Installed.pm index dda594e784..41f3c9b3b8 100644 --- a/lib/ExtUtils/Installed.pm +++ b/lib/ExtUtils/Installed.pm @@ -56,7 +56,7 @@ my $self = {}; # Read the core packlist $self->{Perl}{packlist} = ExtUtils::Packlist->new("$Config{installarchlib}/.packlist"); -$self->{Perl}{version} = $]; +$self->{Perl}{version} = $Config{version}; # Read the module packlists my $sub = sub diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 13e4e29e88..b992ec0116 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -540,7 +540,7 @@ below. =head2 EXTRALIBS List of libraries that need to be linked with when linking a perl -binary which includes this extension Only those libraries that +binary which includes this extension. Only those libraries that actually exist are included. These are written to a file and used when linking perl. @@ -562,7 +562,7 @@ object file. This list is used to create a .bs (bootstrap) file. =head1 PORTABILITY This module deals with a lot of system dependencies and has quite a -few architecture specific B<if>s in the code. +few architecture specific C<if>s in the code. =head2 VMS implementation @@ -682,7 +682,7 @@ enable searching for default libraries specified by C<$Config{libs}>. The libraries specified may be a mixture of static libraries and import libraries (to link with DLLs). Since both kinds are used -pretty transparently on the win32 platform, we do not attempt to +pretty transparently on the Win32 platform, we do not attempt to distinguish between them. =item * diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index f9fdcaaf58..f4329e13d7 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -377,10 +377,22 @@ sub cflags { if ($Is_PERL_OBJECT) { $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\b|$)/-DPERL_CAPI/g; - if ($Is_Win32 && $Config{'cc'} =~ /^cl/i) { - # Turn off C++ mode of the MSC compiler - $self->{CCFLAGS} =~ s/-TP(\s|$)//; - $self->{OPTIMIZE} =~ s/-TP(\s|$)//; + if ($Is_Win32) { + if ($Config{'cc'} =~ /^cl/i) { + # Turn off C++ mode of the MSC compiler + $self->{CCFLAGS} =~ s/-TP(\s|$)//g; + $self->{OPTIMIZE} =~ s/-TP(\s|$)//g; + } + elsif ($Config{'cc'} =~ /^bcc32/i) { + # Turn off C++ mode of the Borland compiler + $self->{CCFLAGS} =~ s/-P(\s|$)//g; + $self->{OPTIMIZE} =~ s/-P(\s|$)//g; + } + elsif ($Config{'cc'} =~ /^gcc/i) { + # Turn off C++ mode of the GCC compiler + $self->{CCFLAGS} =~ s/-xc\+\+(\s|$)//g; + $self->{OPTIMIZE} =~ s/-xc\+\+(\s|$)//g; + } } } @@ -1992,7 +2004,8 @@ usually solves this kind of problem. push @defpath, $component if defined $component; } $self->{PERL} ||= - $self->find_perl(5.0, [ $self->canonpath($^X), 'miniperl','perl','perl5',"perl$]" ], + $self->find_perl(5.0, [ $self->canonpath($^X), 'miniperl', + 'perl','perl5',"perl$Config{version}" ], \@defpath, $Verbose ); # don't check if perl is executable, maybe they have decided to # supply switches with perl @@ -3233,11 +3246,14 @@ sub subdir_x { my($self, $subdir) = @_; my(@m); if ($Is_Win32 && Win32::IsWin95()) { + # XXX: dmake-specific, like rest of Win95 port return <<EOT; subdirs :: +@[ cd $subdir \$(MAKE) all \$(PASTHRU) cd .. +] EOT } else { @@ -3596,12 +3612,6 @@ config :: $(INST_AUTODIR)/.exists '.$self->{NOECHO}.'$(NOOP) '; - push @m, qq{ -config :: Version_check - $self->{NOECHO}\$(NOOP) - -} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; - push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); if (%{$self->{HTMLLIBPODS}}) { diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 31ca69067e..f3de323e53 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -1106,13 +1106,6 @@ config :: $(INST_AUTODIR).exists $(NOECHO) $(NOOP) '; - push @m, q{ -config :: Version_check - $(NOECHO) $(NOOP) - -} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; - - push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); if (%{$self->{MAN1PODS}}) { push @m, q[ diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index e1cb83ba80..534f26d823 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -37,9 +37,14 @@ $PERLMAKE = 1 if $Config{'make'} =~ /^pmake/i; $OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; # a few workarounds for command.com (very basic) -if (Win32::IsWin95()) { +{ package ExtUtils::MM_Win95; - unshift @MM::ISA, 'ExtUtils::MM_Win95'; + + # the $^O test may be overkill, but we want to be sure Win32::IsWin95() + # exists before we try it + + unshift @MM::ISA, 'ExtUtils::MM_Win95' + if ($^O =~ /Win32/ && Win32::IsWin95()); sub xs_c { my($self) = shift; @@ -65,8 +70,6 @@ if (Win32::IsWin95()) { sub xs_o { my($self) = shift; return '' unless $self->needs_linking(); - # Dmake gets confused with 2 ways of making things - return '' if $ExtUtils::MM_Win32::DMAKE; ' .xs$(OBJ_EXT): $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) \\ @@ -74,7 +77,7 @@ if (Win32::IsWin95()) { $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c '; } -} +} # end of command.com workarounds sub dlsyms { my($self,%attribs) = @_; @@ -481,6 +484,18 @@ sub dynamic_lib { my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; my($ldfrom) = '$(LDFROM)'; my(@m); + +# one thing for GCC/Mingw32: +# we try to overcome non-relocateable-DLL problems by generating +# a (hopefully unique) image-base from the dll's name +# -- BKS, 10-19-1999 + if ($GCC) { + my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT}; + $dllname =~ /(....)(.{0,4})/; + my $baseaddr = unpack("n", $1 ^ $2); + $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr); + } + push(@m,' # This section creates the dynamically loadable $(INST_DYNAMIC) # from $(OBJECT) and possibly $(MYEXTLIB). @@ -734,12 +749,6 @@ config :: $(INST_AUTODIR)\.exists '.$self->{NOECHO}.'$(NOOP) '; - push @m, qq{ -config :: Version_check - $self->{NOECHO}\$(NOOP) - -} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; - push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); if (%{$self->{HTMLLIBPODS}}) { diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 0f00e39afc..0426575f87 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -2,7 +2,7 @@ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatib package ExtUtils::MakeMaker; -$VERSION = "5.4302"; +$VERSION = "5.44"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) ($Revision = substr(q$Revision: 1.222 $, 10)) =~ s/\s+$//; @@ -17,7 +17,7 @@ use Carp (); use vars qw( @ISA @EXPORT @EXPORT_OK $AUTOLOAD - $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision $Setup_done + $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision $VERSION $Verbose $Version_OK %Config %Keep_after_flush %MM_Sections %Prepend_dot_dot %Recognized_Att_Keys @Get_from_Config @MM_Sections @Overridable @Parent @@ -70,7 +70,7 @@ $Is_VMS = $^O eq 'VMS'; $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; -$Is_Cygwin= $^O =~ /cygwin/i; +$Is_Cygwin= $^O eq 'cygwin'; require ExtUtils::MM_Unix; @@ -91,35 +91,11 @@ if ($Is_Cygwin) { require ExtUtils::MM_Cygwin; } -# The SelfLoader would bring a lot of overhead for MakeMaker, because -# we know for sure we will use most of the autoloaded functions once -# we have to use one of them. So we write our own loader - -sub AUTOLOAD { - my $code; - if (defined fileno(DATA)) { - my $fh = select DATA; - my $o = $/; # For future reads from the file. - $/ = "\n__END__\n"; - $code = <DATA>; - $/ = $o; - select $fh; - close DATA; - eval $code; - if ($@) { - $@ =~ s/ at .*\n//; - Carp::croak $@; - } - } else { - warn "AUTOLOAD called unexpectedly for $AUTOLOAD"; - } - defined(&$AUTOLOAD) or die "Myloader inconsistency error"; - goto &$AUTOLOAD; -} +full_setup(); -# The only subroutine we do not SelfLoad is Version_Check because it's -# called so often. Loading this minimum still requires 1.2 secs on my -# Indy :-( +# The use of the Version_check target has been dropped between perl +# 5.5.63 and 5.5.64. We must keep the subroutine for a while so that +# old Makefiles can satisfy the Version_check target. sub Version_check { my($checkversion) = @_; @@ -140,38 +116,10 @@ sub warnhandler { warn @_; } -sub ExtUtils::MakeMaker::eval_in_subdirs ; -sub ExtUtils::MakeMaker::eval_in_x ; -sub ExtUtils::MakeMaker::full_setup ; -sub ExtUtils::MakeMaker::writeMakefile ; -sub ExtUtils::MakeMaker::new ; -sub ExtUtils::MakeMaker::check_manifest ; -sub ExtUtils::MakeMaker::parse_args ; -sub ExtUtils::MakeMaker::check_hints ; -sub ExtUtils::MakeMaker::mv_all_methods ; -sub ExtUtils::MakeMaker::skipcheck ; -sub ExtUtils::MakeMaker::flush ; -sub ExtUtils::MakeMaker::mkbootstrap ; -sub ExtUtils::MakeMaker::mksymlists ; -sub ExtUtils::MakeMaker::neatvalue ; -sub ExtUtils::MakeMaker::selfdocument ; -sub ExtUtils::MakeMaker::WriteMakefile ; -sub ExtUtils::MakeMaker::prompt ($;$) ; - -1; - -__DATA__ - -package ExtUtils::MakeMaker; - sub WriteMakefile { Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; local $SIG{__WARN__} = \&warnhandler; - unless ($Setup_done++){ - full_setup(); - undef &ExtUtils::MakeMaker::full_setup; #safe memory - } my %att = @_; MM->new(\%att)->flush; } @@ -382,9 +330,13 @@ sub ExtUtils::MakeMaker::new { my($prereq); foreach $prereq (sort keys %{$self->{PREREQ_PM}}) { - my $eval = "use $prereq $self->{PREREQ_PM}->{$prereq}"; + my $eval = "require $prereq"; eval $eval; - if ($@){ + + if ($@) { + warn "Warning: prerequisite $prereq failed to load: $@"; + } + elsif ($prereq->VERSION < $self->{PREREQ_PM}->{$prereq} ){ warn "Warning: prerequisite $prereq $self->{PREREQ_PM}->{$prereq} not found"; # Why is/was this 'delete' here? We need PREREQ_PM later to make PPDs. # } else { @@ -1183,7 +1135,7 @@ MakeMaker gives you much more freedom than needed to configure internal variables and get different results. It is worth to mention, that make(1) also lets you configure most of the variables that are used in the Makefile. But in the majority of situations this will not -be necessary, and should only be done, if the author of a package +be necessary, and should only be done if the author of a package recommends it (or you know what you're doing). =head2 Using Attributes and Parameters @@ -1598,9 +1550,9 @@ Makefile.PL. =item NEEDS_LINKING -MakeMaker will figure out, if an extension contains linkable code +MakeMaker will figure out if an extension contains linkable code anywhere down the directory tree, and will set this variable -accordingly, but you can speed it up a very little bit, if you define +accordingly, but you can speed it up a very little bit if you define this boolean variable yourself. =item NOECHO @@ -1615,7 +1567,7 @@ Boolean. Attribute to inhibit descending into subdirectories. =item NO_VC -In general any generated Makefile checks for the current version of +In general, any generated Makefile checks for the current version of MakeMaker and the version the Makefile was built under. If NO_VC is set, the version check is neglected. Do not write this into your Makefile.PL, use it interactively instead. @@ -1642,7 +1594,7 @@ to $(CC). =item PERL_ARCHLIB -Same as above for architecture dependent files +Same as above for architecture dependent files. =item PERL_LIB @@ -1699,14 +1651,14 @@ Defining PM in the Makefile.PL will override PMLIBDIRS. =item POLLUTE Release 5.005 grandfathered old global symbol names by providing preprocessor -macros for extension source compatibility. As of release 5.006, these +macros for extension source compatibility. As of release 5.6, these preprocessor definitions are not available by default. The POLLUTE flag specifies that the old names should still be defined: perl Makefile.PL POLLUTE=1 Please inform the module author if this is necessary to successfully install -a module under 5.006 or later. +a module under 5.6 or later. =item PPM_INSTALL_EXEC @@ -1736,8 +1688,8 @@ only check if any version is installed already. =item SKIP Arryref. E.g. [qw(name1 name2)] skip (do not write) sections of the -Makefile. Caution! Do not use the SKIP attribute for the neglectible -speedup. It may seriously damage the resulting Makefile. Only use it, +Makefile. Caution! Do not use the SKIP attribute for the negligible +speedup. It may seriously damage the resulting Makefile. Only use it if you really need it. =item TYPEMAPS @@ -1860,7 +1812,7 @@ NB: Extensions that have nothing but *.pm files had to say {LINKTYPE => ''} with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line -can be deleted safely. MakeMaker recognizes, when there's nothing to +can be deleted safely. MakeMaker recognizes when there's nothing to be linked. =item macro @@ -1963,7 +1915,7 @@ details) =item make distclean does a realclean first and then the distcheck. Note that this is not -needed to build a new distribution as long as you are sure, that the +needed to build a new distribution as long as you are sure that the MANIFEST file is ok. =item make manifest diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 52cfc2a80a..58c91bc44b 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -187,7 +187,6 @@ sub manicopy { require File::Basename; my(%dirs,$file); $target = VMS::Filespec::unixify($target) if $Is_VMS; - umask 0 unless $Is_VMS; File::Path::mkpath([ $target ],1,$Is_VMS ? undef : 0755); foreach $file (keys %$read){ $file = VMS::Filespec::unixify($file) if $Is_VMS; diff --git a/lib/ExtUtils/Mkbootstrap.pm b/lib/ExtUtils/Mkbootstrap.pm index 25c374c153..323c3ab6ba 100644 --- a/lib/ExtUtils/Mkbootstrap.pm +++ b/lib/ExtUtils/Mkbootstrap.pm @@ -81,8 +81,8 @@ C<mkbootstrap> Mkbootstrap typically gets called from an extension Makefile. -There is no C<*.bs> file supplied with the extension. Instead a -C<*_BS> file which has code for the special cases, like posix for +There is no C<*.bs> file supplied with the extension. Instead, there may +be a C<*_BS> file which has code for the special cases, like posix for berkeley db on the NeXT. This file will get parsed, and produce a maybe empty diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index cfc1e7dff8..9dcedbf35e 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -78,7 +78,7 @@ sub _write_os2 { } my $distname = $data->{DISTNAME} || $data->{NAME}; $distname = "Distribution $distname"; - my $comment = "Perl (v$]$threaded) module $data->{NAME}"; + my $comment = "Perl (v$Config::Config{version}$threaded) module $data->{NAME}"; if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') { $distname = 'perl5-porters@perl.org'; $comment = "Core $comment"; diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 6db993c521..ff9b452caf 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -6,10 +6,12 @@ xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] ... file.xs +B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs =head1 DESCRIPTION +This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>. + I<xsubpp> will compile XS code into C code by embedding the constructs necessary to let C functions manipulate Perl values and creates the glue necessary to let Perl access those functions. The compiler uses typemaps to @@ -23,13 +25,15 @@ typemap taking precedence. =head1 OPTIONS +Note that the C<XSOPT> MakeMaker option may be used to add these options to +any makefiles generated by MakeMaker. + =over 5 =item B<-C++> Adds ``extern "C"'' to the C code. - =item B<-except> Adds exception handling stubs to the C code. @@ -59,6 +63,13 @@ number. Prevents the inclusion of `#line' directives in the output. +=item B<-nooptimize> + +Disables certain optimizations. The only optimization that is currently +affected is the use of I<target>s by the output C code (see L<perlguts>). +This may significantly slow down the generated code, but this is the way +B<xsubpp> of 5.005 and earlier operated. + =back =head1 ENVIRONMENT @@ -103,7 +114,7 @@ if ($^O eq 'VMS') { $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; +$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; # mjn @@ -114,6 +125,7 @@ $WantPrototypes = -1 ; $WantVersionChk = 1 ; $ProtoUsed = 0 ; $WantLineNumbers = 1 ; +$WantOptimize = 1 ; SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; @@ -129,7 +141,9 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { push(@tm,shift), next SWITCH if $flag eq 'typemap'; $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; - (print "xsubpp version $XSUBPP_version\n"), exit + $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; + $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; + (print "xsubpp version $XSUBPP_version\n"), exit if $flag eq 'v'; die $usage; } @@ -235,6 +249,24 @@ foreach $key (keys %input_expr) { $input_expr{$key} =~ s/\n+$//; } +$bal = qr[(?:(?>[^()]+)|\((?p{ $bal })\))*]; # ()-balanced +$cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast +$size = qr[,\s* (?p{ $bal }) ]x; # Third arg (to setpvn) + +foreach $key (keys %output_expr) { + use re 'eval'; + + my ($t, $with_size, $arg, $sarg) = + ($output_expr{$key} =~ + m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn + \s* \( \s* $cast \$arg \s* , + \s* ( (?p{ $bal }) ) # Set from + ( (?p{ $size }) )? # Possible sizeof set-from + \) \s* ; \s* $ + ]x); + $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; +} + $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # Match an XS keyword @@ -1099,6 +1131,8 @@ EOF if !$retvaldone; $args_match{"RETVAL"} = 0; $var_types{"RETVAL"} = $ret_type; + print "\tdXSTARG;\n" + if $WantOptimize and $targetable{$type_kind{$ret_type}}; } print $deferred; @@ -1151,8 +1185,32 @@ EOF if ($gotRETVAL && $RETVAL_code) { print "\t$RETVAL_code\n"; } elsif ($gotRETVAL || $wantRETVAL) { - # RETVAL almost never needs SvSETMAGIC() - &generate_output($ret_type, 0, 'RETVAL', 0); + my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; + my $var = 'RETVAL'; + my $type = $ret_type; + + # 0: type, 1: with_size, 2: how, 3: how_size + if ($t and not $t->[1] and $t->[0] eq 'p') { + # PUSHp corresponds to setpvn. Treate setpv directly + my $what = eval qq("$t->[2]"); + warn $@ if $@; + + print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; + } + elsif ($t) { + my $what = eval qq("$t->[2]"); + warn $@ if $@; + + my $size = $t->[3]; + $size = '' unless defined $size; + $size = eval qq("$size"); + warn $@ if $@; + print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; + } + else { + # RETVAL almost never needs SvSETMAGIC() + &generate_output($ret_type, 0, 'RETVAL', 0); + } } # do cleanup diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index fd812bc721..8df54e55a8 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -10,14 +10,14 @@ package File::Copy; use strict; use Carp; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big - © &syscopy &cp &mv); + © &syscopy &cp &mv $Syscopy_is_copy); # Note that this module implements only *part* of the API defined by # the File/Copy.pm module of the File-Tools-2.0 package. However, that # package has not yet been updated to work with Perl 5.004, and so it # would be a Bad Thing for the CPAN module to grab it and replace this # module. Therefore, we set this module's version higher than 2.0. -$VERSION = '2.02'; +$VERSION = '2.03'; require Exporter; @ISA = qw(Exporter); @@ -60,12 +60,12 @@ sub copy { $to = _catname($from, $to); } - if (defined &syscopy && \&syscopy != \© + if (defined &syscopy && !$Syscopy_is_copy && !$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); } @@ -83,16 +83,16 @@ sub copy { open(FROM, "< $from\0") or goto fail_open1; binmode FROM or die "($!,$^E)"; $closefrom = 1; - } - + } + if ($to_a_handle) { *TO = *$to{FILEHANDLE}; - } else { + } else { $to = "./$to" if $to =~ /^\s/; open(TO,"> $to\0") or goto fail_open2; binmode TO or die "($!,$^E)"; $closeto = 1; - } + } if (@_) { $size = shift(@_) + 0; @@ -120,7 +120,7 @@ sub copy { # Use this idiom to avoid uninitialized value warning. return 1; - + # All of these contortions try to preserve error messages... fail_inner: if ($closeto) { @@ -163,10 +163,10 @@ sub move { (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed $tosz2 == $fromsz; # it's all there - + ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something return 1 if ($copied = copy($from,$to)) && unlink($from); - + ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; ($!,$^E) = ($sts,$ossts); @@ -193,6 +193,7 @@ unless (defined &syscopy) { return Win32::CopyFile(@_, 1); }; } else { + $Syscopy_is_copy = 1; *syscopy = \© } } diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index 594ee2ec84..e6fc311e32 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -206,7 +206,7 @@ pandering to DOS habits. Needs a dose of optimizium too. =head1 AUTHOR -Gurusamy Sarathy <gsar@umich.edu> +Gurusamy Sarathy <gsar@activestate.com> =head1 HISTORY diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 28e2e90e44..c674b2c5f6 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -1,5 +1,5 @@ package File::Find; -require 5.000; +require 5.005; require Exporter; require Cwd; @@ -12,70 +12,163 @@ finddepth - traverse a directory structure depth-first =head1 SYNOPSIS use File::Find; - find(\&wanted, '/foo','/bar'); + find(\&wanted, '/foo', '/bar'); sub wanted { ... } use File::Find; - finddepth(\&wanted, '/foo','/bar'); + finddepth(\&wanted, '/foo', '/bar'); sub wanted { ... } + + use File::Find; + find({ wanted => \&process, follow => 1 }, '.'); =head1 DESCRIPTION The first argument to find() is either a hash reference describing the -operations to be performed for each file, a code reference, or a string -that contains a subroutine name. If it is a hash reference, then the -value for the key C<wanted> should be a code reference. This code -reference is called I<the wanted() function> below. +operations to be performed for each file, or a code reference. -Currently the only other supported key for the above hash is -C<bydepth>, in presense of which the walk over directories is -performed depth-first. Entry point finddepth() is a shortcut for -specifying C<{ bydepth => 1}> in the first argument of find(). +Here are the possible keys for the hash: + +=over 3 + +=item C<wanted> + +The value should be a code reference. This code reference is called +I<the wanted() function> below. + +=item C<bydepth> + +Reports the name of a directory only AFTER all its entries +have been reported. Entry point finddepth() is a shortcut for +specifying C<{ bydepth => 1 }> in the first argument of find(). + +=item C<follow> + +Causes symbolic links to be followed. Since directory trees with symbolic +links (followed) may contain files more than once and may even have +cycles, a hash has to be built up with an entry for each file. +This might be expensive both in space and time for a large +directory tree. See I<follow_fast> and I<follow_skip> below. +If either I<follow> or I<follow_fast> is in effect: + +=over 6 + +=item + +It is guarantueed that an I<lstat> has been called before the user's +I<wanted()> function is called. This enables fast file checks involving S< _>. + +=item + +There is a variable C<$File::Find::fullname> which holds the absolute +pathname of the file with all symbolic links resolved + +=back + +=item C<follow_fast> + +This is similar to I<follow> except that it may report some files +more than once. It does detect cycles however. +Since only symbolic links have to be hashed, this is +much cheaper both in space and time. +If processing a file more than once (by the user's I<wanted()> function) +is worse than just taking time, the option I<follow> should be used. + +=item C<follow_skip> + +C<follow_skip==1>, which is the default, causes all files which are +neither directories nor symbolic links to be ignored if they are about +to be processed a second time. If a directory or a symbolic link +are about to be processed a second time, File::Find dies. +C<follow_skip==0> causes File::Find to die if any file is about to be +processed a second time. +C<follow_skip==2> causes File::Find to ignore any duplicate files and +dirctories but to proceed normally otherwise. -The wanted() function does whatever verifications you want. -$File::Find::dir contains the current directory name, and $_ the -current filename within that directory. $File::Find::name contains -C<"$File::Find::dir/$_">. You are chdir()'d to $File::Find::dir when -the function is called. The function may set $File::Find::prune to -prune the tree. -File::Find assumes that you don't alter the $_ variable. If you do then -make sure you return it to its original value before exiting your function. +=item C<no_chdir> + +Does not C<chdir()> to each directory as it recurses. The wanted() +function will need to be aware of this, of course. In this case, +C<$_> will be the same as C<$File::Find::name>. + +=item C<untaint> + +If find is used in taint-mode (-T command line switch or if EUID != UID +or if EGID != GID) then internally directory names have to be untainted +before they can be cd'ed to. Therefore they are checked against a regular +expression I<untaint_pattern>. Note, that all names passed to the +user's I<wanted()> function are still tainted. + +=item C<untaint_pattern> + +See above. This should be set using the C<qr> quoting operator. +The default is set to C<qr|^([-+@\w./]+)$|>. +Note that the paranthesis which are vital. + +=item C<untaint_skip> + +If set, directories (subtrees) which fail the I<untaint_pattern> +are skipped. The default is to 'die' in such a case. + +=back + +The wanted() function does whatever verifications you want. +C<$File::Find::dir> contains the current directory name, and C<$_> the +current filename within that directory. C<$File::Find::name> contains +the complete pathname to the file. You are chdir()'d to C<$File::Find::dir> when +the function is called, unless C<no_chdir> was specified. +When <follow> or <follow_fast> are in effect there is also a +C<$File::Find::fullname>. +The function may set C<$File::Find::prune> to prune the tree +unless C<bydepth> was specified. +Unless C<follow> or C<follow_fast> is specified, for compatibility +reasons (find.pl, find2perl) there are in addition the following globals +available: C<$File::Find::topdir>, C<$File::Find::topdev>, C<$File::Find::topino>, +C<$File::Find::topmode> and C<$File::Find::topnlink>. This library is useful for the C<find2perl> tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ - -exec rm -f {} \; -o -fstype nfs -prune + -exec rm -f {} \; -o -fstype nfs -prune produces something like: sub wanted { /^\.nfs.*$/ && - (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && + (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) && int(-M _) > 7 && unlink($_) || - ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && + ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) && $dev < 0 && ($File::Find::prune = 1); } -Set the variable $File::Find::dont_use_nlink if you're using AFS, +Set the variable C<$File::Find::dont_use_nlink> if you're using AFS, since AFS cheats. -C<finddepth> is just like C<find>, except that it does a depth-first -search. Here's another interesting wanted function. It will find all symlinks that don't resolve: sub wanted { - -l && !-e && print "bogus link: $File::Find::name\n"; + -l && !-e && print "bogus link: $File::Find::name\n"; } -=head1 BUGS +See also the script C<pfind> on CPAN for a nice application of this +module. + +=head1 CAVEAT + +Be aware that the option to follow symblic links can be dangerous. +Depending on the structure of the directory tree (including symbolic +links to directories) you might traverse a given (physical) directory +more than once (only if C<follow_fast> is in effect). +Furthermore, deleting or changing files in a symbolically linked directory +might cause very unpleasant surprises, since you delete or change files +in an unknown directory. -There is no way to make find or finddepth follow symlinks. =cut @@ -83,151 +176,522 @@ There is no way to make find or finddepth follow symlinks. @EXPORT = qw(find finddepth); -sub find_opt { - my $wanted = shift; - my $bydepth = $wanted->{bydepth}; - my $cwd = $bydepth ? Cwd::fastcwd() : Cwd::cwd(); - # Localize these rather than lexicalizing them for backwards - # compatibility. - local($topdir,$topdev,$topino,$topmode,$topnlink); - foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = - ($Is_VMS ? stat($topdir) : lstat($topdir))) - || (warn("Can't stat $topdir: $!\n"), next); - if (-d _) { - if (chdir($topdir)) { - $prune = 0; - unless ($bydepth) { - ($dir,$_) = ($topdir,'.'); - $name = $topdir; - $wanted->{wanted}->(); - } - next if $prune; - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$fixtopdir,$topnlink, $bydepth); - if ($bydepth) { - ($dir,$_) = ($fixtopdir,'.'); - $name = $fixtopdir; - $wanted->{wanted}->(); - } +use strict; +my $Is_VMS; + +require File::Basename; + +my %SLnkSeen; +my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat); + +sub contract_name { + my ($cdir,$fn) = @_; + + return substr($cdir,0,rindex($cdir,'/')) if $fn eq '.'; + + $cdir = substr($cdir,0,rindex($cdir,'/')+1); + + $fn =~ s|^\./||; + + my $abs_name= $cdir . $fn; + + if (substr($fn,0,3) eq '../') { + do 1 while ($abs_name=~ s|/(?>[^/]+)/\.\./|/|); + } + + return $abs_name; +} + + +sub PathCombine($$) { + my ($Base,$Name) = @_; + my $AbsName; + + if (substr($Name,0,1) eq '/') { + $AbsName= $Name; + } + else { + $AbsName= contract_name($Base,$Name); + } + + # (simple) check for recursion + my $newlen= length($AbsName); + if ($newlen <= length($Base)) { + if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/') + && $AbsName eq substr($Base,0,$newlen)) + { + return undef; + } + } + return $AbsName; +} + +sub Follow_SymLink($) { + my ($AbsName) = @_; + + my ($NewName,$DEV, $INO); + ($DEV, $INO)= lstat $AbsName; + + while (-l _) { + if ($SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 2) { + die "$AbsName is encountered a second time"; } else { - warn "Can't cd to $topdir: $!\n"; + return undef; } } - else { - require File::Basename; - unless (($_,$dir) = File::Basename::fileparse($topdir)) { - ($dir,$_) = ('.', $topdir); + $NewName= PathCombine($AbsName, readlink($AbsName)); + unless(defined $NewName) { + if ($follow_skip < 2) { + die "$AbsName is a recursive symbolic link"; + } + else { + return undef; } - if (chdir($dir)) { - $name = $topdir; - $wanted->{wanted}->(); + } + else { + $AbsName= $NewName; + } + ($DEV, $INO) = lstat($AbsName); + return undef unless defined $DEV; # dangling symbolic link + } + + if ($full_check && $SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 1) { + die "$AbsName encountered a second time"; + } + else { + return undef; + } + } + + return $AbsName; +} + +use vars qw/ $dir $name $fullname $prune /; +sub _find_dir_symlnk($$$); +sub _find_dir($$$); + +sub _find_opt { + my $wanted = shift; + die "invalid top directory" unless defined $_[0]; + + my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd(); + my $cwd_untainted = $cwd; + $wanted_callback = $wanted->{wanted}; + $bydepth = $wanted->{bydepth}; + $no_chdir = $wanted->{no_chdir}; + $full_check = $wanted->{follow}; + $follow = $full_check || $wanted->{follow_fast}; + $follow_skip = $wanted->{follow_skip}; + $untaint = $wanted->{untaint}; + $untaint_pat = $wanted->{untaint_pattern}; + $untaint_skip = $wanted->{untaint_skip}; + + # for compatability reasons (find.pl, find2perl) + our ($topdir, $topdev, $topino, $topmode, $topnlink); + + # a symbolic link to a directory doesn't increase the link count + $avoid_nlink = $follow || $File::Find::dont_use_nlink; + + if ( $untaint ) { + $cwd_untainted= $1 if $cwd_untainted =~ m|$untaint_pat|; + die "insecure cwd in find(depth)" unless defined($cwd_untainted); + } + + my ($abs_dir, $Is_Dir); + + Proc_Top_Item: + foreach my $TOP (@_) { + my $top_item = $TOP; + $top_item =~ s|/$|| unless $top_item eq '/'; + $Is_Dir= 0; + + if ($follow) { + if (substr($top_item,0,1) eq '/') { + $abs_dir = $top_item; + } + elsif ($top_item eq '.') { + $abs_dir = $cwd; } + else { # care about any ../ + $abs_dir = contract_name("$cwd/",$top_item); + } + $abs_dir= Follow_SymLink($abs_dir); + unless (defined $abs_dir) { + warn "$top_item is a dangling symbolic link\n"; + next Proc_Top_Item; + } + if (-d _) { + _find_dir_symlnk($wanted, $abs_dir, $top_item); + $Is_Dir= 1; + } + } + else { # no follow + $topdir = $top_item; + ($topdev,$topino,$topmode,$topnlink) = lstat $top_item; + unless (defined $topnlink) { + warn "Can't stat $top_item: $!\n"; + next Proc_Top_Item; + } + if (-d _) { + $top_item =~ s/\.dir$// if $Is_VMS; + _find_dir($wanted, $top_item, $topnlink); + $Is_Dir= 1; + } else { - warn "Can't cd to $dir: $!\n"; + $abs_dir= $top_item; + } + } + + unless ($Is_Dir) { + unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { + ($dir,$_) = ('.', $top_item); + } + + $abs_dir = $dir; + if ($untaint) { + my $abs_dir_save = $abs_dir; + $abs_dir = $1 if $abs_dir =~ m|$untaint_pat|; + unless (defined $abs_dir) { + if ($untaint_skip == 0) { + die "directory $abs_dir_save is still tainted"; + } + else { + next Proc_Top_Item; + } + } + } + + unless ($no_chdir or chdir $abs_dir) { + warn "Couldn't chdir $abs_dir: $!\n"; + next Proc_Top_Item; + } + + $name = $abs_dir; + + &$wanted_callback; + + } + + $no_chdir or chdir $cwd_untainted; + } +} + +# API: +# $wanted +# $p_dir : "parent directory" +# $nlink : what came back from the stat +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir($$$) { + my ($wanted, $p_dir, $nlink) = @_; + my ($CdLvl,$Level) = (0,0); + my @Stack; + my @filenames; + my ($subcount,$sub_nlink); + my $SE= []; + my $dir_name= $p_dir; + my $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" ); + my $dir_rel= '.'; # directory name relative to current directory + + local ($dir, $name, $prune, *DIR); + + unless ($no_chdir or $p_dir eq '.') { + my $udir = $p_dir; + if ($untaint) { + $udir = $1 if $p_dir =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $p_dir is still tainted"; + } + else { + return; + } } } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + return; + } + } + + while (defined $SE) { + unless ($bydepth) { + $dir= $p_dir; + $name= $dir_name; + $_= ($no_chdir ? $dir_name : $dir_rel ); + # prune may happen here + $prune= 0; + &$wanted_callback; + next if $prune; + } + + # change to that directory + unless ($no_chdir or $dir_rel eq '.') { + my $udir= $dir_rel; + if ($untaint) { + $udir = $1 if $dir_rel =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory (" + . ($p_dir ne '/' ? $p_dir : '') + . "/) $dir_rel is still tainted"; + } + } + } + unless (chdir $udir) { + warn "Can't cd to (" + . ($p_dir ne '/' ? $p_dir : '') + . "/) $udir : $!\n"; + next; + } + $CdLvl++; + } + + $dir= $dir_name; + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_name : '.')) { + warn "Can't opendir($dir_name): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + if ($nlink == 2 && !$avoid_nlink) { + # This dir has no subdirectories. + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}$/; + + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + &$wanted_callback; + } + + } + else { + # This dir has subdirectories. + $subcount = $nlink - 2; + + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}$/; + if ($subcount > 0 || $avoid_nlink) { + # Seen all the subdirs? + # check for directoriness. + # stat is faster for a file in the current directory + $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3]; + + if (-d _) { + --$subcount; + $FN =~ s/\.dir$// if $Is_VMS; + push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink]; + } + else { + $name = $dir_pref . $FN; + $_= ($no_chdir ? $name : $FN); + &$wanted_callback; + } + } + else { + $name = $dir_pref . $FN; + $_= ($no_chdir ? $name : $FN); + &$wanted_callback; + } + } + } + if ($bydepth) { + $name = $dir_name; + $dir = $p_dir; + $_ = ($no_chdir ? $dir_name : $dir_rel ); + &$wanted_callback; + } } continue { - chdir $cwd; + if ( defined ($SE = pop @Stack) ) { + ($Level, $p_dir, $dir_rel, $nlink) = @$SE; + if ($CdLvl > $Level && !$no_chdir) { + die "Can't cd to $dir_name" . '../' x ($CdLvl-$Level) + unless chdir '../' x ($CdLvl-$Level); + $CdLvl = $Level; + } + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + } } } -sub finddir { - my($wanted, $nlink, $bydepth); - local($dir, $name); - ($wanted, $dir, $nlink, $bydepth) = @_; - - my($dev, $ino, $mode, $subcount); - - # Get the list of files in the current directory. - opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return); - my(@filenames) = readdir(DIR); - closedir(DIR); - - if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $name = "$dir/$_"; - $nlink = 0; - $wanted->{wanted}->(); - } - } - else { # This dir has subdirectories. - $subcount = $nlink - 2; - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $nlink = 0; - $prune = 0 unless $bydepth; - $name = "$dir/$_"; - $wanted->{wanted}->() unless $bydepth; - if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? - - # Get link count and check for directoriness. - - $_ = "" if (!defined($_)); - ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); - # unless ($nlink || $dont_use_nlink); - - if (-d _) { - - # It really is a directory, so do it recursively. - - --$subcount; - next if $prune; - if (chdir $_) { - $name =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$name,$nlink, $bydepth); - chdir '..'; + +# API: +# $wanted +# $dir_loc : absolute location of a dir +# $p_dir : "parent directory" +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir_symlnk($$$) { + my ($wanted, $dir_loc, $p_dir) = @_; + my @Stack; + my @filenames; + my $new_loc; + my $SE = []; + my $dir_name = $p_dir; + my $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" ); + my $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" ); + my $dir_rel = '.'; # directory name relative to current directory + + local ($dir, $name, $fullname, $prune, *DIR); + + unless ($no_chdir or $p_dir eq '.') { + my $udir = $dir_loc; + if ($untaint) { + $udir = $1 if $dir_loc =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + return; + } + } + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + return; + } + } + + while (defined $SE) { + + unless ($bydepth) { + $dir= $p_dir; + $name= $dir_name; + $_= ($no_chdir ? $dir_name : $dir_rel ); + $fullname= $dir_loc; + # prune may happen here + $prune= 0; + &$wanted_callback; + next if $prune; + } + + # change to that directory + unless ($no_chdir or $dir_rel eq '.') { + my $udir = $dir_loc; + if ($untaint) { + $udir = $1 if $dir_loc =~ m|$untaint_pat|; + unless (defined $udir ) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; } else { - warn "Can't cd to $_: $!\n"; + next; } } } - $wanted->{wanted}->() if $bydepth; + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } + + $dir = $dir_name; + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_loc : '.')) { + warn "Can't opendir($dir_loc): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}$/; + + # follow symbolic links / do an lstat + $new_loc = Follow_SymLink($loc_pref.$FN); + + # ignore if invalid symlink + next unless defined $new_loc; + + if (-d _) { + push @Stack,[$new_loc,$dir_name,$FN]; + } + else { + $fullname = $new_loc; + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + &$wanted_callback; + } + } + + if ($bydepth) { + $fullname = $dir_loc; + $name = $dir_name; + $_ = ($no_chdir ? $dir_name : $dir_rel); + &$wanted_callback; + } + } + continue { + if (defined($SE = pop @Stack)) { + ($dir_loc, $p_dir, $dir_rel) = @$SE; + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + $loc_pref = "$dir_loc/"; } } } + sub wrap_wanted { - my $wanted = shift; - ref($wanted) eq 'HASH' ? $wanted : { wanted => $wanted }; + my $wanted = shift; + if ( ref($wanted) eq 'HASH' ) { + if ( $wanted->{follow} || $wanted->{follow_fast}) { + $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; + } + if ( $wanted->{untaint} ) { + $wanted->{untaint_pattern} = qr|^([-+@\w./]+)$| + unless defined $wanted->{untaint_pattern}; + $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; + } + return $wanted; + } + else { + return { wanted => $wanted }; + } } sub find { - my $wanted = shift; - find_opt(wrap_wanted($wanted), @_); + my $wanted = shift; + _find_opt(wrap_wanted($wanted), @_); + %SLnkSeen= (); # free memory } sub finddepth { - my $wanted = wrap_wanted(shift); - $wanted->{bydepth} = 1; - find_opt($wanted, @_); + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + _find_opt($wanted, @_); + %SLnkSeen= (); # free memory } # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { - $Is_VMS = 1; - $dont_use_nlink = 1; + $Is_VMS = 1; + $File::Find::dont_use_nlink = 1; } -$dont_use_nlink = 1 +$File::Find::dont_use_nlink = 1 if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; # Set dont_use_nlink in your hint file if your system's stat doesn't # report the number of links in a directory as an indication # of the number of files. # See, e.g. hints/machten.sh for MachTen 2.2. -unless ($dont_use_nlink) { - require Config; - $dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +unless ($File::Find::dont_use_nlink) { + require Config; + $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); } 1; - diff --git a/lib/File/Path.pm b/lib/File/Path.pm index a82fd8004e..634b2cd108 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -126,13 +126,15 @@ sub mkpath { my $parent = File::Basename::dirname($path); # Allow for creation of new logical filesystems under VMS if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { - push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + unless (-d $parent or $path eq $parent) { + push(@created,mkpath($parent, $verbose, $mode)); + } } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { - my $e = $!; - # allow for another process to have created it meanwhile - croak "mkdir $path: $e" unless -d $path; + my $e = $!; + # allow for another process to have created it meanwhile + croak "mkdir $path: $e" unless -d $path; } push(@created, $path); } diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index b71e357cdc..40f5345140 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -86,4 +86,7 @@ Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty <F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. VMS support by Charles Bailey <F<bailey@newman.upenn.edu>>. OS/2 support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Mac support by Paul Schinder -<F<schinder@pobox.com>>. +<F<schinder@pobox.com>>. abs2rel() and rel2abs() written by +Shigio Yamaguchi <F<shigio@tamacom.com>>, modified by Barrie Slaymaker +<F<barries@slaysys.com>>. splitpath(), splitdir(), catpath() and catdir() +by Barrie Slaymaker. diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index 87ad643fe2..85df2c2d3b 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -41,7 +41,7 @@ ricochet (some scripts depend on it). sub canonpath { my ($self,$path,$reduce_ricochet) = @_; - $path =~ s|/+|/|g unless($^O =~ /cygwin/); # xx////xx -> xx/xx + $path =~ s|/+|/|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx $path =~ s|^/(\.\./)+|/|; # /../../xx -> xx diff --git a/lib/FindBin.pm b/lib/FindBin.pm index 9e1c0a06bf..9d35f6f9c9 100644 --- a/lib/FindBin.pm +++ b/lib/FindBin.pm @@ -82,7 +82,7 @@ use File::Spec; %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); @ISA = qw(Exporter); -$VERSION = $VERSION = "1.42"; +$VERSION = "1.42"; BEGIN { diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm index 390bf14e96..e027bad3d2 100644 --- a/lib/Getopt/Std.pm +++ b/lib/Getopt/Std.pm @@ -42,7 +42,7 @@ the argument or 1 if no argument is specified. @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); -$VERSION = $VERSION = '1.01'; +$VERSION = '1.01'; # Process single-character switches with switch clustering. Pass one argument # which is a string containing all switches that take an argument. For each diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index 8aa6a6604b..1a9195e185 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -240,12 +240,13 @@ sub fcmp #(fnum_str, fnum_str) return cond_code if ($x eq "NaN" || $y eq "NaN") { undef; } else { + local($xm,$xe,$ym,$ye) = split('E', $x."E$y"); + if ($xm eq '+0' || $ym eq '+0') { + return $xm <=> $ym; + } ord($y) <=> ord($x) - || - ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"), - (($xe <=> $ye) * (substr($x,$[,1).'1') - || Math::BigInt::cmp($xm,$ym)) - ); + || ($xe <=> $ye) * (substr($x,$[,1).'1') + || Math::BigInt::cmp($xm,$ym); } } diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 5b69039afc..b339573bc9 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -1746,7 +1746,7 @@ Whatever it is, it does not manifest itself anywhere else where Perl runs. =head1 AUTHORS -Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>> and +Raphael Manfredi <F<Raphael_Manfredi@pobox.com>> and Jarkko Hietaniemi <F<jhi@iki.fi>>. Extensive patches by Daniel S. Lewart <F<d-lewart@uiuc.edu>>. diff --git a/lib/Math/Trig.pm b/lib/Math/Trig.pm index d987b5cc76..c659137eba 100644 --- a/lib/Math/Trig.pm +++ b/lib/Math/Trig.pm @@ -435,7 +435,7 @@ an answer instead of giving a fatal runtime error. =head1 AUTHORS Jarkko Hietaniemi <F<jhi@iki.fi>> and -Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>>. +Raphael Manfredi <F<Raphael_Manfredi@pobox.com>>. =cut diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 495b82f95b..54540601d3 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -4,7 +4,7 @@ package Net::Ping; # # Authors of the original pingecho(): # karrer@bernina.ethz.ch (Andreas Karrer) -# pmarquess@bfsec.bt.co.uk (Paul Marquess) +# Paul.Marquess@btinternet.com (Paul Marquess) # # Copyright (c) 1996 Russell Mosemann. All rights reserved. This # program is free software; you may redistribute it and/or modify it diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index e9c640cf5d..15757ec80d 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -1487,7 +1487,7 @@ sub process_L { if (m,^(.*?)/"?(.*?)"?$,) { # yes ($page, $section) = ($1, $2); } else { # no - ($page, $section) = ($str, ""); + ($page, $section) = ($_, ""); } # check if we know that this is a section in this page diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm index 87de42efb3..9aadd42dea 100644 --- a/lib/Pod/Man.pm +++ b/lib/Pod/Man.pm @@ -338,9 +338,10 @@ sub initialize { # but we shouldn't need that any more. Get the version from the running # Perl. if (!defined $$self{release}) { - my ($version, $patch) = ($] =~ /^(.{5})(\d{2})?/); - $$self{release} = "perl $version"; - $$self{release} .= ", patch $patch" if $patch; + my ($rev, $ver, $sver) = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/); + $sver ||= 0; $sver *= 10 ** (3-length($sver)); + $rev += 0; $ver += 0; $sver += 0; + $$self{release} = "perl v$rev.$ver.$sver"; } # Double quotes in things that will be quoted. diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm index e96822e414..4d93f91f9e 100644 --- a/lib/Sys/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -65,6 +65,10 @@ sub hostname { chomp($host = `hostname 2> NUL`) unless defined $host; return $host; } + elsif ($^O eq 'epoc') { + $host = 'localhost'; + return $host; + } else { # Unix # method 2 - syscall is preferred since it avoids tainting problems diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index 3f34c3b81f..5ef83c4781 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -1,7 +1,8 @@ package Tie::Array; use vars qw($VERSION); use strict; -$VERSION = '1.00'; +use Carp; +$VERSION = '1.01'; # Pod documentation after __END__ below. @@ -74,6 +75,16 @@ sub SPLICE return @result; } +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg dosn't define an EXISTS method"; +} + +sub DELETE { + my $pkg = ref $_[0]; + croak "$pkg dosn't define a DELETE method"; +} + package Tie::StdArray; use vars qw(@ISA); @ISA = 'Tie::Array'; @@ -88,6 +99,8 @@ sub POP { pop(@{$_[0]}) } sub PUSH { my $o = shift; push(@$o,@_) } sub SHIFT { shift(@{$_[0]}) } sub UNSHIFT { my $o = shift; unshift(@$o,@_) } +sub EXISTS { exists $_[0]->[$_[1]] } +sub DELETE { delete $_[0]->[$_[1]] } sub SPLICE { @@ -120,6 +133,8 @@ Tie::Array - base class for tied arrays sub STORE { ... } # mandatory if elements writeable sub STORESIZE { ... } # mandatory if elements can be added/deleted + sub EXISTS { ... } # mandatory if exists() expected to work + sub DELETE { ... } # mandatory if delete() expected to work # optional methods - for efficiency sub CLEAR { ... } @@ -150,9 +165,11 @@ Tie::Array - base class for tied arrays This module provides methods for array-tying classes. See L<perltie> for a list of the functions required in order to tie an array -to a package. The basic B<Tie::Array> package provides stub C<DELETE> -and C<EXTEND> methods, and implementations of C<PUSH>, C<POP>, C<SHIFT>, -C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, +to a package. The basic B<Tie::Array> package provides stub C<DESTROY>, +and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS> +methods that croak() if the delete() or exists() builtins are ever called +on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>, +C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, C<FETCHSIZE>, C<STORESIZE>. The B<Tie::StdArray> package provides efficient methods required for tied arrays @@ -203,6 +220,18 @@ deleted. Informative call that array is likely to grow to have I<count> entries. Can be used to optimize allocation. This method need do nothing. +=item EXISTS this, key + +Verify that the element at index I<key> exists in the tied array I<this>. + +The B<Tie::Array> implementation is a stub that simply croaks. + +=item DELETE this, key + +Delete the element at index I<key> from the tied array I<this>. + +The B<Tie::Array> implementation is a stub that simply croaks. + =item CLEAR this Clear (remove, delete, ...) all values from the tied array associated with diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 2902efb4d0..928b798e45 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -73,6 +73,8 @@ Return the next key for the hash. Verify that I<key> exists with the tied hash I<this>. +The B<Tie::Hash> implementation is a stub that simply croaks. + =item DELETE this, key Delete the key I<key> from the tied hash I<this>. diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 8cb6a96f5f..f3f6f542a6 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -5,6 +5,7 @@ use Carp; @ISA = qw( Exporter ); @EXPORT = qw( timegm timelocal ); +@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck ); # Set up constants $SEC = 1; @@ -17,6 +18,8 @@ use Carp; $breakpoint = ($thisYear + 50) % 100; $nextCentury += 100 if $breakpoint < 50; +my %options; + sub timegm { my (@date) = @_; if ($date[5] > 999) { @@ -35,6 +38,11 @@ sub timegm { + ($date[3]-1) * $DAY; } +sub timegm_nocheck { + local $options{no_range_check} = 1; + &timegm; +} + sub timelocal { my $t = &timegm; my $tt = $t; @@ -69,10 +77,15 @@ sub timelocal { $time; } +sub timelocal_nocheck { + local $options{no_range_check} = 1; + &timelocal; +} + sub cheat { $year = $_[5]; $month = $_[4]; - unless ($no_range_check) { + unless ($options{no_range_check}) { croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; @@ -138,27 +151,25 @@ the values provided. While the day of the month is expected to be in the range 1..31, the month should be in the range 0..11. This is consistent with the values returned from localtime() and gmtime(). -Also worth noting is the ability to disable the range checking that -would normally occur on the input $sec, $min, $hours, $mday, and $mon -values. You can do this by localizing $Time::Local::no_range_check -to 1. +The timelocal() and timegm() functions perform range checking on the +input $sec, $min, $hours, $mday, and $mon values by default. If you'd +rather they didn't, you can explicitly import the timelocal_nocheck() +and timegm_nocheck() functions. - use Time::Local; + use Time::Local 'timelocal_nocheck'; { - local $Time::Local::no_range_check = 1; - # The 365th day of 1999 - print scalar localtime timelocal 0,0,0,365,0,99; + print scalar localtime timelocal_nocheck 0,0,0,365,0,99; # The twenty thousandth day since 1970 - print scalar localtime timelocal 0,0,0,20000,0,70; + print scalar localtime timelocal_nocheck 0,0,0,20000,0,70; # And even the 10,000,000th second since 1999! - print scalar localtime timelocal 10000000,0,0,1,0,99; + print scalar localtime timelocal_nocheck 10000000,0,0,1,0,99; } -Your mileage may vary when trying this trick with minutes and hours, +Your mileage may vary when trying these with minutes and hours, and it doesn't work at all for months. Strictly speaking, the year should also be specified in a form consistent diff --git a/lib/bigfloat.pl b/lib/bigfloat.pl index 6af5f17303..8c28abdcd1 100644 --- a/lib/bigfloat.pl +++ b/lib/bigfloat.pl @@ -79,7 +79,12 @@ sub norm { #(mantissa, exponent) return fnum_str sub main'fneg { #(fnum_str) return fnum_str local($_) = &'fnorm($_[$[]); vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign - s/^H/N/; + if ( ord("\t") == 9 ) { # ascii + s/^H/N/; + } + else { # ebcdic character set + s/\373/N/; + } $_; } diff --git a/lib/byte.pm b/lib/byte.pm new file mode 100644 index 0000000000..cc23b40f4f --- /dev/null +++ b/lib/byte.pm @@ -0,0 +1,33 @@ +package byte; + +sub import { + $^H |= 0x00000010; +} + +sub unimport { + $^H &= ~0x00000010; +} + +sub AUTOLOAD { + require "byte_heavy.pl"; + goto &$AUTOLOAD; +} + +sub length ($); + +1; +__END__ + +=head1 NAME + +byte - Perl pragma to turn force treating strings as bytes not UNICODE + +=head1 SYNOPSIS + + use byte; + no byte; + +=head1 DESCRIPTION + + +=cut diff --git a/lib/byte_heavy.pl b/lib/byte_heavy.pl new file mode 100644 index 0000000000..07c908a689 --- /dev/null +++ b/lib/byte_heavy.pl @@ -0,0 +1,8 @@ +package byte; + +sub length ($) +{ + return CORE::length($_[0]); +} + +1; diff --git a/lib/constant.pm b/lib/constant.pm index 5d3dd91b46..31f47fbf54 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -1,6 +1,112 @@ package constant; -$VERSION = '1.00'; +use strict; +use vars qw( $VERSION %declared ); +$VERSION = '1.01'; + +#======================================================================= + +require 5.005_62; + +# Some names are evil choices. +my %keywords = map +($_, 1), qw{ BEGIN INIT STOP END DESTROY AUTOLOAD }; + +my %forced_into_main = map +($_, 1), + qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG }; + +my %forbidden = (%keywords, %forced_into_main); + +#======================================================================= +# import() - import symbols into user's namespace +# +# What we actually do is define a function in the caller's namespace +# which returns the value. The function we create will normally +# be inlined as a constant, thereby avoiding further sub calling +# overhead. +#======================================================================= +sub import { + my $class = shift; + return unless @_; # Ignore 'use constant;' + my $name = shift; + unless (defined $name) { + require Carp; + Carp::croak("Can't use undef as constant name"); + } + my $pkg = caller; + + # Normal constant name + if ($name =~ /^(?:[A-Z]\w|_[A-Z])\w*\z/ and !$forbidden{$name}) { + # Everything is okay + + # Name forced into main, but we're not in main. Fatal. + } elsif ($forced_into_main{$name} and $pkg ne 'main') { + require Carp; + Carp::croak("Constant name '$name' is forced into main::"); + + # Starts with double underscore. Fatal. + } elsif ($name =~ /^__/) { + require Carp; + Carp::croak("Constant name '$name' begins with '__'"); + + # Maybe the name is tolerable + } elsif ($name =~ /^[A-Za-z_]\w*\z/) { + # Then we'll warn only if you've asked for warnings + if ($^W) { + require Carp; + if ($keywords{$name}) { + Carp::carp("Constant name '$name' is a Perl keyword"); + } elsif ($forced_into_main{$name}) { + Carp::carp("Constant name '$name' is " . + "forced into package main::"); + } elsif (1 == length $name) { + Carp::carp("Constant name '$name' is too short"); + } elsif ($name =~ /^_?[a-z\d]/) { + Carp::carp("Constant name '$name' should " . + "have an initial capital letter"); + } else { + # Catch-all - what did I miss? If you get this error, + # please let me know what your constant's name was. + # Write to <rootbeer@redcat.com>. Thanks! + Carp::carp("Constant name '$name' has unknown problems"); + } + } + + # Looks like a boolean + # use constant FRED == fred; + } elsif ($name =~ /^[01]?\z/) { + require Carp; + if (@_) { + Carp::croak("Constant name '$name' is invalid"); + } else { + Carp::croak("Constant name looks like boolean value"); + } + + } else { + # Must have bad characters + require Carp; + Carp::croak("Constant name '$name' has invalid characters"); + } + + { + no strict 'refs'; + my $full_name = "${pkg}::$name"; + $declared{$full_name}++; + if (@_ == 1) { + my $scalar = $_[0]; + *$full_name = sub () { $scalar }; + } elsif (@_) { + my @list = @_; + *$full_name = sub () { @list }; + } else { + *$full_name = sub () { }; + } + } + +} + +1; + +__END__ =head1 NAME @@ -20,7 +126,7 @@ constant - Perl pragma to declare constants print "This line does nothing" unless DEBUGGING; - # references can be declared constant + # references can be constants use constant CHASH => { foo => 42 }; use constant CARRAY => [ 1,2,3,4 ]; use constant CPSEUDOHASH => [ { foo => 1}, 42 ]; @@ -30,7 +136,7 @@ constant - Perl pragma to declare constants print CARRAY->[$i]; print CPSEUDOHASH->{foo}; print CCODE->("me"); - print CHASH->[10]; # compile-time error + print CHASH->[10]; # compile-time error =head1 DESCRIPTION @@ -63,7 +169,10 @@ List constants are returned as lists, not as arrays. The use of all caps for constant names is merely a convention, although it is recommended in order to make constants stand out and to help avoid collisions with other barewords, keywords, and -subroutine names. Constant names must begin with a letter. +subroutine names. Constant names must begin with a letter or +underscore. Names beginning with a double underscore are reserved. Some +poor choices for names will generate warnings, if warnings are enabled at +compile time. Constant symbols are package scoped (rather than block scoped, as C<use strict> is). That is, you can refer to a constant from package @@ -98,7 +207,24 @@ constants at compile time, allowing for way cool stuff like this. print E2BIG, "\n"; # something like "Arg list too long" print 0+E2BIG, "\n"; # "7" -Errors in dereferencing constant references are trapped at compile-time. +Dereferencing constant references incorrectly (such as using an array +subscript on a constant hash reference, or vice versa) will be trapped at +compile time. + +In the rare case in which you need to discover at run time whether a +particular constant has been declared via this module, you may use +this function to examine the hash C<%constant::declared>. If the given +constant name does not include a package name, the current package is +used. + + sub declared ($) { + use constant 1.01; # don't omit this! + my $name = shift; + $name =~ s/^::/main::/; + my $pkg = caller; + my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; + $constant::declared{$full_name}; + } =head1 TECHNICAL NOTE @@ -115,7 +241,19 @@ In the current version of Perl, list constants are not inlined and some symbols may be redefined without generating a warning. It is not possible to have a subroutine or keyword with the same -name as a constant. This is probably a Good Thing. +name as a constant in the same package. This is probably a Good Thing. + +A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT +ENV INC SIG> is not allowed anywhere but in package C<main::>, for +technical reasons. + +Even though a reference may be declared as a constant, the reference may +point to data which may be changed, as this code shows. + + use constant CARRAY => [ 1,2,3,4 ]; + print CARRAY->[1]; + CARRAY->[1] = " be changed"; + print CARRAY->[1]; Unlike constants in some languages, these cannot be overridden on the command line or via environment variables. @@ -126,61 +264,20 @@ For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will be interpreted as a string. Use C<$hash{CONSTANT()}> or C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from kicking in. Similarly, since the C<=E<gt>> operator quotes a bareword -immediately to its left you have to say C<CONSTANT() =E<gt> 'value'> -instead of C<CONSTANT =E<gt> 'value'>. +immediately to its left, you have to say C<CONSTANT() =E<gt> 'value'> +(or simply use a comma in place of the big arrow) instead of +C<CONSTANT =E<gt> 'value'>. =head1 AUTHOR -Tom Phoenix, E<lt>F<rootbeer@teleport.com>E<gt>, with help from +Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from many other folks. =head1 COPYRIGHT -Copyright (C) 1997, Tom Phoenix +Copyright (C) 1997, 1999 Tom Phoenix This module is free software; you can redistribute it or modify it under the same terms as Perl itself. =cut - -use strict; -use Carp; -use vars qw($VERSION); - -#======================================================================= - -# Some of this stuff didn't work in version 5.003, alas. -require 5.003_96; - -#======================================================================= -# import() - import symbols into user's namespace -# -# What we actually do is define a function in the caller's namespace -# which returns the value. The function we create will normally -# be inlined as a constant, thereby avoiding further sub calling -# overhead. -#======================================================================= -sub import { - my $class = shift; - my $name = shift or return; # Ignore 'use constant;' - croak qq{Can't define "$name" as constant} . - qq{ (name contains invalid characters or is empty)} - unless $name =~ /^[^\W_0-9]\w*$/; - - my $pkg = caller; - { - no strict 'refs'; - if (@_ == 1) { - my $scalar = $_[0]; - *{"${pkg}::$name"} = sub () { $scalar }; - } elsif (@_) { - my @list = @_; - *{"${pkg}::$name"} = sub () { @list }; - } else { - *{"${pkg}::$name"} = sub () { }; - } - } - -} - -1; diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index d405e3673e..e6a9127158 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -167,9 +167,11 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. =cut -require 5.001; +require 5.005_64; use Carp; +$VERSION = v1.0; + use Config; ($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; if ($^O eq 'VMS') { @@ -179,10 +181,10 @@ if ($^O eq 'VMS') { } @trypod = ( "$archlib/pod/perldiag.pod", - "$privlib/pod/perldiag-$].pod", + "$privlib/pod/perldiag-$Config{version}.pod", "$privlib/pod/perldiag.pod", "$archlib/pods/perldiag.pod", - "$privlib/pods/perldiag-$].pod", + "$privlib/pods/perldiag-$Config{version}.pod", "$privlib/pods/perldiag.pod", ); # handy for development testing of new warnings etc @@ -333,7 +335,7 @@ EOFUNC # strip formatting directives in =item line ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; - if ($header =~ /%[sd]/) { + if ($header =~ /%[csd]/) { $rhs = $lhs = $header; #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { @@ -346,6 +348,7 @@ EOFUNC $lhs =~ s/\377//g; $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all } + $lhs =~ s/\\%c/./g; $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; } else { $transmo .= " m{^\Q$header\E} && return 1;\n"; @@ -376,7 +379,8 @@ if ($standalone) { } exit; } else { - $old_w = 0; $oldwarn = ''; $olddie = ''; + #$old_w = 0; + $oldwarn = ''; $olddie = ''; } sub import { diff --git a/lib/lib.pm b/lib/lib.pm index d35510df86..afc979bb45 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -4,6 +4,7 @@ use vars qw(@ORIG_INC); use Config; my $archname = $Config{'archname'}; +my $ver = $Config{'version'}; @ORIG_INC = @INC; # take a handy copy of 'original' value @@ -26,7 +27,7 @@ sub import { # looks like $_ has an archlib directory below it. if (-d "$_/$archname") { unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; - unshift(@INC, "$_/$archname/$]") if -d "$_/$archname/$]/auto"; + unshift(@INC, "$_/$archname/$ver") if -d "$_/$archname/$ver/auto"; } } diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 2314bf7c3d..d2bd98e654 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.0403; +$VERSION = 1.04041; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -76,6 +76,8 @@ $header = "perl5db.pl version $VERSION"; # LineInfo - file or pipe to print line number info to. If it is a # pipe, a short "emacs like" message is used. # +# RemotePort - host:port to connect to on remote host for remote debugging. +# # Example $rcfile: (delete leading hashes!) # # &parse_options("NonStop=1 LineInfo=db.out"); @@ -179,7 +181,8 @@ $inhibit_exit = $option{PrintRet} = 1; TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments signalLevel warnLevel dieLevel inhibit_exit - ImmediateStop bareStringify); + ImmediateStop bareStringify + RemotePort); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -197,6 +200,7 @@ $inhibit_exit = $option{PrintRet} = 1; inhibit_exit => \$inhibit_exit, maxTraceLen => \$maxtrace, ImmediateStop => \$ImmediateStop, + RemotePort => \$remoteport, ); %optionAction = ( @@ -216,6 +220,7 @@ $inhibit_exit = $option{PrintRet} = 1; dieLevel => \&dieLevel, tkRunning => \&tkRunning, ornaments => \&ornaments, + RemotePort => \&RemotePort, ); %optionRequire = ( @@ -296,7 +301,7 @@ if ($notty) { #require Term::ReadLine; - if ($^O =~ /cygwin/) { + if ($^O eq 'cygwin') { # /dev/tty is binary. use stdin for textmode undef $console; } elsif (-e "/dev/tty") { @@ -322,19 +327,30 @@ if ($notty) { $console = $tty if defined $tty; - if (defined $console) { - open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN"); - open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR") - || open(OUT,">&STDOUT"); # so we don't dongle stdout - } else { - open(IN,"<&STDIN"); - open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout - $console = 'STDIN/OUT'; + if (defined $remoteport) { + require IO::Socket; + $OUT = new IO::Socket::INET( Timeout => '10', + PeerAddr => $remoteport, + Proto => 'tcp', + ); + if (!$OUT) { die "Could not create socket to connect to remote host."; } + $IN = $OUT; } - # so open("|more") can read from STDOUT and so we don't dingle stdin - $IN = \*IN; + else { + if (defined $console) { + open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN"); + open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR") + || open(OUT,">&STDOUT"); # so we don't dongle stdout + } else { + open(IN,"<&STDIN"); + open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout + $console = 'STDIN/OUT'; + } + # so open("|more") can read from STDOUT and so we don't dingle stdin + $IN = \*IN; - $OUT = \*OUT; + $OUT = \*OUT; + } select($OUT); $| = 1; # for DB::OUT select(STDOUT); @@ -434,7 +450,7 @@ Debugged program terminated. Use B<q> to quit or B<R> to restart, B<h q>, B<h R> or B<h O> to get additional info. EOP $package = 'main'; - $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . + $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas } else { $sub =~ s/\'/::/; @@ -1525,7 +1541,15 @@ sub readline { } local $frame = 0; local $doret = -2; - $term->readline(@_); + if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { + print $OUT @_; + my $stuff; + $IN->recv( $stuff, 2048 ); + $stuff; + } + else { + $term->readline(@_); + } } sub dump_option { @@ -1673,6 +1697,14 @@ sub ReadLine { $rl; } +sub RemotePort { + if ($term) { + &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; + } + $remoteport = shift if @_; + $remoteport; +} + sub tkRunning { if ($ {$term->Features}{tkRunning}) { return $term->tkRunning(@_); @@ -1823,6 +1855,7 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity; I<inhibit_exit> Allows stepping off the end of the script. I<ImmediateStop> Debugger should stop as early as possible. + I<RemotePort>: Remote hostname:port for remote debugging The following options affect what happens with B<V>, B<X>, and B<x> commands: I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all); I<compactDump>, I<veryCompact>: change style of array and hash dump; @@ -1839,7 +1872,8 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... I<ornaments> affects screen appearance of the command line. During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options I<TTY>, I<noTTY>, - I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them). + I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use + `B<R>' after you set them). B<<> I<expr> Define Perl command to run before each prompt. B<<<> I<expr> Add to the list of Perl commands to run before each prompt. B<>> I<expr> Define Perl command to run after each prompt. diff --git a/lib/strict.pm b/lib/strict.pm index 940e8bf7ff..99ed01d583 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -56,6 +56,9 @@ L<perlfunc/local>. The local() generated a compile-time error because you just touched a global name without fully qualifying it. +Because of their special use by sort(), the variables $a and $b are +exempted from this check. + =item C<strict subs> This disables the poetry optimization, generating a compile-time error if diff --git a/lib/unicode/UnicodeData-Latest.txt b/lib/unicode/Unicode.300 index 6a54d3d74e..6a54d3d74e 100644 --- a/lib/unicode/UnicodeData-Latest.txt +++ b/lib/unicode/Unicode.300 |