diff options
| author | Gurusamy Sarathy <gsar@cpan.org> | 1998-05-18 09:40:58 +0000 |
|---|---|---|
| committer | Gurusamy Sarathy <gsar@cpan.org> | 1998-05-18 09:40:58 +0000 |
| commit | 3666098248b43282bda1153dae2f4c1e4af38d09 (patch) | |
| tree | 9c69a323f89cdd81b231dc630b0eaf134225da7a /lib | |
| parent | 9e6b2b00f0190751b970ece3db7033405cb08ca5 (diff) | |
| parent | d2719217c9b7910115cef7ea0c16d68e6b286cf7 (diff) | |
| download | perl-3666098248b43282bda1153dae2f4c1e4af38d09.tar.gz | |
[asperl] integrate mainline changes (untested)
p4raw-id: //depot/asperl@1010
Diffstat (limited to 'lib')
39 files changed, 1221 insertions, 733 deletions
diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index df54f15d36..471499adcb 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -1,12 +1,17 @@ package AutoSplit; -require 5.000; -require Exporter; - -use Config; -use Carp; +use Exporter (); +use Config qw(%Config); +use Carp qw(carp); +use File::Basename (); use File::Path qw(mkpath); +use strict; +use vars qw( + $VERSION @ISA @EXPORT @EXPORT_OK + $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime + ); +$VERSION = "1.0302"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -17,13 +22,9 @@ AutoSplit - split a package for autoloading =head1 SYNOPSIS - perl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... - - use AutoSplit; autosplit($file, $dir, $keep, $check, $modtime); - -for perl versions 5.002 and later: + autosplit($file, $dir, $keep, $check, $modtime); - perl -MAutoSplit -e 'autosplit($ARGV[0], $ARGV[1], $k, $chk, $modtime)' ... + autosplit_lib_modules(@modules); =head1 DESCRIPTION @@ -37,16 +38,36 @@ class hierarchy, and creates the file F<autosplit.ix>. This file acts as both forward declaration of all package routines, and as timestamp for the last update of the hierarchy. -The remaining three arguments to C<autosplit> govern other options to the -autosplitter. If the third argument, I<$keep>, is false, then any pre-existing -C<*.al> files in the autoload directory are removed if they are no longer -part of the module (obsoleted functions). The fourth argument, I<$check>, -instructs C<autosplit> to check the module currently being split to ensure -that it does include a C<use> specification for the AutoLoader module, and -skips the module if AutoLoader is not detected. Lastly, the I<$modtime> -argument specifies that C<autosplit> is to check the modification time of the -module against that of the C<autosplit.ix> file, and only split the module -if it is newer. +The remaining three arguments to C<autosplit> govern other options to +the autosplitter. + +=over 2 + +=item $keep + +If the third argument, I<$keep>, is false, then any +pre-existing C<*.al> files in the autoload directory are removed if +they are no longer part of the module (obsoleted functions). +$keep defaults to 0. + +=item $check + +The +fourth argument, I<$check>, instructs C<autosplit> to check the module +currently being split to ensure that it does include a C<use> +specification for the AutoLoader module, and skips the module if +AutoLoader is not detected. +$check defaults to 1. + +=item $modtime + +Lastly, the I<$modtime> argument specifies +that C<autosplit> is to check the modification time of the module +against that of the C<autosplit.ix> file, and only split the module if +it is newer. +$modtime defaults to 1. + +=back Typical use of AutoSplit in the perl MakeMaker utility is via the command-line with: @@ -65,33 +86,49 @@ B<lib> relative to the current directory. Each file is sent to the autosplitter one at a time, to be split into the directory B<lib/auto>. In both usages of the autosplitter, only subroutines defined following the -perl special marker I<__END__> are split out into separate files. Some +perl I<__END__> token are split out into separate files. Some routines may be placed prior to this marker to force their immediate loading and parsing. -=head1 CAVEATS +=head2 Multiple packages + +As of version 1.01 of the AutoSplit module it is possible to have +multiple packages within a single file. Both of the following cases +are supported: + + package NAME; + __END__ + sub AAA { ... } + package NAME::option1; + sub BBB { ... } + package NAME::option2; + sub BBB { ... } -Currently, C<AutoSplit> cannot handle multiple package specifications -within one file. + package NAME; + __END__ + sub AAA { ... } + sub NAME::option1::BBB { ... } + sub NAME::option2::BBB { ... } =head1 DIAGNOSTICS -C<AutoSplit> will inform the user if it is necessary to create the top-level -directory specified in the invocation. It is preferred that the script or -installation process that invokes C<AutoSplit> have created the full directory -path ahead of time. This warning may indicate that the module is being split -into an incorrect path. +C<AutoSplit> will inform the user if it is necessary to create the +top-level directory specified in the invocation. It is preferred that +the script or installation process that invokes C<AutoSplit> have +created the full directory path ahead of time. This warning may +indicate that the module is being split into an incorrect path. -C<AutoSplit> will warn the user of all subroutines whose name causes potential -file naming conflicts on machines with drastically limited (8 characters or -less) file name length. Since the subroutine name is used as the file name, -these warnings can aid in portability to such systems. +C<AutoSplit> will warn the user of all subroutines whose name causes +potential file naming conflicts on machines with drastically limited +(8 characters or less) file name length. Since the subroutine name is +used as the file name, these warnings can aid in portability to such +systems. -Warnings are issued and the file skipped if C<AutoSplit> cannot locate either -the I<__END__> marker or a "package Name;"-style specification. +Warnings are issued and the file skipped if C<AutoSplit> cannot locate +either the I<__END__> marker or a "package Name;"-style specification. -C<AutoSplit> will also emit general diagnostics for inability to create -directories or files. +C<AutoSplit> will also emit general diagnostics for inability to +create directories or files. =cut @@ -102,21 +139,21 @@ $Keep = 0; $CheckForAutoloader = 1; $CheckModTime = 1; -$IndexFile = "autosplit.ix"; # file also serves as timestamp -$maxflen = 255; +my $IndexFile = "autosplit.ix"; # file also serves as timestamp +my $maxflen = 255; $maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; if (defined (&Dos::UseLFN)) { $maxflen = Dos::UseLFN() ? 255 : 11; } -$Is_VMS = ($^O eq 'VMS'); +my $Is_VMS = ($^O eq 'VMS'); sub autosplit{ - my($file, $autodir, $k, $ckal, $ckmt) = @_; + my($file, $autodir, $keep, $ckal, $ckmt) = @_; # $file - the perl source file to be split (after __END__) # $autodir - the ".../auto" dir below which to write split subs # Handle optional flags: - $keep = $Keep unless defined $k; + $keep = $Keep unless defined $keep; $ckal = $CheckForAutoloader unless defined $ckal; $ckmt = $CheckModTime unless defined $ckmt; autosplit_file($file, $autodir, $keep, $ckal, $ckmt); @@ -139,7 +176,8 @@ sub autosplit_lib_modules{ $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } - autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime); + autosplit_file("lib/$_", "lib/auto", + $Keep, $CheckForAutoloader, $CheckModTime); } 0; } @@ -147,60 +185,64 @@ sub autosplit_lib_modules{ # private functions -sub autosplit_file{ - my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; - my(@names); +sub autosplit_file { + my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) + = @_; + my(@outfiles); local($_); + local($/) = "\n"; # where to write output files - $autodir = "lib/auto" unless $autodir; + $autodir ||= "lib/auto"; if ($Is_VMS) { - ($autodir = VMS::Filespec::unixpath($autodir)) =~ s{/$}{}; + ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/$||; $filename = VMS::Filespec::unixify($filename); # may have dirs } unless (-d $autodir){ mkpath($autodir,0,0755); - # We should never need to create the auto dir here. installperl - # (or similar) should have done it. Expecting it to exist is a valuable - # sanity check against autosplitting into some random directory by mistake. - print "Warning: AutoSplit had to create top-level $autodir unexpectedly.\n"; + # We should never need to create the auto dir + # here. installperl (or similar) should have done + # it. Expecting it to exist is a valuable sanity check against + # autosplitting into some random directory by mistake. + print "Warning: AutoSplit had to create top-level " . + "$autodir unexpectedly.\n"; } # allow just a package name to be used $filename .= ".pm" unless ($filename =~ m/\.pm$/); - open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n"; + open(IN, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; my($pm_mod_time) = (stat($filename))[9]; my($autoloader_seen) = 0; my($in_pod) = 0; + my($def_package,$last_package,$this_package,$fnr); while (<IN>) { # Skip pod text. + $fnr++; $in_pod = 1 if /^=/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # record last package name seen - $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); + $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; last if /^__END__/; } if ($check_for_autoloader && !$autoloader_seen){ - print "AutoSplit skipped $filename: no AutoLoader used\n" if ($Verbose>=2); - return 0 + print "AutoSplit skipped $filename: no AutoLoader used\n" + if ($Verbose>=2); + return 0; } $_ or die "Can't find __END__ in $filename\n"; - $package or die "Can't find 'package Name;' in $filename\n"; + $def_package or die "Can't find 'package Name;' in $filename\n"; - my($modpname) = $package; - if ($^O eq 'MSWin32') { - $modpname =~ s#::#\\#g; - } else { - $modpname =~ s#::#/#g; - } + my($modpname) = _modpname($def_package); - die "Package $package ($modpname.pm) does not match filename $filename" + # this _has_ to match so we have a reasonable timestamp file + die "Package $def_package ($modpname.pm) does not ". + "match filename $filename" unless ($filename =~ m/\Q$modpname.pm\E$/ or ($^O eq 'dos') or ($^O eq 'MSWin32') or $Is_VMS && $filename =~ m/$modpname.pm/i); @@ -210,14 +252,13 @@ sub autosplit_file{ if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; if ($al_ts_time >= $pm_mod_time){ - print "AutoSplit skipped ($al_idx_file newer that $filename)\n" + print "AutoSplit skipped ($al_idx_file newer than $filename)\n" if ($Verbose >= 2); return undef; # one undef, not a list } } - my($from) = ($Verbose>=2) ? "$filename => " : ""; - print "AutoSplitting $package ($from$autodir/$modpname)\n" + print "AutoSplitting $filename ($autodir/$modpname)\n" if $Verbose; unless (-d "$autodir/$modpname"){ @@ -231,69 +272,71 @@ sub autosplit_file{ # This is a problem because some systems silently truncate the file # names while others treat long file names as an error. - # We do not yet deal with multiple packages within one file. - # Ideally both of these styles should work. - # - # package NAME; - # __END__ - # sub AAA { ... } - # package NAME::option1; - # sub BBB { ... } - # package NAME::option2; - # sub BBB { ... } - # - # package NAME; - # __END__ - # sub AAA { ... } - # sub NAME::option1::BBB { ... } - # sub NAME::option2::BBB { ... } - # - # For now both of these produce warnings. - my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames - open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning - my(@subnames, %proto); + my(@subnames, $subname, %proto, %package); my @cache = (); my $caching = 1; + $last_package = ''; while (<IN>) { - next if /^=\w/ .. /^=cut/; - if (/^package ([\w:]+)\s*;/) { - warn "package $1; in AutoSplit section ignored. Not currently supported."; + $fnr++; + $in_pod = 1 if /^=/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); + # the following (tempting) old coding gives big troubles if a + # cut is forgotten at EOF: + # next if /^=\w/ .. /^=cut/; + if (/^package\s+([\w:]+)\s*;/) { + $this_package = $def_package = $1; } if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) { - print OUT "1;\n"; - my $subname = $1; - $proto{$1} = $2 || ''; - if ($subname =~ m/::/){ - warn "subs with package names not currently supported in AutoSplit section"; + print OUT "# end of $last_package\::$subname\n1;\n" + if $last_package; + $subname = $1; + my $proto = $2 || ''; + if ($subname =~ s/(.*):://){ + $this_package = $1; + } else { + $this_package = $def_package; } - push(@subnames, $subname); + my $fq_subname = "$this_package\::$subname"; + $package{$fq_subname} = $this_package; + $proto{$fq_subname} = $proto; + push(@subnames, $fq_subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); + $modpname = _modpname($this_package); + mkpath("$autodir/$modpname",0,0777); my($lpath) = "$autodir/$modpname/$lname.al"; my($spath) = "$autodir/$modpname/$sname.al"; - unless(open(OUT, ">$lpath")){ - open(OUT, ">$spath") or die "Can't create $spath: $!\n"; - push(@names, $Is83 ? lc $sname : $sname); - print " writing $spath (with truncated name)\n" if ($Verbose>=1); - }else{ - push(@names, $Is83 ? lc substr ($lname,0,8) : $lname); + my $path; + if (!$Is83 and open(OUT, ">$lpath")){ + $path=$lpath; print " writing $lpath\n" if ($Verbose>=2); + } else { + open(OUT, ">$spath") or die "Can't create $spath: $!\n"; + $path=$spath; + print " writing $spath (with truncated name)\n" + if ($Verbose>=1); } - print OUT "# NOTE: Derived from $filename. ", - "Changes made here will be lost.\n"; - print OUT "package $package;\n\n"; + push(@outfiles, $path); + print OUT <<EOT; +# NOTE: Derived from $filename. +# Changes made here will be lost when autosplit again. +# See AutoSplit.pm. +package $this_package; + +#line $fnr "$filename (autosplit into $path)" +EOT print OUT @cache; @cache = (); $caching = 0; } if($caching) { push(@cache, $_) if @cache || /\S/; - } - else { + } else { print OUT $_; } - if(/^}/) { + if(/^\}/) { if($caching) { print OUT @cache; @cache = (); @@ -301,70 +344,118 @@ sub autosplit_file{ print OUT "\n"; $caching = 1; } + $last_package = $this_package if defined $this_package; } - print OUT @cache,"1;\n"; + print OUT @cache,"1;\n# end of $last_package\::$subname\n"; close(OUT); close(IN); - + if (!$keep){ # don't keep any obsolete *.al files in the directory - my(%names); - @names{@names} = @names; - opendir(OUTDIR,"$autodir/$modpname"); - foreach(sort readdir(OUTDIR)){ - next unless /\.al$/; - my($subname) = m/(.*)\.al$/; - next if $names{substr($subname,0,$maxflen-3)}; - next if ($Is83 && $names{lc substr($subname,0,8)}); - my($file) = "$autodir/$modpname/$_"; - print " deleting $file\n" if ($Verbose>=2); - my($deleted,$thistime); # catch all versions on VMS - do { $deleted += ($thistime = unlink $file) } while ($thistime); - carp "Unable to delete $file: $!" unless $deleted; + my(%outfiles); + # @outfiles{@outfiles} = @outfiles; + # perl downcases all filenames on VMS (which upcases all filenames) so + # we'd better downcase the sub name list too, or subs with upper case + # letters in them will get their .al files deleted right after they're + # created. (The mixed case sub name wonn't match the all-lowercase + # filename, and so be cleaned up as a scrap file) + if ($Is_VMS or $Is83) { + %outfiles = map {lc($_) => lc($_) } @outfiles; + } else { + @outfiles{@outfiles} = @outfiles; + } + my(%outdirs,@outdirs); + for (@outfiles) { + $outdirs{File::Basename::dirname($_)}||=1; + } + for my $dir (keys %outdirs) { + opendir(OUTDIR,$dir); + foreach (sort readdir(OUTDIR)){ + next unless /\.al$/; + my($file) = "$dir/$_"; + $file = lc $file if $Is83; + next if $outfiles{$file}; + print " deleting $file\n" if ($Verbose>=2); + my($deleted,$thistime); # catch all versions on VMS + do { $deleted += ($thistime = unlink $file) } while ($thistime); + carp "Unable to delete $file: $!" unless $deleted; + } + closedir(OUTDIR); } - closedir(OUTDIR); } open(TS,">$al_idx_file") or carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; - print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n"; - print TS "package $package;\n"; - print TS map("sub $_$proto{$_} ;\n", @subnames); + print TS "# Index created by AutoSplit for $filename\n"; + print TS "# (file acts as timestamp)\n"; + $last_package = ''; + for my $fqs (@subnames) { + my($subname) = $fqs; + $subname =~ s/.*:://; + print TS "package $package{$fqs};\n" + unless $last_package eq $package{$fqs}; + print TS "sub $subname $proto{$fqs};\n"; + $last_package = $package{$fqs}; + } print TS "1;\n"; close(TS); - check_unique($package, $Maxlen, 1, @names); + _check_unique($filename, $Maxlen, 1, @outfiles); - @names; + @outfiles; } +sub _modpname ($) { + my($package) = @_; + my $modpname = $package; + if ($^O eq 'MSWin32') { + $modpname =~ s#::#\\#g; + } else { + $modpname =~ s#::#/#g; + } + $modpname; +} -sub check_unique{ - my($module, $maxlen, $warn, @names) = @_; +sub _check_unique { + my($filename, $maxlen, $warn, @outfiles) = @_; my(%notuniq) = (); my(%shorts) = (); - my(@toolong) = grep(length > $maxlen, @names); - - foreach(@toolong){ - my($trunc) = substr($_,0,$maxlen); - $notuniq{$trunc}=1 if $shorts{$trunc}; - $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_; + my(@toolong) = grep( + length(File::Basename::basename($_)) + > $maxlen, + @outfiles + ); + + foreach (@toolong){ + my($dir) = File::Basename::dirname($_); + my($file) = File::Basename::basename($_); + my($trunc) = substr($file,0,$maxlen); + $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; + $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? + "$shorts{$dir}{$trunc}, $file" : $file; } if (%notuniq && $warn){ - print "$module: some names are not unique when truncated to $maxlen characters:\n"; - foreach(keys %notuniq){ - print " $shorts{$_} truncate to $_\n"; + print "$filename: some names are not unique when " . + "truncated to $maxlen characters:\n"; + foreach my $dir (sort keys %notuniq){ + print " directory $dir:\n"; + foreach my $trunc (sort keys %{$notuniq{$dir}}) { + print " $shorts{$dir}{$trunc} truncate to $trunc\n"; + } } } - %notuniq; } 1; __END__ # test functions so AutoSplit.pm can be applied to itself: -sub test1{ "test 1\n"; } -sub test2{ "test 2\n"; } -sub test3{ "test 3\n"; } -sub test4{ "test 4\n"; } - - +sub test1 ($) { "test 1\n"; } +sub test2 ($$) { "test 2\n"; } +sub test3 ($$$) { "test 3\n"; } +sub testtesttesttest4_1 { "test 4\n"; } +sub testtesttesttest4_2 { "duplicate test 4\n"; } +sub Just::Another::test5 { "another test 5\n"; } +sub test6 { return join ":", __FILE__,__LINE__; } +package Yet::Another::AutoSplit; +sub testtesttesttest4_1 ($) { "another test 4\n"; } +sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index e09bc92958..fe77dd0a61 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -82,6 +82,30 @@ Results will be printed to STDOUT as TITLE followed by the times. TITLE defaults to "timethis COUNT" if none is provided. STYLE determines the format of the output, as described for timestr() below. +The COUNT can be zero or negative: this means the I<minimum number of +CPU seconds> to run. A zero signifies the default of 3 seconds. For +example to run at least for 10 seconds: + + timethis(-10, $code) + +or to run two pieces of code tests for at least 3 seconds: + + timethese(0, { test1 => '...', test2 => '...'}) + +CPU seconds is, in UNIX terms, the user time plus the system time of +the process itself, as opposed to the real (wallclock) time and the +time spent by the child processes. Less than 0.1 seconds is not +accepted (-0.01 as the count, for example, will cause a fatal runtime +exception). + +Note that the CPU seconds is the B<minimum> time: CPU scheduling and +other operating system factors may complicate the attempt so that a +little bit more time is spent. The benchmark output will, however, +also tell the number of C<$code> runs/second, which should be a more +interesting number than the actually spent seconds. + +Returns a Benchmark object. + =item timethese ( COUNT, CODEHASHREF, [ STYLE ] ) The CODEHASHREF is a reference to a hash containing names as keys @@ -91,12 +115,14 @@ call timethis(COUNT, VALUE, KEY, STYLE) +The Count can be zero or negative, see timethis(). + =item timediff ( T1, T2 ) Returns the difference between two Benchmark times as a Benchmark object suitable for passing to timestr(). -=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ]] ) +=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ] ] ) Returns a string that formats the times in the TIMEDIFF object in the requested STYLE. TIMEDIFF is expected to be a Benchmark object @@ -205,6 +231,9 @@ March 28th, 1997; by Hugo van der Sanden: added support for code references and the already documented 'debug' method; revamped documentation. +April 04-07th, 1997: by Jarkko Hietaniemi, added the run-for-some-time +functionality. + =cut use Carp; @@ -237,7 +266,9 @@ sub disablecache { $cache = 0; } # --- Functions to process the 'time' data type -sub new { my @t = (time, times); print "new=@t\n" if $debug; bless \@t; } +sub new { my @t = (time, times, @_ == 2 ? $_[1] : 0); + print "new=@t\n" if $debug; + bless \@t; } sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } @@ -256,20 +287,21 @@ sub timediff { sub timestr { my($tr, $style, $f) = @_; my @t = @$tr; - warn "bad time value" unless @t==5; - my($r, $pu, $ps, $cu, $cs) = @t; + warn "bad time value (@t)" unless @t==6; + my($r, $pu, $ps, $cu, $cs, $n) = @t; my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); $f = $defaultfmt unless defined $f; # format a time in the required style, other formats may be added here $style ||= $defaultstyle; $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto'; my $s = "@t $style"; # default for unknown style - $s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)", + $s=sprintf("%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU secs)", @t,$t) if $style eq 'all'; - $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)", - $r,$pu,$ps,$pt) if $style eq 'noc'; - $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)", - $r,$cu,$cs,$ct) if $style eq 'nop'; + $s=sprintf("%$f CPU secs (%$f usr + %$f sys)", + $pt,$pu,$ps) if $style eq 'noc'; + $s=sprintf("%$f CPU secs (%$f cusr %$f csys)", + $ct,$cu,$cs) if $style eq 'nop'; + $s .= sprintf(" @ %$f/s (n=$n)", $n / ( $pu + $ps )) if $n; $s; } @@ -302,9 +334,9 @@ sub runloop { croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; print STDERR "runloop $n '$subcode'\n" if $debug; - $t0 = &new; + $t0 = Benchmark->new(0); &$subref; - $t1 = &new; + $t1 = Benchmark->new($n); $td = &timediff($t1, $t0); timedebug("runloop:",$td); @@ -336,16 +368,98 @@ sub timeit { $wd; } + +my $default_for = 3; +my $min_for = 0.1; + +sub runfor { + my ($code, $tmax) = @_; + + if ( not defined $tmax or $tmax == 0 ) { + $tmax = $default_for; + } elsif ( $tmax < 0 ) { + $tmax = -$tmax; + } + + die "runfor(..., $tmax): timelimit cannot be less than $min_for.\n" + if $tmax < $min_for; + + my ($n, $td, $tc, $ntot, $rtot, $utot, $stot, $cutot, $cstot ); + + # First find the minimum $n that gives a non-zero timing. + + my $nmin; + + for ($n = 1, $tc = 0; $tc <= 0; $n *= 2 ) { + $td = timeit($n, $code); + $tc = $td->[1] + $td->[2]; + } + + $nmin = $n; + + my $ttot = 0; + my $tpra = 0.05 * $tmax; # Target/time practice. + + # Double $n until we have think we have practiced enough. + for ( $n = 1; $ttot < $tpra; $n *= 2 ) { + $td = timeit($n, $code); + $tc = $td->cpu_p; + $ntot += $n; + $rtot += $td->[0]; + $utot += $td->[1]; + $stot += $td->[2]; + $ttot = $utot + $stot; + $cutot += $td->[3]; + $cstot += $td->[4]; + } + + my $r; + + # Then iterate towards the $tmax. + while ( $ttot < $tmax ) { + $r = $tmax / $ttot - 1; # Linear approximation. + $n = int( $r * $n ); + $n = $nmin if $n < $nmin; + $td = timeit($n, $code); + $ntot += $n; + $rtot += $td->[0]; + $utot += $td->[1]; + $stot += $td->[2]; + $ttot = $utot + $stot; + $cutot += $td->[3]; + $cstot += $td->[4]; + } + + return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ]; +} + # --- Functions implementing high-level time-then-print utilities +sub n_to_for { + my $n = shift; + return $n == 0 ? $default_for : $n < 0 ? -$n : undef; +} + sub timethis{ my($n, $code, $title, $style) = @_; - my $t = timeit($n, $code); + my($t, $for, $forn); + + if ( $n > 0 ) { + croak "non-integer loopcount $n, stopped" if int($n)<$n; + $t = timeit($n, $code); + $title = "timethis $n" unless defined $title; + } else { + $fort = n_to_for( $n ); + $t = runfor($code, $fort); + $title = "timethis for $fort" unless defined $title; + $forn = $t->[-1]; + } local $| = 1; - $title = "timethis $n" unless defined $title; $style = "" unless defined $style; printf("%10s: ", $title); - print timestr($t, $style),"\n"; + print timestr($t, $style, $defaultfmt),"\n"; + + $n = $forn if defined $forn; # A conservative warning to spot very silly tests. # Don't assume that your benchmark is ok simply because @@ -363,7 +477,19 @@ sub timethese{ unless ref $alt eq HASH; my @names = sort keys %$alt; $style = "" unless defined $style; - print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n"; + print "Benchmark: "; + if ( $n > 0 ) { + croak "non-integer loopcount $n, stopped" if int($n)<$n; + print "timing $n iterations of"; + } else { + print "running"; + } + print " ", join(', ',@names); + unless ( $n > 0 ) { + my $for = n_to_for( $n ); + print ", each for at least $for CPU seconds"; + } + print "...\n"; # we could save the results in an array and produce a summary here # sum, min, max, avg etc etc diff --git a/lib/Carp.pm b/lib/Carp.pm index 685a7933d0..6bac36446a 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -47,10 +47,20 @@ environment variable. # This package is heavily used. Be small. Be fast. Be good. +# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an +# _almost_ complete understanding of the package. Corrections and +# comments are welcome. + +# The $CarpLevel variable can be set to "strip off" extra caller levels for +# those times when Carp calls are buried inside other functions. The +# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval +# text and function arguments should be formatted when printed. + $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. +$Verbose = 0; # If true then make shortmess call longmess instead require Exporter; @ISA = ('Exporter'); @@ -58,30 +68,58 @@ require Exporter; @EXPORT_OK = qw(cluck verbose); @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") +# then the following method will be called by the Exporter which knows +# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word +# 'verbose'. + sub export_fail { shift; - if ($_[0] eq 'verbose') { - local $^W = 0; - *shortmess = \&longmess; - shift; - } + $Verbose = shift if $_[0] eq 'verbose'; return @_; } +# longmess() crawls all the way up the stack reporting on all the function +# calls made. The error string, $error, is originally constructed from the +# arguments passed into longmess() via confess(), cluck() or shortmess(). +# This gets appended with the stack trace messages which are generated for +# each function call on the stack. + sub longmess { my $error = join '', @_; my $mess = ""; my $i = 1 + $CarpLevel; my ($pack,$file,$line,$sub,$hargs,$eval,$require); my (@a); + # + # crawl up the stack.... + # while (do { { package DB; @a = caller($i++) } } ) { - ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # get copies of the variables returned from caller() + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # + # if the $error error string is newline terminated then it + # is copied into $mess. Otherwise, $mess gets set (at the end of + # the 'else {' section below) to one of two things. The first time + # through, it is set to the "$error at $file line $line" message. + # $error is then set to 'called' which triggers subsequent loop + # iterations to append $sub to $mess before appending the "$error + # at $file line $line" which now actually reads "called at $file line + # $line". Thus, the stack trace message is constructed: + # + # first time: $mess = $error at $file line $line + # subsequent times: $mess .= $sub $error at $file line $line + # ^^^^^^ + # "called" if ($error =~ m/\n$/) { $mess .= $error; } else { + # Build a string, $sub, which names the sub-routine called. + # This may also be "require ...", "eval '...' or "eval {...}" if (defined $eval) { - if ($require) { + if ($require) { $sub = "require $eval"; } else { $eval =~ s/([\\\'])/\\$1/g; @@ -93,32 +131,48 @@ sub longmess { } elsif ($sub eq '(eval)') { $sub = 'eval {...}'; } + # if there are any arguments in the sub-routine call, format + # them according to the format variables defined earlier in + # this file and join them onto the $sub sub-routine string if ($hargs) { - @a = @DB::args; # must get local copy of args - if ($MaxArgNums and @a > $MaxArgNums) { - $#a = $MaxArgNums; - $a[$#a] = "..."; - } - for (@a) { - $_ = "undef", next unless defined $_; - if (ref $_) { - $_ .= ''; - s/'/\\'/g; + # we may trash some of the args so we take a copy + @a = @DB::args; # must get local copy of args + # don't print any more than $MaxArgNums + if ($MaxArgNums and @a > $MaxArgNums) { + # cap the length of $#a and set the last element to '...' + $#a = $MaxArgNums; + $a[$#a] = "..."; } - else { - s/'/\\'/g; - substr($_,$MaxArgLen) = '...' - if $MaxArgLen and $MaxArgLen < length; + for (@a) { + # set args to the string "undef" if undefined + $_ = "undef", next unless defined $_; + if (ref $_) { + # dunno what this is for... + $_ .= ''; + s/'/\\'/g; + } + else { + s/'/\\'/g; + # terminate the string early with '...' if too long + substr($_,$MaxArgLen) = '...' + if $MaxArgLen and $MaxArgLen < length; + } + # 'quote' arg unless it looks like a number + $_ = "'$_'" unless /^-?[\d.]+$/; + # print high-end chars as 'M-<char>' or '^<char>' + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } - $_ = "'$_'" unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - $sub .= '(' . join(', ', @a) . ')'; + # append ('all', 'the', 'arguments') to the $sub string + $sub .= '(' . join(', ', @a) . ')'; } + # here's where the error message, $mess, gets constructed $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; } + # we don't need to print the actual error message again so we can + # change this to "called" so that the string "$error at $file line + # $line" makes sense as "called at $file line $line". $error = "called"; } # this kludge circumvents die's incorrect handling of NUL @@ -127,36 +181,71 @@ sub longmess { $$msg; } + +# shortmess() is called by carp() and croak() to skip all the way up to +# the top-level caller's package and report the error from there. confess() +# and cluck() generate a full stack trace so they call longmess() to +# generate that. In verbose mode shortmess() calls longmess() so +# you always get a stack trace + sub shortmess { # Short-circuit &longmess if called via multiple packages + goto &longmess if $Verbose; my $error = join '', @_; my ($prevpack) = caller(1); my $extra = $CarpLevel; my $i = 2; my ($pack,$file,$line); + # when reporting an error, we want to report it from the context of the + # calling package. So what is the calling package? Within a module, + # there may be many calls between methods and perhaps between sub-classes + # and super-classes, but the user isn't interested in what happens + # inside the package. We start by building a hash array which keeps + # track of all the packages to which the calling package belongs. We + # do this by examining its @ISA variable. Any call from a base class + # method (one of our caller's @ISA packages) can be ignored my %isa = ($prevpack,1); + # merge all the caller's @ISA packages into %isa. @isa{@{"${prevpack}::ISA"}} = () if(defined @{"${prevpack}::ISA"}); + # now we crawl up the calling stack and look at all the packages in + # there. For each package, we look to see if it has an @ISA and then + # we see if our caller features in that list. That would imply that + # our caller is a derived class of that package and its calls can also + # be ignored while (($pack,$file,$line) = caller($i++)) { if(defined @{$pack . "::ISA"}) { my @i = @{$pack . "::ISA"}; my %i; @i{@i} = (); + # merge any relevant packages into %isa @isa{@i,$pack} = () if(exists $i{$prevpack} || exists $isa{$pack}); } + # and here's where we do the ignoring... if the package in + # question is one of our caller's base or derived packages then + # we can ignore it (skip it) and go onto the next (but note that + # the continue { } block below gets called every time) next if(exists $isa{$pack}); + # Hey! We've found a package that isn't one of our caller's + # clan....but wait, $extra refers to the number of 'extra' levels + # we should skip up. If $extra > 0 then this is a false alarm. + # We must merge the package into the %isa hash (so we can ignore it + # if it pops up again), decrement $extra, and continue. if ($extra-- > 0) { %isa = ($pack,1); @isa{@{$pack . "::ISA"}} = () if(defined @{$pack . "::ISA"}); } else { - # this kludge circumvents die's incorrect handling of NUL + # OK! We've got a candidate package. Time to construct the + # relevant error message and return it. die() doesn't like + # to be given NUL characters (which $msg may contain) so we + # remove them first. (my $msg = "$error at $file line $line\n") =~ tr/\0//d; return $msg; } @@ -165,12 +254,23 @@ sub shortmess { # Short-circuit &longmess if called via multiple packages $prevpack = $pack; } + # uh-oh! It looks like we crawled all the way up the stack and + # never found a candidate package. Oh well, let's call longmess + # to generate a full stack trace. We use the magical form of 'goto' + # so that this shortmess() function doesn't appear on the stack + # to further confuse longmess() about it's calling package. goto &longmess; } -sub confess { die longmess @_; } -sub croak { die shortmess @_; } -sub carp { warn shortmess @_; } -sub cluck { warn longmess @_; } + +# the following four functions call longmess() or shortmess() depending on +# whether they should generate a full stack trace (confess() and cluck()) +# or simply report the caller's package (croak() and carp()), respectively. +# confess() and croak() die, carp() and cluck() warn. + +sub croak { die shortmess @_ } +sub confess { die longmess @_ } +sub carp { warn shortmess @_ } +sub cluck { warn longmess @_ } 1; diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index 09ab196254..a39d1ac04a 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -180,7 +180,7 @@ sub struct { } elsif( defined $classes{$name} ){ if ( $CHECK_CLASS_MEMBERSHIP ) { - $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$type');\n"; + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; } } $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 652ee7e493..64798da00f 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -20,11 +20,21 @@ getcwd - get pathname of current working directory chdir "/tmp"; print $ENV{'PWD'}; + use Cwd 'abs_path'; + print abs_path($ENV{'PWD'}); + + use Cwd 'fast_abs_path'; + print fast_abs_path($ENV{'PWD'}); + =head1 DESCRIPTION The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. +The abs_path() function takes a single argument and returns the +absolute pathname for that argument. It uses the same algoritm as +getcwd(). (actually getcwd() is abs_path(".")) + The fastcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because it might conceivably chdir() you out of a directory that it can't chdir() you back into. If fastcwd @@ -35,6 +45,9 @@ that it leaves you in the same directory that it started in. If it has changed it will C<die> with the message "Unstable directory path, current directory changed unexpectedly". That should never happen. +The fast_abs_path() function looks the same as abs_path(), but runs faster. +And like fastcwd() is more dangerous. + The cwd() function looks the same as getcwd and fastgetcwd but is implemented using the most natural and safe form for the current architecture. For most systems it is identical to `pwd` (but without diff --git a/lib/English.pm b/lib/English.pm index bbb6bd7b28..1cbacd11f8 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -137,8 +137,8 @@ sub import { # Error status. *CHILD_ERROR = *? ; - *OS_ERROR = *! ; - *ERRNO = *! ; + *OS_ERROR = \$! ; + *ERRNO = \$! ; *EXTENDED_OS_ERROR = *^E ; *EVAL_ERROR = *@ ; diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 992d178659..6a5c1847ac 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -81,10 +81,13 @@ sub install { #there are any files in arch. So we depend on having ./blib/arch #hardcoded here. my $targetroot = $hash{$source}; - if ($source eq "./blib/lib" and - exists $hash{"./blib/arch"} and - directory_not_empty("./blib/arch")) { - $targetroot = $hash{"./blib/arch"}; + if ($source eq "blib/lib" and + exists $hash{"blib/arch"} and + directory_not_empty("blib/arch")) { + $targetroot = $hash{"blib/arch"}; + print "Files found in blib/arch --> Installing files in " + . "blib/lib into architecture dependend library tree!\n" + ; #if $verbose>1; } chdir($source) or next; find(sub { diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 5c35dc7307..ccdffb8eea 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -182,6 +182,9 @@ sub _unix_os2_ext { } sub _win32_ext { + + require Text::ParseWords; + my($self, $potential_libs, $verbose) = @_; # If user did not supply a list, we punt. @@ -206,14 +209,14 @@ sub _win32_ext { # compute $extralibs from $potential_libs my(@searchpath); # from "-L/path" entries in $potential_libs - my(@libpath) = split " ", $libpth; + my(@libpath) = Text::ParseWords::quotewords('\s+', 0, $libpth); my(@extralibs); my($fullname, $thislib, $thispth); my($pwd) = cwd(); # from Cwd.pm my($lib) = ''; my($found) = 0; - foreach $thislib (split ' ', $potential_libs){ + foreach $thislib (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ # Handle possible linker path arguments. if ($thislib =~ s/^-L// and not -d $thislib) { @@ -223,7 +226,7 @@ sub _win32_ext { } elsif (-d $thislib) { unless ($self->file_name_is_absolute($thislib)) { - warn "Warning: -L$thislib changed to -L$pwd/$thislib\n"; + warn "Warning: '-L$thislib' changed to '-L$pwd/$thislib'\n"; $thislib = $self->catdir($pwd,$thislib); } push(@searchpath, $thislib); @@ -253,6 +256,9 @@ sub _win32_ext { unless $found_lib>0; } return ('','','','') unless $found; + + # make sure paths with spaces are properly quoted + @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs; $lib = join(' ',@extralibs); warn "Result: $lib\n" if $verbose; wantarray ? ($lib, '', $lib, '') : $lib; @@ -595,6 +601,17 @@ distinguish between them. LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS and LD_RUN_PATH are always empty (this may change in future). +=item * + +You must make sure that any paths and path components are properly +surrounded with double-quotes if they contain spaces. For example, +C<$potential_libs> could be (literally): + + "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib" + +Note how the first and last entries are protected by quotes in order +to protect the spaces. + =back diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index 65abfc2d99..5a603caa36 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -8,7 +8,6 @@ require Exporter; Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); -$ENV{EMXSHELL} = 'sh'; # to run `commands` unshift @MM::ISA, 'ExtUtils::MM_OS2'; sub dlsyms { @@ -29,7 +28,8 @@ $self->{BASEEXT}.def: Makefile.PL '", "DLBASE" => "',$self->{DLBASE}, '", "DL_FUNCS" => ',neatvalue($funcs), ', "IMPORTS" => ',neatvalue($imports), - ', "DL_VARS" => ', neatvalue($vars), ');\' + ', "VERSION" => "',$self->{VERSION}, + '", "DL_VARS" => ', neatvalue($vars), ');\' '); } join('',@m); diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 2daa056067..3b5dbb3616 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1011,6 +1011,10 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} if ($^O eq 'solaris'); + # The IRIX linker also doesn't use LD_RUN_PATH + $ldrun = "-rpath $self->{LD_RUN_PATH}" + if ($^O eq 'irix'); + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' @@ -1271,7 +1275,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my($self) = @_; my($name, %dir, %xs, %c, %h, %ignore, %pl_files, %manifypods); local(%pm); #the sub in find() has to see this hash - $ignore{'test.pl'} = 1; + @ignore{qw(Makefile.PL test.pl)} = (1,1); $ignore{'makefile.pl'} = 1 if $Is_VMS; foreach $name ($self->lsdir($self->curdir)){ next if $name =~ /\#/; @@ -1289,13 +1293,16 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) unless $name =~ m/perlmain\.c/; # See MAP_TARGET } elsif ($name =~ /\.h$/i){ $h{$name} = 1; + } elsif ($name =~ /\.PL$/) { + ($pl_files{$name} = $name) =~ s/\.PL$// ; + } elsif ($Is_VMS && $name =~ /\.pl$/) { # case-insensitive filesystem + local($/); open(PL,$name); my $txt = <PL>; close PL; + if ($txt =~ /Extracting \S+ \(with variable substitutions/) { + ($pl_files{$name} = $name) =~ s/\.pl$// ; + } + else { $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); } } elsif ($name =~ /\.(p[ml]|pod)$/){ $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); - } elsif ($name =~ /\.PL$/ && $name ne "Makefile.PL") { - ($pl_files{$name} = $name) =~ s/\.PL$// ; - } elsif ($Is_VMS && $name =~ /\.pl$/ && $name ne 'makefile.pl' && - $name ne 'test.pl') { # case-insensitive filesystem - ($pl_files{$name} = $name) =~ s/\.pl$// ; } } @@ -1499,7 +1506,7 @@ sub init_main { $modfname = &DynaLoader::mod2fname(\@modparts); } - ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!([\w:]+::)?(\w+)$! ; + ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)$! ; if (defined &DynaLoader::mod2fname) { # As of 5.001m, dl_os2 appends '_' @@ -1953,7 +1960,7 @@ pure_site_install :: }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{ doc_perl_install :: - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLPRIVLIB)" \ LINKTYPE "$(LINKTYPE)" \ @@ -1962,7 +1969,7 @@ doc_perl_install :: >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ doc_site_install :: - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ @@ -2327,7 +2334,7 @@ $tmp/perlmain.c: $makefilename}, q{ push @m, q{ doc_inst_perl: }.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Perl binary" "$(MAP_TARGET)" \ MAP_STATIC "$(MAP_STATIC)" \ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 29bfaf2e55..a1eae3799b 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -14,7 +14,7 @@ use VMS::Filespec; use File::Basename; use vars qw($Revision); -$Revision = '5.3901 (6-Mar-1997)'; +$Revision = '5.42 (31-Mar-1997)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; @@ -90,8 +90,10 @@ are all macro, so that we can tell how long the expansion is, and avoid overrunning DCL's command buffer when MM[KS] is running. If optional second argument has a TRUE value, then the return string is -a VMS-syntax directory specification, otherwise it is a VMS-syntax file -specification. +a VMS-syntax directory specification, if it is FALSE, the return string +is a VMS-syntax file specification, and if it is not specified, fixpath() +checks to see whether it matches the name of a directory in the current +default directory, and returns a directory or file specification accordingly. =cut @@ -122,8 +124,10 @@ sub fixpath { $fixedpath = $path; $fixedpath = vmspath($fixedpath) if $force_path; } - # Convert names without directory or type to paths - if (!$force_path and $fixedpath !~ /[:>(.\]]/) { $fixedpath = vmspath($fixedpath); } + # 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/; print "fixpath($path) = |$fixedpath|\n" if $Verbose >= 3; @@ -436,7 +440,7 @@ sub find_perl { } foreach $name (@snames){ if ($name !~ m![/:>\]]!) { push(@cand,$self->catfile($dir,$name)); } - else { push(@cand,$self->fixpath($name)); } + else { push(@cand,$self->fixpath($name,0)); } } } foreach $name (@cand) { @@ -639,9 +643,9 @@ sub constants { if ($self->{OBJECT} =~ /\s/) { $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g; - $self->{OBJECT} = $self->wraplist(map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT}))); + $self->{OBJECT} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{OBJECT}))); } - $self->{LDFROM} = $self->wraplist(map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM}))); + $self->{LDFROM} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{LDFROM}))); # Fix up directory specs @@ -664,7 +668,7 @@ sub constants { # Fix up file specs foreach $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKE_APERL_FILE MYEXTLIB] ) { next unless defined $self->{$macro}; - $self->{$macro} = $self->fixpath($self->{$macro}); + $self->{$macro} = $self->fixpath($self->{$macro},0); } foreach $macro (qw/ @@ -702,7 +706,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision FULLEXT VERSION_FROM OBJECT LDFROM / ) { next unless defined $self->{$tmp}; - push @m, "$tmp = ",$self->fixpath($self->{$tmp}),"\n"; + push @m, "$tmp = ",$self->fixpath($self->{$tmp},0),"\n"; } for $tmp (qw/ @@ -716,7 +720,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision next unless defined $self->{$tmp}; my(%tmp,$key); for $key (keys %{$self->{$tmp}}) { - $tmp{$self->fixpath($key)} = $self->fixpath($self->{$tmp}{$key}); + $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$tmp}{$key},0); } $self->{$tmp} = \%tmp; } @@ -725,7 +729,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision next unless defined $self->{$tmp}; my(@tmp,$val); for $val (@{$self->{$tmp}}) { - push(@tmp,$self->fixpath($val)); + push(@tmp,$self->fixpath($val,0)); } $self->{$tmp} = \@tmp; } @@ -1011,7 +1015,7 @@ sub tool_xsubpp { warn "Typemap $typemap not found.\n"; } else{ - push(@tmdeps, $self->fixpath($typemap)); + push(@tmdeps, $self->fixpath($typemap,0)); } } } @@ -1464,31 +1468,6 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) } -# sub installpm_x { # called by installpm perl file -# my($self, $dist, $inst, $splitlib) = @_; -# if ($inst =~ m!#!) { -# warn "Warning: MM[SK] would have problems processing this file: $inst, SKIPPED\n"; -# return ''; -# } -# $inst = $self->fixpath($inst); -# $dist = $self->fixpath($dist); -# my($instdir) = $inst =~ /([^\)]+\))[^\)]*$/ ? $1 : dirname($inst); -# my(@m); -# -# push(@m, " -# $inst : $dist \$(MAKEFILE) ${instdir}.exists \$(INST_ARCHAUTODIR).exists -# ",' $(NOECHO) $(RM_F) $(MMS$TARGET) -# $(NOECHO) $(CP) ',"$dist $inst",' -# $(CHMOD) 644 $(MMS$TARGET) -# '); -# push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ', -# $self->catdir($splitlib,'auto')."\n\n") -# if ($splitlib and $inst =~ /\.pm$/); -# push(@m,$self->dir_target($instdir)); -# -# join('',@m); -# } - =item manifypods (override) Use VMS-style quoting on command line, and VMS logical name @@ -1674,7 +1653,7 @@ clean :: if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { push(@otherfiles, @{$self->{$key}}); } - else { push(@otherfiles, $attribs{FILES}); } + else { push(@otherfiles, $word); } } } push(@otherfiles, qw[ blib $(MAKE_APERL_FILE) extralibs.ld perlmain.c pm_to_blib.ts ]); @@ -1748,7 +1727,7 @@ realclean :: clean if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { push(@allfiles, @{$self->{$key}}); } - else { push(@allfiles, $attribs{FILES}); } + else { push(@allfiles, $word); } } $line = ''; # Occasionally files are repeated several times from different sources @@ -2037,7 +2016,7 @@ $(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl Set Default $(PERL_SRC) $(MMS)],$mmsquals,); if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { - my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm')); + my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0)); $target =~ s/\Q$prefix/[/; push(@m," $target"); } @@ -2047,7 +2026,7 @@ $(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl ]); } - push(@m, join(" ", map($self->fixpath($_),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") + push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") if %{$self->{XS}}; join('',@m); @@ -2330,8 +2309,8 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) push @m, ' # Fill in the target you want to produce if it\'s not perl -MAP_TARGET = ',$self->fixpath($target),' -MAP_SHRTARGET = ',$self->fixpath($shrtarget)," +MAP_TARGET = ',$self->fixpath($target,0),' +MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," MAP_LINKCMD = $linkcmd MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',' # We use the linker options files created with each extension, rather than @@ -2339,7 +2318,7 @@ MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',' MAP_STATIC = ',@staticopts ? join(' ', @staticopts) : '',' MAP_OPTS = ',@staticopts ? ','.join(',', map($_.'/Option', @staticopts)) : ''," MAP_EXTRA = $extralist -MAP_LIBPERL = ",$self->fixpath($libperl),' +MAP_LIBPERL = ",$self->fixpath($libperl,0),' '; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 6735b034c0..168c98d7f2 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -1540,15 +1540,14 @@ Hashref of .pm files and *.pl files to be installed. e.g. {'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'} -By default this will include *.pm and *.pl. If a lib directory -exists and is not listed in DIR (above) then any *.pm and *.pl files -it contains will also be included by default. Defining PM in the +By default this will include *.pm and *.pl and the files found in +the PMLIBDIRS directories. Defining PM in the Makefile.PL will override PMLIBDIRS. =item PMLIBDIRS Ref to array of subdirectories containing library files. Defaults to -[ 'lib', $(BASEEXT) ]. The directories will be scanned and any files +[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 8437346c91..55570892f8 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -242,7 +242,11 @@ sub ln { link($srcFile, $dstFile); local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x) my $mode= 0444 | (stat)[2] & 0700; - chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ ); + if (! chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ )) { + unlink $dstFile; + return; + } + 1; } sub best { diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 2f2366a1c8..7e436384aa 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -7,7 +7,7 @@ use Exporter; use vars qw( @ISA @EXPORT $VERSION ); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; -$VERSION = substr q$Revision: 1.16 $, 10; +$VERSION = substr q$Revision: 1.17 $, 10; sub Mksymlists { my(%spec) = @_; @@ -69,6 +69,8 @@ sub _write_aix { sub _write_os2 { my($data) = @_; + require Config; + my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : ""); if (not $data->{DLBASE}) { ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; @@ -79,6 +81,7 @@ sub _write_os2 { open(DEF,">$data->{FILE}.def") or croak("Can't create $data->{FILE}.def: $!\n"); print DEF "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n"; + print DEF "DESCRIPTION 'Perl (v$]$threaded) module $data->{NAME} v$data->{VERSION}'\n"; print DEF "CODE LOADONCALL\n"; print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; print DEF "EXPORTS\n "; diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 8828a52bfc..e21af92682 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -160,23 +160,27 @@ sub fileparse { if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { - ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/); + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/t); $dirpath ||= ''; # should always be defined } } if ($fstype =~ /^MS(DOS|Win32)/i) { - ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/); + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/t); $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/; } elsif ($fstype =~ /^MacOS/i) { - ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/t); } elsif ($fstype =~ /^AmigaOS/i) { - ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/t); $dirpath = './' unless $dirpath; } elsif ($fstype !~ /^VMS/i) { # default to Unix - ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); + ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#t); + if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + ($basename,$dirpath) = ('',$fullname); + } $dirpath = './' unless $dirpath; } @@ -184,7 +188,7 @@ sub fileparse { $tail = ''; foreach $suffix (@suffices) { my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; - if ($basename =~ s/$pat//) { + if ($basename =~ s/$pat//t) { $taint .= substr($suffix,0,0); $tail = $1 . $tail; } @@ -222,30 +226,30 @@ sub dirname { } if ($fstype =~ /MacOS/i) { return $dirname } elsif ($fstype =~ /MSDOS/i) { - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; } } elsif ($fstype =~ /MSWin32/i) { - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*$/$1/t; } } elsif ($fstype =~ /AmigaOS/i) { if ( $dirname =~ /:$/) { return $dirname } chop $dirname; - $dirname =~ s#[^:/]+$## unless length($basename); + $dirname =~ s#[^:/]+$##t unless length($basename); } else { $dirname =~ s:(.)/*$:$1:; unless( length($basename) ) { local($File::Basename::Fileparse_fstype) = $fstype; ($basename,$dirname) = fileparse $dirname; - $dirname =~ s:(.)/*$:$1:; + $dirname =~ s:(.)/*$:$1:t; } } diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm index a39308b6c9..dca7f6aff3 100644 --- a/lib/File/CheckTree.pm +++ b/lib/File/CheckTree.pm @@ -137,13 +137,13 @@ sub valmess { $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } - print STDERR $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; - print STDERR "Can't do $this.\n"; + $mess = "Can't do $this.\n"; } - if ($disposition eq 'die') { exit 1; } + die "$mess\n" if $disposition eq 'die'; + warn "$mess\n"; ++$warnings; } diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 7abebc6544..1305d21e6b 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -1,10 +1,7 @@ package File::Find; require 5.000; require Exporter; -use Config; require Cwd; -require File::Basename; - =head1 NAME @@ -24,6 +21,17 @@ finddepth - traverse a directory structure depth-first =head1 DESCRIPTION +The first argument to find() is either a hash reference describing the +operations to be performed for each file, or a code reference. 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. + +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(). + 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 @@ -34,7 +42,7 @@ 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. -This library is primarily for the C<find2perl> tool, which when fed, +This library is useful for the C<find2perl> tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ -exec rm -f {} \; -o -fstype nfs -prune @@ -75,9 +83,10 @@ There is no way to make find or finddepth follow symlinks. @EXPORT = qw(find finddepth); -sub find { +sub find_opt { my $wanted = shift; - my $cwd = Cwd::cwd(); + 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); @@ -87,27 +96,35 @@ sub find { || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { - ($dir,$_) = ($topdir,'.'); - $name = $topdir; $prune = 0; - &$wanted; + 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); + &finddir($wanted,$fixtopdir,$topnlink, $bydepth); + if ($bydepth) { + ($dir,$_) = ($fixtopdir,'.'); + $name = $fixtopdir; + $wanted->{wanted}->(); + } } else { warn "Can't cd to $topdir: $!\n"; } } else { + require File::Basename; unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } if (chdir($dir)) { $name = $topdir; - &$wanted; + $wanted->{wanted}->(); } else { warn "Can't cd to $dir: $!\n"; @@ -118,14 +135,14 @@ sub find { } sub finddir { - my($wanted, $nlink); + my($wanted, $nlink, $bydepth); local($dir, $name); - ($wanted, $dir, $nlink) = @_; + ($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", return); + opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return); my(@filenames) = readdir(DIR); closedir(DIR); @@ -135,7 +152,7 @@ sub finddir { next if $_ eq '..'; $name = "$dir/$_"; $nlink = 0; - &$wanted; + $wanted->{wanted}->(); } } else { # This dir has subdirectories. @@ -143,9 +160,10 @@ sub finddir { for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; - $nlink = $prune = 0; + $nlink = 0; + $prune = 0 unless $bydepth; $name = "$dir/$_"; - &$wanted; + $wanted->{wanted}->() unless $bydepth; if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? # Get link count and check for directoriness. @@ -161,7 +179,7 @@ sub finddir { next if $prune; if (chdir $_) { $name =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$name,$nlink); + &finddir($wanted,$name,$nlink, $bydepth); chdir '..'; } else { @@ -169,109 +187,26 @@ sub finddir { } } } + $wanted->{wanted}->() if $bydepth; } } } - -sub finddepth { - my $wanted = shift; - my $cwd = 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)) { - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - &finddepthdir($wanted,$fixtopdir,$topnlink); - ($dir,$_) = ($topdir,'.'); - $name = $topdir; - &$wanted; - } - else { - warn "Can't cd to $topdir: $!\n"; - } - } - else { - unless (($_,$dir) = File::Basename::fileparse($topdir)) { - ($dir,$_) = ('.', $topdir); - } - if (chdir($dir)) { - $name = $topdir; - &$wanted; - } - else { - warn "Can't cd to $dir: $!\n"; - } - } - chdir $cwd; - } +sub wrap_wanted { + my $wanted = shift; + defined &$wanted ? {wanted => $wanted} : $wanted; } -sub finddepthdir { - my($wanted, $nlink); - local($dir, $name); - ($wanted, $dir, $nlink) = @_; - my($dev, $ino, $mode, $subcount); - - # Get the list of files in the current directory. - opendir(DIR,'.') || (warn "Can't open $dir: $!\n", 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; - } - } - else { # This dir has subdirectories. - $subcount = $nlink - 2; - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $nlink = 0; - $name = "$dir/$_"; - if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? - - # Get link count and check for directoriness. - - ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); - - if (-d _) { - - # It really is a directory, so do it recursively. - - --$subcount; - if (chdir $_) { - $name =~ s/\.dir$// if $Is_VMS; - &finddepthdir($wanted,$name,$nlink); - chdir '..'; - } - else { - warn "Can't cd to $_: $!\n"; - } - } - } - &$wanted; - } - } +sub find { + my $wanted = shift; + find_opt(wrap_wanted($wanted), @_); } -# 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. -$dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +sub finddepth { + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + find_opt($wanted, @_); +} # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { @@ -282,5 +217,14 @@ if ($^O eq 'VMS') { $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'}); +} + 1; diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 6b5d5683f1..39f1ba1771 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -124,11 +124,15 @@ sub mkpath { $paths = [$paths] unless ref $paths; my(@created,$path); foreach $path (@$paths) { + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:$/; # feature of CRT next if -d $path; # Logic wants Unix paths, so go with the flow. $path = VMS::Filespec::unixify($path) if $Is_VMS; my $parent = File::Basename::dirname($path); - push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + # 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); + } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { # allow for another process to have created it meanwhile diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index 455fc63917..72ecdac1b6 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -249,6 +249,10 @@ It will also croak() if accidentally called in a scalar context. =back +There are many other functions available since FileHandle is descended +from IO::File, IO::Seekable, and IO::Handle. Please see those +respective pages for documentation on more functions. + =head1 SEE ALSO The B<IO> extension, diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 38b396771b..fe7e12f09b 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,17 +2,17 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pm,v 2.13 1997-12-25 16:20:17+01 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.16 1998-03-13 11:05:29+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Thu Dec 25 16:18:08 1997 -# Update Count : 647 +# Last Modified On: Fri Mar 13 11:05:28 1998 +# Update Count : 659 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,1997 by Johan Vromans. +# This program is Copyright 1990,1998 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 @@ -32,10 +32,10 @@ package Getopt::Long; use strict; BEGIN { - require 5.003; + require 5.004; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = sprintf("%d.%02d", q$Revision: 2.13 $ =~ /(\d+)\.(\d+)/); + $VERSION = sprintf("%d.%02d", q$Revision: 2.16 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -87,7 +87,7 @@ sub GetOptions { $genprefix = $gen_prefix; # so we can call the same module many times $error = ''; - print STDERR ('GetOptions $Revision: 2.13 $ ', + print STDERR ('GetOptions $Revision: 2.16 $ ', "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", " (@ARGV)\n", @@ -127,7 +127,7 @@ sub GetOptions { my $opt = shift (@optionlist); # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $2 if $opt =~ /^$genprefix+(.*)$/; + $opt = $+ if $opt =~ /^$genprefix+(.*)$/s; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -420,9 +420,9 @@ sub config (@) { foreach $opt ( @options ) { my $try = lc ($opt); my $action = 1; - if ( $try =~ /^no_?(.*)$/ ) { + if ( $try =~ /^no_?(.*)$/s ) { $action = 0; - $try = $1; + $try = $+; } if ( $try eq 'default' or $try eq 'defaults' ) { &$config_defaults () if $action; @@ -454,6 +454,21 @@ sub config (@) { elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { $passthrough = $action; } + elsif ( $try =~ /^prefix=(.+)$/ ) { + $gen_prefix = $1; + # Turn into regexp. Needs to be parenthesized! + $gen_prefix = "(" . quotemeta($gen_prefix) . ")"; + eval { '' =~ /$gen_prefix/; }; + &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@; + } + elsif ( $try =~ /^prefix_pattern=(.+)$/ ) { + $gen_prefix = $1; + # Parenthesize if needed. + $gen_prefix = "(" . $gen_prefix . ")" + unless $gen_prefix =~ /^\(.*\)$/; + eval { '' =~ /$gen_prefix/; }; + &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@; + } elsif ( $try eq 'debug' ) { $debug = $action; } @@ -476,9 +491,9 @@ $find_option = sub { print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug; - return 0 unless $opt =~ /^$genprefix(.*)$/; + return 0 unless $opt =~ /^$genprefix(.*)$/s; - $opt = $2; + $opt = $+; my ($starter) = $1; print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; @@ -488,7 +503,7 @@ $find_option = sub { # If it is a long option, it may include the value. if (($starter eq "--" || ($getopt_compat && !$bundling)) - && $opt =~ /^([^=]+)=(.*)$/ ) { + && $opt =~ /^([^=]+)=(.*)$/s ) { $opt = $1; $optarg = $2; print STDERR ("=> option \"", $opt, @@ -626,7 +641,7 @@ $find_option = sub { # Get key if this is a "name=value" pair for a hash option. $key = undef; if ($hash && defined $arg) { - ($key, $arg) = ($arg =~ /^(.*)=(.*)$/o) ? ($1, $2) : ($arg, 1); + ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1); } #### Check if the argument is valid for this option #### @@ -650,7 +665,7 @@ $find_option = sub { } elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/ ) { + if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) { $arg = $1; $rest = $2; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; @@ -683,9 +698,9 @@ $find_option = sub { # and at least one digit following the point and 'e'. # [-]NN[.NN][eNN] if ( $bundling && defined $rest && - $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/ ) { + $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) { $arg = $1; - $rest = $4; + $rest = $+; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; } elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) { @@ -940,6 +955,12 @@ identifier is $opt_ . The linkage specifier can be a reference to a scalar, a reference to an array, a reference to a hash or a reference to a subroutine. +Note that, if your code is running under the recommended C<use strict +'vars'> pragma, it may be helpful to declare these package variables +via C<use vars> perhaps something like this: + + use vars qw/ $opt_size @opt_sizes $opt_bar /; + If a REF SCALAR is supplied, the new value is stored in the referenced variable. If the option occurs more than once, the previous value is overwritten. @@ -1228,6 +1249,16 @@ remaining options to some other program. This can be very confusing, especially when B<permute> is also set. +=item prefix + +The string that starts options. See also B<prefix_pattern>. + +=item prefix_pattern + +A Perl pattern that identifies the strings that introduce options. +Default is C<(--|-|\+)> unless environment variable +POSIXLY_CORRECT has been set, in which case it is C<(--|-)>. + =item debug (default: reset) Enable copious debugging output. @@ -1262,7 +1293,7 @@ Johan Vromans E<lt>jvromans@squirrel.nlE<gt> =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 1990,1997 by Johan Vromans. +This program is Copyright 1990,1998 by Johan Vromans. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm index 27882935f9..18b5739e92 100644 --- a/lib/Getopt/Std.pm +++ b/lib/Getopt/Std.pm @@ -27,6 +27,12 @@ switch name) to the value of the argument, or 1 if no argument. Switches which take an argument don't care whether there is a space between the switch and the argument. +Note that, if your code is running under the recommended C<use strict +'vars'> pragma, it may be helpful to declare these package variables +via C<use vars> perhaps something like this: + + use vars qw/ $opt_foo $opt_bar /; + For those of you who don't like additional variables being created, getopt() and getopts() will also accept a hash reference as an optional second argument. Hash keys will be x (where x is the switch name) with key values the value of diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index 7551ad01a3..77fb5dd818 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -37,7 +37,7 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead sub stringify { my $n = ${$_[0]}; - $n =~ s/^\+//; + my $minus = ($n =~ s/^([+-])// && $1 eq '-'); $n =~ s/E//; $n =~ s/([-+]\d+)$//; @@ -52,6 +52,7 @@ sub stringify { } else { $n = '.' . ("0" x (abs($e) - $ln)) . $n; } + $n = "-$n" if $minus; # 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/; diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index 422dca42fd..013e55fadb 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -171,7 +171,7 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; + $x -= 1e5 if $car = (($x += (@y ? shift(@y) : 0) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; @@ -185,8 +185,8 @@ sub sub { #(int_num_array, int_num_array) return int_num_array local(*sx, *sy) = @_; $bar = 0; for $sx (@sx) { - last unless @y || $bar; - $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); + last unless @sy || $bar; + $sx += 1e5 if $bar = (($sx -= (@sy ? shift(@sy) : 0) + $bar) < 0); } @sx; } diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 8ff3e8964b..dafa27d781 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -3,6 +3,8 @@ package Pod::Html; use Pod::Functions; use Getopt::Long; # package for handling command-line parameters require Exporter; +use vars qw($VERSION); +$VERSION = 1.01; @ISA = Exporter; @EXPORT = qw(pod2html htmlify); use Cwd; @@ -11,13 +13,15 @@ use Carp; use strict; +use Config; + =head1 NAME -Pod::HTML - module to convert pod files to HTML +Pod::Html - module to convert pod files to HTML =head1 SYNOPSIS - use Pod::HTML; + use Pod::Html; pod2html([options]); =head1 DESCRIPTION @@ -302,7 +306,7 @@ sub pod2html { for (my $i = 0; $i < @poddata; $i++) { if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { for my $para ( @poddata[$i, $i+1] ) { - last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+\s*.*)/s; + last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+.*\S)/s; } } @@ -316,19 +320,22 @@ sub pod2html { warn "adopted '$title' as title for $podfile\n" if $verbose and $title; } - unless ($title) { + if ($title) { + $title =~ s/\s*\(.*\)//; + } else { warn "$0: no title for $podfile"; $podfile =~ /^(.*)(\.[^.\/]+)?$/; $title = ($podfile eq "-" ? 'No Title' : $1); warn "using $title" if $verbose; } print HTML <<END_OF_HEAD; - <HTML> - <HEAD> - <TITLE>$title</TITLE> - </HEAD> +<HTML> +<HEAD> +<TITLE>$title</TITLE> +<LINK REV="made" HREF="mailto:$Config{perladmin}"> +</HEAD> - <BODY> +<BODY> END_OF_HEAD @@ -368,9 +375,9 @@ END_OF_HEAD } else { next if @begin_stack && $begin_stack[-1] ne 'html'; - if (/^=(head[1-6])\s+(.*)/s) { # =head[1-6] heading + if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading process_head($1, $2); - } elsif (/^=item\s*(.*)/sm) { # =item text + } elsif (/^=item\s*(.*\S)/sm) { # =item text process_item($1); } elsif (/^=over\s*(.*)/) { # =over N process_over(); @@ -391,16 +398,16 @@ END_OF_HEAD next if @begin_stack && $begin_stack[-1] ne 'html'; my $text = $_; process_text(\$text, 1); - print HTML "$text\n<P>\n\n"; + print HTML "<P>\n$text"; } } # finish off any pending directives finish_list(); print HTML <<END_OF_TAIL; - </BODY> +</BODY> - </HTML> +</HTML> END_OF_TAIL # close the html file @@ -782,7 +789,7 @@ sub scan_headings { $index .= "\n" . ("\t" x $listdepth) . "<LI>" . "<A HREF=\"#" . htmlify(0,$title) . "\">" . - process_text(\$title, 0) . "</A>"; + html_escape(process_text(\$title, 0)) . "</A>"; } } @@ -823,8 +830,8 @@ sub scan_items { if ($1 eq "*") { # bullet list /\A=item\s+\*\s*(.*?)\s*\Z/s; $item = $1; - } elsif ($1 =~ /^[0-9]+/) { # numbered list - /\A=item\s+[0-9]+\.?(.*?)\s*\Z/s; + } elsif ($1 =~ /^\d+/) { # numbered list + /\A=item\s+\d+\.?(.*?)\s*\Z/s; $item = $1; } else { # /\A=item\s+(.*?)\s*\Z/s; @@ -856,6 +863,7 @@ sub process_head { print HTML "<H$level>"; # unless $listlevel; #print HTML "<H$level>" unless $listlevel; my $convert = $heading; process_text(\$convert, 0); + $convert = html_escape($convert); print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>"; print HTML "</H$level>"; # unless $listlevel; print HTML "\n"; @@ -898,30 +906,36 @@ sub process_item { print HTML "<UL>\n"; } - print HTML "<LI><STRONG>"; - $text =~ /\A\*\s*(.*)\Z/s; - print HTML "<A NAME=\"item_" . htmlify(1,$1) . "\">" if $1 && !$items_named{$1}++; - $quote = 1; - #print HTML process_puretext($1, \$quote); - print HTML $1; - print HTML "</A>" if $1; - print HTML "</STRONG>"; + print HTML '<LI>'; + if ($text =~ /\A\*\s*(.+)\Z/s) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($1); + } else { + my $name = 'item_' . htmlify(1,$1); + print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; + } + print HTML '</STRONG>'; + } - } elsif ($text =~ /\A[0-9#]+/) { # numbered list + } elsif ($text =~ /\A[\d#]+/) { # numbered list if ($need_preamble) { push(@listend, "</OL>"); print HTML "<OL>\n"; } - print HTML "<LI><STRONG>"; - $text =~ /\A[0-9]+\.?(.*)\Z/s; - print HTML "<A NAME=\"item_" . htmlify(0,$1) . "\">" if $1; - $quote = 1; - #print HTML process_puretext($1, \$quote); - print HTML $1 if $1; - print HTML "</A>" if $1; - print HTML "</STRONG>"; + print HTML '<LI>'; + if ($text =~ /\A\d+\.?\s*(.+)\Z/s) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($1); + } else { + my $name = 'item_' . htmlify(0,$1); + print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; + } + print HTML '</STRONG>'; + } } else { # all others @@ -930,18 +944,17 @@ sub process_item { print HTML "<DL>\n"; } - print HTML "<DT><STRONG>"; - print HTML "<A NAME=\"item_" . htmlify(1,$text) . "\">" - if $text && !$items_named{($text =~ /(\S+)/)[0]}++; - # preceding craziness so that the duplicate leading bits in - # perlfunc work to find just the first one. otherwise - # open etc would have many names - $quote = 1; - #print HTML process_puretext($text, \$quote); - print HTML $text; - print HTML "</A>" if $text; - print HTML "</STRONG>"; - + print HTML '<DT>'; + if ($text =~ /(\S+)/) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($text); + } else { + my $name = 'item_' . htmlify(1,$text); + print HTML qq(<A NAME="$name">), html_escape($text), '</A>'; + } + print HTML '</STRONG>'; + } print HTML '<DD>'; } @@ -1276,12 +1289,15 @@ sub process_puretext { $word = qq(<A HREF="$word">$word</A>); } elsif ($word =~ /[\w.-]+\@\w+\.\w/) { # looks like an e-mail address - $word = qq(<A HREF="MAILTO:$word">$word</A>); + my ($w1, $w2, $w3) = ("", $word, ""); + ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/; + ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/; + $word = qq($w1<A HREF="mailto:$w2">$w2</A>$w3); } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) { # all uppercase? - $word = html_escape($word) if $word =~ /[&<>]/; + $word = html_escape($word) if $word =~ /["&<>]/; $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape; } else { - $word = html_escape($word) if $word =~ /[&<>]/; + $word = html_escape($word) if $word =~ /["&<>]/; } } @@ -1443,6 +1459,7 @@ sub process_C { $s1 =~ s/\([^()]*\)//g; # delete parentheses $s2 = $s1; $s1 =~ s/\W//g; # delete bogus characters + $str = html_escape($str); # if there was a pod file that we found earlier with an appropriate # =item directive, then create a link to that page. @@ -1512,7 +1529,7 @@ sub process_X { # after the entire pod file has been read and converted. # sub finish_list { - while ($listlevel >= 0) { + while ($listlevel > 0) { print HTML "</DL>\n"; $listlevel--; } @@ -1546,4 +1563,3 @@ BEGIN { } 1; - diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 6b0b5e7f23..83ba375742 100644 --- a/lib/Term/ReadLine.pm +++ b/lib/Term/ReadLine.pm @@ -193,7 +193,7 @@ sub findConsole { $console = "sys\$command"; } - if ($^O eq 'amigaos') { + if (($^O eq 'amigaos') || ($^O eq 'beos')) { $console = undef; } elsif ($^O eq 'os2') { @@ -310,7 +310,7 @@ sub ornaments { return $rl_term_set unless @_; $rl_term_set = shift; $rl_term_set ||= ',,,'; - $rl_term_set = 'us,ue,md,me' if $rl_term_set == 1; + $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1'; my @ts = split /,/, $rl_term_set, 4; eval { LoadTermCap }; unless (defined $terminal) { diff --git a/lib/Test.pm b/lib/Test.pm index b10d104ded..5f198c234c 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -2,8 +2,9 @@ use strict; package Test; use Test::Harness 1.1601 (); use Carp; -use vars qw($VERSION @ISA @EXPORT $ntest %todo %history $TestLevel); -$VERSION = '0.08'; +use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish + qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish +$VERSION = '1.04'; require Exporter; @ISA=('Exporter'); @EXPORT= qw(&plan &ok &skip $ntest); @@ -19,12 +20,17 @@ $ENV{REGRESSION_TEST} = $0; sub plan { croak "Test::plan(%args): odd number of arguments" if @_ & 1; + croak "Test::plan(): should not be called more than once" if $planned; my $max=0; for (my $x=0; $x < @_; $x+=2) { my ($k,$v) = @_[$x,$x+1]; if ($k =~ /^test(s)?$/) { $max = $v; } elsif ($k eq 'todo' or $k eq 'failok') { for (@$v) { $todo{$_}=1; }; } + elsif ($k eq 'onfail') { + ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE"; + $ONFAIL = $v; + } else { carp "Test::plan(): skipping unrecognized directive '$k'" } } my @todo = sort { $a <=> $b } keys %todo; @@ -33,6 +39,7 @@ sub plan { } else { print "1..$max\n"; } + ++$planned; } sub to_value { @@ -40,79 +47,89 @@ sub to_value { (ref $v or '') eq 'CODE' ? $v->() : $v; } -# prototypes are not used for maximum flexibility - -# STDERR is NOT used for diagnostic output that should be fixed before -# the module is released. +# STDERR is NOT used for diagnostic output which should have been +# fixed before release. Is this appropriate? -sub ok { +sub ok ($;$$) { + croak "ok: plan before you test!" if !$planned; my ($pkg,$file,$line) = caller($TestLevel); my $repetition = ++$history{"$file:$line"}; my $context = ("$file at line $line". - ($repetition > 1 ? " (\#$repetition)" : '')); + ($repetition > 1 ? " fail \#$repetition" : '')); my $ok=0; - + my $result = to_value(shift); + my ($expected,$diag); if (@_ == 0) { - print "not ok $ntest\n"; - print "# test $context: DOESN'T TEST ANYTHING!\n"; + $ok = $result; } else { - my $result = to_value(shift); - my ($expected,$diag); - if (@_ == 0) { - $ok = $result; + $expected = to_value(shift); + # until regex can be manipulated like objects... + my ($regex,$ignore); + if (($regex) = ($expected =~ m,^ / (.+) / $,sx) or + ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { + $ok = $result =~ /$regex/; } else { - $expected = to_value(shift); $ok = $result eq $expected; } - if ($todo{$ntest}) { - if ($ok) { - print "ok $ntest # Wow!\n"; + } + if ($todo{$ntest}) { + if ($ok) { + print "ok $ntest # Wow! ($context)\n"; + } else { + $diag = to_value(shift) if @_; + if (!$diag) { + print "not ok $ntest # (failure expected in $context)\n"; } else { - $diag = to_value(shift) if @_; + print "not ok $ntest # (failure expected: $diag)\n"; + } + } + } else { + print "not " if !$ok; + print "ok $ntest\n"; + + if (!$ok) { + my $detail = { 'repetition' => $repetition, 'package' => $pkg, + 'result' => $result }; + $$detail{expected} = $expected if defined $expected; + $diag = $$detail{diagnostic} = to_value(shift) if @_; + if (!defined $expected) { if (!$diag) { - print "not ok $ntest # (failure expected)\n"; + print STDERR "# Failed test $ntest in $context\n"; } else { - print "not ok $ntest # (failure expected: $diag)\n"; + print STDERR "# Failed test $ntest in $context: $diag\n"; } - } - } else { - print "not " if !$ok; - print "ok $ntest\n"; - - if (!$ok) { - $diag = to_value(shift) if @_; - if (!defined $expected) { - if (!$diag) { - print STDERR "# Failed $context\n"; - } else { - print STDERR "# Failed $context: $diag\n"; - } + } else { + my $prefix = "Test $ntest"; + print STDERR "# $prefix got: '$result' ($context)\n"; + $prefix = ' ' x (length($prefix) - 5); + if (!$diag) { + print STDERR "# $prefix Expected: '$expected'\n"; } else { - print STDERR "# Got: '$result' ($context)\n"; - if (!$diag) { - print STDERR "# Expected: '$expected'\n"; - } else { - print STDERR "# Expected: '$expected' ($diag)\n"; - } + print STDERR "# $prefix Expected: '$expected' ($diag)\n"; } } + push @FAILDETAIL, $detail; } } ++ $ntest; $ok; } -sub skip { +sub skip ($$;$$) { if (to_value(shift)) { print "ok $ntest # skip\n"; ++ $ntest; 1; } else { - local($TestLevel) += 1; #ignore this stack frame - ok(@_); + local($TestLevel) = $TestLevel+1; #ignore this stack frame + &ok; } } +END { + $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; +} + 1; __END__ @@ -124,7 +141,7 @@ __END__ use strict; use Test; - BEGIN { plan tests => 12, todo => [3,4] } + BEGIN { plan tests => 13, todo => [3,4] } ok(0); # failure ok(1); # success @@ -141,7 +158,8 @@ __END__ ok(0, int(rand(2)); # (just kidding! :-) my @list = (0,0); - ok(scalar(@list), 3, "\@list=".join(',',@list)); #extra diagnostics + ok @list, 3, "\@list=".join(',',@list); #extra diagnostics + ok 'segmentation fault', '/(?i)success/'; #regex match skip($feature_is_missing, ...); #do platform specific test @@ -175,10 +193,32 @@ test would be on the new feature list, not the TODO list). Packages should NOT be released with successful TODO tests. As soon as a TODO test starts working, it should be promoted to a normal test -and the new feature should be documented in the release notes. +and the newly minted feature should be documented in the release +notes. =back +=head1 ONFAIL + + BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } + +The test failures can trigger extra diagnostics at the end of the test +run. C<onfail> is passed an array ref of hash refs that describe each +test failure. Each hash will contain at least the following fields: +package, repetition, and result. (The file, line, and test number are +not included because their correspondance to a particular test is +fairly weak.) If the test had an expected value or a diagnostic +string, these will also be included. + +This optional feature might be used simply to print out the version of +your package and/or how to report problems. It might also be used to +generate extremely sophisticated diagnostics for a particular test +failure. It's not a panacea, however. Core dumps or other +unrecoverable errors will prevent the C<onfail> hook from running. +(It is run inside an END block.) Besides, C<onfail> is probably +over-kill in the majority of cases. (Your test code should be simpler +than the code it is testing, yes?) + =head1 SEE ALSO L<Test::Harness> and various test coverage analysis tools. diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 8102ff4cac..e2c47d62ad 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -68,7 +68,9 @@ sub runtests { my $s = $switches; $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/; $fh->close or print "can't close $test. $!\n"; - my $cmd = "$^X $s $test|"; + my $cmd = ($ENV{'COMPILE_TEST'})? +"./perl -I../lib ../utils/perlcc $test -run -verbose dcf -log ./compilelog |" + : "$^X $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; $fh->open($cmd) or print "can't run $test. $!\n"; $ok = $next = $max = 0; diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 62da1d273f..d3a89f03b8 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -1,140 +1,93 @@ package Text::ParseWords; -require 5.000; -use Carp; +use vars qw($VERSION @ISA @EXPORT); +$VERSION = "3.0"; -require AutoLoader; -*AUTOLOAD = \&AutoLoader::AUTOLOAD; +require 5.000; -require Exporter; +use Exporter; @ISA = qw(Exporter); -@EXPORT = qw(shellwords quotewords); +@EXPORT = qw(shellwords quotewords nested_quotewords parse_line); @EXPORT_OK = qw(old_shellwords); -=head1 NAME - -Text::ParseWords - parse text into an array of tokens - -=head1 SYNOPSIS - - use Text::ParseWords; - @words = "ewords($delim, $keep, @lines); - @words = &shellwords(@lines); - @words = &old_shellwords(@lines); - -=head1 DESCRIPTION -"ewords() accepts a delimiter (which can be a regular expression) -and a list of lines and then breaks those lines up into a list of -words ignoring delimiters that appear inside quotes. - -The $keep argument is a boolean flag. If true, the quotes are kept -with each word, otherwise quotes are stripped in the splitting process. -$keep also defines whether unprotected backslashes are retained. - -A &shellwords() replacement is included to demonstrate the new package. -This version differs from the original in that it will _NOT_ default -to using $_ if no arguments are given. I personally find the old behavior -to be a mis-feature. - -"ewords() works by simply jamming all of @lines into a single -string in $_ and then pulling off words a bit at a time until $_ -is exhausted. +sub shellwords { + local(@lines) = @_; + $lines[$#lines] =~ s/\s+$//; + return(quotewords('\s+', 0, @lines)); +} -=head1 AUTHORS -Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 -Basically an update and generalization of the old shellwords.pl. -Much code shamelessly stolen from the old version (author unknown). +sub quotewords { + my($delim, $keep, @lines) = @_; + my($line, @words, @allwords); + + + foreach $line (@lines) { + @words = parse_line($delim, $keep, $line); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); +} -=cut -1; -__END__ -sub shellwords { - local(@lines) = @_; - $lines[$#lines] =~ s/\s+$//; - "ewords('\s+', 0, @lines); +sub nested_quotewords { + my($delim, $keep, @lines) = @_; + my($i, @allwords); + + for ($i = 0; $i < @lines; $i++) { + @{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]); + return() unless (@{$allwords[$i]} || !length($lines[$i])); + } + return(@allwords); } -sub quotewords { - -# The inner "for" loop builds up each word (or $field) one $snippet -# at a time. A $snippet is a quoted string, a backslashed character, -# or an unquoted string. We fall out of the "for" loop when we reach -# the end of $_ or when we hit a delimiter. Falling out of the "for" -# loop, we push the $field we've been building up onto the list of -# @words we'll be returning, and then loop back and pull another word -# off of $_. -# -# The first two cases inside the "for" loop deal with quoted strings. -# The first case matches a double quoted string, removes it from $_, -# and assigns the double quoted string to $snippet in the body of the -# conditional. The second case handles single quoted strings. In -# the third case we've found a quote at the current beginning of $_, -# but it didn't match the quoted string regexps in the first two cases, -# so it must be an unbalanced quote and we croak with an error (which can -# be caught by eval()). -# -# The next case handles backslashed characters, and the next case is the -# exit case on reaching the end of the string or finding a delimiter. -# -# Otherwise, we've found an unquoted thing and we pull of characters one -# at a time until we reach something that could start another $snippet-- -# a quote of some sort, a backslash, or the delimiter. This one character -# at a time behavior was necessary if the delimiter was going to be a -# regexp (love to hear it if you can figure out a better way). - - my ($delim, $keep, @lines) = @_; - my (@words, $snippet, $field); - - local $_ = join ('', @lines); - - while (length) { - $field = ''; +sub parse_line { + my($delimiter, $keep, $line) = @_; + my($quote, $quoted, $unquoted, $delim, $word, @pieces); - for (;;) { - $snippet = ''; + while (length($line)) { + ($quote, $quoted, $unquoted, $delim) = + $line =~ m/^(["']) # a $quote + ((?:\\.|[^\1\\])*?) # and $quoted text + \1 # followed by the same quote + | # --OR-- + ^((?:\\.|[^\\"'])*?) # an $unquoted text + (\Z(?!\n)|$delimiter|(?!^)(?=["'])) + # plus EOL, delimiter, or quote + /x; # extended layout - if (s/^"([^"\\]*(\\.[^"\\]*)*)"//) { - $snippet = $1; - $snippet = qq|"$snippet"| if $keep; - } - elsif (s/^'([^'\\]*(\\.[^'\\]*)*)'//) { - $snippet = $1; - $snippet = "'$snippet'" if $keep; - } - elsif (/^["']/) { - croak 'Unmatched quote'; - } - elsif (s/^\\(.)//) { - $snippet = $1; - $snippet = "\\$snippet" if $keep; - } - elsif (!length || s/^$delim//) { - last; - } - else { - while (length && !(/^$delim/ || /^['"\\]/)) { - $snippet .= substr ($_, 0, 1); - substr($_, 0, 1) = ''; - } - } + return() unless(length($&)); + $line = $'; - $field .= $snippet; + if ($keep) { + $quoted = "$quote$quoted$quote"; + } + else { + $unquoted =~ s/\\(.)/$1/g; + $quoted =~ s/\\(.)/$1/g if ($quote eq '"'); + } + $word .= ($quote) ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); } - - push @words, $field; } - - return @words; + return(@pieces); } + sub old_shellwords { # Usage: @@ -154,13 +107,13 @@ sub old_shellwords { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { - croak "Unmatched double quote: $_"; + return(); } elsif (s/^'(([^'\\]|\\.)*)'//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^'/) { - croak "Unmatched single quote: $_"; + return(); } elsif (s/^\\(.)//) { $snippet = $1; @@ -178,3 +131,117 @@ sub old_shellwords { } @words; } + +1; + +__END__ + +=head1 NAME + +Text::ParseWords - parse text into an array of tokens or array of arrays + +=head1 SYNOPSIS + + use Text::ParseWords; + @lists = &nested_quotewords($delim, $keep, @lines); + @words = "ewords($delim, $keep, @lines); + @words = &shellwords(@lines); + @words = &parse_line($delim, $keep, $line); + @words = &old_shellwords(@lines); # DEPRECATED! + +=head1 DESCRIPTION + +The &nested_quotewords() and "ewords() functions accept a delimiter +(which can be a regular expression) +and a list of lines and then breaks those lines up into a list of +words ignoring delimiters that appear inside quotes. "ewords() +returns all of the tokens in a single long list, while &nested_quotewords() +returns a list of token lists corresponding to the elements of @lines. +&parse_line() does tokenizing on a single string. The &*quotewords() +functions simply call &parse_lines(), so if you're only splitting +one line you can call &parse_lines() directly and save a function +call. + +The $keep argument is a boolean flag. If true, then the tokens are +split on the specified delimiter, but all other characters (quotes, +backslashes, etc.) are kept in the tokens. If $keep is false then the +&*quotewords() functions remove all quotes and backslashes that are +not themselves backslash-escaped or inside of single quotes (i.e., +"ewords() tries to interpret these characters just like the Bourne +shell). NB: these semantics are significantly different from the +original version of this module shipped with Perl 5.000 through 5.004. +As an additional feature, $keep may be the keyword "delimiters" which +causes the functions to preserve the delimiters in each string as +tokens in the token lists, in addition to preserving quote and +backslash characters. + +&shellwords() is written as a special case of "ewords(), and it +does token parsing with whitespace as a delimiter-- similar to most +Unix shells. + +=head1 EXAMPLES + +The sample program: + + use Text::ParseWords; + @words = "ewords('\s+', 0, q{this is "a test" of\ quotewords \"for you}); + $i = 0; + foreach (@words) { + print "$i: <$_>\n"; + $i++; + } + +produces: + + 0: <this> + 1: <is> + 2: <a test> + 3: <of quotewords> + 4: <"for> + 5: <you> + +demonstrating: + +=over 4 + +=item 0 +a simple word + +=item 1 +multiple spaces are skipped because of our $delim + +=item 2 +use of quotes to include a space in a word + +=item 3 +use of a backslash to include a space in a word + +=item 4 +use of a backslash to remove the special meaning of a double-quote + +=item 5 +another simple word (note the lack of effect of the +backslashed double-quote) + +=back + +Replacing C<"ewords('\s+', 0, q{this is...})> +with C<&shellwords(q{this is...})> +is a simpler way to accomplish the same thing. + +=head1 AUTHORS + +Maintainer is Hal Pomeranz <pomeranz@netcom.com>, 1994-1997 (Original +author unknown). Much of the code for &parse_line() (including the +primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>. + +Examples section another documentation provided by John Heidemann +<johnh@ISI.EDU> + +Bug reports, patches, and nagging provided by lots of folks-- thanks +everybody! Special thanks to Michael Schwern <schwern@envirolink.org> +for assuring me that a &nested_quotewords() would be useful, and to +Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about +error-checking (sort of-- you had to be there). + +=cut diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm index 0910a2ab34..0fe7fb93c2 100644 --- a/lib/Text/Wrap.pm +++ b/lib/Text/Wrap.pm @@ -1,71 +1,74 @@ package Text::Wrap; -require Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $columns $debug); +use strict; +use Exporter; -@ISA = (Exporter); +$VERSION = "97.02"; +@ISA = qw(Exporter); @EXPORT = qw(wrap); -@EXPORT_OK = qw($columns); +@EXPORT_OK = qw($columns $tabstop fill); -$VERSION = 97.011701; +use Text::Tabs qw(expand unexpand $tabstop); -use vars qw($VERSION $columns $debug); -use strict; BEGIN { - $columns = 76; # <= screen width - $debug = 0; + $columns = 76; # <= screen width + $debug = 0; } -use Text::Tabs qw(expand unexpand); - sub wrap { - my ($ip, $xp, @t) = @_; - - my $r = ""; - my $t = expand(join(" ",@t)); - my $lead = $ip; - my $ll = $columns - length(expand($lead)) - 1; - my $nl = ""; - - # remove up to a line length of things that aren't - # new lines and tabs. - - if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm) { - - # accept it. - $r .= unexpand($lead . $1); - - # recompute the leader - $lead = $xp; - $ll = $columns - length(expand($lead)) - 1; - $nl = $2; - - # repeat the above until there's none left - while ($t) { - if ( $t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm ) { - print "\$2 is '$2'\n" if $debug; - $nl = $2; - $r .= unexpand("\n" . $lead . $1); - } elsif ($t =~ s/^([^\n]{$ll})//) { - $nl = "\n"; - $r .= unexpand("\n" . $lead . $1); - } - } - $r .= $nl; - } + my ($ip, $xp, @t) = @_; + + my @rv; + my $t = expand(join(" ",@t)); + + my $lead = $ip; + my $ll = $columns - length(expand($lead)) - 1; + my $nl = ""; + + $t =~ s/^\s+//; + while(length($t) > $ll) { + # remove up to a line length of things that + # aren't new lines and tabs. + if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//) { + my ($l,$r) = ($1,$2); + $l =~ s/\s+$//; + print "WRAP $lead$l..($r)\n" if $debug; + push @rv, unexpand($lead . $l), "\n"; + + } elsif ($t =~ s/^([^\n]{$ll})//) { + print "SPLIT $lead$1..\n" if $debug; + push @rv, unexpand($lead . $1),"\n"; + } + # recompute the leader + $lead = $xp; + $ll = $columns - length(expand($lead)) - 1; + $t =~ s/^\s+//; + } + print "TAIL $lead$t\n" if $debug; + push @rv, $lead.$t if $t ne ""; + return join '', @rv; +} - die "couldn't wrap '$t'" - if length($t) > $ll; - print "-----------$r---------\n" if $debug; +sub fill +{ + my ($ip, $xp, @raw) = @_; + my @para; + my $pp; - print "Finish up with '$lead', '$t'\n" if $debug; + for $pp (split(/\n\s+/, join("\n",@raw))) { + $pp =~ s/\s+/ /g; + my $x = wrap($ip, $xp, $pp); + push(@para, $x); + } - $r .= $lead . $t if $t ne ""; + # if paragraph_indent is the same as line_indent, + # separate paragraphs with blank lines - print "-----------$r---------\n" if $debug;; - return $r; + return join ($ip eq $xp ? "\n\n" : "\n", @para); } 1; @@ -81,9 +84,13 @@ Text::Wrap - line wrapping to form simple paragraphs print wrap($initial_tab, $subsequent_tab, @text); - use Text::Wrap qw(wrap $columns); + use Text::Wrap qw(wrap $columns $tabstop fill); $columns = 132; + $tabstop = 4; + + print fill($initial_tab, $subsequent_tab, @text); + print fill("", "", `cat book`); =head1 DESCRIPTION @@ -93,6 +100,12 @@ Indentation is controlled for the first line ($initial_tab) and all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns should be set to the full width of your output device. +Text::Wrap::fill() is a simple multi-paragraph formatter. It formats +each paragraph separately and then joins them together when it's done. It +will destory any whitespace in the original text. It breaks text into +paragraphs by looking for whitespace after a newline. In other respects +it acts like wrap(). + =head1 EXAMPLE print wrap("\t","","This is a bit of text that forms @@ -102,44 +115,11 @@ should be set to the full width of your output device. It's not clear what the correct behavior should be when Wrap() is presented with a word that is longer than a line. The previous -behavior was to die. Now the word is split at line-length. +behavior was to die. Now the word is now split at line-length. =head1 AUTHOR David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and -others. +others. Updated by Jacqui Caren. =cut - -Latest change by Andreas Koenig <k@anna.in-berlin.de> - 1/17/97 - - print fill($initial_tab, $subsequent_tab, @text); - - print fill("", "", `cat book`); - -Text::Wrap::fill() is a simple multi-paragraph formatter. It formats -each paragraph separately and then joins them together when it's done. It -will destory any whitespace in the original text. It breaks text into -paragraphs by looking for whitespace after a newline. In other respects -it acts like wrap(). - -# Tim Pierce did a faster version of this: - -sub fill -{ - my ($ip, $xp, @raw) = @_; - my @para; - my $pp; - - for $pp (split(/\n\s+/, join("\n",@raw))) { - $pp =~ s/\s+/ /g; - my $x = wrap($ip, $xp, $pp); - push(@para, $x); - } - - # if paragraph_indent is the same as line_indent, - # separate paragraphs with blank lines - - return join ($ip eq $xp ? "\n\n" : "\n", @para); -} - diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 89fd61dd74..7ed18962e9 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -67,7 +67,7 @@ Return the (key, value) pair for the first key in the hash. =item NEXTKEY this, lastkey -Return the next (key, value) pair for the hash. +Return the next key for the hash. =item EXISTS this, key diff --git a/lib/base.pm b/lib/base.pm index e20a64bc9a..4c4fb8b86b 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -34,6 +34,9 @@ sub import { foreach my $base (@_) { unless (defined %{"$base\::"}) { eval "require $base"; + # Only ignore "Can't locate" errors from our eval require. + # Other fatal errors (syntax etc) must be reported. + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; unless (defined %{"$base\::"}) { require Carp; Carp::croak("Base class package \"$base\" is empty.\n", diff --git a/lib/chat2.pl b/lib/chat2.pl index 0d9a7d3d50..094d3dff21 100644 --- a/lib/chat2.pl +++ b/lib/chat2.pl @@ -275,7 +275,9 @@ sub print { ## public if ($_[0] =~ /$nextpat/) { *S = shift; } - print S @_; + + local $out = join $, , @_; + syswrite(S, $out, length $out); if( $chat'debug ){ print STDERR "printed:"; print STDERR @_; diff --git a/lib/constant.pm b/lib/constant.pm index a0d4f9d5cd..464e20cd91 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -106,6 +106,15 @@ name as a constant. This is probably a Good Thing. Unlike constants in some languages, these cannot be overridden on the command line or via environment variables. +You can get into trouble if you use constants in a context which +automatically quotes barewords (as is true for any subroutine call). +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'>. + =head1 AUTHOR Tom Phoenix, E<lt>F<rootbeer@teleport.com>E<gt>, with help from diff --git a/lib/integer.pm b/lib/integer.pm index a88ce6a77c..894931896f 100644 --- a/lib/integer.pm +++ b/lib/integer.pm @@ -12,11 +12,22 @@ integer - Perl pragma to compute arithmetic in integer instead of double =head1 DESCRIPTION -This tells the compiler that it's okay to use integer operations +This tells the compiler to use integer operations from here to the end of the enclosing BLOCK. On many machines, this doesn't matter a great deal for most computations, but on those without floating point hardware, it can make a big difference. +Note that this affects the operations, not the numbers. If you run this +code + + use integer; + $x = 1.5; + $y = $x + 1; + $z = -1.5; + +you'll be left with C<$x == 1.5>, C<$y == 2> and C<$z == -1>. The $z +case happens because unary C<-> counts as an operation. + See L<perlmod/Pragmatic Modules>. =cut diff --git a/lib/lib.pm b/lib/lib.pm index 4d32f96355..6e6e15e4ce 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -18,6 +18,10 @@ sub import { Carp::carp("Empty compile time value given to use lib"); # at foo.pl line ... } + if (-e && ! -d _) { + require Carp; + Carp::carp("Parameter to use lib must be directory, not file"); + } unshift(@INC, $_); # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. diff --git a/lib/perl5db.pl b/lib/perl5db.pl index a4a1b1aae6..3ca0adc3d5 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -178,7 +178,8 @@ $inhibit_exit = $option{PrintRet} = 1; globPrint PrintRet UsageOnly frame AutoTrace TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments - signalLevel warnLevel dieLevel inhibit_exit); + signalLevel warnLevel dieLevel inhibit_exit + ImmediateStop); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -194,6 +195,7 @@ $inhibit_exit = $option{PrintRet} = 1; AutoTrace => \$trace, inhibit_exit => \$inhibit_exit, maxTraceLen => \$maxtrace, + ImmediateStop => \$ImmediateStop, ); %optionAction = ( @@ -363,6 +365,9 @@ sub DB { } $single = 0; # return; # Would not print trace! + } elsif ($ImmediateStop) { + $ImmediateStop = 0; + $signal = 1; } } $runnonstop = 0 if $single or $signal; # Disable it if interactive. @@ -1255,6 +1260,10 @@ sub postponed_sub { } sub postponed { + if ($ImmediateStop) { + $ImmediateStop = 0; + $signal = 1; + } return &postponed_sub unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. # Cannot be done before the file is compiled @@ -1795,6 +1804,7 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... I<tkRunning>: run Tk while prompting (with ReadLine); 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. 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; diff --git a/lib/strict.pm b/lib/strict.pm index 8492e933fd..940e8bf7ff 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -38,6 +38,7 @@ use symbolic references (see L<perlref>). =item C<strict vars> This generates a compile-time error if you access a variable that wasn't +declared via C<use vars>, localized via C<my()> or wasn't fully qualified. Because this is to avoid variable suicide problems and subtle dynamic scoping issues, a merely local() variable isn't good enough. See L<perlfunc/my> and @@ -48,6 +49,10 @@ L<perlfunc/local>. my $foo = 10; # ok, my() var local $foo = 9; # blows up + package Cinna; + use vars qw/ $bar /; # Declares $bar in current package + $bar = 'HgS'; # ok, global declared via pragma + The local() generated a compile-time error because you just touched a global name without fully qualifying it. @@ -67,19 +72,22 @@ appears in curly braces or on the left hand side of the "=E<gt>" symbol. =back -See L<perlmod/Pragmatic Modules>. +See L<perlmodlib/Pragmatic Modules>. =cut +$strict::VERSION = "1.01"; + +my %bitmask = ( +refs => 0x00000002, +subs => 0x00000200, +vars => 0x00000400 +); + sub bits { my $bits = 0; - my $sememe; - foreach $sememe (@_) { - $bits |= 0x00000002, next if $sememe eq 'refs'; - $bits |= 0x00000200, next if $sememe eq 'subs'; - $bits |= 0x00000400, next if $sememe eq 'vars'; - } + foreach my $s (@_){ $bits |= $bitmask{$s} || 0; }; $bits; } diff --git a/lib/subs.pm b/lib/subs.pm index 512bc9be9a..aa332a6785 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -20,7 +20,7 @@ C<use subs> declarations are not BLOCK-scoped. They are thus effective for the entire file in which they appear. You may not rescind such declarations with C<no vars> or C<no subs>. -See L<perlmod/Pragmatic Modules> and L<strict/strict subs>. +See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>. =cut diff --git a/lib/vars.pm b/lib/vars.pm index 5723ac6c2c..5256d1199f 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -61,6 +61,6 @@ outside of the package), it can act as an acceptable substitute by pre-declaring global symbols, ensuring their availability to the later-loaded routines. -See L<perlmod/Pragmatic Modules>. +See L<perlmodlib/Pragmatic Modules>. =cut |