diff options
Diffstat (limited to 'gnu/usr.bin/perl/lib')
90 files changed, 8621 insertions, 4135 deletions
diff --git a/gnu/usr.bin/perl/lib/AnyDBM_File.pm b/gnu/usr.bin/perl/lib/AnyDBM_File.pm index 50acce412a4..aff3c7cdec9 100644 --- a/gnu/usr.bin/perl/lib/AnyDBM_File.pm +++ b/gnu/usr.bin/perl/lib/AnyDBM_File.pm @@ -1,18 +1,24 @@ package AnyDBM_File; +use vars qw(@ISA); @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; -eval { require NDBM_File } || -eval { require DB_File } || -eval { require GDBM_File } || -eval { require SDBM_File } || -eval { require ODBM_File }; +my $mod; +for $mod (@ISA) { + if (eval "require $mod") { + @ISA = ($mod); # if we leave @ISA alone, warnings abound + return 1; + } +} + +die "No DBM package was successfully found or installed"; +#return 0; =head1 NAME AnyDBM_File - provide framework for multiple DBMs -NDBM_File, ODBM_File, SDBM_File, GDBM_File - various DBM implementations +NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations =head1 SYNOPSIS @@ -27,20 +33,14 @@ L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and finally ODBM. This way old programs that used to use NDBM via dbmopen() can still do so, but new ones can reorder @ISA: - @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File); - -Note, however, that an explicit use overrides the specified order: - - use GDBM_File; - @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File); - -will only find GDBM_File. + BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) } + use AnyDBM_File; Having multiple DBM implementations makes it trivial to copy database formats: use POSIX; use NDBM_File; use DB_File; - tie %newhash, DB_File, $new_filename, O_CREAT|O_RDWR; - tie %oldhash, NDBM_File, $old_filename, 1, 0; + tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR; + tie %oldhash, 'NDBM_File', $old_filename, 1, 0; %newhash = %oldhash; =head2 DBM Comparisons diff --git a/gnu/usr.bin/perl/lib/AutoLoader.pm b/gnu/usr.bin/perl/lib/AutoLoader.pm index 566ca8688e9..2773a90f10f 100644 --- a/gnu/usr.bin/perl/lib/AutoLoader.pm +++ b/gnu/usr.bin/perl/lib/AutoLoader.pm @@ -1,54 +1,67 @@ package AutoLoader; -use Carp; -$DB::sub = $DB::sub; # Avoid warning -=head1 NAME - -AutoLoader - load functions only on demand - -=head1 SYNOPSIS - - package FOOBAR; - use Exporter; - use AutoLoader; - @ISA = (Exporter, AutoLoader); - -=head1 DESCRIPTION - -This module tells its users that functions in the FOOBAR package are to be -autoloaded from F<auto/$AUTOLOAD.al>. See L<perlsub/"Autoloading">. +use vars qw(@EXPORT @EXPORT_OK); -=cut +BEGIN { + require Exporter; + @EXPORT = (); + @EXPORT_OK = qw(AUTOLOAD); +} AUTOLOAD { - my $name = "auto/$AUTOLOAD.al"; - $name =~ s#::#/#g; - eval {require $name}; + my $name; + # Braces used to preserve $1 et al. + { + my ($pkg,$func) = $AUTOLOAD =~ /(.*)::([^:]+)$/; + $pkg =~ s#::#/#g; + if (defined($name=$INC{"$pkg.pm"})) + { + $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#; + $name = undef unless (-r $name); + } + unless (defined $name) + { + $name = "auto/$AUTOLOAD.al"; + $name =~ s#::#/#g; + } + } + my $save = $@; + eval {local $SIG{__DIE__};require $name}; if ($@) { - # The load might just have failed because the filename was too - # long for some old SVR3 systems which treat long names as errors. - # If we can succesfully truncate a long name then it's worth a go. - # There is a slight risk that we could pick up the wrong file here - # but autosplit should have warned about that when splitting. - if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ - eval {require $name}; - } - elsif ($AUTOLOAD =~ /::DESTROY$/) { - # eval "sub $AUTOLOAD {}"; + if (substr($AUTOLOAD,-9) eq '::DESTROY') { *$AUTOLOAD = sub {}; - } - if ($@){ - $@ =~ s/ at .*\n//; - croak $@; + } else { + # The load might just have failed because the filename was too + # long for some old SVR3 systems which treat long names as errors. + # If we can succesfully truncate a long name then it's worth a go. + # There is a slight risk that we could pick up the wrong file here + # but autosplit should have warned about that when splitting. + if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval {local $SIG{__DIE__};require $name}; + } + if ($@){ + $@ =~ s/ at .*\n//; + my $error = $@; + require Carp; + Carp::croak($error); + } } } - $DB::sub = $AUTOLOAD; # Now debugger know where we are. + $@ = $save; goto &$AUTOLOAD; } - + sub import { - my ($callclass, $callfile, $callline,$path,$callpack) = caller(0); - ($callpack = $callclass) =~ s#::#/#; + my $pkg = shift; + my $callpkg = caller; + + # + # Export symbols, but not by accident of inheritance. + # + + Exporter::export $pkg, $callpkg, @_ if $pkg eq 'AutoLoader'; + + # # Try to find the autosplit index file. Eg., if the call package # is POSIX, then $INC{POSIX.pm} is something like # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in @@ -59,17 +72,178 @@ sub import { # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require # 'auto/POSIX/autosplit.ix' (without the leading 'lib'). # - if (defined($path = $INC{$callpack . '.pm'})) { + + (my $calldir = $callpkg) =~ s#::#/#; + my $path = $INC{$calldir . '.pm'}; + if (defined($path)) { # Try absolute path name. - $path =~ s#^(.*)$callpack\.pm$#$1auto/$callpack/autosplit.ix#; + $path =~ s#^(.*)$calldir\.pm$#$1auto/$calldir/autosplit.ix#; eval { require $path; }; # If that failed, try relative path with normal @INC searching. if ($@) { - $path ="auto/$callpack/autosplit.ix"; + $path ="auto/$calldir/autosplit.ix"; eval { require $path; }; } - carp $@ if ($@); + if ($@) { + my $error = $@; + require Carp; + Carp::carp($error); + } } } 1; + +__END__ + +=head1 NAME + +AutoLoader - load subroutines only on demand + +=head1 SYNOPSIS + + package Foo; + use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine + + package Bar; + use AutoLoader; # don't import AUTOLOAD, define our own + sub AUTOLOAD { + ... + $AutoLoader::AUTOLOAD = "..."; + goto &AutoLoader::AUTOLOAD; + } + +=head1 DESCRIPTION + +The B<AutoLoader> module works with the B<AutoSplit> module and the +C<__END__> token to defer the loading of some subroutines until they are +used rather than loading them all at once. + +To use B<AutoLoader>, the author of a module has to place the +definitions of subroutines to be autoloaded after an C<__END__> token. +(See L<perldata>.) The B<AutoSplit> module can then be run manually to +extract the definitions into individual files F<auto/funcname.al>. + +B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined +subroutine in is called in a client module of B<AutoLoader>, +B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a +file with a name related to the location of the file from which the +client module was read. As an example, if F<POSIX.pm> is located in +F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl +subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where +the C<.al> file has the same name as the subroutine, sans package. If +such a file exists, AUTOLOAD will read and evaluate it, +thus (presumably) defining the needed subroutine. AUTOLOAD will then +C<goto> the newly defined subroutine. + +Once this process completes for a given funtion, it is defined, so +future calls to the subroutine will bypass the AUTOLOAD mechanism. + +=head2 Subroutine Stubs + +In order for object method lookup and/or prototype checking to operate +correctly even when methods have not yet been defined it is necessary to +"forward declare" each subroutine (as in C<sub NAME;>). See +L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine +stubs", which are place holders with no code. + +The AutoSplit and B<AutoLoader> modules automate the creation of forward +declarations. The AutoSplit module creates an 'index' file containing +forward declarations of all the AutoSplit subroutines. When the +AutoLoader module is 'use'd it loads these declarations into its callers +package. + +Because of this mechanism it is important that B<AutoLoader> is always +C<use>d and not C<require>d. + +=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine + +In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must> +explicitly import it: + + use AutoLoader 'AUTOLOAD'; + +=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine + +Some modules, mainly extensions, provide their own AUTOLOAD subroutines. +They typically need to check for some special cases (such as constants) +and then fallback to B<AutoLoader>'s AUTOLOAD for the rest. + +Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine. +Instead, they should define their own AUTOLOAD subroutines along these +lines: + + use AutoLoader; + use Carp; + + sub AUTOLOAD { + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + croak "Your vendor has not defined constant $constname"; + } + } + *$AUTOLOAD = sub { $val }; # same as: eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; + } + +If any module's own AUTOLOAD subroutine has no need to fallback to the +AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit +subroutines), then that module should not use B<AutoLoader> at all. + +=head2 Package Lexicals + +Package lexicals declared with C<my> in the main block of a package +using B<AutoLoader> will not be visible to auto-loaded subroutines, due to +the fact that the given scope ends at the C<__END__> marker. A module +using such variables as package globals will not work properly under the +B<AutoLoader>. + +The C<vars> pragma (see L<perlmod/"vars">) may be used in such +situations as an alternative to explicitly qualifying all globals with +the package namespace. Variables pre-declared with this pragma will be +visible to any autoloaded routines (but will not be invisible outside +the package, unfortunately). + +=head2 B<AutoLoader> vs. B<SelfLoader> + +The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the +loading of subroutines. + +B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>. +While this avoids the use of a hierarchy of disk files and the +associated open/close for each routine loaded, B<SelfLoader> suffers a +startup speed disadvantage in the one-time parsing of the lines after +C<__DATA__>, after which routines are cached. B<SelfLoader> can also +handle multiple packages in a file. + +B<AutoLoader> only reads code as it is requested, and in many cases +should be faster, but requires a machanism like B<AutoSplit> be used to +create the individual files. L<ExtUtils::MakeMaker> will invoke +B<AutoSplit> automatically if B<AutoLoader> is used in a module source +file. + +=head1 CAVEATS + +AutoLoaders prior to Perl 5.002 had a slightly different interface. Any +old modules which use B<AutoLoader> should be changed to the new calling +style. Typically this just means changing a require to a use, adding +the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader> +from C<@ISA>. + +On systems with restrictions on file name length, the file corresponding +to a subroutine may have a shorter name that the routine itself. This +can lead to conflicting file names. The I<AutoSplit> package warns of +these potential conflicts when used to split a module. + +=head1 SEE ALSO + +L<SelfLoader> - an autoloader that doesn't use external files. + +=cut diff --git a/gnu/usr.bin/perl/lib/AutoSplit.pm b/gnu/usr.bin/perl/lib/AutoSplit.pm index f9e3ad6dc4c..8019df7187b 100644 --- a/gnu/usr.bin/perl/lib/AutoSplit.pm +++ b/gnu/usr.bin/perl/lib/AutoSplit.pm @@ -5,6 +5,7 @@ require Exporter; use Config; use Carp; +use File::Path qw(mkpath); @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @@ -16,14 +17,81 @@ AutoSplit - split a package for autoloading =head1 SYNOPSIS - perl -e 'use AutoSplit; autosplit_modules(@ARGV)' ... + perl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... + + use AutoSplit; autosplit($file, $dir, $keep, $check, $modtime); + +for perl versions 5.002 and later: + + perl -MAutoSplit -e 'autosplit($ARGV[0], $ARGV[1], $k, $chk, $modtime)' ... =head1 DESCRIPTION This function will split up your program into files that the AutoLoader -module can handle. Normally only used to build autoloading Perl library -modules, especially extensions (like POSIX). You should look at how -they're built out for details. +module can handle. It is used by both the standard perl libraries and by +the MakeMaker utility, to automatically configure libraries for autoloading. + +The C<autosplit> interface splits the specified file into a hierarchy +rooted at the directory C<$dir>. It creates directories as needed to reflect +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. + +Typical use of AutoSplit in the perl MakeMaker utility is via the command-line +with: + + perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)' + +Defined as a Make macro, it is invoked with file and directory arguments; +C<autosplit> will split the specified file into the specified directory and +delete obsolete C<.al> files, after checking first that the module does use +the AutoLoader, and ensuring that the module is not already currently split +in its current form (the modtime test). + +The C<autosplit_lib_modules> form is used in the building of perl. It takes +as input a list of files (modules) that are assumed to reside in a directory +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 +routines may be placed prior to this marker to force their immediate loading +and parsing. + +=head1 CAVEATS + +Currently, C<AutoSplit> cannot handle multiple package specifications +within one file. + +=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 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. + +C<AutoSplit> will also emit general diagnostics for inability to create +directories or files. =cut @@ -53,12 +121,12 @@ sub autosplit{ # This function is used during perl building/installation -# ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ... +# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... sub autosplit_lib_modules{ my(@modules) = @_; # list of Module names - foreach(@modules){ + while(defined($_ = shift @modules)){ s#::#/#g; # incase specified as ABC::XYZ s|\\|/|g; # bug in ksh OS/2 s#^lib/##; # incase specified as lib/*.pm @@ -79,17 +147,16 @@ sub autosplit_lib_modules{ sub autosplit_file{ my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; my(@names); + local($_); # where to write output files $autodir = "lib/auto" unless $autodir; - ($autodir = VMS::Filespec::unixpath($autodir)) =~ s#/$## if $Is_VMS; + if ($Is_VMS) { + ($autodir = VMS::Filespec::unixpath($autodir)) =~ s{/$}{}; + $filename = VMS::Filespec::unixify($filename); # may have dirs + } unless (-d $autodir){ - local($", @p)="/"; - foreach(split(/\//,$autodir)){ - push(@p, $_); - next if -d "@p/"; - mkdir("@p",0755) or die "AutoSplit unable to mkdir @p: $!"; - } + 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. @@ -123,13 +190,20 @@ sub autosplit_file{ $package or die "Can't find 'package Name;' in $filename\n"; - my($modpname) = $package; $modpname =~ s#::#/#g; - my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + my($modpname) = $package; + if ($^O eq 'MSWin32') { + $modpname =~ s#::#\\#g; + } else { + $modpname =~ s#::#/#g; + } - die "Package $package does not match filename $filename" - unless ($filename =~ m/$modpname.pm$/ or + die "Package $package ($modpname.pm) does not match filename $filename" + unless ($filename =~ m/\Q$modpname.pm\E$/ or + ($^O eq "msdos") or ($^O eq 'MSWin32') or $Is_VMS && $filename =~ m/$modpname.pm/i); + my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; if ($al_ts_time >= $pm_mod_time){ @@ -144,12 +218,7 @@ sub autosplit_file{ if $Verbose; unless (-d "$autodir/$modpname"){ - local($", @p)="/"; - foreach(split(/\//,"$autodir/$modpname")){ - push(@p, $_); - next if -d "@p/"; - mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!"; - } + mkpath("$autodir/$modpname",0,0777); } # We must try to deal with some SVR3 systems with a limit of 14 @@ -180,14 +249,17 @@ sub autosplit_file{ open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning my(@subnames, %proto); + my @cache = (); + my $caching = 1; while (<IN>) { + next if /^=\w/ .. /^=cut/; if (/^package ([\w:]+)\s*;/) { warn "package $1; in AutoSplit section ignored. Not currently supported."; } if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) { print OUT "1;\n"; my $subname = $1; - $proto{$1} = $2 or ''; + $proto{$1} = $2 || ''; if ($subname =~ m/::/){ warn "subs with package names not currently supported in AutoSplit section"; } @@ -207,10 +279,26 @@ sub autosplit_file{ print OUT "# NOTE: Derived from $filename. ", "Changes made here will be lost.\n"; print OUT "package $package;\n\n"; + print OUT @cache; + @cache = (); + $caching = 0; + } + if($caching) { + push(@cache, $_) if @cache || /\S/; + } + else { + print OUT $_; + } + if(/^}/) { + if($caching) { + print OUT @cache; + @cache = (); + } + print OUT "\n"; + $caching = 1; } - print OUT $_; } - print OUT "1;\n"; + print OUT @cache,"1;\n"; close(OUT); close(IN); diff --git a/gnu/usr.bin/perl/lib/Benchmark.pm b/gnu/usr.bin/perl/lib/Benchmark.pm index 9929e6e0be6..13acf869bc1 100644 --- a/gnu/usr.bin/perl/lib/Benchmark.pm +++ b/gnu/usr.bin/perl/lib/Benchmark.pm @@ -14,11 +14,18 @@ timeit - run a chunk of code and see how long it goes timethis ($count, "code"); + # Use Perl code in strings... timethese($count, { 'Name1' => '...code1...', 'Name2' => '...code2...', }); + # ... or use subroutine references. + timethese($count, { + 'Name1' => sub { ...code1... }, + 'Name2' => sub { ...code2... }, + }); + $t = timeit($count, '...other code...') print "$count loops of other code took:",timestr($t),"\n"; @@ -40,43 +47,70 @@ Returns the current time. Example: # ... your code here ... $t1 = new Benchmark; $td = timediff($t1, $t0); - print "the code took:",timestr($dt),"\n"; + print "the code took:",timestr($td),"\n"; =item debug Enables or disable debugging by setting the C<$Benchmark::Debug> flag: - debug Benchmark 1; + debug Benchmark 1; $t = timeit(10, ' 5 ** $Global '); - debug Benchmark 0; + debug Benchmark 0; =back =head2 Standard Exports -The following routines will be exported into your namespace +The following routines will be exported into your namespace if you use the Benchmark module: =over 10 =item timeit(COUNT, CODE) -Arguments: COUNT is the number of time to run the loop, and -the second is the code to run. CODE may be a string containing the code, -a reference to the function to run, or a reference to a hash containing -keys which are names and values which are more CODE specs. +Arguments: COUNT is the number of times to run the loop, and CODE is +the code to run. CODE may be either a code reference or a string to +be eval'd; either way it will be run in the caller's package. + +Returns: a Benchmark object. + +=item timethis ( COUNT, CODE, [ TITLE, [ STYLE ]] ) + +Time COUNT iterations of CODE. CODE may be a string to eval or a +code reference; either way the CODE will run in the caller's package. +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. + +=item timethese ( COUNT, CODEHASHREF, [ STYLE ] ) -Side-effects: prints out noise to standard out. +The CODEHASHREF is a reference to a hash containing names as keys +and either a string to eval or a code reference for each value. +For each (KEY, VALUE) pair in the CODEHASHREF, this routine will +call -Returns: a Benchmark object. + timethis(COUNT, VALUE, KEY, STYLE) -=item timethis +=item timediff ( T1, T2 ) -=item timethese +Returns the difference between two Benchmark times as a Benchmark +object suitable for passing to timestr(). -=item timediff +=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ]] ) -=item timestr +Returns a string that formats the times in the TIMEDIFF object in +the requested STYLE. TIMEDIFF is expected to be a Benchmark object +similar to that returned by timediff(). + +STYLE can be any of 'all', 'noc', 'nop' or 'auto'. 'all' shows each +of the 5 times available ('wallclock' time, user time, system time, +user time of children, and system time of children). 'noc' shows all +except the two children times. 'nop' shows only wallclock and the +two children times. 'auto' (the default) will act as 'all' unless +the children times are both zero, in which case it acts as 'noc'. + +FORMAT is the L<printf(3)>-style format specifier (without the +leading '%') to use to print the times. It defaults to '5.2f'. =back @@ -87,20 +121,31 @@ if you specifically ask that they be imported: =over 10 -clearcache +=item clearcache ( COUNT ) + +Clear the cached time for COUNT rounds of the null loop. + +=item clearallcache ( ) -clearallcache +Clear all cached times. -disablecache +=item disablecache ( ) -enablecache +Disable caching of timings for the null loop. This will force Benchmark +to recalculate these timings for each new piece of code timed. + +=item enablecache ( ) + +Enable caching of timings for the null loop. The time taken for COUNT +rounds of the null loop will be calculated only once for each +different COUNT used. =back =head1 NOTES The data is stored as a list of values from the time and times -functions: +functions: ($real, $user, $system, $children_user, $children_system) @@ -110,10 +155,6 @@ The timing is done using time(3) and times(3). Code is executed in the caller's package. -Enable debugging by: - - $Benchmark::debug = 1; - The time of the null loop (a loop with the same number of rounds but empty loop body) is subtracted from the time of the real loop. @@ -122,10 +163,10 @@ The null loop times are cached, the key being the number of rounds. The caching can be controlled using calls like these: - clearcache($key); + clearcache($key); clearallcache(); - disablecache(); + disablecache(); enablecache(); =head1 INHERITANCE @@ -135,112 +176,36 @@ for Exporter. =head1 CAVEATS +Comparing eval'd strings with code references will give you +inaccurate results: a code reference will show a slower +execution time than the equivalent eval'd string. + The real time timing is done using time(2) and the granularity is therefore only one second. Short tests may produce negative figures because perl -can appear to take longer to execute the empty loop -than a short test; try: +can appear to take longer to execute the empty loop +than a short test; try: timethis(100,'1'); The system time of the null loop might be slightly more than the system time of the loop with the actual -code and therefore the difference might end up being < 0. - -More documentation is needed :-( especially for styles and formats. +code and therefore the difference might end up being E<lt> 0. =head1 AUTHORS -Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi>, -Tim Bunce <Tim.Bunce@ig.co.uk> +Jarkko Hietaniemi <F<jhi@iki.fi>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>> =head1 MODIFICATION HISTORY September 8th, 1994; by Tim Bunce. -=cut +March 28th, 1997; by Hugo van der Sanden: added support for code +references and the already documented 'debug' method; revamped +documentation. -# Purpose: benchmark running times of code. -# -# -# Usage - to time code snippets and print results: -# -# timethis($count, '...code...'); -# -# prints: -# timethis 100: 2 secs ( 0.23 usr 0.10 sys = 0.33 cpu) -# -# -# timethese($count, { -# Name1 => '...code1...', -# Name2 => '...code2...', -# ... }); -# prints: -# Benchmark: timing 100 iterations of Name1, Name2... -# Name1: 2 secs ( 0.50 usr 0.00 sys = 0.50 cpu) -# Name2: 1 secs ( 0.48 usr 0.00 sys = 0.48 cpu) -# -# The default display style will automatically add child process -# values if non-zero. -# -# -# Usage - to time sections of your own code: -# -# use Benchmark; -# $t0 = new Benchmark; -# ... your code here ... -# $t1 = new Benchmark; -# $td = &timediff($t1, $t0); -# print "the code took:",timestr($td),"\n"; -# -# $t = &timeit($count, '...other code...') -# print "$count loops of other code took:",timestr($t),"\n"; -# -# -# Data format: -# The data is stored as a list of values from the time and times -# functions: ($real, $user, $system, $children_user, $children_system) -# in seconds for the whole loop (not divided by the number of rounds). -# -# Internals: -# The timing is done using time(3) and times(3). -# -# Code is executed in the callers package -# -# Enable debugging by: $Benchmark::debug = 1; -# -# The time of the null loop (a loop with the same -# number of rounds but empty loop body) is substracted -# from the time of the real loop. -# -# The null loop times are cached, the key being the -# number of rounds. The caching can be controlled using -# &clearcache($key); &clearallcache; -# &disablecache; &enablecache; -# -# Caveats: -# -# The real time timing is done using time(2) and -# the granularity is therefore only one second. -# -# Short tests may produce negative figures because perl -# can appear to take longer to execute the empty loop -# than a short test: try timethis(100,'1'); -# -# The system time of the null loop might be slightly -# more than the system time of the loop with the actual -# code and therefore the difference might end up being < 0 -# -# More documentation is needed :-( -# Especially for styles and formats. -# -# Authors: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi> -# Tim Bunce <Tim.Bunce@ig.co.uk> -# -# -# Last updated: Sept 8th 94 by Tim Bunce -# +=cut use Carp; use Exporter; @@ -263,76 +228,79 @@ sub init { &clearallcache; } +sub debug { $debug = ($_[1] != 0); } + sub clearcache { delete $cache{$_[0]}; } sub clearallcache { %cache = (); } sub enablecache { $cache = 1; } 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); 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 ; } sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; } sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } -sub timediff{ +sub timediff { my($a, $b) = @_; - my(@r); - for($i=0; $i < @$a; ++$i){ + my @r; + for ($i=0; $i < @$a; ++$i) { push(@r, $a->[$i] - $b->[$i]); } bless \@r; } -sub timestr{ +sub timestr { my($tr, $style, $f) = @_; - my(@t) = @$tr; + my @t = @$tr; warn "bad time value" unless @t==5; my($r, $pu, $ps, $cu, $cs) = @t; my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); - $f = $defaultfmt unless $f; + $f = $defaultfmt unless defined $f; # format a time in the required style, other formats may be added here - $style = $defaultstyle unless $style; - $style = ($ct>0) ? 'all' : 'noc' if $style=~/^auto$/; - my($s) = "@t $style"; # default for unknown style + $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)", - @t,$t) if $style =~ /^all$/; + @t,$t) if $style eq 'all'; $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)", - $r,$pu,$ps,$pt) if $style =~ /^noc$/; + $r,$pu,$ps,$pt) if $style eq 'noc'; $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)", - $r,$cu,$cs,$ct) if $style =~ /^nop$/; + $r,$cu,$cs,$ct) if $style eq 'nop'; $s; } -sub timedebug{ + +sub timedebug { my($msg, $t) = @_; - print STDERR "$msg",timestr($t),"\n" if ($debug); + print STDERR "$msg",timestr($t),"\n" if $debug; } - # --- Functions implementing low-level support for timing loops sub runloop { my($n, $c) = @_; $n+=0; # force numeric now, so garbage won't creep into the eval - croak "negativ loopcount $n" if $n<0; - confess "Usage: runloop(number, string)" unless defined $c; + croak "negative loopcount $n" if $n<0; + confess "Usage: runloop(number, [string | coderef])" unless defined $c; my($t0, $t1, $td); # before, after, difference # find package of caller so we can execute code there - my ($curpack) = caller(0); - my ($i, $pack)= 0; + my($curpack) = caller(0); + my($i, $pack)= 0; while (($pack) = caller(++$i)) { last if $pack ne $curpack; } - my $subcode = "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }"; + my $subcode = (ref $c eq 'CODE') + ? "sub { package $pack; my(\$_i)=$n; while (\$_i--){&\$c;} }" + : "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }"; my $subref = eval $subcode; croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; - print STDERR "runloop $n '$subcode'\n" if ($debug); + print STDERR "runloop $n '$subcode'\n" if $debug; $t0 = &new; &$subref; @@ -350,9 +318,9 @@ sub timeit { printf STDERR "timeit $n $code\n" if $debug; - if ($cache && exists $cache{$n}){ + if ($cache && exists $cache{$n}) { $wn = $cache{$n}; - }else{ + } else { $wn = &runloop($n, ''); $cache{$n} = $wn; } @@ -368,44 +336,38 @@ sub timeit { $wd; } - # --- Functions implementing high-level time-then-print utilities sub timethis{ my($n, $code, $title, $style) = @_; - my($t) = timeit($n, $code); - local($|) = 1; - $title = "timethis $n" unless $title; - $style = "" unless $style; + my $t = timeit($n, $code); + local $| = 1; + $title = "timethis $n" unless defined $title; + $style = "" unless defined $style; printf("%10s: ", $title); print timestr($t, $style),"\n"; + # A conservative warning to spot very silly tests. # Don't assume that your benchmark is ok simply because # you don't get this warning! print " (warning: too few iterations for a reliable count)\n" - if ( $n < $min_count + if $n < $min_count || ($t->real < 1 && $n < 1000) - || $t->cpu_a < $min_cpu); + || $t->cpu_a < $min_cpu; $t; } - sub timethese{ my($n, $alt, $style) = @_; die "usage: timethese(count, { 'Name1'=>'code1', ... }\n" unless ref $alt eq HASH; - my(@all); - my(@names) = sort keys %$alt; - $style = "" unless $style; + my @names = sort keys %$alt; + $style = "" unless defined $style; print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n"; - foreach(@names){ - $t = timethis($n, $alt->{$_}, $_, $style); - push(@all, $t); - } - # we could produce a summary from @all here + + # we could save the results in an array and produce a summary here # sum, min, max, avg etc etc - @all; + map timethis($n, $alt->{$_}, $_, $style), @names; } - 1; diff --git a/gnu/usr.bin/perl/lib/Bundle/CPAN.pm b/gnu/usr.bin/perl/lib/Bundle/CPAN.pm new file mode 100644 index 00000000000..062aab287df --- /dev/null +++ b/gnu/usr.bin/perl/lib/Bundle/CPAN.pm @@ -0,0 +1,43 @@ +package Bundle::CPAN; + +$VERSION = '0.03'; + +1; + +__END__ + +=head1 NAME + +Bundle::CPAN - A bundle to play with all the other modules on CPAN + +=head1 SYNOPSIS + +C<perl -MCPAN -e 'install Bundle::CPAN'> + +=head1 CONTENTS + +MD5 + +Data::Dumper # Bundle::libnet may have problems to work without it + +Bundle::libnet + +Term::ReadKey + +Term::ReadLine::Perl # sorry, I'm discriminating the ::Gnu module + +CPAN::WAIT + +CPAN + +=head1 DESCRIPTION + +This bundle includes CPAN.pm as the base module and CPAN::WAIT, the +first plugin for CPAN that was developed even before there was an API. + +After installing this bundle, it is recommended to quit the current +session and start again in a new process to enable Term::ReadLine. + +=head1 AUTHOR + +Andreas König diff --git a/gnu/usr.bin/perl/lib/Carp.pm b/gnu/usr.bin/perl/lib/Carp.pm index f30bd24135c..685a7933d05 100644 --- a/gnu/usr.bin/perl/lib/Carp.pm +++ b/gnu/usr.bin/perl/lib/Carp.pm @@ -2,9 +2,12 @@ package Carp; =head1 NAME -carp - warn of errors (from perspective of caller) +carp - warn of errors (from perspective of caller) -croak - die of errors (from perspective of caller) +cluck - warn of errors with stack backtrace + (not exported by default) + +croak - die of errors (from perspective of caller) confess - die of errors with stack backtrace @@ -13,6 +16,9 @@ confess - die of errors with stack backtrace use Carp; croak "We're outta here!"; + use Carp qw(cluck); + cluck "This is how we got here!"; + =head1 DESCRIPTION The Carp routines are useful in your own modules because @@ -22,24 +28,55 @@ routine Foo() that has a carp() in it, then the carp() will report the error as occurring where Foo() was called, not where carp() was called. +=head2 Forcing a Stack Trace + +As a debugging aid, you can force Carp to treat a croak as a confess +and a carp as a cluck across I<all> modules. In other words, force a +detailed stack trace to be given. This can be very helpful when trying +to understand why, or from where, a warning or error is being generated. + +This feature is enabled by 'importing' the non-existant symbol +'verbose'. You would typically enable it by saying + + perl -MCarp=verbose script.pl + +or by including the string C<MCarp=verbose> in the L<PERL5OPT> +environment variable. + =cut -# This package implements handy routines for modules that wish to throw -# exceptions outside of the current package. +# This package is heavily used. Be small. Be fast. Be good. $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. require Exporter; -@ISA = Exporter; +@ISA = ('Exporter'); @EXPORT = qw(confess croak carp); +@EXPORT_OK = qw(cluck verbose); +@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +sub export_fail { + shift; + if ($_[0] eq 'verbose') { + local $^W = 0; + *shortmess = \&longmess; + shift; + } + return @_; +} + sub longmess { - my $error = shift; + my $error = join '', @_; my $mess = ""; my $i = 1 + $CarpLevel; - my ($pack,$file,$line,$sub,$eval,$require); - while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) { + my ($pack,$file,$line,$sub,$hargs,$eval,$require); + my (@a); + while (do { { package DB; @a = caller($i++) } } ) { + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; if ($error =~ m/\n$/) { $mess .= $error; } else { @@ -47,7 +84,7 @@ sub longmess { if ($require) { $sub = "require $eval"; } else { - $eval =~ s/[\\\']/\\$&/g; + $eval =~ s/([\\\'])/\\$1/g; if ($MaxEvalLen && length($eval) > $MaxEvalLen) { substr($eval,$MaxEvalLen) = '...'; } @@ -56,35 +93,84 @@ sub longmess { } elsif ($sub eq '(eval)') { $sub = 'eval {...}'; } + 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; + } + else { + s/'/\\'/g; + substr($_,$MaxArgLen) = '...' + if $MaxArgLen and $MaxArgLen < length; + } + $_ = "'$_'" 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) . ')'; + } $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; } $error = "called"; } - $mess || $error; + # this kludge circumvents die's incorrect handling of NUL + my $msg = \($mess || $error); + $$msg =~ tr/\0//d; + $$msg; } sub shortmess { # Short-circuit &longmess if called via multiple packages - my $error = $_[0]; # Instead of "shift" - my ($curpack) = caller(1); + my $error = join '', @_; + my ($prevpack) = caller(1); my $extra = $CarpLevel; my $i = 2; my ($pack,$file,$line); + my %isa = ($prevpack,1); + + @isa{@{"${prevpack}::ISA"}} = () + if(defined @{"${prevpack}::ISA"}); + while (($pack,$file,$line) = caller($i++)) { - if ($pack ne $curpack) { - if ($extra-- > 0) { - $curpack = $pack; - } - else { - return "$error at $file line $line\n"; - } + if(defined @{$pack . "::ISA"}) { + my @i = @{$pack . "::ISA"}; + my %i; + @i{@i} = (); + @isa{@i,$pack} = () + if(exists $i{$prevpack} || exists $isa{$pack}); + } + + next + if(exists $isa{$pack}); + + if ($extra-- > 0) { + %isa = ($pack,1); + @isa{@{$pack . "::ISA"}} = () + if(defined @{$pack . "::ISA"}); + } + else { + # this kludge circumvents die's incorrect handling of NUL + (my $msg = "$error at $file line $line\n") =~ tr/\0//d; + return $msg; } } + continue { + $prevpack = $pack; + } + goto &longmess; } sub confess { die longmess @_; } sub croak { die shortmess @_; } sub carp { warn shortmess @_; } +sub cluck { warn longmess @_; } 1; diff --git a/gnu/usr.bin/perl/lib/Cwd.pm b/gnu/usr.bin/perl/lib/Cwd.pm index bee2e179aef..3bd0085c730 100644 --- a/gnu/usr.bin/perl/lib/Cwd.pm +++ b/gnu/usr.bin/perl/lib/Cwd.pm @@ -1,6 +1,5 @@ package Cwd; require 5.000; -require Exporter; =head1 NAME @@ -27,33 +26,49 @@ The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. The fastcwd() function looks the same as getcwd(), but runs faster. -It's also more dangerous because you might conceivably chdir() out of a -directory that you can't chdir() back into. +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 +encounters a problem it will return undef but will probably leave you +in a different directory. For a measure of extra security, if +everything appears to have worked, the fastcwd() function will check +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 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 -the trailing line terminator). It is recommended that cwd (or another -*cwd() function) is used in I<all> code to ensure portability. +the trailing line terminator). + +It is recommended that cwd (or another *cwd() function) is used in +I<all> code to ensure portability. If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See -L<perlsub/Overriding builtin functions>.) Note that it will only be -kept up to date it all packages which use chdir import it from Cwd. +L<perlsub/Overriding Builtin Functions>.) Note that it will only be +kept up to date if all packages which use chdir import it from Cwd. =cut +## use strict; + +use Carp; + +$VERSION = '2.00'; + +require Exporter; @ISA = qw(Exporter); @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -@EXPORT_OK = qw(chdir); +@EXPORT_OK = qw(chdir abs_path fast_abs_path); + -# use strict; +# The 'natural and safe form' for UNIX (pwd may be setuid root) -sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root) +sub _backtick_pwd { my $cwd; chop($cwd = `pwd`); $cwd; -} +} # Since some ports may predefine cwd internally (e.g., NT) # we take care not to override an existing definition for cwd(). @@ -94,7 +109,7 @@ sub getcwd } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { - $dir = ''; + $dir = undef; } else { @@ -108,7 +123,7 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; + # warn "lstat($dotdots/$dir): $!"; # Just because you can't lstat this directory # doesn't mean you'll never find the right one. # closedir(PARENT); @@ -118,10 +133,10 @@ sub getcwd while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || $tst[1] != $pst[1]); } - $cwd = "$dir/$cwd"; + $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; closedir(PARENT); - } while ($dir); - chop($cwd); # drop the trailing / + } while (defined $dir); + chop($cwd) unless $cwd eq '/'; # drop the trailing / $cwd; } @@ -133,33 +148,45 @@ sub getcwd # # This is a faster version of getcwd. It's also more dangerous because # you might chdir out of a directory that you can't chdir back into. + +# List of metachars taken from do_exec() in doio.c +my $quoted_shell_meta = quotemeta('$&*(){}[]";\\|?<>~`'."'\n"); sub fastcwd { my($odev, $oino, $cdev, $cino, $tdev, $tino); my(@path, $path); local(*DIR); - ($cdev, $cino) = stat('.'); + my($orig_cdev, $orig_cino) = stat('.'); + ($cdev, $cino) = ($orig_cdev, $orig_cino); for (;;) { my $direntry; ($odev, $oino) = ($cdev, $cino); - chdir('..'); + chdir('..') || return undef; ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; - opendir(DIR, '.'); + opendir(DIR, '.') || return undef; for (;;) { $direntry = readdir(DIR); + last unless defined $direntry; next if $direntry eq '.'; next if $direntry eq '..'; - last unless defined $direntry; ($tdev, $tino) = lstat($direntry); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); + return undef unless defined $direntry; # should never happen unshift(@path, $direntry); } - chdir($path = '/' . join('/', @path)); + $path = '/' . join('/', @path); + # At this point $path may be tainted (if tainting) and chdir would fail. + # To be more useful we untaint it then check that we landed where we started. + $path = $1 if $path =~ /^(.*)$/; # untaint + chdir($path) || return undef; + ($cdev, $cino) = stat('.'); + die "Unstable directory path, current directory changed unexpectedly" + if $cdev != $orig_cdev || $cino != $orig_cino; $path; } @@ -172,7 +199,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -216,20 +243,94 @@ sub chdir { 1; } +# Taken from Cwd.pm It is really getcwd with an optional +# parameter instead of '.' +# + +sub abs_path +{ + my $start = shift || '.'; + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat( $start )) + { + carp "stat($start): $!"; + return ''; + } + $cwd = ''; + $dotdots = $start; + do + { + $dotdots .= '/..'; + @pst = @cst; + unless (opendir(PARENT, $dotdots)) + { + carp "opendir($dotdots): $!"; + return ''; + } + unless (@cst = stat($dotdots)) + { + carp "stat($dotdots): $!"; + closedir(PARENT); + return ''; + } + if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) + { + $dir = ''; + } + else + { + do + { + unless (defined ($dir = readdir(PARENT))) + { + carp "readdir($dotdots): $!"; + closedir(PARENT); + return ''; + } + $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) + } + while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || + $tst[1] != $pst[1]); + } + $cwd = "$dir/$cwd"; + closedir(PARENT); + } while ($dir); + chop($cwd); # drop the trailing / + $cwd; +} + +sub fast_abs_path { + my $cwd = getcwd(); + my $path = shift || '.'; + chdir($path) || croak "Cannot chdir to $path:$!"; + my $realpath = getcwd(); + chdir($cwd) || croak "Cannot chdir back to $cwd:$!"; + $realpath; +} + # --- PORTING SECTION --- # VMS: $ENV{'DEFAULT'} points to default directory at all times # 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu # Note: Use of Cwd::chdir() causes the logical name PWD to be defined -# in the process logical name table as the default device and directory -# seen by Perl. This may not be the same as the default device +# in the process logical name table as the default device and directory +# seen by Perl. This may not be the same as the default device # and directory seen by DCL after Perl exits, since the effects # the CRTL chdir() function persist only until Perl exits. sub _vms_cwd { - return $ENV{'DEFAULT'} + return $ENV{'DEFAULT'}; +} + +sub _vms_abs_path { + return $ENV{'DEFAULT'} unless @_; + my $path = VMS::Filespec::pathify($_[0]); + croak("Invalid path name $_[0]") unless defined $path; + return VMS::Filespec::rmsexpand($path); } + sub _os2_cwd { $ENV{'PWD'} = `cmd /c cd`; chop $ENV{'PWD'}; @@ -237,27 +338,59 @@ sub _os2_cwd { return $ENV{'PWD'}; } -my($oldw) = $^W; -$^W = 0; # assignments trigger 'subroutine redefined' warning -if ($^O eq 'VMS') { - - *cwd = \&_vms_cwd; - *getcwd = \&_vms_cwd; - *fastcwd = \&_vms_cwd; - *fastgetcwd = \&_vms_cwd; +sub _win32_cwd { + $ENV{'PWD'} = Win32::GetCurrentDirectory(); + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; } -elsif ($^O eq 'NT') { - *getcwd = \&cwd; - *fastgetcwd = \&cwd; +*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && + defined &Win32::GetCurrentDirectory); + +*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd; + +sub _msdos_cwd { + $ENV{'PWD'} = `command /c cd`; + chop $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; } -elsif ($^O eq 'os2') { - *cwd = \&_os2_cwd; - *getcwd = \&_os2_cwd; - *fastgetcwd = \&_os2_cwd; - *fastcwd = \&_os2_cwd; + +{ + local $^W = 0; # assignments trigger 'subroutine redefined' warning + + if ($^O eq 'VMS') { + *cwd = \&_vms_cwd; + *getcwd = \&_vms_cwd; + *fastcwd = \&_vms_cwd; + *fastgetcwd = \&_vms_cwd; + *abs_path = \&_vms_abs_path; + *fast_abs_path = \&_vms_abs_path; + } + elsif ($^O eq 'NT' or $^O eq 'MSWin32') { + # We assume that &_NT_cwd is defined as an XSUB or in the core. + *cwd = \&_NT_cwd; + *getcwd = \&_NT_cwd; + *fastcwd = \&_NT_cwd; + *fastgetcwd = \&_NT_cwd; + *abs_path = \&fast_abs_path; + } + elsif ($^O eq 'os2') { + # sys_cwd may keep the builtin command + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + *abs_path = \&fast_abs_path; + } + elsif ($^O eq 'msdos') { + *cwd = \&_msdos_cwd; + *getcwd = \&_msdos_cwd; + *fastgetcwd = \&_msdos_cwd; + *fastcwd = \&_msdos_cwd; + *abs_path = \&fast_abs_path; + } } -$^W = $oldw; # package main; eval join('',<DATA>) || die $@; # quick test diff --git a/gnu/usr.bin/perl/lib/Devel/SelfStubber.pm b/gnu/usr.bin/perl/lib/Devel/SelfStubber.pm index fc7ee4b5110..4c2d0395803 100644 --- a/gnu/usr.bin/perl/lib/Devel/SelfStubber.pm +++ b/gnu/usr.bin/perl/lib/Devel/SelfStubber.pm @@ -35,7 +35,7 @@ sub stub { $fh = "${module}::DATA"; open($fh,$mod_file) || die "Unable to open $mod_file"; - while($line = <$fh> and $line !~ m/^__DATA__/) { + while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) { push(@BEFORE_DATA,$line); $line =~ /use\s+SelfLoader/ && $found_selfloader++; } @@ -45,7 +45,7 @@ sub stub { $self->_load_stubs($module); if ( fileno($fh) ) { $end = 1; - while($line = <$fh>) { + while(defined($line = <$fh>)) { push(@AFTER_DATA,$line); } } @@ -118,7 +118,7 @@ So, for classes and subclasses to have inheritance correctly work with autoloading, you need to ensure stubs are loaded. The SelfLoader can load stubs automatically at module initialization -with the statement 'SelfLoader->load_stubs()';, but you may wish to +with the statement 'SelfLoader-E<gt>load_stubs()';, but you may wish to avoid having the stub loading overhead associated with your initialization (though note that the SelfLoader::load_stubs method will be called sooner or later - at latest when the first sub diff --git a/gnu/usr.bin/perl/lib/English.pm b/gnu/usr.bin/perl/lib/English.pm index ce4520a8911..bbb6bd7b280 100644 --- a/gnu/usr.bin/perl/lib/English.pm +++ b/gnu/usr.bin/perl/lib/English.pm @@ -92,7 +92,7 @@ sub import { *OSNAME ); -# The ground of all being. +# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical) *ARG = *_ ; @@ -138,8 +138,8 @@ sub import { *CHILD_ERROR = *? ; *OS_ERROR = *! ; - *EXTENDED_OS_ERROR = *^E ; *ERRNO = *! ; + *EXTENDED_OS_ERROR = *^E ; *EVAL_ERROR = *@ ; # Process info. diff --git a/gnu/usr.bin/perl/lib/Env.pm b/gnu/usr.bin/perl/lib/Env.pm index 0e790754a82..f2fe4af422e 100644 --- a/gnu/usr.bin/perl/lib/Env.pm +++ b/gnu/usr.bin/perl/lib/Env.pm @@ -11,10 +11,9 @@ Env - perl module that imports environment variables =head1 DESCRIPTION -Perl maintains environment variables in a pseudo-associative-array -named %ENV. For when this access method is inconvenient, the Perl -module C<Env> allows environment variables to be treated as simple -variables. +Perl maintains environment variables in a pseudo-hash named %ENV. For +when this access method is inconvenient, the Perl module C<Env> allows +environment variables to be treated as simple variables. The Env::import() function ties environment variables with suitable names to global Perl variables with the same names. By default it @@ -39,7 +38,7 @@ the environment, assign it the undefined value =head1 AUTHOR -Chip Salzenberg <chip@fin.uucp> +Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt> =cut @@ -47,7 +46,11 @@ sub import { my ($callpack) = caller(0); my $pack = shift; my @vars = @_ ? @_ : keys(%ENV); + return unless @vars; + eval "package $callpack; use vars qw(" + . join(' ', map { '$'.$_ } @vars) . ")"; + die $@ if $@; foreach (@vars) { tie ${"${callpack}::$_"}, Env, $_ if /^[A-Za-z_]\w*$/; } diff --git a/gnu/usr.bin/perl/lib/Exporter.pm b/gnu/usr.bin/perl/lib/Exporter.pm index 343b9fbd174..3f42e407e0b 100644 --- a/gnu/usr.bin/perl/lib/Exporter.pm +++ b/gnu/usr.bin/perl/lib/Exporter.pm @@ -2,21 +2,31 @@ package Exporter; require 5.001; +# +# We go to a lot of trouble not to 'require Carp' at file scope, +# because Carp requires Exporter, and something has to give. +# + $ExportLevel = 0; $Verbose = 0 unless $Verbose; -require Carp; - sub export { # First make import warnings look like they're coming from the "use". local $SIG{__WARN__} = sub { my $text = shift; - $text =~ s/ at \S*Exporter.pm line \d+.*\n//; - local $Carp::CarpLevel = 1; # ignore package calling us too. - Carp::carp($text); + if ($text =~ s/ at \S*Exporter.pm line \d+.*\n//) { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. + Carp::carp($text); + } + else { + warn $text; + } }; local $SIG{__DIE__} = sub { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") if $_[0] =~ /^Unable to create sub named "(.*?)::"/; }; @@ -91,13 +101,23 @@ sub export { @imports = @exports; last; } + # We need a way to emulate 'use Foo ()' but still + # allow an easy version check: "use Foo 1.23, ''"; + if (@imports == 2 and !$imports[1]) { + @imports = (); + last; + } } elsif ($sym !~ s/^&// || !$exports{$sym}) { - warn qq["$sym" is not exported by the $pkg module]; + require Carp; + Carp::carp(qq["$sym" is not exported by the $pkg module]); $oops++; } } } - Carp::croak("Can't continue after import errors") if $oops; + if ($oops) { + require Carp; + Carp::croak("Can't continue after import errors"); + } } else { @imports = @exports; @@ -118,10 +138,14 @@ sub export { if (@failed) { @failed = $pkg->export_fail(@failed); foreach $sym (@failed) { - warn qq["$sym" is not implemented by the $pkg module ], - "on this architecture"; + require Carp; + Carp::carp(qq["$sym" is not implemented by the $pkg module ], + "on this architecture"); + } + if (@failed) { + require Carp; + Carp::croak("Can't continue after import errors"); } - Carp::croak("Can't continue after import errors") if @failed; } } @@ -139,10 +163,19 @@ sub export { $type eq '@' ? \@{"${pkg}::$sym"} : $type eq '%' ? \%{"${pkg}::$sym"} : $type eq '*' ? *{"${pkg}::$sym"} : - Carp::croak("Can't export symbol: $type$sym"); + do { require Carp; Carp::croak("Can't export symbol: $type$sym") }; } } +sub export_to_level +{ + my $pkg = shift; + my ($level, $junk) = (shift, shift); # need to get rid of first arg + # we know it already. + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + sub import { my $pkg = shift; my $callpkg = caller($ExportLevel); @@ -150,6 +183,7 @@ sub import { } + # Utility functions sub _push_tags { @@ -159,8 +193,11 @@ sub _push_tags { push(@{"${pkg}::$var"}, map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) } (@$syms) ? @$syms : keys %export_tags); - # This may change to a die one day - Carp::carp("Some names are not tags") if $nontag and $^W; + if ($nontag and $^W) { + # This may change to a die one day + require Carp; + Carp::carp("Some names are not tags"); + } } sub export_tags { _push_tags((caller)[0], "EXPORT", \@_) } @@ -170,15 +207,21 @@ sub export_ok_tags { _push_tags((caller)[0], "EXPORT_OK", \@_) } # Default methods sub export_fail { + my $self = shift; @_; } sub require_version { my($self, $wanted) = @_; my $pkg = ref $self || $self; - my $version = ${"${pkg}::VERSION"} || "(undef)"; - Carp::croak("$pkg $wanted required--this is only version $version") - if $version < $wanted; + my $version = ${"${pkg}::VERSION"}; + if (!$version or $version < $wanted) { + $version ||= "(undef)"; + my $file = $INC{"$pkg.pm"}; + $file &&= " ($file)"; + require Carp; + Carp::croak("$pkg $wanted required--this is only version $version$file") + } $version; } @@ -235,7 +278,7 @@ In other files which wish to use ModuleName: =head1 DESCRIPTION The Exporter module implements a default C<import> method which -many modules choose inherit rather than implement their own. +many modules choose to inherit rather than implement their own. Perl automatically calls the C<import> method when processing a C<use> statement for a module. Modules and C<use> are documented @@ -254,7 +297,7 @@ try to use @EXPORT_OK in preference to @EXPORT and avoid short or common symbol names to reduce the risk of name clashes. Generally anything not exported is still accessible from outside the -module using the ModuleName::item_name (or $blessed_ref->method) +module using the ModuleName::item_name (or $blessed_ref-E<gt>method) syntax. By convention you can use a leading underscore on names to informally indicate that they are 'internal' and not for public use. @@ -315,10 +358,57 @@ You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the specifications are being processed and what is actually being imported into modules. +=head2 Exporting without using Export's import method + +Exporter has a special method, 'export_to_level' which is used in situations +where you can't directly call Export's import method. The export_to_level +method looks like: + +MyPackage->export_to_level($where_to_export, @what_to_export); + +where $where_to_export is an integer telling how far up the calling stack +to export your symbols, and @what_to_export is an array telling what +symbols *to* export (usually this is @_). + +For example, suppose that you have a module, A, which already has an +import function: + +package A; + +@ISA = qw(Exporter); +@EXPORT_OK = qw ($b); + +sub import +{ + $A::b = 1; # not a very useful import method +} + +and you want to Export symbol $A::b back to the module that called +package A. Since Exporter relies on the import method to work, via +inheritance, as it stands Exporter::import() will never get called. +Instead, say the following: + +package A; +@ISA = qw(Exporter); +@EXPORT_OK = qw ($b); + +sub import +{ + $A::b = 1; + A->export_to_level(1, @_); +} + +This will export the symbols one level 'above' the current package - ie: to +the program or module that used package A. + +Note: Be careful not to modify '@_' at all before you call export_to_level +- or people using your package will get very unexplained results! + + =head2 Module Version Checking The Exporter module will convert an attempt to import a number from a -module into a call to $module_name->require_version($value). This can +module into a call to $module_name-E<gt>require_version($value). This can be used to validate that the version of the module being used is greater than or equal to the required version. @@ -339,7 +429,7 @@ or constants that may not exist on some systems. The names of any symbols that cannot be exported should be listed in the C<@EXPORT_FAIL> array. -If a module attempts to import any of these symbols the Exporter will +If a module attempts to import any of these symbols the Exporter will give the module an opportunity to handle the situation before generating an error. The Exporter will call an export_fail method with a list of the failed symbols: diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Install.pm b/gnu/usr.bin/perl/lib/ExtUtils/Install.pm index 441448eeade..2c1dd8ae341 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Install.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Install.pm @@ -1,18 +1,18 @@ package ExtUtils::Install; -$VERSION = substr q$Revision: 1.1 $, 10; -# $Id: Install.pm,v 1.1 1996/08/19 10:12:39 downsj Exp $ +$VERSION = substr q$Revision: 1.2 $, 10; +# $Date: 1997/11/30 07:57:24 $ use Exporter; use Carp (); -use Config (); +use Config qw(%Config); use vars qw(@ISA @EXPORT $VERSION); @ISA = ('Exporter'); -@EXPORT = ('install','uninstall','pm_to_blib'); +@EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); $Is_VMS = $^O eq 'VMS'; my $splitchar = $^O eq 'VMS' ? '|' : $^O eq 'os2' ? ';' : ':'; -my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'}; +my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; my $Inc_uninstall_warn_handler; #use vars qw( @EXPORT @ISA $Is_VMS ); @@ -34,16 +34,12 @@ sub install { use File::Copy qw(copy); use File::Find qw(find); use File::Path qw(mkpath); - # The following lines were needed with AutoLoader (left for the record) - # my $my_req = $self->catfile(qw(auto ExtUtils Install my_cmp.al)); - # require $my_req; - # $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); - # require $my_req; # Hairy, but for the first - # time use we are in a different directory when autoload happens, so - # the relativ path to ./blib is ill. + use File::Compare qw(compare); my(%hash) = %$hash; - my(%pack, %write, $dir); + my(%pack, %write, $dir, $warn_permissions); + # -w doesn't work reliably on FAT dirs + $warn_permissions++ if $^O eq 'MSWin32'; local(*DIR, *P); for (qw/read write/) { $pack{$_}=$hash{$_}; @@ -59,7 +55,8 @@ sub install { if (-w $hash{$source_dir_or_file} || mkpath($hash{$source_dir_or_file})) { last; } else { - Carp::croak("You do not have permissions to install into $hash{$source_dir_or_file}"); + warn "Warning: You do not have permissions to install into $hash{$source_dir_or_file}" + unless $warn_permissions++; } } closedir DIR; @@ -100,7 +97,7 @@ sub install { my $diff = 0; if ( -f $targetfile && -s _ == $size) { # We have a good chance, we can skip this one - $diff = my_cmp($_,$targetfile); + $diff = compare($_,$targetfile); } else { print "$_ differs\n" if $verbose>1; $diff++; @@ -148,30 +145,26 @@ sub install { } } -sub my_cmp { - my($one,$two) = @_; - local(*F,*T); - my $diff = 0; - open T, $two or return 1; - open F, $one or Carp::croak("Couldn't open $one: $!"); - my($fr, $tr, $fbuf, $tbuf, $size); - $size = 1024; - # print "Reading $one\n"; - while ( $fr = read(F,$fbuf,$size)) { - unless ( - $tr = read(T,$tbuf,$size) and - $tbuf eq $fbuf - ){ - # print "diff "; - $diff++; - last; - } - # print "$fr/$tr "; - } - # print "\n"; - close F; - close T; - $diff; +sub install_default { + @_ < 2 or die "install_default should be called with 0 or 1 argument"; + my $FULLEXT = @_ ? shift : $ARGV[0]; + defined $FULLEXT or die "Do not know to where to write install log"; + my $INST_LIB = MM->catdir(MM->curdir,"blib","lib"); + my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch"); + my $INST_BIN = MM->catdir(MM->curdir,'blib','bin'); + my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script'); + my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1'); + my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3'); + install({ + read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", + write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", + $INST_LIB => $Config{installsitelib}, + $INST_ARCHLIB => $Config{installsitearch}, + $INST_BIN => $Config{installbin} , + $INST_SCRIPT => $Config{installscript}, + $INST_MAN1DIR => $Config{installman1dir}, + $INST_MAN3DIR => $Config{installman3dir}, + },1,0,0); } sub uninstall { @@ -196,7 +189,7 @@ sub inc_uninstall { my $MY = {}; bless $MY, 'MY'; my %seen_dir = (); - foreach $dir (@INC, @PERL_ENV_LIB, @Config::Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) { + foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) { next if $dir eq "."; next if $seen_dir{$dir}++; my($targetfile) = $MY->catfile($dir,$libdir,$file); @@ -208,7 +201,7 @@ sub inc_uninstall { my $diff = 0; if ( -f $targetfile && -s _ == -s $file) { # We have a good chance, we can skip this one - $diff = my_cmp($file,$targetfile); + $diff = compare($file,$targetfile); } else { print "#$file and $targetfile differ\n" if $verbose>1; $diff++; @@ -235,15 +228,27 @@ sub pm_to_blib { use File::Basename qw(dirname); use File::Copy qw(copy); use File::Path qw(mkpath); + use File::Compare qw(compare); use AutoSplit; # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first + if (!ref($fromto) && -r $fromto) + { + # Win32 has severe command line length limitations, but + # can generate temporary files on-the-fly + # so we pass name of file here - eval it to get hash + open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!"; + my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}'; + eval $str; + close(FROMTO); + } + my $umask = umask 0022 unless $Is_VMS; mkpath($autodir,0,0755); foreach (keys %$fromto) { next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; - unless (my_cmp($_,$fromto->{$_})){ + unless (compare($_,$fromto->{$_})){ print "Skip $fromto->{$_} (unchanged)\n"; next; } @@ -253,7 +258,9 @@ sub pm_to_blib { mkpath(dirname($fromto->{$_}),0,0755); } copy($_,$fromto->{$_}); - chmod(0444 | ( (stat)[2] & 0111 ? 0111 : 0 ),$fromto->{$_}); + my($mode,$atime,$mtime) = (stat)[2,8,9]; + utime($atime,$mtime+$Is_VMS,$fromto->{$_}); + chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_}); print "cp $_ $fromto->{$_}\n"; next unless /\.pm$/; autosplit($fromto->{$_},$autodir); @@ -318,12 +325,26 @@ be copied preserving timestamps and permissions. There are two keys with a special meaning in the hash: "read" and "write". After the copying is done, install will write the list of -target files to the file named by $hashref->{write}. If there is -another file named by $hashref->{read}, the contents of this file will +target files to the file named by C<$hashref-E<gt>{write}>. If there is +another file named by C<$hashref-E<gt>{read}>, the contents of this file will be merged into the written file. The read and the written file may be identical, but on AFS it is quite likely, people are installing to a different directory than the one where the files later appear. +install_default() takes one or less arguments. If no arguments are +specified, it takes $ARGV[0] as if it was specified as an argument. +The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>. +This function calls install() with the same arguments as the defaults +the MakeMaker would use. + +The argumement-less form is convenient for install scripts like + + perl -MExtUtils::Install -e install_default Tk/Canvas + +Assuming this command is executed in a directory with populated F<blib> +directory, it will proceed as if the F<blib> was build by MakeMaker on +this machine. This is useful for binary distributions. + uninstall() takes as first argument a file containing filenames to be unlinked. The second argument is a verbose switch, the third is a no-don't-really-do-it-now switch. @@ -334,4 +355,3 @@ the extension pm are autosplit. Second argument is the autosplit directory. =cut - diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm b/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm index b67f86bbce0..5b4d6abecb4 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm @@ -1,17 +1,21 @@ package ExtUtils::Liblist; - +use vars qw($VERSION); # Broken out of MakeMaker from version 4.11 -$ExtUtils::Liblist::VERSION = substr q$Revision: 1.1 $, 10; +$VERSION = substr q$Revision: 1.2 $, 10; use Config; use Cwd 'cwd'; use File::Basename; -my $Config_libext = $Config{lib_ext} || ".a"; - sub ext { - my($self,$potential_libs, $Verbose) = @_; + if ($^O eq 'VMS') { return &_vms_ext; } + elsif($^O eq 'MSWin32') { return &_win32_ext; } + else { return &_unix_os2_ext; } +} + +sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. @@ -20,15 +24,16 @@ sub ext { $potential_libs .= $Config{libs}; } return ("", "", "", "") unless $potential_libs; - print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + warn "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs # this is a rewrite of Andy Dougherty's extliblist in perl - # its home is in <distribution>/ext/util my(@searchpath); # from "-L/path" entries in $potential_libs my(@libpath) = split " ", $Config{'libpth'}; @@ -43,12 +48,12 @@ sub ext { if ($thislib =~ s/^(-[LR])//){ # save path flag type my($ptype) = $1; unless (-d $thislib){ - print STDOUT "$ptype$thislib ignored, directory does not exist\n" - if $Verbose; + warn "$ptype$thislib ignored, directory does not exist\n" + if $verbose; next; } unless ($self->file_name_is_absolute($thislib)) { - print STDOUT "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; + warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; $thislib = $self->catdir($pwd,$thislib); } push(@searchpath, $thislib); @@ -59,7 +64,7 @@ sub ext { # Handle possible library arguments. unless ($thislib =~ s/^-l//){ - print STDOUT "Unrecognized argument in LIBS ignored: '$thislib'\n"; + warn "Unrecognized argument in LIBS ignored: '$thislib'\n"; next; } @@ -72,7 +77,8 @@ sub ext { # For gcc-2.6.2 on linux (March 1995), DLD can not load # .sa libraries, with the exception of libm.sa, so we # deliberately skip them. - if (@fullname = $self->lsdir($thispth,"^lib$thislib\.$so\.[0-9]+")){ + if (@fullname = + $self->lsdir($thispth,"^\Qlib$thislib.$so.\E[0-9]+")){ # Take care that libfoo.so.10 wins against libfoo.so.9. # Compare two libraries to find the most recent version # number. E.g. if you have libfoo.so.9.0.7 and @@ -118,10 +124,10 @@ sub ext { # # , the compilation tools expand the environment variables.) } else { - print STDOUT "$thislib not found in $thispth\n" if $Verbose; + warn "$thislib not found in $thispth\n" if $verbose; next; } - print STDOUT "'-l$thislib' found at $fullname\n" if $Verbose; + warn "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; @@ -135,15 +141,18 @@ sub ext { # Do not add it into the list if it is already linked in # with the main perl executable. - # We have to special-case the NeXT, because all the math - # is also in libsys_s + # We have to special-case the NeXT, because math and ndbm + # are both in libsys_s unless ($in_perl || - ($^O eq 'next' && $thislib eq 'm') ){ + ($Config{'osname'} eq 'next' && + ($thislib eq 'm' || $thislib eq 'ndbm')) ){ push(@extralibs, "-l$thislib"); } # We might be able to load this archive file dynamically - if ( $Config{'dlsrc'} =~ /dl_next|dl_dld/){ + if ( ($Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0') + || ($Config{'dlsrc'} =~ /dl_dld/) ) + { # We push -l$thislib instead of $fullname because # it avoids hardwiring a fixed path into the .bs file. # Mkbootstrap will automatically add dl_findfile() to @@ -164,13 +173,223 @@ sub ext { } last; # found one here so don't bother looking further } - print STDOUT "Warning (will try anyway): No library found for -l$thislib\n" + warn "Note (probably harmless): " + ."No library found for -l$thislib\n" unless $found_lib>0; } return ('','','','') unless $found; ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); } +sub _win32_ext { + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. + # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; + my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + + if ($libs and $potential_libs !~ /:nodefault/i) { + # If Config.pm defines a set of default libs, we always + # tack them on to the user-supplied list, unless the user + # specified :nodefault + + $potential_libs .= " " if $potential_libs; + $potential_libs .= $libs; + } + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + # compute $extralibs from $potential_libs + + my(@searchpath); # from "-L/path" entries in $potential_libs + my(@libpath) = split " ", $libpth; + my(@extralibs); + my($fullname, $thislib, $thispth); + my($pwd) = cwd(); # from Cwd.pm + my($lib) = ''; + my($found) = 0; + + foreach $thislib (split ' ', $potential_libs){ + + # Handle possible linker path arguments. + if ($thislib =~ s/^-L// and not -d $thislib) { + warn "-L$thislib ignored, directory does not exist\n" + if $verbose; + next; + } + elsif (-d $thislib) { + unless ($self->file_name_is_absolute($thislib)) { + warn "Warning: -L$thislib changed to -L$pwd/$thislib\n"; + $thislib = $self->catdir($pwd,$thislib); + } + push(@searchpath, $thislib); + next; + } + + # Handle possible library arguments. + $thislib =~ s/^-l//; + $thislib .= $libext if $thislib !~ /\Q$libext\E$/i; + + my($found_lib)=0; + foreach $thispth (@searchpath, @libpath){ + unless (-f ($fullname="$thispth\\$thislib")) { + warn "$thislib not found in $thispth\n" if $verbose; + next; + } + warn "'$thislib' found at $fullname\n" if $verbose; + $found++; + $found_lib++; + push(@extralibs, $fullname); + last; + } + warn "Note (probably harmless): " + ."No library found for '$thislib'\n" + unless $found_lib>0; + } + return ('','','','') unless $found; + $lib = join(' ',@extralibs); + warn "Result: $lib\n" if $verbose; + wantarray ? ($lib, '', $lib, '') : $lib; +} + + +sub _vms_ext { + my($self, $potential_libs,$verbose) = @_; + return ('', '', '', '') unless $potential_libs; + + my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj); + my $cwd = cwd(); + my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'}; + # List of common Unix library names and there VMS equivalents + # (VMS equivalent of '' indicates that the library is automatially + # searched by the linker, and should be skipped here.) + my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', + 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', + 'socket' => '', 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR'); + if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } + + warn "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + foreach $lib (split ' ',$potential_libs) { + push(@dirs,$1), next if $lib =~ /^-L(.*)/; + push(@dirs,$lib), next if $lib =~ /[:>\]]$/; + push(@dirs,$lib), next if -d $lib; + push(@libs,$1), next if $lib =~ /^-l(.*)/; + push(@libs,$lib); + } + push(@dirs,split(' ',$Config{'libpth'})); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach $dir (@dirs) { + unless (-d $dir) { + warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + warn "Resolving directory $dir\n" if $verbose; + if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); } + else { $dir = $self->catdir($cwd,$dir); } + } + @dirs = grep { length($_) } @dirs; + unshift(@dirs,''); # Check each $lib without additions first + + LIB: foreach $lib (@libs) { + if (exists $libmap{$lib}) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my(@variants,$variant,$name,$test,$cand); + my($ctype) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ($lib !~ /\.[^:>\]]*$/) { + push(@variants,"${lib}shr","${lib}rtl","${lib}lib"); + push(@variants,"lib$lib") if $lib !~ /[:>\]]/; + } + push(@variants,$lib); + warn "Looking for $lib\n" if $verbose; + foreach $variant (@variants) { + foreach $dir (@dirs) { + my($type); + + $name = "$dir$variant"; + warn "\tChecking $name\n" if $verbose > 2; + if (-f ($test = VMS::Filespec::rmsexpand($name))) { + # It's got its own suffix, so we'll have to figure out the type + if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; } + elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } + elsif ($test =~ /(?:$obj_ext|obj)$/i) { + warn "Note (probably harmless): " + ."Plain object file $test found in library list\n"; + $type = 'obj'; + } + else { + warn "Note (probably harmless): " + ."Unknown library type for $test; assuming shared\n"; + $type = 'sh'; + } + } + elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) { + $type = 'sh'; + $name = $test unless $test =~ /exe;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, don't bother + ( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.olb')))) { + $type = 'olb'; + $name = $test unless $test =~ /olb;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, don't bother + ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) { + warn "Note (probably harmless): " + ."Plain object file $test found in library list\n"; + $type = 'obj'; + $name = $test unless $test =~ /obj;?\d*$/i; + } + if (defined $type) { + $ctype = $type; $cand = $name; + last if $ctype eq 'sh'; + } + } + if ($ctype) { + eval '$' . $ctype . "{'$cand'}++"; + die "Error recording library: $@" if $@; + warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; + next LIB; + } + } + warn "Note (probably harmless): " + ."No library found for $lib\n"; + } + + @libs = sort keys %obj; + # This has to precede any other CRTLs, so just make it first + if ($olb{VAXCCURSE}) { + push(@libs,"$olb{VAXCCURSE}/Library"); + delete $olb{VAXCCURSE}; + } + push(@libs, map { "$_/Library" } sort keys %olb); + push(@libs, map { "$_/Share" } sort keys %sh); + $lib = join(' ',@libs); + warn "Result: $lib\n" if $verbose; + wantarray ? ($lib, '', $lib, '') : $lib; +} + 1; __END__ @@ -183,7 +402,7 @@ ExtUtils::Liblist - determine libraries to use and how to use them C<require ExtUtils::Liblist;> -C<ExtUtils::Liblist::ext($potential_libs, $Verbose);> +C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);> =head1 DESCRIPTION @@ -194,7 +413,9 @@ C<-L/another/path> this will affect the searches for all subsequent libraries. It returns an array of four scalar values: EXTRALIBS, BSLOADLIBS, -LDLOADLIBS, and LD_RUN_PATH. +LDLOADLIBS, and LD_RUN_PATH. Some of these don't mean anything +on VMS and Win32. See the details about those platform specifics +below. Dependent libraries can be linked in one of three ways: @@ -244,11 +465,107 @@ object file. This list is used to create a .bs (bootstrap) file. This module deals with a lot of system dependencies and has quite a few architecture specific B<if>s in the code. +=head2 VMS implementation + +The version of ext() which is executed under VMS differs from the +Unix-OS/2 version in several respects: + +=over 2 + +=item * + +Input library and path specifications are accepted with or without the +C<-l> and C<-L> prefices used by Unix linkers. If neither prefix is +present, a token is considered a directory to search if it is in fact +a directory, and a library to search for otherwise. Authors who wish +their extensions to be portable to Unix or OS/2 should use the Unix +prefixes, since the Unix-OS/2 version of ext() requires them. + +=item * + +Wherever possible, shareable images are preferred to object libraries, +and object libraries to plain object files. In accordance with VMS +naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl; +it also looks for I<lib>lib and libI<lib> to accomodate Unix conventions +used in some ported software. + +=item * + +For each library that is found, an appropriate directive for a linker options +file is generated. The return values are space-separated strings of +these directives, rather than elements used on the linker command line. + +=item * + +LDLOADLIBS and EXTRALIBS are always identical under VMS, and BSLOADLIBS +and LD_RIN_PATH are always empty. + +=back + +In addition, an attempt is made to recognize several common Unix library +names, and filter them out or convert them to their VMS equivalents, as +appropriate. + +In general, the VMS version of ext() should properly handle input from +extensions originally designed for a Unix or VMS environment. If you +encounter problems, or discover cases where the search could be improved, +please let us know. + +=head2 Win32 implementation + +The version of ext() which is executed under Win32 differs from the +Unix-OS/2 version in several respects: + +=over 2 + +=item * + +Input library and path specifications are accepted with or without the +C<-l> and C<-L> prefices used by Unix linkers. C<-lfoo> specifies the +library C<foo.lib> and C<-Ls:ome\dir> specifies a directory to look for +the libraries that follow. If neither prefix is present, a token is +considered a directory to search if it is in fact a directory, and a +library to search for otherwise. The C<$Config{lib_ext}> suffix will +be appended to any entries that are not directories and don't already +have the suffix. Authors who wish their extensions to be portable to +Unix or OS/2 should use the Unix prefixes, since the Unix-OS/2 version +of ext() requires them. + +=item * + +Entries cannot be plain object files, as many Win32 compilers will +not handle object files in the place of libraries. + +=item * + +If C<$potential_libs> is empty, the return value will be empty. +Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) +will be appended to the list of C<$potential_libs>. The libraries +will be searched for in the directories specified in C<$potential_libs> +as well as in C<$Config{libpth}>. For each library that is found, a +space-separated list of fully qualified library pathnames is generated. +You may specify an entry that matches C</:nodefault/i> in +C<$potential_libs> to disable the appending of default libraries +found in C<$Config{libs}> (this should be only needed very rarely). + +=item * + +The libraries specified may be a mixture of static libraries and +import libraries (to link with DLLs). Since both kinds are used +pretty transparently on the win32 platform, we do not attempt to +distinguish between them. + +=item * + +LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS +and LD_RUN_PATH are always empty (this may change in future). + +=back + + =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut - - diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm index 1a1f8b16a04..65abfc2d99c 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm @@ -54,6 +54,17 @@ sub file_name_is_absolute { $file =~ m{^([a-z]:)?[\\/]}i ; } +sub perl_archive +{ + return "\$(PERL_INC)/libperl\$(LIB_EXT)"; +} + +sub export_list +{ + my ($self) = @_; + return "$self->{BASEEXT}.def"; +} + 1; __END__ diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm index 332a6c6912c..b308c4aad6f 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm @@ -1,18 +1,22 @@ package ExtUtils::MM_Unix; -$VERSION = substr q$Revision: 1.2 $, 10; -# $Id: MM_Unix.pm,v 1.2 1996/10/04 08:51:44 downsj Exp $ - -require Exporter; +use Exporter (); use Config; use File::Basename qw(basename dirname fileparse); use DirHandle; +use strict; +use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 + $Verbose %pm %static $Xsubpp_Version); + +$VERSION = substr q$Revision: 1.3 $, 10; +# $Id: MM_Unix.pm,v 1.3 1997/11/30 07:57:26 millert Exp $ Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); -$Is_OS2 = $^O =~ m|^os/?2$|i; -$Is_Mac = $^O eq "MacOS"; +$Is_OS2 = $^O eq 'os2'; +$Is_Mac = $^O eq 'MacOS'; +$Is_Win32 = $^O eq 'MSWin32'; if ($Is_VMS = $^O eq 'VMS') { require VMS::Filespec; @@ -40,8 +44,8 @@ overrides by defining rather primitive operations within ExtUtils::MM_Unix. If you are going to write a platform specific MM package, please try -to limit the necessary overrides to primitiv methods, and if it is not -possible to do so, let's work it out how to achieve that gain. +to limit the necessary overrides to primitive methods, and if it is not +possible to do so, let's work out how to achieve that gain. If you are overriding any of these methods in your Makefile.PL (in the MY class), please report that to the makemaker mailing list. We are @@ -97,12 +101,12 @@ sub catdir { my @args = @_; for (@args) { # append a slash to each argument unless it has one there - $_ .= "/" unless substr($_,length($_)-1,1) eq "/"; + $_ .= "/" if $_ eq '' or substr($_,-1) ne "/"; } my $result = join('', @args); # remove a trailing slash unless we are root - substr($result,length($result)-1,1) = "" - if length($result) > 1 && substr($result,length($result)-1,1) eq "/"; + substr($result,-1) = "" + if length($result) > 1 && substr($result,-1) eq "/"; $result; } @@ -173,9 +177,11 @@ sub ExtUtils::MM_Unix::dynamic ; sub ExtUtils::MM_Unix::dynamic_bs ; sub ExtUtils::MM_Unix::dynamic_lib ; sub ExtUtils::MM_Unix::exescan ; +sub ExtUtils::MM_Unix::export_list ; sub ExtUtils::MM_Unix::extliblist ; sub ExtUtils::MM_Unix::file_name_is_absolute ; sub ExtUtils::MM_Unix::find_perl ; +sub ExtUtils::MM_Unix::fixin ; sub ExtUtils::MM_Unix::force ; sub ExtUtils::MM_Unix::guess_name ; sub ExtUtils::MM_Unix::has_link_code ; @@ -198,6 +204,7 @@ sub ExtUtils::MM_Unix::nicetext ; sub ExtUtils::MM_Unix::parse_version ; sub ExtUtils::MM_Unix::pasthru ; sub ExtUtils::MM_Unix::path ; +sub ExtUtils::MM_Unix::perl_archive; sub ExtUtils::MM_Unix::perl_script ; sub ExtUtils::MM_Unix::perldepend ; sub ExtUtils::MM_Unix::pm_to_blib ; @@ -227,13 +234,18 @@ sub ExtUtils::MM_Unix::xsubpp_version ; package ExtUtils::MM_Unix; -#use SelfLoader; +use SelfLoader; 1; -#__DATA__ + +__DATA__ + +=back =head2 SelfLoaded methods +=over 2 + =item c_o (o) Defines the suffix rules to compile different flavors of C files to @@ -250,10 +262,12 @@ sub c_o { push @m, ' .c$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c - +'; + push @m, ' .C$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C - +' if $^O ne 'os2' and $^O ne 'MSWin32'; # Case-specific + push @m, ' .cpp$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cpp @@ -385,7 +399,7 @@ clean :: '); # clean subdirectories first for $dir (@{$self->{DIR}}) { - push @m, "\t-cd $dir && test -f $self->{MAKEFILE} && \$(MAKE) clean\n"; + push @m, "\t-cd $dir && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) clean\n"; } my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files @@ -399,7 +413,7 @@ clean :: push @m, "\t-$self->{RM_RF} @otherfiles\n"; # See realclean and ext/utils/make_ext for usage of Makefile.old push(@m, - "\t-$self->{MV} $self->{MAKEFILE} $self->{MAKEFILE}.old 2>/dev/null\n"); + "\t-$self->{MV} $self->{MAKEFILE} $self->{MAKEFILE}.old \$(DEV_NULL)\n"); push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP}; join("", @m); @@ -486,7 +500,7 @@ sub constants { AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB - INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS + INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB @@ -590,20 +604,11 @@ INST_BOOT = '; } - if ($Is_OS2) { - $tmp = "$self->{BASEEXT}.def"; - } else { - $tmp = ""; - } + $tmp = $self->export_list; push @m, " EXPORT_LIST = $tmp "; - - if ($Is_OS2) { - $tmp = "\$(PERL_INC)/libperl\$(LIB_EXT)"; - } else { - $tmp = ""; - } + $tmp = $self->perl_archive; push @m, " PERL_ARCHIVE = $tmp "; @@ -659,12 +664,17 @@ sub dir_target { # too often :) my($self,@dirs) = @_; - my(@m,$dir); + my(@m,$dir,$targdir); foreach $dir (@dirs) { my($src) = $self->catfile($self->{PERL_INC},'perl.h'); my($targ) = $self->catfile($dir,'.exists'); - my($targdir) = $targ; # Necessary because catfile may have - $targdir =~ s:/?.exists$::; # adapted syntax of $dir to target OS + # catfile may have adapted syntax of $dir to target OS, so... + if ($Is_VMS) { # Just remove file name; dirspec is often in macro + ($targdir = $targ) =~ s:/?\.exists$::; + } + else { # while elsewhere we expect to see the dir separator in $targ + $targdir = dirname($targ); + } next if $self->{DIR_TARGET}{$self}{$targdir}++; push @m, qq{ $targ :: $src @@ -703,7 +713,7 @@ sub dist { my($to_unix) = $attribs{TO_UNIX} || ($Is_OS2 ? "$self->{NOECHO}" - . 'test -f tmp.zip && $(RM) tmp.zip;' + . '$(TEST_F) tmp.zip && $(RM) tmp.zip;' . ' $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM) tmp.zip' : "$self->{NOECHO}\$(NOOP)"); @@ -747,20 +757,20 @@ distclean :: realclean distcheck push @m, q{ distcheck : - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&fullcheck";' \\ - -e 'fullcheck();' + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \\ + -e fullcheck }; push @m, q{ skipcheck : - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&skipcheck";' \\ - -e 'skipcheck();' + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \\ + -e skipcheck }; push @m, q{ manifest : - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&mkmanifest";' \\ - -e 'mkmanifest();' + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\ + -e mkmanifest }; join "", @m; } @@ -776,8 +786,8 @@ sub dist_ci { my @m; push @m, q{ ci : - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&maniread";' \\ - -e '@all = keys %{ maniread() };' \\ + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\ + -e "@all = keys %{ maniread() };" \\ -e 'print("Executing $(CI) @all\n"); system("$(CI) @all");' \\ -e 'print("Executing $(RCS_LABEL) ...\n"); system("$(RCS_LABEL) @all");' }; @@ -844,7 +854,7 @@ sub dist_dir { distdir : $(RM_RF) $(DISTVNAME) $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \\ - -e 'manicopy(maniread(),"$(DISTVNAME)", "$(DIST_CP)");' + -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" }; join "", @m; } @@ -945,8 +955,8 @@ BOOTSTRAP = '."$self->{BASEEXT}.bs".' $(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)/.exists '.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))" '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \ - -e \'use ExtUtils::Mkbootstrap;\' \ - -e \'Mkbootstrap("$(BASEEXT)","$(BSLOADLIBS)");\' + -MExtUtils::Mkbootstrap \ + -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP) $(CHMOD) 644 $@ @@ -990,7 +1000,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists push(@m,' $(RANLIB) '."$ldfrom\n"); } $ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf'); - push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ $(LDDLFLAGS) '.$ldfrom. + + # Brain dead solaris linker does not use LD_RUN_PATH? + # This fixes dynamic extensions which need shared libs + my $ldrun = ''; + $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} + if ($^O eq 'solaris'); + + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' $(CHMOD) 755 $@ @@ -1026,7 +1043,7 @@ sub extliblist { =item file_name_is_absolute -Takes as argument a path and returns true, it it is an absolute path. +Takes as argument a path and returns true, if it is an absolute path. =cut @@ -1054,7 +1071,7 @@ in these dirs: foreach $dir (@$dirs){ next unless defined $dir; # $self->{PERL_SRC} may be undefined foreach $name (@$names){ - my $abs; + my ($abs, $val); if ($self->file_name_is_absolute($name)) { # /foo/bar $abs = $name; } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo @@ -1065,9 +1082,12 @@ in these dirs: print "Checking $abs\n" if ($trace >= 2); next unless $self->maybe_command($abs); print "Executing $abs\n" if ($trace >= 2); - if (`$abs -e 'require $ver; print "VER_OK\n" ' 2>&1` =~ /VER_OK/) { + $val = `$abs -e 'require $ver; print "VER_OK\n" ' 2>&1`; + if ($val =~ /VER_OK/) { print "Using PERL=$abs\n" if $trace; return $abs; + } elsif ($trace >= 2) { + print "Result: `$val'\n"; } } } @@ -1075,12 +1095,99 @@ in these dirs: 0; # false and not empty } +=back + =head2 Methods to actually produce chunks of text for the Makefile -The methods here are called in the order specified by -@ExtUtils::MakeMaker::MM_Sections. This manpage reflects the order as -well as possible. Some methods call each other, so in doubt refer to -the code. +The methods here are called for each MakeMaker object in the order +specified by @ExtUtils::MakeMaker::MM_Sections. + +=over 2 + +=item fixin + +Inserts the sharpbang or equivalent magic number to a script + +=cut + +sub fixin { # stolen from the pink Camel book, more or less + my($self,@files) = @_; + my($does_shbang) = $Config::Config{'sharpbang'} =~ /^\s*\#\!/; + my($file,$interpreter); + for $file (@files) { + local(*FIXIN); + local(*FIXOUT); + open(FIXIN, $file) or Carp::croak "Can't process '$file': $!"; + local $/ = "\n"; + chomp(my $line = <FIXIN>); + next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. + # Now figure out the interpreter name. + my($cmd,$arg) = split ' ', $line, 2; + $cmd =~ s!^.*/!!; + + # Now look (in reverse) for interpreter in absolute PATH (unless perl). + if ($cmd eq "perl") { + if ($Config{startperl} =~ m,^\#!.*/perl,) { + $interpreter = $Config{startperl}; + $interpreter =~ s,^\#!,,; + } else { + $interpreter = $Config{perlpath}; + } + } else { + my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; + $interpreter = ''; + my($dir); + foreach $dir (@absdirs) { + if ($self->maybe_command($cmd)) { + warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; + $interpreter = $self->catfile($dir,$cmd); + } + } + } + # Figure out how to invoke interpreter on this machine. + + my($shb) = ""; + if ($interpreter) { + print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose; + if ($does_shbang) { + $shb .= "$Config{'sharpbang'}$interpreter"; + $shb .= ' ' . $arg if defined $arg; + $shb .= "\n"; + } + $shb .= qq{ +eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' + if 0; # not running under some shell +}; + } else { + warn "Can't find $cmd in PATH, $file unchanged" + if $Verbose; + next; + } + + unless ( rename($file, "$file.bak") ) { + warn "Can't modify $file"; + next; + } + unless ( open(FIXOUT,">$file") ) { + warn "Can't create new $file: $!\n"; + next; + } + my($dev,$ino,$mode) = stat FIXIN; + $mode = 0755 unless $dev; + chmod $mode, $file; + + # Print out the new #! line (or equivalent). + local $\; + undef $/; + print FIXOUT $shb, <FIXIN>; + close FIXIN; + close FIXOUT; + unlink "$file.bak"; + } continue { + chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; + system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; + } +} =item force (o) @@ -1092,6 +1199,7 @@ sub force { my($self) = shift; '# Phony target to force checking subdirectories. FORCE: + '.$self->{NOECHO}.'$(NOOP) '; } @@ -1147,6 +1255,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) $ignore{'test.pl'} = 1; $ignore{'makefile.pl'} = 1 if $Is_VMS; foreach $name ($self->lsdir($self->curdir)){ + next if $name =~ /\#/; next if $name eq $self->curdir or $name eq $self->updir or $ignore{$name}; next unless $self->libscan($name); if (-d $name){ @@ -1222,9 +1331,10 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) } return; } + return if /\#/; my($path, $prefix) = ($File::Find::name, '$(INST_LIBDIR)'); my($striplibpath,$striplibname); - $prefix = '$(INST_LIB)' if (($striplibpath = $path) =~ s:^(\W*)lib\W:$1:); + $prefix = '$(INST_LIB)' if (($striplibpath = $path) =~ s:^(\W*)lib\W:$1:i); ($striplibname,$striplibpath) = fileparse($striplibpath); my($inst) = $self->catfile($prefix,$striplibpath,$striplibname); local($_) = $inst; # for backwards compatibility @@ -1256,7 +1366,6 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) # my $fh = new FileHandle; local *FH; my($ispod)=0; - # one day test, if $/ can be set to '' safely (is the bug fixed that was in 5.001m?) # if ($fh->open("<$name")) { if (open(FH,"<$name")) { # while (<$fh>) { @@ -1273,7 +1382,9 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) $ispod = 1; } if( $ispod ) { - $manifypods{$name} = $self->catfile('$(INST_MAN1DIR)',basename($name).'.$(MAN1EXT)'); + $manifypods{$name} = + $self->catfile('$(INST_MAN1DIR)', + basename($name).'.$(MAN1EXT)'); } } } @@ -1336,7 +1447,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) Initializes NAME, FULLEXT, BASEEXT, PARENT_NAME, DLBASE, PERL_SRC, PERL_LIB, PERL_ARCHLIB, PERL_INC, INSTALLDIRS, INST_*, INSTALL*, -PREFIX, CONFIG, AR, AR_STATIC_ARGS, LD, OBJ_EXT, LIB_EXT, MAP_TARGET, +PREFIX, CONFIG, AR, AR_STATIC_ARGS, LD, OBJ_EXT, LIB_EXT, EXE_EXT, MAP_TARGET, LIBPERL_A, VERSION_FROM, VERSION, DISTNAME, VERSION_SYM. =cut @@ -1367,14 +1478,11 @@ sub init_main { # It may also edit @modparts if required. if (defined &DynaLoader::mod2fname) { $modfname = &DynaLoader::mod2fname(\@modparts); - } elsif ($Is_OS2) { # Need manual correction if run with miniperl:-( - $modfname = substr($modfname, 0, 7) . '_'; } - ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!([\w:]+::)?(\w+)$! ; - if (defined &DynaLoader::mod2fname or $Is_OS2) { + if (defined &DynaLoader::mod2fname) { # As of 5.001m, dl_os2 appends '_' $self->{DLBASE} = $modfname; } else { @@ -1412,10 +1520,21 @@ sub init_main { if ($self->{PERL_SRC}){ $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib"); $self->{PERL_ARCHLIB} = $self->{PERL_LIB}; - $self->{PERL_INC} = $self->{PERL_SRC}; - # catch a situation that has occurred a few times in the past: + $self->{PERL_INC} = ($Is_Win32) ? $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC}; - warn <<EOM unless (-s $self->catfile($self->{PERL_SRC},'cflags') or $Is_VMS && -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt') or $Is_Mac); + # catch a situation that has occurred a few times in the past: + unless ( + -s $self->catfile($self->{PERL_SRC},'cflags') + or + $Is_VMS + && + -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt') + or + $Is_Mac + or + $Is_Win32 + ){ + warn qq{ You cannot build extensions below the perl source tree after executing a 'make clean' in the perl source tree. @@ -1427,26 +1546,27 @@ usually without extra arguments. It is recommended that you unpack and build additional extensions away from the perl source tree. -EOM +}; + } } else { # we should also consider $ENV{PERL5LIB} here $self->{PERL_LIB} ||= $Config::Config{privlibexp}; $self->{PERL_ARCHLIB} ||= $Config::Config{archlibexp}; $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now my $perl_h; - die <<EOM unless (-f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))); + unless (-f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))){ + die qq{ Error: Unable to locate installed Perl libraries or Perl source code. It is recommended that you install perl in a standard location before -building extensions. You can say: - - $^X Makefile.PL PERL_SRC=/path/to/perl/source/directory - -if you have not yet installed perl but still want to build this -extension now. -(You get this message, because MakeMaker could not find "$perl_h") -EOM +building extensions. Some precompiled versions of perl do not contain +these header files, so you cannot build extensions. In such a case, +please build and install your perl from a fresh perl distribution. It +usually solves this kind of problem. +\(You get this message, because MakeMaker could not find "$perl_h"\) +}; + } # print STDOUT "Using header files found in $self->{PERL_INC}\n" # if $Verbose && $self->needs_linking(); @@ -1476,13 +1596,20 @@ EOM $self->{INST_ARCHLIB} ||= $self->catdir($self->curdir,"blib","arch"); $self->{INST_BIN} ||= $self->catdir($self->curdir,'blib','bin'); + # We need to set up INST_LIBDIR before init_libscan() for VMS + my @parentdir = split(/::/, $self->{PARENT_NAME}); + $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)',@parentdir); + $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)',@parentdir); + $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)','auto','$(FULLEXT)'); + $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)'); + # INST_EXE is deprecated, should go away March '97 $self->{INST_EXE} ||= $self->catdir($self->curdir,'blib','script'); $self->{INST_SCRIPT} ||= $self->catdir($self->curdir,'blib','script'); # The user who requests an installation directory explicitly # should not have to tell us a architecture installation directory - # as well We look if a directory exists that is named after the + # as well. We look if a directory exists that is named after the # architecture. If not we take it as a sign that it should be the # same as the requested installation directory. Otherwise we take # the found one. @@ -1510,23 +1637,67 @@ EOM # requested values. We're going to set the $Config{prefix} part of # all the installation path variables to literally $(PREFIX), so # the user can still say make PREFIX=foo - my($prefix) = $Config{'prefix'}; - $prefix = VMS::Filespec::unixify($prefix) if $Is_VMS; - unless ($self->{PREFIX}){ - $self->{PREFIX} = $prefix; + my($configure_prefix) = $Config{'prefix'}; + $configure_prefix = VMS::Filespec::unixify($configure_prefix) if $Is_VMS; + $self->{PREFIX} ||= $configure_prefix; + + + my($install_variable,$search_prefix,$replace_prefix); + + # The rule, taken from Configure, is that if prefix contains perl, + # we shape the tree + # perlprefix/lib/ INSTALLPRIVLIB + # perlprefix/lib/pod/ + # perlprefix/lib/site_perl/ INSTALLSITELIB + # perlprefix/bin/ INSTALLBIN + # perlprefix/man/ INSTALLMAN1DIR + # else + # prefix/lib/perl5/ INSTALLPRIVLIB + # prefix/lib/perl5/pod/ + # prefix/lib/perl5/site_perl/ INSTALLSITELIB + # prefix/bin/ INSTALLBIN + # prefix/lib/perl5/man/ INSTALLMAN1DIR + + $replace_prefix = qq[\$\(PREFIX\)]; + for $install_variable (qw/ + INSTALLBIN + INSTALLSCRIPT + /) { + $self->prefixify($install_variable,$configure_prefix,$replace_prefix); + } + $search_prefix = $configure_prefix =~ /perl/ ? + $self->catdir($configure_prefix,"lib") : + $self->catdir($configure_prefix,"lib","perl5"); + if ($self->{LIB}) { + $self->{INSTALLPRIVLIB} = $self->{INSTALLSITELIB} = $self->{LIB}; + $self->{INSTALLARCHLIB} = $self->{INSTALLSITEARCH} = + $self->catdir($self->{LIB},$Config{'archname'}); + } else { + $replace_prefix = $self->{PREFIX} =~ /perl/ ? + $self->catdir(qq[\$\(PREFIX\)],"lib") : + $self->catdir(qq[\$\(PREFIX\)],"lib","perl5"); + for $install_variable (qw/ + INSTALLPRIVLIB + INSTALLARCHLIB + INSTALLSITELIB + INSTALLSITEARCH + /) { + $self->prefixify($install_variable,$search_prefix,$replace_prefix); + } } - my($install_variable); + $search_prefix = $configure_prefix =~ /perl/ ? + $self->catdir($configure_prefix,"man") : + $self->catdir($configure_prefix,"lib","perl5","man"); + $replace_prefix = $self->{PREFIX} =~ /perl/ ? + $self->catdir(qq[\$\(PREFIX\)],"man") : + $self->catdir(qq[\$\(PREFIX\)],"lib","perl5","man"); for $install_variable (qw/ - - INSTALLPRIVLIB INSTALLARCHLIB INSTALLBIN - INSTALLMAN1DIR INSTALLMAN3DIR INSTALLSCRIPT - INSTALLSITELIB INSTALLSITEARCH - + INSTALLMAN1DIR + INSTALLMAN3DIR /) { - $self->prefixify($install_variable,$prefix,q[$(PREFIX)]); + $self->prefixify($install_variable,$search_prefix,$replace_prefix); } - # Now we head at the manpages. Maybe they DO NOT want manpages # installed $self->{INSTALLMAN1DIR} = $Config::Config{installman1dir} @@ -1623,9 +1794,9 @@ EOM foreach $component ($self->{PERL_SRC}, $self->path(), $Config::Config{binexp}) { push @defpath, $component if defined $component; } - $self->{PERL} = + $self->{PERL} ||= $self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ], - \@defpath, $Verbose ) unless ($self->{PERL}); + \@defpath, $Verbose ); # don't check if perl is executable, maybe they have decided to # supply switches with perl @@ -1638,7 +1809,7 @@ EOM Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH, OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, NOOP, FIRST_MAKEFILE, -MAKEFILE, NOECHO, RM_F, RM_RF, TOUCH, CP, MV, CHMOD, UMASK_NULL +MAKEFILE, NOECHO, RM_F, RM_RF, TEST_F, TOUCH, CP, MV, CHMOD, UMASK_NULL =cut @@ -1652,7 +1823,7 @@ sub init_others { # --- Initialize Other Attributes # May check $Config{libs} too, thus not empty. $self->{LIBS}=[''] unless $self->{LIBS}; - $self->{LIBS}=[$self->{LIBS}] if ref \$self->{LIBS} eq SCALAR; + $self->{LIBS}=[$self->{LIBS}] if ref \$self->{LIBS} eq 'SCALAR'; $self->{LD_RUN_PATH} = ""; my($libs); foreach $libs ( @{$self->{LIBS}} ){ @@ -1688,7 +1859,7 @@ sub init_others { # --- Initialize Other Attributes }; # These get overridden for VMS and maybe some other systems - $self->{NOOP} ||= "sh -c true"; + $self->{NOOP} ||= '$(SHELL) -c true'; $self->{FIRST_MAKEFILE} ||= "Makefile"; $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; $self->{MAKE_APERL_FILE} ||= "Makefile.aperl"; @@ -1696,10 +1867,12 @@ sub init_others { # --- Initialize Other Attributes $self->{RM_F} ||= "rm -f"; $self->{RM_RF} ||= "rm -rf"; $self->{TOUCH} ||= "touch"; + $self->{TEST_F} ||= "test -f"; $self->{CP} ||= "cp"; $self->{MV} ||= "mv"; $self->{CHMOD} ||= "chmod"; $self->{UMASK_NULL} ||= "umask 0"; + $self->{DEV_NULL} ||= "> /dev/null 2>&1"; } =item install (o) @@ -1762,7 +1935,7 @@ pure_site_install :: doc_perl_install :: }.$self->{NOECHO}.q{$(DOC_INSTALL) \ - "$(NAME)" \ + "Module" "$(NAME)" \ "installed into" "$(INSTALLPRIVLIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ @@ -1771,7 +1944,7 @@ doc_perl_install :: doc_site_install :: }.$self->{NOECHO}.q{$(DOC_INSTALL) \ - "Module $(NAME)" \ + "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ @@ -1815,22 +1988,27 @@ sub installbin { $fromto{$from}=$to; } @to = values %fromto; - push(@m, " + push(@m, qq{ EXE_FILES = @{$self->{EXE_FILES}} +FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker \\ + -e "MY->fixin(shift)" + all :: @to + $self->{NOECHO}\$(NOOP) realclean :: $self->{RM_F} @to -"); +}); while (($from,$to) = each %fromto) { last unless defined $from; my $todir = dirname($to); push @m, " -$to: $from $self->{MAKEFILE} $todir/.exists +$to: $from $self->{MAKEFILE} " . $self->catdir($todir,'.exists') . " $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to + \$(FIXIN) $to "; } join "", @m; @@ -1910,6 +2088,10 @@ sub macro { Called by staticmake. Defines how to write the Makefile to produce a static new perl. +By default the Makefile produced includes all the static extensions in +the perl library. (Purified versions of library files, e.g., +DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.) + =cut sub makeaperl { @@ -1958,13 +2140,15 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) $cccmd = $self->const_cccmd($libperl); $cccmd =~ s/^CCCMD\s*=\s*//; $cccmd =~ s/\$\(INC\)/ -I$self->{PERL_INC} /; - $cccmd .= " $Config::Config{cccdlflags}" if ($Config::Config{d_shrplib}); + $cccmd .= " $Config::Config{cccdlflags}" + if ($Config::Config{useshrplib} eq 'true'); $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/; # The front matter of the linkcommand... $linkcmd = join ' ', "\$(CC)", grep($_, @Config{qw(large split ldflags ccdlflags)}); $linkcmd =~ s/\s+/ /g; + $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,; # Which *.a files could we make use of... local(%static); @@ -1972,6 +2156,8 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) File::Find::find(sub { return unless m/\Q$self->{LIB_EXT}\E$/; return if m/^libperl/; + # Skip purified versions of libraries (e.g., DynaLoader_pure_p1_c0_032.a) + return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; if( exists $self->{INCLUDE_EXT} ){ my $found = 0; @@ -2055,6 +2241,16 @@ MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} $libperl = "$dir/$libperl"; $lperl ||= "libperl$self->{LIB_EXT}"; $lperl = "$dir/$lperl"; + + if (! -f $libperl and ! -f $lperl) { + # We did not find a static libperl. Maybe there is a shared one? + if ($^O eq 'solaris' or $^O eq 'sunos') { + $lperl = $libperl = "$dir/$Config::Config{libperl}"; + # SUNOS ld does not take the full path to a shared library + $libperl = '' if $^O eq 'sunos'; + } + } + print STDOUT "Warning: $libperl not found If you're going to build a static perl binary, make sure perl is installed otherwise ignore this warning\n" @@ -2075,10 +2271,17 @@ MAP_LIBPERL = $libperl foreach $catfile (@$extra){ push @m, "\tcat $catfile >> \$\@\n"; } + # SUNOS ld does not take the full path to a shared library + my $llibperl = ($libperl)?'$(MAP_LIBPERL)':'-lperl'; - push @m, " + # Brain dead solaris linker does not use LD_RUN_PATH? + # This fixes dynamic extensions which need shared libs + my $ldfrom = ($^O eq 'solaris')? + join(' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}):''; + +push @m, " \$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all - \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) + \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom $llibperl \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) $self->{NOECHO}echo 'To install the new \"\$(MAP_TARGET)\" binary, call' $self->{NOECHO}echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)' $self->{NOECHO}echo 'To remove the intermediate files say' @@ -2091,8 +2294,8 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c push @m, qq{ $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ - }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -e 'use ExtUtils::Miniperl; \\ - writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@.tmp && mv $@.tmp $@ + }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\ + -e "writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)" > $@t && $(MV) $@t $@ }; @@ -2100,7 +2303,7 @@ $tmp/perlmain.c: $makefilename}, q{ doc_inst_perl: }.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod }.$self->{NOECHO}.q{$(DOC_INSTALL) \ - "Perl binary $(MAP_TARGET)" \ + "Perl binary" "$(MAP_TARGET)" \ MAP_STATIC "$(MAP_STATIC)" \ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ MAP_LIBPERL "$(MAP_LIBPERL)" \ @@ -2145,11 +2348,12 @@ $(OBJECT) : $(FIRST_MAKEFILE) }.$self->{MAKEFILE}.q{ : Makefile.PL $(CONFIGDEP) }.$self->{NOECHO}.q{echo "Makefile out-of-date with respect to $?" }.$self->{NOECHO}.q{echo "Cleaning current config before rebuilding Makefile..." - -}.$self->{NOECHO}.q{mv }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{ - -$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean >/dev/null 2>&1 || true + -}.$self->{NOECHO}.q{$(MV) }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{ + -$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean $(DEV_NULL) || $(NOOP) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL }.join(" ",map(qq["$_"],@ARGV)).q{ - }.$self->{NOECHO}.q{echo ">>> Your Makefile has been rebuilt. <<<" - }.$self->{NOECHO}.q{echo ">>> Please rerun the make command. <<<"; false + }.$self->{NOECHO}.q{echo "==> Your Makefile has been rebuilt. <==" + }.$self->{NOECHO}.q{echo "==> Please rerun the make command. <==" + false # To change behavior to :: would be nice, but would break Tk b9.02 # so you find such a warning below the dist target. @@ -2318,14 +2522,21 @@ sub parse_version { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod; chop; - next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; - local $ExtUtils::MakeMaker::module_version_variable = $1; - my($thispackage) = $2 || $current_package; - $thispackage =~ s/:+$//; - my($eval) = "$_;"; - eval $eval; + # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; + next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; + my $eval = qq{ + package ExtUtils::MakeMaker::_version; + no strict; + + local $1$2; + \$$2=undef; do { + $_ + }; \$$2 + }; + local($^W) = 0; + $result = eval($eval); die "Could not eval '$eval' in $parsefile: $@" if $@; - $result = $ {$ExtUtils::MakeMaker::module_version_variable} || 0; + $result = "undef" unless defined $result; last; } close FH; @@ -2345,12 +2556,14 @@ sub pasthru { my(@m,$key); my(@pasthru); + my($sep) = $Is_VMS ? ',' : ''; + $sep .= "\\\n\t"; - foreach $key (qw(LIBPERL_A LINKTYPE PREFIX OPTIMIZE)){ + foreach $key (qw(LIB LIBPERL_A LINKTYPE PREFIX OPTIMIZE)){ push @pasthru, "$key=\"\$($key)\""; } - push @m, "\nPASTHRU = ", join ("\\\n\t", @pasthru), "\n"; + push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n"; join "", @m; } @@ -2366,6 +2579,8 @@ sub path { my $path = $ENV{PATH}; $path =~ s:\\:/:g if $Is_OS2; my @path = split $path_sep, $path; + foreach(@path) { $_ = '.' if $_ eq '' } + @path; } =item perl_script @@ -2430,7 +2645,7 @@ $(OBJECT) : $(PERL_HDRS) =item pm_to_blib Defines target that copies all files in the hash PM to their -destination and autosplits them. See L<ExtUtils::Install/pm_to_blib> +destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> =cut @@ -2441,7 +2656,7 @@ sub pm_to_blib { pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ - -e 'pm_to_blib({qw{$(PM_TO_BLIB)}},"}.$autodir.q{")' + -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')" }.$self->{NOECHO}.q{$(TOUCH) $@ }; } @@ -2460,7 +2675,7 @@ sub post_constants{ =item post_initialize (o) -Returns an ampty string per default. Used in Makefile.PLs to add some +Returns an empty string per default. Used in Makefile.PLs to add some chunk of text to the Makefile after the object is initialized. =cut @@ -2512,6 +2727,7 @@ sub processPL { foreach $plfile (sort keys %{$self->{PL_FILES}}) { push @m, " all :: $self->{PL_FILES}->{$plfile} + $self->{NOECHO}\$(NOOP) $self->{PL_FILES}->{$plfile} :: $plfile \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile @@ -2534,7 +2750,7 @@ sub realclean { realclean purge :: clean '); # realclean subdirectories first (already cleaned) - my $sub = "\t-cd %s && test -f %s && \$(MAKE) %s realclean\n"; + my $sub = "\t-cd %s && \$(TEST_F) %s && \$(MAKE) %s realclean\n"; foreach(@{$self->{DIR}}){ push(@m, sprintf($sub,$_,"$self->{MAKEFILE}.old","-f $self->{MAKEFILE}.old")); push(@m, sprintf($sub,$_,"$self->{MAKEFILE}",'')); @@ -2544,9 +2760,7 @@ realclean purge :: clean push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n"); push(@m, " $self->{RM_F} \$(INST_STATIC)\n"); } - if ( values %{$self->{PM}} ){ - push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n"); - } + push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n"); my(@otherfiles) = ($self->{MAKEFILE}, "$self->{MAKEFILE}.old"); # Makefiles last push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; @@ -2611,14 +2825,14 @@ END push @m, q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@ - }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld $(CHMOD) 755 $@ + }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld }; - -# Old mechanism - still available: - - push @m, "\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs}."\n\n" - if $self->{PERL_SRC}; + # Old mechanism - still available: + push @m, +"\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs +} if $self->{PERL_SRC} && $self->{EXTRALIBS}; + push @m, "\n"; push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('', "\n",@m); @@ -2722,27 +2936,32 @@ sub test { # --- Test and Installation Sections --- my($self, %attribs) = @_; - my($tests) = $attribs{TESTS} || (-d "t" ? "t/*.t" : ""); + my $tests = $attribs{TESTS}; + if (!$tests && -d 't') { + $tests = $Is_Win32 ? join(' ', <t\\*.t>) : 't/*.t'; + } + # note: 'test.pl' name is also hardcoded in init_dirscan() my(@m); push(@m," TEST_VERBOSE=0 TEST_TYPE=test_\$(LINKTYPE) TEST_FILE = test.pl +TEST_FILES = $tests TESTDB_SW = -d testdb :: testdb_\$(LINKTYPE) test :: \$(TEST_TYPE) "); - push(@m, map("\t$self->{NOECHO}cd $_ && test -f $self->{MAKEFILE} && \$(MAKE) test \$(PASTHRU)\n", + push(@m, map("\t$self->{NOECHO}cd $_ && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) test \$(PASTHRU)\n", @{$self->{DIR}})); push(@m, "\t$self->{NOECHO}echo 'No tests defined for \$(NAME) extension.'\n") unless $tests or -f "test.pl" or @{$self->{DIR}}; push(@m, "\n"); push(@m, "test_dynamic :: pure_all\n"); - push(@m, $self->test_via_harness('$(FULLPERL)', $tests)) if $tests; - push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl"; + push(@m, $self->test_via_harness('$(FULLPERL)', '$(TEST_FILES)')) if $tests; + push(@m, $self->test_via_script('$(FULLPERL)', '$(TEST_FILE)')) if -f "test.pl"; push(@m, "\n"); push(@m, "testdb_dynamic :: pure_all\n"); @@ -2754,8 +2973,8 @@ test :: \$(TEST_TYPE) if ($self->needs_linking()) { push(@m, "test_static :: pure_all \$(MAP_TARGET)\n"); - push(@m, $self->test_via_harness('./$(MAP_TARGET)', $tests)) if $tests; - push(@m, $self->test_via_script('./$(MAP_TARGET)', 'test.pl')) if -f "test.pl"; + push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests; + push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl"; push(@m, "\n"); push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n"); push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)')); @@ -2775,7 +2994,8 @@ Helper method to write the test targets sub test_via_harness { my($self, $perl, $tests) = @_; - "\tPERL_DL_NONLAZY=1 $perl".q! -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' !."$tests\n"; + $perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32; + "\t$perl".q! -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' !."$tests\n"; } =item test_via_script (o) @@ -2786,7 +3006,8 @@ Other helper method for test. sub test_via_script { my($self, $perl, $script) = @_; - qq{\tPERL_DL_NONLAZY=1 $perl}.q{ -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) }.qq{$script + $perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32; + qq{\t$perl}.q{ -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) }.qq{$script }; } @@ -2825,27 +3046,23 @@ sub tools_other { SHELL = $bin_sh }; - for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TOUCH UMASK_NULL / ) { + for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) { push @m, "$_ = $self->{$_}\n"; } - push @m, q{ # The following is a portable way to say mkdir -p # To see which directories are created, change the if 0 to if 1 -MKPATH = $(PERL) -wle '$$"="/"; foreach $$p (@ARGV){' \\ --e 'next if -d $$p; my(@p); foreach(split(/\//,$$p)){' \\ --e 'push(@p,$$_); next if -d "@p/"; print "mkdir @p" if 0;' \\ --e 'mkdir("@p",0777)||die $$! } } exit 0;' +MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath # This helps us to minimize the effect of the .exists files A yet # better solution would be to have a stable file in the perl # distribution with a timestamp of zero. But this solution doesn't # need any changes to the core distribution and works with older perls -EQUALIZE_TIMESTAMP = $(PERL) -we 'open F, ">$$ARGV[1]"; close F;' \\ --e 'utime ((stat("$$ARGV[0]"))[8,9], $$ARGV[1])' +EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime }; + return join "", @m if $self->{PARENT}; push @m, q{ @@ -2860,16 +3077,18 @@ UNINST=0 VERBINST=1 MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ --e 'install({@ARGV},"$(VERBINST)",0,"$(UNINST)");' +-e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" -DOC_INSTALL = $(PERL) -e '$$\="\n\n";print "=head3 ", scalar(localtime), ": C<", shift, ">";' \ +DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \ +-e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", shift, ">";' \ -e 'print "=over 4";' \ -e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \ -e 'print "=back";' UNINSTALL = $(PERL) -MExtUtils::Install \ --e 'uninstall($$ARGV[0],1);' - +-e 'uninstall($$ARGV[0],1,1); print "\nUninstall is deprecated. Please check the";' \ +-e 'print " packlist above carefully.\n There may be errors. Remove the";' \ +-e 'print " appropriate files manually.\n Sorry for the inconveniences.\n"' }; return join "", @m; @@ -2997,10 +3216,15 @@ sub top_targets { my(@m); push @m, ' #all :: config $(INST_PM) subdirs linkext manifypods +'; + push @m, ' all :: pure_all manifypods '.$self->{NOECHO}.'$(NOOP) - +' + unless $self->{SKIPHASH}{'all'}; + + push @m, ' pure_all :: config pm_to_blib subdirs linkext '.$self->{NOECHO}.'$(NOOP) @@ -3055,7 +3279,7 @@ help: Version_check: }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ -MExtUtils::MakeMaker=Version_check \ - -e 'Version_check("$(MM_VERSION)")' + -e "Version_check('$(MM_VERSION)')" }; join('',@m); @@ -3087,7 +3311,7 @@ sub xs_c { return '' unless $self->needs_linking(); ' .xs.c: - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && mv $*.tc $@ + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && $(MV) $*.tc $@ '; } @@ -3103,13 +3327,41 @@ sub xs_o { # many makes are too dumb to use xs_c then c_o return '' unless $self->needs_linking(); ' .xs$(OBJ_EXT): - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && mv xstmp.c $*.c + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c '; } +=item perl_archive + +This is internal method that returns path to libperl.a equivalent +to be linked to dynamic extensions. UNIX does not have one but OS2 +and Win32 do. + +=cut + +sub perl_archive +{ + return ""; +} + +=item export_list + +This is internal method that returns name of a file that is +passed to linker to define symbols to be exported. +UNIX does not have one but OS2 and Win32 do. + +=cut + +sub export_list +{ + return ""; +} + + 1; +=back =head1 SEE ALSO diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm index 9a382284d11..dc3b4ceca64 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm @@ -6,14 +6,18 @@ # Author: Charles Bailey bailey@genetics.upenn.edu package ExtUtils::MM_VMS; -$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.35 (23-Jun-1996)'; -unshift @MM::ISA, 'ExtUtils::MM_VMS'; +use Carp qw( &carp ); use Config; require Exporter; use VMS::Filespec; use File::Basename; +use vars qw($Revision); +$Revision = '5.3901 (6-Mar-1997)'; + +unshift @MM::ISA, 'ExtUtils::MM_VMS'; + Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue'); =head1 NAME @@ -32,6 +36,8 @@ the semantics. =head2 Methods always loaded +=over + =item eliminate_macros Expands MM[KS]/Make macros in a text string, using the contents of @@ -47,16 +53,23 @@ sub eliminate_macros { return ''; } my($npath) = unixify($path); + my($complex) = 0; my($head,$macro,$tail); # perform m##g in scalar context so it acts as an iterator while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) { if ($self->{$2}) { ($head,$macro,$tail) = ($1,$2,$3); - ($macro = unixify($self->{$macro})) =~ s#/$##; + if (ref $self->{$macro}) { + carp "Can't expand macro containing " . ref $self->{$macro}; + $npath = "$head\cB$macro\cB$tail"; + $complex = 1; + } + else { ($macro = unixify($self->{$macro})) =~ s#/$##; } $npath = "$head$macro$tail"; } } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\$($1)#g; } print "eliminate_macros($path) = |$npath|\n" if $Verbose >= 3; $npath; } @@ -83,7 +96,7 @@ sub fixpath { } my($fixedpath,$prefix,$name); - if ($path =~ m#^\$\(.+\)$# || $path =~ m#[/:>\]]#) { + if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) { if ($force_path or $path =~ /(?:DIR\)|\])$/) { $fixedpath = vmspath($self->eliminate_macros($path)); } @@ -92,7 +105,9 @@ sub fixpath { } } elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) { - my($vmspre) = vmspath($self->{$prefix}) || ''; # is it a dir or just a name? + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : ''; $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; $fixedpath = vmspath($fixedpath) if $force_path; } @@ -102,6 +117,8 @@ sub fixpath { } # Convert names without directory or type to paths if (!$force_path and $fixedpath !~ /[:>(.\]]/) { $fixedpath = vmspath($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; $fixedpath; } @@ -123,9 +140,12 @@ sub catdir { my($spath,$sdir) = ($path,$dir); $spath =~ s/.dir$//; $sdir =~ s/.dir$//; $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; - $rslt = vmspath($self->eliminate_macros($spath)."/$sdir"); + $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + } + else { + if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } + else { $rslt = vmspath($dir); } } - else { $rslt = vmspath($dir); } print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; $rslt; } @@ -157,6 +177,30 @@ sub catfile { $rslt; } +=item wraplist + +Converts a list into a string wrapped at approximately 80 columns. + +=cut + +sub wraplist { + my($self) = shift; + my($line,$hlen) = ('',0); + my($word); + + foreach $word (@_) { + # Perl bug -- seems to occasionally insert extra elements when + # traversing array (scalar(@array) doesn't show them, but + # foreach(@array) does) (5.00307) + next unless $word =~ /\w/; + $line .= ', ' if length($line); + if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } + $line .= $word; + $hlen += length($word) + 2; + } + $line; +} + =item curdir (override) Returns a string representing of the current directory. @@ -189,6 +233,7 @@ sub updir { package ExtUtils::MM_VMS; +sub ExtUtils::MM_VMS::ext; sub ExtUtils::MM_VMS::guess_name; sub ExtUtils::MM_VMS::find_perl; sub ExtUtils::MM_VMS::path; @@ -199,7 +244,6 @@ sub ExtUtils::MM_VMS::file_name_is_absolute; sub ExtUtils::MM_VMS::replace_manpage_separator; sub ExtUtils::MM_VMS::init_others; sub ExtUtils::MM_VMS::constants; -sub ExtUtils::MM_VMS::const_loadlibs; sub ExtUtils::MM_VMS::cflags; sub ExtUtils::MM_VMS::const_cccmd; sub ExtUtils::MM_VMS::pm_to_blib; @@ -263,6 +307,17 @@ sub AUTOLOAD { #__DATA__ + +# This isn't really an override. It's just here because ExtUtils::MM_VMS +# appears in @MM::ISA before ExtUtils::Liblist, so if there isn't an ext() +# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just +# mimic inheritance here and hand off to ExtUtils::Liblist. +sub ext { + ExtUtils::Liblist::ext(@_); +} + +=back + =head2 SelfLoaded methods Those methods which override default MM_Unix methods are marked @@ -271,6 +326,8 @@ For overridden methods, documentation is limited to an explanation of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix documentation for more details. +=over + =item guess_name (override) Try to determine name of extension being built. We begin with the name @@ -284,12 +341,24 @@ package name. sub guess_name { my($self) = @_; - my($defname,$defpm); + my($defname,$defpm,@pm,%xs,$pm); local *PM; $defname = basename(fileify($ENV{'DEFAULT'})); $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version $defpm = $defname; + # Fallback in case for some reason a user has copied the files for an + # extension into a working directory whose name doesn't reflect the + # extension's name. We'll use the name of a unique .pm file, or the + # first .pm file with a matching .xs file. + if (not -e "${defpm}.pm") { + @pm = map { s/.pm$//; $_ } glob('*.pm'); + if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } + elsif (@pm) { + %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); + if (%xs) { foreach $pm (@pm) { $defpm = $pm, last if exists $xs{$pm}; } } + } + } if (open(PM,"${defpm}.pm")){ while (<PM>) { if (/^\s*package\s+([^;]+)/i) { @@ -317,13 +386,14 @@ invoke Perl images. =cut -sub find_perl{ +sub find_perl { my($self, $ver, $names, $dirs, $trace) = @_; my($name,$dir,$vmsfile,@sdirs,@snames,@cand); + my($inabs) = 0; # Check in relative directories first, so we pick up the current # version of Perl if we're running MakeMaker as part of the main build. - @sdirs = sort { my($absb) = file_name_is_absolute($a); - my($absb) = file_name_is_absolute($b); + @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); + my($absb) = $self->file_name_is_absolute($b); if ($absa && $absb) { return $a cmp $b } else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); } } @$dirs; @@ -332,9 +402,16 @@ sub find_perl{ # executable that's less likely to be from an old installation. @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename my($bb) = $b =~ m!([^:>\]/]+)$!; - substr($ba,0,1) cmp substr($bb,0,1) - or -1*(length($ba) <=> length($bb)) } @$names; - if ($trace){ + my($ahasdir) = (length($a) - length($ba) > 0); + my($bhasdir) = (length($b) - length($bb) > 0); + if ($ahasdir and not $bhasdir) { return 1; } + elsif ($bhasdir and not $ahasdir) { return -1; } + else { $bb =~ /\d/ <=> $ba =~ /\d/ + or substr($ba,0,1) cmp substr($bb,0,1) + or length($bb) <=> length($ba) } } @$names; + # Image names containing Perl version use '_' instead of '.' under VMS + foreach $name (@snames) { $name =~ s/\.(\d+)$/_$1/; } + if ($trace >= 2){ print "Looking for perl $ver by these names:\n"; print "\t@snames,\n"; print "in these dirs:\n"; @@ -342,6 +419,14 @@ sub find_perl{ } foreach $dir (@sdirs){ next unless defined $dir; # $self->{PERL_SRC} may be undefined + $inabs++ if $self->file_name_is_absolute($dir); + if ($inabs == 1) { + # We've covered relative dirs; everything else is an absolute + # dir (probably an installed location). First, we'll try potential + # command names, to see whether we can avoid a long MCR expression. + foreach $name (@snames) { push(@cand,$name) if $name =~ /^[\w\-\$]+$/; } + $inabs++; # Should happen above in next $dir, but just in case . . . + } foreach $name (@snames){ if ($name !~ m![/:>\]]!) { push(@cand,$self->catfile($dir,$name)); } else { push(@cand,$self->fixpath($name)); } @@ -349,12 +434,18 @@ sub find_perl{ } foreach $name (@cand) { print "Checking $name\n" if ($trace >= 2); + # If it looks like a potential command, try it without the MCR + if ($name =~ /^[\w\-\$]+$/ && + `$name -e "require $ver; print ""VER_OK\n"""` =~ /VER_OK/) { + print "Using PERL=$name\n" if $trace; + return $name; + } next unless $vmsfile = $self->maybe_command($name); $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well print "Executing $vmsfile\n" if ($trace >= 2); if (`MCR $vmsfile -e "require $ver; print ""VER_OK\n"""` =~ /VER_OK/) { print "Using PERL=MCR $vmsfile\n" if $trace; - return "MCR $vmsfile" + return "MCR $vmsfile"; } } print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; @@ -378,22 +469,32 @@ sub path { Follows VMS naming conventions for executable files. If the name passed in doesn't exactly match an executable file, -appends F<.Exe> to check for executable image, and F<.Com> to check -for DCL procedure. If this fails, checks F<Sys$Share:> for an -executable file having the name specified. Finally, appends F<.Exe> -and checks again. +appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> +to check for DCL procedure. If this fails, checks directories in DCL$PATH +and finally F<Sys$System:> for an executable file having the name specified, +with or without the F<.Exe>-equivalent suffix. =cut sub maybe_command { my($self,$file) = @_; return $file if -x $file && ! -d _; - return "$file.exe" if -x "$file.exe"; - return "$file.com" if -x "$file.com"; + my(@dirs) = (''); + my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); + my($dir,$ext); if ($file !~ m![/:>\]]!) { - my($shrfile) = 'Sys$Share:' . $file; - return $file if -x $shrfile && ! -d _; - return "$file.exe" if -x "$shrfile.exe"; + for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { + $dir = $ENV{"DCL\$PATH;$i"}; + $dir .= ':' unless $dir =~ m%[\]:]$%; + push(@dirs,$dir); + } + push(@dirs,'Sys$System:'); + foreach $dir (@dirs) { + my $sysfile = "$dir$file"; + foreach $ext (@exts) { + return $file if -x "$sysfile$ext" && ! -d _; + } + } } return 0; } @@ -424,7 +525,7 @@ sub maybe_command_in_dirs { # $ver is optional argument if looking for perl if (defined $ver) { print "Executing $abs\n" if ($trace >= 2); if (`$abs -e 'require $ver; print "VER_OK\n" ' 2>&1` =~ /VER_OK/) { - print "Using PERL=$abs\n" if $trace; + print "Using $abs\n" if $trace; return $abs; } } else { # Do not look for perl @@ -436,8 +537,8 @@ sub maybe_command_in_dirs { # $ver is optional argument if looking for perl =item perl_script (override) -If name passed in doesn't specify a readable file, appends F<.pl> and -tries again, since it's customary to have file types on all files +If name passed in doesn't specify a readable file, appends F<.com> or +F<.pl> and tries again, since it's customary to have file types on all files under VMS. =cut @@ -445,7 +546,8 @@ under VMS. sub perl_script { my($self,$file) = @_; return $file if -r $file && ! -d _; - return "$file.pl" if -r "$file.pl" && ! -d _; + return "$file.com" if -r "$file.com"; + return "$file.pl" if -r "$file.pl"; return ''; } @@ -456,8 +558,10 @@ Checks for VMS directory spec as well as Unix separators. =cut sub file_name_is_absolute { - my($self,$file); - $file =~ m!^/! or $file =~ m![:<\[][^.\-]!; + my($self,$file) = @_; + # If it's a logical name, expand it. + $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; + $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; } =item replace_manpage_separator @@ -483,7 +587,7 @@ off to the default MM_Unix method. sub init_others { my($self) = @_; - $self->{NOOP} = "\t@ Continue"; + $self->{NOOP} = 'Continue'; $self->{FIRST_MAKEFILE} ||= 'Descrip.MMS'; $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS'; $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; @@ -494,7 +598,7 @@ sub init_others { $self->{CHMOD} = '$(PERL) -e "chmod @ARGV"'; # expect Unix syntax from MakeMaker $self->{CP} = 'Copy/NoConfirm'; $self->{MV} = 'Rename/NoConfirm'; - $self->{UMASK_NULL} = "\t!"; + $self->{UMASK_NULL} = '! '; &ExtUtils::MM_Unix::init_others; } @@ -514,29 +618,24 @@ sub constants { my(@defs) = split(/\s+/,$self->{DEFINE}); foreach $def (@defs) { next unless $def; - $def =~ s/^-D//; - $def = "\"$def\"" if $def =~ /=/; + if ($def =~ s/^-D//) { # If it was a Unix-style definition + $def =~ s/='(.*)'$/=$1/; # then remove shell-protection '' + $def =~ s/^'(.*)'$/$1/; # from entire term or argument + } + if ($def =~ /=/) { + $def =~ s/"/""/g; # Protect existing " from DCL + $def = qq["$def"]; # and quote to prevent parsing of = + } } $self->{DEFINE} = join ',',@defs; } if ($self->{OBJECT} =~ /\s/) { $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g; - $self->{OBJECT} = map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT})); + $self->{OBJECT} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT}))); } $self->{LDFROM} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM}))); - if ($self->{'INC'} && $self->{INC} !~ m!/Include=!i) { - my(@val) = ( '/Include=(' ); - my(@includes) = split(/\s+/,$self->{INC}); - my($plural); - foreach (@includes) { - s/^-I//; - push @val,', ' if $plural++; - push @val,$self->fixpath($_,1); - } - $self->{INC} = join('',@val,')'); - } # Fix up directory specs $self->{ROOTEXT} = $self->{ROOTEXT} ? $self->fixpath($self->{ROOTEXT},1) @@ -593,8 +692,14 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision ]; for $tmp (qw/ - FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT - LDFROM LINKTYPE + FULLEXT VERSION_FROM OBJECT LDFROM + / ) { + next unless defined $self->{$tmp}; + push @m, "$tmp = ",$self->fixpath($self->{$tmp}),"\n"; + } + + for $tmp (qw/ + BASEEXT PARENT_NAME DLBASE INC DEFINE LINKTYPE / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; @@ -621,12 +726,12 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision push @m,' # Handy lists of source code files: -XS_FILES = ',join(', ', sort keys %{$self->{XS}}),' -C_FILES = ',join(', ', @{$self->{C}}),' -O_FILES = ',join(', ', @{$self->{O_FILES}} ),' -H_FILES = ',join(', ', @{$self->{H}}),' -MAN1PODS = ',join(', ', sort keys %{$self->{MAN1PODS}}),' -MAN3PODS = ',join(', ', sort keys %{$self->{MAN3PODS}}),' +XS_FILES = ',$self->wraplist(', ', sort keys %{$self->{XS}}),' +C_FILES = ',$self->wraplist(', ', @{$self->{C}}),' +O_FILES = ',$self->wraplist(', ', @{$self->{O_FILES}} ),' +H_FILES = ',$self->wraplist(', ', @{$self->{H}}),' +MAN1PODS = ',$self->wraplist(', ', sort keys %{$self->{MAN1PODS}}),' +MAN3PODS = ',$self->wraplist(', ', sort keys %{$self->{MAN3PODS}}),' '; @@ -638,18 +743,19 @@ MAN3PODS = ',join(', ', sort keys %{$self->{MAN3PODS}}),' } push @m," +.SUFFIXES : .SUFFIXES : \$(OBJ_EXT) .c .cpp .cxx .xs # Here is the Config.pm that we are using/depend on CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h \$(VERSION_FROM) # Where to put things: -INST_LIBDIR = ",($self->{'INST_LIBDIR'} = $self->catdir($self->{INST_LIB},$self->{ROOTEXT}))," -INST_ARCHLIBDIR = ",($self->{'INST_ARCHLIBDIR'} = $self->catdir($self->{INST_ARCHLIB},$self->{ROOTEXT}))," +INST_LIBDIR = $self->{INST_LIBDIR} +INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR} -INST_AUTODIR = ",($self->{'INST_AUTODIR'} = $self->catdir($self->{INST_LIB},'auto',$self->{FULLEXT})),' -INST_ARCHAUTODIR = ',($self->{'INST_ARCHAUTODIR'} = $self->catdir($self->{INST_ARCHLIB},'auto',$self->{FULLEXT})),' -'; +INST_AUTODIR = $self->{INST_AUTODIR} +INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR} +"; if ($self->has_link_code()) { push @m,' @@ -663,79 +769,27 @@ INST_STATIC = INST_DYNAMIC = INST_BOOT = EXPORT_LIST = $(BASEEXT).opt -PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : 'Sys$Share:PerlShr.Exe'),' +PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : "Sys\$Share:PerlShr.$Config{'dlext'}"),' '; } $self->{TO_INST_PM} = [ sort keys %{$self->{PM}} ]; $self->{PM_TO_BLIB} = [ %{$self->{PM}} ]; push @m,' -TO_INST_PM = ',join(', ',@{$self->{TO_INST_PM}}),' +TO_INST_PM = ',$self->wraplist(', ',@{$self->{TO_INST_PM}}),' -PM_TO_BLIB = ',join(', ',@{$self->{PM_TO_BLIB}}),' +PM_TO_BLIB = ',$self->wraplist(', ',@{$self->{PM_TO_BLIB}}),' '; join('',@m); } -=item const_loadlibs (override) - -Basically a stub which passes through library specfications provided -by the caller. Will be updated or removed when VMS support is added -to ExtUtils::Liblist. - -=cut - -sub const_loadlibs{ - my($self) = @_; - my (@m); - push @m, " -# $self->{NAME} might depend on some other libraries. -# (These comments may need revising:) -# -# Dependent libraries can be linked in one of three ways: -# -# 1. (For static extensions) by the ld command when the perl binary -# is linked with the extension library. See EXTRALIBS below. -# -# 2. (For dynamic extensions) by the ld command when the shared -# object is built/linked. See LDLOADLIBS below. -# -# 3. (For dynamic extensions) by the DynaLoader when the shared -# object is loaded. See BSLOADLIBS below. -# -# EXTRALIBS = List of libraries that need to be linked with when -# linking a perl binary which includes this extension -# Only those libraries that actually exist are included. -# These are written to a file and used when linking perl. -# -# LDLOADLIBS = List of those libraries which can or must be linked into -# the shared library when created using ld. These may be -# static or dynamic libraries. -# LD_RUN_PATH is a colon separated list of the directories -# in LDLOADLIBS. It is passed as an environment variable to -# the process that links the shared library. -# -# BSLOADLIBS = List of those libraries that are needed but can be -# linked in dynamically at run time on this platform. -# SunOS/Solaris does not need this because ld records -# the information (from LDLOADLIBS) into the object file. -# This list is used to create a .bs (bootstrap) file. -# -EXTRALIBS = ",map($self->fixpath($_) . ' ',$self->{'EXTRALIBS'})," -BSLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'BSLOADLIBS'})," -LDLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'LDLOADLIBS'}),"\n"; - - join('',@m); -} - =item cflags (override) Bypass shell script and produce qualifiers for CC directly (but warn user if a shell script for this extension exists). Fold multiple -/Defines into one, and do the same with /Includes, since some C -compilers pay attention to only one instance of these qualifiers -on the command line. +/Defines into one, since some C compilers pay attention to only one +instance of this qualifier on the command line. =cut @@ -780,10 +834,7 @@ sub cflags { $incstr .= ', '.$self->fixpath($_,1); } } - if ($quals =~ m:(.*)/include=\(?([^\(\/\)\s]+)\)?(.*):i) { - $quals = "$1$incstr,$2)$3"; - } - else { $quals .= "$incstr)"; } + $quals .= "$incstr)"; $optimize = '/Debug/NoOptimize' if ($self->{OPTIMIZE} =~ /-g/ or $self->{OPTIMIZE} =~ m!/Debug!i); @@ -800,7 +851,7 @@ LARGE = =item const_cccmd (override) Adds directives to point C preprocessor to the right place when -handling #include <sys/foo.h> directives. Also constructs CC +handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC command line a bit differently than MM_Unix method. =cut @@ -851,25 +902,31 @@ sub pm_to_blib { my(@files) = @{$self->{PM_TO_BLIB}}; push @m, q{ + +# Dummy target to match Unix target name; we use pm_to_blib.ts as +# timestamp file to avoid repeated invocations under VMS +pm_to_blib : pm_to_blib.ts + $(NOECHO) $(NOOP) + # As always, keep under DCL's 255-char limit -pm_to_blib : $(TO_INST_PM) - },$self->{NOECHO},q{$(PERL) -e "print '},shift(@files),q{ },shift(@files),q{'" >.MM_tmp +pm_to_blib.ts : $(TO_INST_PM) + $(NOECHO) $(PERL) -e "print '},shift(@files),q{ },shift(@files),q{'" >.MM_tmp }; $line = ''; # avoid uninitialized var warning while ($from = shift(@files),$to = shift(@files)) { $line .= " $from $to"; if (length($line) > 128) { - push(@m,"\t$self->{NOECHO}\$(PERL) -e \"print '$line'\" >>.MM_tmp\n"); + push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n"); $line = ''; } } - push(@m,"\t$self->{NOECHO}\$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line; + push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line; push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[')" <.MM_tmp]); push(@m,qq[ - $self->{NOECHO}Delete/NoLog/NoConfirm .MM_tmp; - $self->{NOECHO}\$(TOUCH) pm_to_blib.ts + \$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; + \$(NOECHO) \$(TOUCH) pm_to_blib.ts ]); join('',@m); @@ -948,8 +1005,8 @@ XSUBPPARGS = @tmargs =item xsubpp_version (override) -Test xsubpp exit status according to VMS rules ($sts & 1 ==> good) -rather than Unix rules ($sts == 0 ==> good). +Test xsubpp exit status according to VMS rules ($sts & 1 ==E<gt> good) +rather than Unix rules ($sts == 0 ==E<gt> good). =cut @@ -966,7 +1023,10 @@ sub xsubpp_version my $command = "$self->{PERL} \"-I$self->{PERL_LIB}\" $xsubpp -v"; print "Running: $command\n" if $Verbose; $version = `$command` ; - warn "Running '$command' exits with status " . $? unless ($? & 1); + if ($?) { + use vmsish 'status'; + warn "Running '$command' exits with status $?"; + } chop $version ; return $1 if $version =~ /^xsubpp version (.*)/ ; @@ -993,7 +1053,10 @@ EOM $command = "$self->{PERL} $xsubpp $file"; print "Running: $command\n" if $Verbose; my $text = `$command` ; - warn "Running '$command' exits with status " . $? unless ($? & 1); + if ($?) { + use vmsish 'status'; + warn "Running '$command' exits with status $?"; + } unlink $file ; # gets 1.2 -> 1.92 and 2.000a1 @@ -1034,15 +1097,17 @@ CP = $self->{CP} MV = $self->{MV} RM_F = $self->{RM_F} RM_RF = $self->{RM_RF} +SAY = Write Sys\$Output UMASK_NULL = $self->{UMASK_NULL} NOOP = $self->{NOOP} +NOECHO = $self->{NOECHO} MKPATH = Create/Directory EQUALIZE_TIMESTAMP = \$(PERL) -we "open F,qq{>\$ARGV[1]};close F;utime(0,(stat(\$ARGV[0]))[9]+1,\$ARGV[1])" !. ($self->{PARENT} ? '' : qq!WARN_IF_OLD_PACKLIST = \$(PERL) -e "if (-f \$ARGV[0]){print qq[WARNING: Old package found (\$ARGV[0]); please check for collisions\\n]}" MOD_INSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "install({split(' ',<STDIN>)},1);" -DOC_INSTALL = \$(PERL) -e "\@ARGV=split('|',<STDIN>);print '=head3 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];while(\$key=shift && \$val=shift){print qq[=item *\\n\\nC<\$key: \$val>\\n\\n];}print qq[=back\\n\\n]" -UNINSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "uninstall(\$ARGV[0],1);" +DOC_INSTALL = \$(PERL) -e "\@ARGV=split(/\\|/,<STDIN>);print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];while(\$key=shift && \$val=shift){print qq[=item *\\n\\nC<\$key: \$val>\\n\\n];}print qq[=back\\n\\n]" +UNINSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "uninstall(\$ARGV[0],1,1);" !); } @@ -1056,12 +1121,17 @@ default MM_Unix method. sub dist { my($self, %attribs) = @_; $attribs{VERSION} ||= $self->{VERSION_SYM}; + $attribs{NAME} ||= $self->{DISTNAME}; $attribs{ZIPFLAGS} ||= '-Vu'; $attribs{COMPRESS} ||= 'gzip'; $attribs{SUFFIX} ||= '-gz'; $attribs{SHAR} ||= 'vms_share'; $attribs{DIST_DEFAULT} ||= 'zipdist'; + # Sanitize these for use in $(DISTVNAME) filespec + $attribs{VERSION} =~ s/[^\w\$]/_/g; + $attribs{NAME} =~ s/[^\w\$]/_/g; + return ExtUtils::MM_Unix::dist($self,%attribs); } @@ -1130,27 +1200,27 @@ sub top_targets { my(@m); push @m, ' all :: pure_all manifypods - $(NOOP) + $(NOECHO) $(NOOP) pure_all :: config pm_to_blib subdirs linkext - $(NOOP) + $(NOECHO) $(NOOP) subdirs :: $(MYEXTLIB) - $(NOOP) + $(NOECHO) $(NOOP) config :: $(MAKEFILE) $(INST_LIBDIR).exists - $(NOOP) + $(NOECHO) $(NOOP) config :: $(INST_ARCHAUTODIR).exists - $(NOOP) + $(NOECHO) $(NOOP) config :: $(INST_AUTODIR).exists - $(NOOP) + $(NOECHO) $(NOOP) '; push @m, q{ config :: Version_check - $(NOOP) + $(NOECHO) $(NOOP) } unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; @@ -1159,14 +1229,14 @@ config :: Version_check if (%{$self->{MAN1PODS}}) { push @m, q[ config :: $(INST_MAN1DIR).exists - $(NOOP) + $(NOECHO) $(NOOP) ]; push @m, $self->dir_target(qw[$(INST_MAN1DIR)]); } if (%{$self->{MAN3PODS}}) { push @m, q[ config :: $(INST_MAN3DIR).exists - $(NOOP) + $(NOECHO) $(NOOP) ]; push @m, $self->dir_target(qw[$(INST_MAN3DIR)]); } @@ -1182,7 +1252,7 @@ help : push @m, q{ Version_check : - },$self->{NOECHO},q{$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" - + $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" - "-MExtUtils::MakeMaker=Version_check" -e "&Version_check('$(MM_VERSION)')" }; @@ -1210,12 +1280,12 @@ sub dlsyms { unless ($self->{SKIPHASH}{'dynamic'}) { push(@m,' dynamic :: rtls.opt $(INST_ARCHAUTODIR)$(BASEEXT).opt - $(NOOP) + $(NOECHO) $(NOOP) '); if ($srcdir) { my($popt) = $self->catfile($srcdir,'perlshr.opt'); my($lopt) = $self->catfile($srcdir,'crtl.opt'); - push(@m,"# Depend on $(BASEEXT).opt to insure we copy here *after* autogenerating (wrong) rtls.opt in Mksymlists + push(@m,"# Depend on \$(BASEEXT).opt to insure we copy here *after* autogenerating (wrong) rtls.opt in Mksymlists rtls.opt : $popt $lopt \$(BASEEXT).opt Copy/Log $popt Sys\$Disk:[]rtls.opt Append/Log $lopt Sys\$Disk:[]rtls.opt @@ -1232,7 +1302,7 @@ rtls.opt : $(BASEEXT).opt push(@m,' static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt - $(NOOP) + $(NOECHO) $(NOOP) ') unless $self->{SKIPHASH}{'static'}; push(@m,' @@ -1246,7 +1316,21 @@ $(BASEEXT).opt : Makefile.PL $(PERL) -e "print ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET) '); + if (length $self->{LDLOADLIBS}) { + my($lib); my($line) = ''; + foreach $lib (split ' ', $self->{LDLOADLIBS}) { + $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs + if (length($line) + length($lib) > 160) { + push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n"; + $line = $lib . '\n'; + } + else { $line .= $lib . '\n'; } + } + push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line; + } + join('',@m); + } =item dynamic_lib (override) @@ -1272,7 +1356,8 @@ INST_DYNAMIC_DEP = $inst_dynamic_dep "; push @m, ' $(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt rtls.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) - ',$self->{NOECHO},'$(MKPATH) $(INST_ARCHAUTODIR) + $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) + $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.',$Config{'dlext'},' Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,rtls.opt/Option,$(PERL_INC)perlshr_attr.opt/Option '; @@ -1298,13 +1383,13 @@ BOOTSTRAP = '."$self->{BASEEXT}.bs".' # we use touch to prevent make continually trying to remake it. # The DynaLoader only reads a non-empty file. $(BOOTSTRAP) : $(MAKEFILE) '."$self->{BOOTDEP}".' $(INST_ARCHAUTODIR).exists - '.$self->{NOECHO}.'Write Sys$Output "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))" - '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" - + $(NOECHO) $(SAY) "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))" + $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" - -e "use ExtUtils::Mkbootstrap; Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" - '.$self->{NOECHO}.' $(TOUCH) $(MMS$TARGET) + $(NOECHO) $(TOUCH) $(MMS$TARGET) $(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR).exists - '.$self->{NOECHO}.'$(RM_RF) $(INST_BOOT) + $(NOECHO) $(RM_RF) $(INST_BOOT) - $(CP) $(BOOTSTRAP) $(INST_BOOT) '; } @@ -1321,7 +1406,7 @@ sub static_lib { return ' $(INST_STATIC) : - $(NOOP) + $(NOECHO) $(NOOP) ' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}); my(@m); @@ -1338,7 +1423,7 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) push(@m,' If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST) - ',$self->{NOECHO},'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq[$(EXTRALIBS)\n];close F;" + $(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq{$(EXTRALIBS)\n};close F;" '); push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('',@m); @@ -1358,8 +1443,8 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) # # push(@m, " # $inst : $dist \$(MAKEFILE) ${instdir}.exists \$(INST_ARCHAUTODIR).exists -# ",' ',$self->{NOECHO},'$(RM_F) $(MMS$TARGET) -# ',$self->{NOECHO},'$(CP) ',"$dist $inst",' +# ",' $(NOECHO) $(RM_F) $(MMS$TARGET) +# $(NOECHO) $(CP) ',"$dist $inst",' # $(CHMOD) 644 $(MMS$TARGET) # '); # push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ', @@ -1380,7 +1465,7 @@ to specify fallback location at build time if we can't find pod2man. sub manifypods { my($self, %attribs) = @_; - return "\nmanifypods :\n\t\$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}}; + return "\nmanifypods :\n\t\$(NOECHO) \$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}}; my($dist); my($pod2man_exe); if (defined $self->{PERL_SRC}) { @@ -1388,8 +1473,7 @@ sub manifypods { } else { $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man'); } - if ($pod2man_exe = $self->perl_script($pod2man_exe)) { $found_pod2man = 1; } - else { + if (not ($pod2man_exe = $self->perl_script($pod2man_exe))) { # No pod2man but some MAN3PODS to be installed print <<END; @@ -1406,9 +1490,7 @@ qq[POD2MAN_EXE = $pod2man_exe\n], q[POD2MAN = $(PERL) -we "%m=@ARGV;for (keys %m){" - -e "system(""MCR $^X $(POD2MAN_EXE) $_ >$m{$_}"");}" ]; - push @m, "\nmanifypods : "; - push @m, join " ", keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}}; - push(@m,"\n"); + push @m, "\nmanifypods : \$(MAN1PODS) \$(MAN3PODS)\n"; if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) { my($pod); foreach $pod (sort keys %{$self->{MAN1PODS}}) { @@ -1434,12 +1516,14 @@ sub processPL { return "" unless $self->{PL_FILES}; my(@m, $plfile); foreach $plfile (sort keys %{$self->{PL_FILES}}) { + my $vmsplfile = vmsify($plfile); + my $vmsfile = vmsify($self->{PL_FILES}->{$plfile}); push @m, " -all :: $self->{PL_FILES}->{$plfile} - \$(NOOP) +all :: $vmsfile + \$(NOECHO) \$(NOOP) -$self->{PL_FILES}->{$plfile} :: $plfile -",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $plfile +$vmsfile :: $vmsplfile +",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile "; } join "", @m; @@ -1458,19 +1542,20 @@ sub installbin { return '' unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY"; return '' unless @{$self->{EXE_FILES}}; my(@m, $from, $to, %fromto, @to, $line); - for $from (@{$self->{EXE_FILES}}) { + my(@exefiles) = map { vmsify($_) } @{$self->{EXE_FILES}}; + for $from (@exefiles) { my($path) = '$(INST_SCRIPT)' . basename($from); local($_) = $path; # backward compatibility $to = $self->libscan($path); print "libscan($from) => '$to'\n" if ($Verbose >=2); - $fromto{$from}=$to; + $fromto{$from} = vmsify($to); } - @to = values %fromto; + @to = values %fromto; push @m, " -EXE_FILES = @{$self->{EXE_FILES}} +EXE_FILES = @exefiles all :: @to - \$(NOOP) + \$(NOECHO) \$(NOOP) realclean :: "; @@ -1514,7 +1599,7 @@ sub subdir_x { subdirs :: olddef = F$Environment("Default") Set Default ',$subdir,' - - $(MMS) all $(USEMACROS)$(PASTHRU)$(MACROEND) + - $(MMS)$(MMSQUALIFIERS) all $(USEMACROS)$(PASTHRU)$(MACROEND) Set Default \'olddef\' '; join('',@m); @@ -1538,14 +1623,26 @@ clean :: '; foreach $dir (@{$self->{DIR}}) { # clean subdirectories first my($vmsdir) = $self->fixpath($dir,1); - push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then \\',"\n\t", - '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) clean`;"',"\n"); + push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)").nes."" Then \\',"\n\t", + '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS)$(MMSQUALIFIERS) clean`;"',"\n"); } - push @m, ' $(RM_F) *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *$(OBJ_EXT) *$(LIB_EXT) *.Opt $(BOOTSTRAP) $(BASEEXT).bso + push @m, ' $(RM_F) *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *$(OBJ_EXT) *$(LIB_EXT) *.Opt $(BOOTSTRAP) $(BASEEXT).bso .MM_Tmp '; my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files - push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; + # Unlink realclean, $attribs{FILES} is a string here; it may contain + # a list or a macro that expands to a list. + if ($attribs{FILES}) { + my($word,$key,@filist); + if (ref $attribs{FILES} eq 'ARRAY') { @filist = @{$attribs{FILES}}; } + else { @filist = split /\s+/, $attribs{FILES}; } + foreach $word (@filist) { + if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { + push(@otherfiles, @{$self->{$key}}); + } + else { push(@otherfiles, $attribs{FILES}); } + } + } push(@otherfiles, qw[ blib $(MAKE_APERL_FILE) extralibs.ld perlmain.c pm_to_blib.ts ]); push(@otherfiles,$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); my($file,$line); @@ -1558,7 +1655,7 @@ clean :: } else { $line .= " $file"; } } - push @m, "\t\$(RM_RF) $line\n" if line; + push @m, "\t\$(RM_RF) $line\n" if $line; push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP}; join('', @m); } @@ -1579,7 +1676,7 @@ realclean :: clean foreach(@{$self->{DIR}}){ my($vmsdir) = $self->fixpath($_,1); push(@m, ' If F$Search("'."$vmsdir".'$(MAKEFILE)").nes."" Then \\',"\n\t", - '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) realclean`;"',"\n"); + '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS)$(MMSQUALIFIERS) realclean`;"',"\n"); } push @m,' $(RM_RF) $(INST_AUTODIR) $(INST_ARCHAUTODIR) '; @@ -1604,9 +1701,18 @@ realclean :: clean else { $line .= " $file"; } } push @m, "\t\$(RM_F) $line\n" if $line; - if ($attribs{FILES} && ref $attribs{FILES} eq 'ARRAY') { + if ($attribs{FILES}) { + my($word,$key,@filist,@allfiles); + if (ref $attribs{FILES} eq 'ARRAY') { @filist = @{$attribs{FILES}}; } + else { @filist = split /\s+/, $attribs{FILES}; } + foreach $word (@filist) { + if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { + push(@allfiles, @{$self->{$key}}); + } + else { push(@allfiles, $attribs{FILES}); } + } $line = ''; - foreach $file (@{$attribs{'FILES'}}) { + foreach $file (@allfiles) { $file = $self->fixpath($file); if (length($line) + length($file) > 80) { push @m, "\t\$(RM_RF) $line\n"; @@ -1630,13 +1736,13 @@ sub dist_basics { my($self) = @_; ' distclean :: realclean distcheck - $(NOOP) + $(NOECHO) $(NOOP) distcheck : $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&fullcheck\'; fullcheck()" skipcheck : - $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&fullcheck\'; skipcheck()" + $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&skipcheck\'; skipcheck()" manifest : $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&mkmanifest\'; mkmanifest()" @@ -1654,28 +1760,28 @@ sub dist_core { my($self) = @_; q[ dist : $(DIST_DEFAULT) - ].$self->{NOECHO}.q[$(PERL) -le "print 'Warning: $m older than $vf' if -e ($vf = '$(VERSION_FROM)') && -M $vf < -M ($m = '$(MAKEFILE)'" + $(NOECHO) $(PERL) -le "print 'Warning: $m older than $vf' if -e ($vf = '$(VERSION_FROM)') && -M $vf < -M ($m = '$(MAKEFILE)')" zipdist : $(DISTVNAME).zip - $(NOOP) + $(NOECHO) $(NOOP) $(DISTVNAME).zip : distdir $(PREOP) - $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) $(SRC) + $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*; $(RM_RF) $(DISTVNAME) $(POSTOP) $(DISTVNAME).tar$(SUFFIX) : distdir $(PREOP) $(TO_UNIX) - $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar $(SRC) + $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)] $(RM_RF) $(DISTVNAME) $(COMPRESS) $(DISTVNAME).tar $(POSTOP) shdist : distdir $(PREOP) - $(SHARE) $(SRC) $(DISTVNAME).share + $(SHAR) [.$(DISTVNAME...]*.*; $(DISTVNAME).share $(RM_RF) $(DISTVNAME) $(POSTOP) ]; @@ -1711,8 +1817,8 @@ disttest : distdir startdir = F$Environment("Default") Set Default [.$(DISTVNAME)] $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL - $(MMS) - $(MMS) test + $(MMS)$(MMSQUALIFIERS) + $(MMS)$(MMSQUALIFIERS) test Set Default 'startdir' }; } @@ -1735,93 +1841,108 @@ sub install { foreach $file (@{$self->{EXE_FILES}}) { $line .= "$file "; if (length($line) > 128) { - push(@docfiles,qq[\t\$(PERL) -e "print $line" >>.MM_tmp\n]); + push(@docfiles,qq[\t\$(PERL) -e "print '$line'" >>.MM_tmp\n]); $line = ''; } } - push(@docfiles,qq[\t\$(PERL) -e "print $line" >>.MM_tmp\n]) if $line; + push(@docfiles,qq[\t\$(PERL) -e "print '$line'" >>.MM_tmp\n]) if $line; } push @m, q[ install :: all pure_install doc_install - $(NOOP) + $(NOECHO) $(NOOP) install_perl :: all pure_perl_install doc_perl_install - $(NOOP) + $(NOECHO) $(NOOP) install_site :: all pure_site_install doc_site_install - $(NOOP) + $(NOECHO) $(NOOP) install_ :: install_site - ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" pure_install :: pure_$(INSTALLDIRS)_install - $(NOOP) + $(NOECHO) $(NOOP) doc_install :: doc_$(INSTALLDIRS)_install - ],$self->{NOECHO},q[Write Sys$Output "Appending installation info to $(INST_ARCHLIB)perllocal.pod" + $(NOECHO) $(SAY) "Appending installation info to $(INSTALLARCHLIB)perllocal.pod" pure__install : pure_site_install - ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" doc__install : doc_site_install - ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" # This hack brought to you by DCL's 255-character command line limit pure_perl_install :: - ].$self->{NOECHO}.q[$(PERL) -e "print 'read ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print 'write ].$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_LIB) $(INSTALLPRIVLIB) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLARCHLIB) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print 'read ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp + $(NOECHO) $(PERL) -e "print 'write ].$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_LIB) $(INSTALLPRIVLIB) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLARCHLIB) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp $(MOD_INSTALL) <.MM_tmp - ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; - ].$self->{NOECHO}.q[$(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ + $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; + $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ # Likewise pure_site_install :: - ].$self->{NOECHO}.q[$(PERL) -e "print 'read ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print 'write ].$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_LIB) $(INSTALLSITELIB) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLSITEARCH) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print 'read ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp + $(NOECHO) $(PERL) -e "print 'write ].$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_LIB) $(INSTALLSITELIB) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLSITEARCH) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp $(MOD_INSTALL) <.MM_tmp - ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; - ].$self->{NOECHO}.q[$(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ + $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; + $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ # Ditto doc_perl_install :: - ].$self->{NOECHO}.q[$(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLPRIVLIB)|'" >.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp -],@docfiles,q[ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ - ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; + $(NOECHO) $(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLPRIVLIB)|'" >.MM_tmp + $(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES)|'" >>.MM_tmp +],@docfiles, +q% $(NOECHO) $(PERL) -e "print q[@ARGV=split(/\\|/,<STDIN>);]" >.MM2_tmp + $(NOECHO) $(PERL) -e "print q[print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];]" >>.MM2_tmp + $(NOECHO) $(PERL) -e "print q[while(($key=shift) && ($val=shift)) ]" >>.MM2_tmp + $(NOECHO) $(PERL) -e "print q[{print qq[=item *\\n\\nC<$key: $val>\\n\\n];}print qq[=back\\n\\n];]" >>.MM2_tmp + $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>%.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ + $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp; # And again doc_site_install :: - ].$self->{NOECHO}.q[$(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLSITELIB)|'" >.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp -],@docfiles,q[ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ - ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; + $(NOECHO) $(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLSITELIB)|'" >.MM_tmp + $(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES)|'" >>.MM_tmp +],@docfiles, +q% $(NOECHO) $(PERL) -e "print q[@ARGV=split(/\\|/,<STDIN>);]" >.MM2_tmp + $(NOECHO) $(PERL) -e "print q[print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];]" >>.MM2_tmp + $(NOECHO) $(PERL) -e "print q[while(($key=shift) && ($val=shift)) ]" >>.MM2_tmp + $(NOECHO) $(PERL) -e "print q[{print qq[=item *\\n\\nC<$key: $val>\\n\\n];}print qq[=back\\n\\n];]" >>.MM2_tmp + $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>%.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ + $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp; ]; push @m, q[ uninstall :: uninstall_from_$(INSTALLDIRS)dirs - $(NOOP) + $(NOECHO) $(NOOP) uninstall_from_perldirs :: - ].$self->{NOECHO}.q[$(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ + $(NOECHO) $(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ + $(NOECHO) $(SAY) "Uninstall is now deprecated and makes no actual changes." + $(NOECHO) $(SAY) "Please check the list above carefully for errors, and manually remove" + $(NOECHO) $(SAY) "the appropriate files. Sorry for the inconvenience." uninstall_from_sitedirs :: - ].$self->{NOECHO}.q[$(UNINSTALL) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist')."\n"; + $(NOECHO) $(UNINSTALL) ],$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist'),"\n",q[ + $(NOECHO) $(SAY) "Uninstall is now deprecated and makes no actual changes." + $(NOECHO) $(SAY) "Please check the list above carefully for errors, and manually remove" + $(NOECHO) $(SAY) "the appropriate files. Sorry for the inconvenience." +]; join('',@m); } @@ -1866,14 +1987,21 @@ $(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h # An out of date config.h is not fatal but complains loudly! #$(PERL_INC)config.h : $(PERL_SRC)config.sh $(PERL_INC)config.h : $(PERL_VMS)config.vms - ],$self->{NOECHO},q[Write Sys$Error "Warning: $(PERL_INC)config.h out of date with $(PERL_VMS)config.vms" + $(NOECHO) Write Sys$Error "Warning: $(PERL_INC)config.h out of date with $(PERL_VMS)config.vms" #$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh $(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl - ],$self->{NOECHO},q[Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.vms or genconfig.pl" + $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.vms or genconfig.pl" olddef = F$Environment("Default") Set Default $(PERL_SRC) - $(MMS)],$mmsquals,q[ $(MMS$TARGET) + $(MMS)],$mmsquals,); + if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { + my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm')); + $target =~ s/\Q$prefix/[/; + push(@m," $target"); + } + else { push(@m,' $(MMS$TARGET)'); } + push(@m,q[ Set Default 'olddef' ]); } @@ -1904,13 +2032,13 @@ $(OBJECT) : $(FIRST_MAKEFILE) # We take a very conservative approach here, but it\'s worth it. # We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping. $(MAKEFILE) : Makefile.PL $(CONFIGDEP) - ],$self->{NOECHO},q[Write Sys$Output "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)" - ],$self->{NOECHO},q[Write Sys$Output "Cleaning current config before rebuilding $(MAKEFILE) ..." + $(NOECHO) $(SAY) "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)" + $(NOECHO) $(SAY) "Cleaning current config before rebuilding $(MAKEFILE) ..." - $(MV) $(MAKEFILE) $(MAKEFILE)_old - - $(MMS) $(USEMAKEFILE)$(MAKEFILE)_old clean + - $(MMS)$(MMSQUALIFIERS) $(USEMAKEFILE)$(MAKEFILE)_old clean $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL ],join(' ',map(qq["$_"],@ARGV)),q[ - ],$self->{NOECHO},q[Write Sys$Output "$(MAKEFILE) has been rebuilt." - ],$self->{NOECHO},q[Write Sys$Output "Please run $(MMS) to build the extension." + $(NOECHO) $(SAY) "$(MAKEFILE) has been rebuilt." + $(NOECHO) $(SAY) "Please run $(MMS) to build the extension." ]; join('',@m); @@ -1933,25 +2061,25 @@ TEST_FILE = test.pl TESTDB_SW = -d test :: \$(TEST_TYPE) - \$(NOOP) + \$(NOECHO) \$(NOOP) testdb :: testdb_\$(LINKTYPE) - \$(NOOP) + \$(NOECHO) \$(NOOP) "; foreach(@{$self->{DIR}}){ my($vmsdir) = $self->fixpath($_,1); push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'", - '; print `$(MMS) $(PASTHRU2) test`'."\n"); + '; print `$(MMS)$(MMSQUALIFIERS) $(PASTHRU2) test`'."\n"); } - push(@m, "\t$self->{NOECHO}Write Sys\$Output \"No tests defined for \$(NAME) extension.\"\n") + push(@m, "\t\$(NOECHO) \$(SAY) \"No tests defined for \$(NAME) extension.\"\n") unless $tests or -f "test.pl" or @{$self->{DIR}}; push(@m, "\n"); push(@m, "test_dynamic :: pure_all\n"); push(@m, $self->test_via_harness('$(FULLPERL)', $tests)) if $tests; push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl"; - push(@m, " \$(NOOP)\n") if (!$tests && ! -f "test.pl"); + push(@m, "\t\$(NOECHO) \$(NOOP)\n") if (!$tests && ! -f "test.pl"); push(@m, "\n"); push(@m, "testdb_dynamic :: pure_all\n"); @@ -1971,8 +2099,8 @@ testdb :: testdb_\$(LINKTYPE) push(@m, "\n"); } else { - push @m, "test_static :: test_dynamic\n\t$self->{NOECHO}\$(NOOP)\n\n"; - push @m, "testdb_static :: testdb_dynamic\n\t$self->{NOECHO}\$(NOOP)\n"; + push @m, "test_static :: test_dynamic\n\t\$(NOECHO) \$(NOOP)\n\n"; + push @m, "testdb_static :: testdb_dynamic\n\t\$(NOECHO) \$(NOOP)\n"; } join('',@m); @@ -2027,14 +2155,14 @@ MAP_TARGET = $target unless ($self->{MAKEAPERL}) { push @m, q{ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) - },$self->{NOECHO},q{Write Sys$Output "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" - },$self->{NOECHO},q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \ + $(NOECHO) $(SAY) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" + $(NOECHO) $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \ Makefile.PL DIR=}, $dir, q{ \ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ MAKEAPERL=1 NORECURS=1 $(MAP_TARGET) :: $(MAKE_APERL_FILE) - $(MMS)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET) + $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET) }; push @m, map( " \\\n\t\t$_", @ARGV ); push @m, "\n"; @@ -2043,7 +2171,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) } - my($linkcmd,@staticopts,@staticpkgs,$extralist,$target,$targdir,$libperldir); + my($linkcmd,@staticopts,@staticpkgs,$extralist,$targdir,$libperldir); # The front matter of the linkcommand... $linkcmd = join ' ', $Config{'ld'}, @@ -2129,7 +2257,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) } } - $target = "Perl.Exe" unless $target; + $target = "Perl$Config{'exe_ext'}" unless $target; ($shrtarget,$targdir) = fileparse($target); $shrtarget =~ s/^([^.]*)/$1Shr/; $shrtarget = $targdir . $shrtarget; @@ -2179,37 +2307,37 @@ $(MAP_SHRTARGET) : $(MAP_LIBPERL) $(MAP_STATIC) ',"${libperldir}Perlshr_Attr.Opt $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",' $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt",' $(MAP_LINKCMD) ',"${tmp}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option - ',$self->{NOECHO},'Write Sys$Output "To install the new ""$(MAP_TARGET)"" binary, say" - ',$self->{NOECHO},'Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" - ',$self->{NOECHO},'Write Sys$Output "To remove the intermediate files, say - ',$self->{NOECHO},'Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) map_clean" + $(NOECHO) $(SAY) "To install the new ""$(MAP_TARGET)"" binary, say" + $(NOECHO) $(SAY) " $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" + $(NOECHO) $(SAY) "To remove the intermediate files, say + $(NOECHO) $(SAY) " $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKEFILE) map_clean" '; push @m,' ',"${tmp}perlmain.c",' : $(MAKEFILE) - ',$self->{NOECHO},'$(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET) + $(NOECHO) $(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET) '; push @m, q[ # More from the 255-char line length limit doc_inst_perl : - ].$self->{NOECHO}.q[$(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp - ].$self->{NOECHO}.q[$(PERL) -e "print 'MAP_LIBPERL|$(MAP_LIBPERL)|'" >>.MM_tmp + $(NOECHO) $(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp + $(NOECHO) $(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp + $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp + $(NOECHO) $(PERL) -e "print 'MAP_LIBPERL|$(MAP_LIBPERL)|'" >>.MM_tmp $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ - ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; + $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; ]; push @m, " inst_perl : pure_inst_perl doc_inst_perl - \$(NOOP) + \$(NOECHO) \$(NOOP) pure_inst_perl : \$(MAP_TARGET) $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1)," $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1)," clean :: map_clean - \$(NOOP) + \$(NOECHO) \$(NOOP) map_clean : \$(RM_F) ${tmp}perlmain\$(OBJ_EXT) ${tmp}perlmain.c \$(MAKEFILE) @@ -2219,18 +2347,6 @@ map_clean : join '', @m; } -=item ext (specific) - -Stub routine standing in for C<ExtUtils::LibList::ext> until VMS -support is added to that package. - -=cut - -sub ext { - my($self) = @_; - '','',''; -} - # --- Output postprocessing section --- =item nicetext (override) @@ -2250,5 +2366,9 @@ sub nicetext { 1; +=back + +=cut + __END__ diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm index 3ee3ac6ab3b..b3e8a926099 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm @@ -2,10 +2,10 @@ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatib package ExtUtils::MakeMaker; -$Version = $VERSION = "5.34"; +$Version = $VERSION = "5.42"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) -($Revision = substr(q$Revision: 1.1 $, 10)) =~ s/\s+$//; +($Revision = substr(q$Revision: 1.2 $, 10)) =~ s/\s+$//; @@ -25,8 +25,9 @@ use vars qw( ); # use strict; -eval {require DynaLoader;}; # Get mod2fname, if defined. Will fail - # with miniperl. +# &DynaLoader::mod2fname should be available to miniperl, thus +# should be a pseudo-builtin (cmp. os2.c). +#eval {require DynaLoader;}; # # Set up the inheritance before we pull in the MM_* packages, because they @@ -65,11 +66,12 @@ package ExtUtils::Liblist; package ExtUtils::MakeMaker; # -# Now we can can pull in the friends +# Now we can pull in the friends # -$Is_VMS = $^O eq 'VMS'; -$Is_OS2 = $^O =~ m|^os/?2$|i; -$Is_Mac = $^O eq 'MacOS'; +$Is_VMS = $^O eq 'VMS'; +$Is_OS2 = $^O eq 'os2'; +$Is_Mac = $^O eq 'MacOS'; +$Is_Win32 = $^O eq 'MSWin32'; require ExtUtils::MM_Unix; @@ -83,6 +85,9 @@ if ($Is_OS2) { if ($Is_Mac) { require ExtUtils::MM_Mac; } +if ($Is_Win32) { + require ExtUtils::MM_Win32; +} # The SelfLoader would bring a lot of overhead for MakeMaker, because # we know for sure we will use most of the autoloaded functions once @@ -149,10 +154,12 @@ sub ExtUtils::MakeMaker::mksymlists ; sub ExtUtils::MakeMaker::neatvalue ; sub ExtUtils::MakeMaker::selfdocument ; sub ExtUtils::MakeMaker::WriteMakefile ; -sub ExtUtils::MakeMaker::prompt ; +sub ExtUtils::MakeMaker::prompt ($;$) ; 1; -#__DATA__ + +__DATA__ + package ExtUtils::MakeMaker; sub WriteMakefile { @@ -228,12 +235,12 @@ sub full_setup { @Attrib_help = qw/ - C CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS EXE_FILES - EXCLUDE_EXT INCLUDE_EXT NO_VC FIRST_MAKEFILE FULLPERL H INC - INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR + C CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS + EXE_FILES EXCLUDE_EXT INCLUDE_EXT NO_VC FIRST_MAKEFILE FULLPERL H + INC INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH INSTALLSITELIB INST_ARCHLIB INST_BIN INST_EXE INST_LIB - INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIBPERL_A LIBS + INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIBPERL_A LIB LIBS LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB NAME NEEDS_LINKING NOECHO NORECURS OBJECT OPTIMIZE PERL PERLMAINCC PERL_ARCHLIB PERL_LIB PERL_SRC PL_FILES PM PMLIBDIRS PREFIX @@ -241,10 +248,13 @@ sub full_setup { XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit - installpm + IMPORTS + installpm /; + # IMPORTS is used under OS/2 + # ^^^ installpm is deprecated, will go about Summer 96 # @Overridable is close to @MM_Sections but not identical. The @@ -297,7 +307,7 @@ sub full_setup { @Get_from_Config = qw( ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc - lib_ext obj_ext ranlib sitelibexp sitearchexp so + lib_ext obj_ext ranlib sitelibexp sitearchexp so exe_ext ); my $item; @@ -405,20 +415,17 @@ sub ExtUtils::MakeMaker::new { # This is for old Makefiles written pre 5.00, will go away if ( Carp::longmess("") =~ /runsubdirpl/s ){ - #$self->{Correct_relativ_directories}++; Carp::carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n"); - } else { - $self->{Correct_relativ_directories}=0; } - my $class = ++$PACKNAME; + my $newclass = ++$PACKNAME; { # no strict; - print "Blessing Object into class [$class]\n" if $Verbose>=2; - mv_all_methods("MY",$class); - bless $self, $class; + print "Blessing Object into class [$newclass]\n" if $Verbose>=2; + mv_all_methods("MY",$newclass); + bless $self, $newclass; push @Parent, $self; - @{"$class\:\:ISA"} = 'MM'; + @{"$newclass\:\:ISA"} = 'MM'; } if (defined $Parent[-2]){ @@ -427,10 +434,14 @@ sub ExtUtils::MakeMaker::new { for $key (keys %Prepend_dot_dot) { next unless defined $self->{PARENT}{$key}; $self->{$key} = $self->{PARENT}{$key}; + # PERL and FULLPERL may be command verbs instead of full + # file specifications under VMS. If so, don't turn them + # into a filespec. $self->{$key} = $self->catdir("..",$self->{$key}) - unless $self->file_name_is_absolute($self->{$key}); + unless $self->file_name_is_absolute($self->{$key}) + || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/)); } - $self->{PARENT}->{CHILDREN}->{$class} = $self if $self->{PARENT}; + $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT}; } else { parse_args($self,@ARGV); } @@ -442,11 +453,18 @@ sub ExtUtils::MakeMaker::new { $self->init_main(); if (! $self->{PERL_SRC} ) { - my($pthinks) = $INC{'Config.pm'}; + my($pthinks) = $self->canonpath($INC{'Config.pm'}); + my($cthinks) = $self->catfile($Config{'archlibexp'},'Config.pm'); $pthinks = VMS::Filespec::vmsify($pthinks) if $Is_VMS; - if ($pthinks ne $self->catfile($Config{archlibexp},'Config.pm')){ - $pthinks =~ s!/Config\.pm$!!; - $pthinks =~ s!.*/!!; + if ($pthinks ne $cthinks && + !($Is_Win32 and lc($pthinks) eq lc($cthinks))) { + print "Have $pthinks expected $cthinks\n"; + if ($Is_Win32) { + $pthinks =~ s![/\\]Config\.pm$!!i; $pthinks =~ s!.*[/\\]!!; + } + else { + $pthinks =~ s!/Config\.pm$!!; $pthinks =~ s!.*/!!; + } print STDOUT <<END; Your perl and your Config.pm seem to have different ideas about the architecture they are running on. @@ -550,15 +568,8 @@ sub parse_args{ (getpwuid($>))[7] ]ex; } - # This may go away, in mid 1996 - if ($self->{Correct_relativ_directories}){ - $value = $self->catdir("..",$value) - if $Prepend_dot_dot{$name} && ! $self->file_name_is_absolute($value); - } $self->{uc($name)} = $value; } - # This may go away, in mid 1996 - delete $self->{Correct_relativ_directories}; # catch old-style 'potential_libs' and inform user how to 'upgrade' if (defined $self->{potential_libs}){ @@ -855,18 +866,26 @@ Makefiles with a single invocation of WriteMakefile(). =head2 How To Write A Makefile.PL -The short answer is: Don't. Run h2xs(1) before you start thinking -about writing a module. For so called pm-only modules that consist of -C<*.pm> files only, h2xs has the very useful C<-X> switch. This will -generate dummy files of all kinds that are useful for the module -developer. +The short answer is: Don't. + + Always begin with h2xs. + Always begin with h2xs! + ALWAYS BEGIN WITH H2XS! + +even if you're not building around a header file, and even if you +don't have an XS component. + +Run h2xs(1) before you start thinking about writing a module. For so +called pm-only modules that consist of C<*.pm> files only, h2xs has +the C<-X> switch. This will generate dummy files of all kinds that are +useful for the module developer. The medium answer is: use ExtUtils::MakeMaker; WriteMakefile( NAME => "Foo::Bar" ); -The long answer is below. +The long answer is the rest of the manpage :-) =head2 Default Makefile Behaviour @@ -892,7 +911,7 @@ Other interesting targets in the generated Makefile are =head2 make test -MakeMaker checks for the existence of a file named "test.pl" in the +MakeMaker checks for the existence of a file named F<test.pl> in the current directory and if it exists it adds commands to the test target of the generated Makefile that will execute the script with the proper set of perl C<-I> options. @@ -902,6 +921,22 @@ add commands to the test target of the generated Makefile that execute all matching files via the L<Test::Harness> module with the C<-I> switches set correctly. +=head2 make testdb + +A useful variation of the above is the target C<testdb>. It runs the +test under the Perl debugger (see L<perldebug>). If the file +F<test.pl> exists in the current directory, it is used for the test. + +If you want to debug some other testfile, set C<TEST_FILE> variable +thusly: + + make testdb TEST_FILE=t/mytest.t + +By default the debugger is called using C<-d> option to perl. If you +want to specify some other option, set C<TESTDB_SW> variable: + + make testdb TESTDB_SW=-Dx + =head2 make install make alone puts all relevant files into directories that are named by @@ -909,7 +944,7 @@ the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR, and INST_MAN3DIR. All these default to something below ./blib if you are I<not> building below the perl source directory. If you I<are> building below the perl source, INST_LIB and INST_ARCHLIB default to -../../lib, and INST_SCRIPT is not defined. + ../../lib, and INST_SCRIPT is not defined. The I<install> target of the generated Makefile copies the files found below each of the INST_* directories to their INSTALL* @@ -931,9 +966,7 @@ The INSTALL... macros in turn default to their %Config You can check the values of these variables on your system with - perl -MConfig -le 'print join $/, map - sprintf("%20s: %s", $_, $Config{$_}), - grep /^install/, keys %Config' + perl '-V:install.*' And to check the sequence in which the library directories are searched by perl, run @@ -941,18 +974,29 @@ searched by perl, run perl -le 'print join $/, @INC' -=head2 PREFIX attribute +=head2 PREFIX and LIB attribute + +PREFIX and LIB can be used to set several INSTALL* attributes in one +go. The quickest way to install a module in a non-standard place might +be -The PREFIX attribute can be used to set the INSTALL* attributes in one -go. The quickest way to install a module in a non-standard place + perl Makefile.PL LIB=~/lib + +This will install the module's architecture-independent files into +~/lib, the architecture-dependent files into ~/lib/$archname/auto. + +Another way to specify many INSTALL directories with a single +parameter is PREFIX. perl Makefile.PL PREFIX=~ This will replace the string specified by $Config{prefix} in all $Config{install*} values. -Note, that the tilde expansion is done by MakeMaker, not by perl by -default, nor by make. +Note, that in both cases the tilde expansion is done by MakeMaker, not +by perl by default, nor by make. Conflicts between parmeters LIB, +PREFIX and the various INSTALL* arguments are resolved so that +XXX If the user has superuser privileges, and is not working on AFS (Andrew File System) or relatives, then the defaults for @@ -1113,6 +1157,11 @@ Ref to array of *.c file names. Initialised from a directory scan and the values portion of the XS attribute hash. This is not currently used by MakeMaker but may be handy in Makefile.PLs. +=item CCFLAGS + +String that will be included in the compiler call command line between +the arguments INC and OPTIMIZE. + =item CONFIG Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from @@ -1137,7 +1186,7 @@ so =item CONFIGURE CODE reference. The subroutine should return a hash reference. The -hash may contain further attributes, e.g. {LIBS => ...}, that have to +hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to be determined by some evaluation method. =item DEFINE @@ -1213,6 +1262,10 @@ Perl binary able to run this extension. Ref to array of *.h file names. Similar to C. +=item IMPORTS + +IMPORTS is only used on OS/2. + =item INC Include file dirs eg: C<"-I/usr/5include -I/path/to/inc"> @@ -1323,6 +1376,11 @@ specify ld flags) The filename of the perllibrary that will be used together with this extension. Defaults to libperl.a. +=item LIB + +LIB can only be set at C<perl Makefile.PL> time. It has the effect of +setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any + =item LIBS An anonymous array of alternative library @@ -1515,15 +1573,17 @@ routine requires that the file named by VERSION_FROM contains one single line to compute the version number. The first line in the file that contains the regular expression - /(\$[\w:]*\bVERSION)\b.*=/ + /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ will be evaluated with eval() and the value of the named variable B<after> the eval() will be assigned to the VERSION attribute of the MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; - ( $VERSION ) = '$Revision: 1.1 $ ' =~ /\$Revision:\s+([^\s]+)/; + *VERSION = \'1.01'; + ( $VERSION ) = '$Revision: 1.2 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; + *FOO::VERSION = \'1.11'; but these will fail: @@ -1531,9 +1591,16 @@ but these will fail: local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; -The file named in VERSION_FROM is added as a dependency to Makefile to -guarantee, that the Makefile contains the correct VERSION macro after -a change of the file. +The file named in VERSION_FROM is not added as a dependency to +Makefile. This is not really correct, but it would be a major pain +during development to have to rewrite the Makefile for any smallish +change in that file. If you want to make sure that the Makefile +contains the correct VERSION macro after any change of the file, you +would have to do something like + + depend => { Makefile => '$(VERSION_FROM)' } + +See attribute C<depend> below. =item XS @@ -1644,7 +1711,8 @@ either say: or you can edit the default by saying something like: sub MY::c_o { - my($inherited) = shift->SUPER::c_o(@_); + package MY; # so that "SUPER" works right + my $inherited = shift->SUPER::c_o(@_); $inherited =~ s/old text/new text/; $inherited; } @@ -1797,11 +1865,10 @@ ExtUtils::Install, ExtUtils::embed =head1 AUTHORS -Andy Dougherty F<E<lt>doughera@lafcol.lafayette.eduE<gt>>, Andreas -KE<ouml>nig F<E<lt>A.Koenig@franz.ww.TU-Berlin.DEE<gt>>, Tim Bunce -F<E<lt>Tim.Bunce@ig.co.ukE<gt>>. VMS support by Charles Bailey -F<E<lt>bailey@genetics.upenn.eduE<gt>>. OS/2 support by Ilya -Zakharevich F<E<lt>ilya@math.ohio-state.eduE<gt>>. Contact the +Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig +<F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. +VMS support by Charles Bailey <F<bailey@genetics.upenn.edu>>. OS/2 +support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Contact the makemaker mailing list C<mailto:makemaker@franz.ww.tu-berlin.de>, if you have any questions. diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm b/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm index 9511dc24bd2..cc323c8924f 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm @@ -1,24 +1,26 @@ package ExtUtils::Manifest; - require Exporter; -@ISA=('Exporter'); -@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck', - 'skipcheck', 'maniread', 'manicopy'); - use Config; use File::Find; use File::Copy 'copy'; use Carp; +use strict; -$Debug = 0; -$Verbose = 1; -$Is_VMS = $^O eq 'VMS'; +use vars qw($VERSION @ISA @EXPORT_OK + $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found); -$VERSION = $VERSION = substr(q$Revision: 1.1 $,10,4); +$VERSION = substr(q$Revision: 1.2 $, 10); +@ISA=('Exporter'); +@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck', + 'skipcheck', 'maniread', 'manicopy'); -$Quiet = 0; +$Is_VMS = $^O eq 'VMS'; +if ($Is_VMS) { require File::Basename } +$Debug = 0; +$Verbose = 1; +$Quiet = 0; $MANIFEST = 'MANIFEST'; # Really cool fix from Ilya :) @@ -83,10 +85,10 @@ sub skipcheck { sub _manicheck { my($arg) = @_; my $read = maniread(); + my $found = manifind(); my $file; my(@missfile,@missentry); if ($arg & 1){ - my $found = manifind(); foreach $file (sort keys %$read){ warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug; unless ( exists $found->{$file} ) { @@ -98,7 +100,6 @@ sub _manicheck { if ($arg & 2){ $read ||= {}; my $matches = _maniskip(); - my $found = manifind(); my $skipwarn = $arg & 4; foreach $file (sort keys %$found){ if (&$matches($file)){ @@ -117,7 +118,7 @@ sub _manicheck { sub maniread { my ($mfile) = @_; - $mfile = $MANIFEST unless defined $mfile; + $mfile ||= $MANIFEST; my $read = {}; local *M; unless (open M, $mfile){ @@ -126,8 +127,20 @@ sub maniread { } while (<M>){ chomp; - if ($Is_VMS) { /^(\S+)/ and $read->{"\L$1"}=$_; } - else { /^(\S+)\s*(.*)/ and $read->{$1}=$2; } + next if /^#/; + if ($Is_VMS) { + my($file)= /^(\S+)/; + next unless $file; + my($base,$dir) = File::Basename::fileparse($file); + # Resolve illegal file specifications in the same way as tar + $dir =~ tr/./_/; + my(@pieces) = split(/\./,$base); + if (@pieces > 2) { $base = shift(@pieces) . '.' . join('_',@pieces); } + my $okfile = "$dir$base"; + warn "Debug: Illegal name $file changed to $okfile\n" if $Debug; + $read->{"\L$okfile"}=$_; + } + else { /^(\S+)\s*(.*)/ and $read->{$1}=$2; } } close M; $read; @@ -138,12 +151,13 @@ sub _maniskip { my ($mfile) = @_; my $matches = sub {0}; my @skip ; - $mfile = "$MANIFEST.SKIP" unless defined $mfile; + $mfile ||= "$MANIFEST.SKIP"; local *M; return $matches unless -f $mfile; open M, $mfile or return $matches; while (<M>){ chomp; + next if /^#/; next if /^\s*$/; push @skip, $_; } @@ -161,7 +175,7 @@ sub _maniskip { sub manicopy { my($read,$target,$how)=@_; croak "manicopy() called without target argument" unless defined $target; - $how = 'cp' unless defined $how && $how; + $how ||= 'cp'; require File::Path; require File::Basename; my(%dirs,$file); @@ -175,14 +189,13 @@ sub manicopy { $dir = VMS::Filespec::unixify($dir) if $Is_VMS; File::Path::mkpath(["$target/$dir"],1,$Is_VMS ? undef : 0755); } - if ($Is_VMS) { vms_cp_if_diff($file,"$target/$file"); } - else { cp_if_diff($file, "$target/$file", $how); } + cp_if_diff($file, "$target/$file", $how); } } sub cp_if_diff { - my($from,$to, $how)=@_; - -f $from || carp "$0: $from not found"; + my($from, $to, $how)=@_; + -f $from or carp "$0: $from not found"; my($diff) = 0; local(*F,*T); open(F,$from) or croak "Can't read $from: $!\n"; @@ -197,26 +210,14 @@ sub cp_if_diff { if (-e $to) { unlink($to) or confess "unlink $to: $!"; } - &$how($from, $to); - } -} - -# Do the comparisons here rather than spawning off another process -sub vms_cp_if_diff { - my($from,$to) = @_; - my($diff) = 0; - local(*F,*T); - open(F,$from) or croak "Can't read $from: $!\n"; - if (open(T,$to)) { - while (<F>) { $diff++,last if $_ ne <T>; } - $diff++ unless eof(T); - close T; - } - else { $diff++; } - close F; - if ($diff) { - system('copy',VMS::Filespec::vmsify($from),VMS::Filespec::vmsify($to)) & 1 - or confess "Copy failed: $!"; + STRICT_SWITCH: { + best($from,$to), last STRICT_SWITCH if $how eq 'best'; + cp($from,$to), last STRICT_SWITCH if $how eq 'cp'; + ln($from,$to), last STRICT_SWITCH if $how eq 'ln'; + croak("ExtUtils::Manifest::cp_if_diff " . + "called with illegal how argument [$how]. " . + "Legal values are 'best', 'cp', and 'ln'."); + } } } @@ -224,13 +225,14 @@ sub cp { my ($srcFile, $dstFile) = @_; my ($perm,$access,$mod) = (stat $srcFile)[2,8,9]; copy($srcFile,$dstFile); - utime $access, $mod, $dstFile; + utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile; # chmod a+rX-w,go-w chmod( 0444 | ( $perm & 0111 ? 0111 : 0 ), $dstFile ); } sub ln { my ($srcFile, $dstFile) = @_; + return &cp if $Is_VMS; link($srcFile, $dstFile); local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x) my $mode= 0444 | (stat)[2] & 0700; @@ -242,7 +244,7 @@ sub best { if (-l $srcFile) { cp($srcFile, $dstFile); } else { - ln($srcFile, $dstFile); + ln($srcFile, $dstFile) or cp($srcFile, $dstFile); } } @@ -311,6 +313,8 @@ files found below the current directory. Maniread($file) reads a named C<MANIFEST> file (defaults to C<MANIFEST> in the current directory) and returns a HASH reference with files being the keys and comments being the values of the HASH. +Blank lines and lines which start with C<#> in the C<MANIFEST> file +are discarded. I<Manicopy($read,$target,$how)> copies the files that are the keys in the HASH I<%$read> to the named target directory. The HASH reference @@ -326,7 +330,9 @@ make a tree without any symbolic link. Best is the default. The file MANIFEST.SKIP may contain regular expressions of files that should be ignored by mkmanifest() and filecheck(). The regular -expressions should appear one on each line. A typical example: +expressions should appear one on each line. Blank lines and lines +which start with C<#> are skipped. Use C<\#> if you need a regular +expression to start with a sharp character. A typical example: \bRCS\b ^MANIFEST\. @@ -350,7 +356,7 @@ C<MANIFEST.SKIP> file. This is useful if you want to maintain different distributions for different audiences (say a user version and a developer version including RCS). -<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value, +C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value, all functions act silently. =head1 DIAGNOSTICS @@ -387,6 +393,6 @@ L<ExtUtils::MakeMaker> which has handy targets for most of the functionality. =head1 AUTHOR -Andreas Koenig F<E<lt>koenig@franz.ww.TU-Berlin.DEE<gt>> +Andreas Koenig <F<koenig@franz.ww.TU-Berlin.DE>> =cut diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm b/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm index 06c001553bf..ff0aa096b3e 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm @@ -1,47 +1,15 @@ package ExtUtils::Mkbootstrap; + +$VERSION = substr q$Revision: 1.2 $, 10; +# $Date: 1997/11/30 07:57:31 $ + use Config; use Exporter; @ISA=('Exporter'); @EXPORT='&Mkbootstrap'; -$Version=2.0; # just to start somewhere sub Mkbootstrap { - -=head1 NAME - -ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader - -=head1 SYNOPSIS - -C<mkbootstrap> - -=head1 DESCRIPTION - -Mkbootstrap typically gets called from an extension Makefile. - -There is no C<*.bs> file supplied with the extension. Instead a -C<*_BS> file which has code for the special cases, like posix for -berkeley db on the NeXT. - -This file will get parsed, and produce a maybe empty -C<@DynaLoader::dl_resolve_using> array for the current architecture. -That will be extended by $BSLOADLIBS, which was computed by -ExtUtils::Liblist::ext(). If this array still is empty, we do nothing, -else we write a .bs file with an C<@DynaLoader::dl_resolve_using> -array. - -The C<*_BS> file can put some code into the generated C<*.bs> file by -placing it in C<$bscode>. This is a handy 'escape' mechanism that may -prove useful in complex situations. - -If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then -Mkbootstrap will automatically add a dl_findfile() call to the -generated C<*.bs> file. - -=cut - my($baseext, @bsloadlibs)=@_; - @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose; @@ -58,6 +26,8 @@ generated C<*.bs> file. if (-f "${baseext}_BS"){ $_ = "${baseext}_BS"; package DynaLoader; # execute code as if in DynaLoader + local($osname, $dlsrc) = (); # avoid warnings + ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)}; $bscode = ""; unshift @INC, "."; require $_; @@ -95,3 +65,39 @@ generated C<*.bs> file. } } +1; + +__END__ + +=head1 NAME + +ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader + +=head1 SYNOPSIS + +C<mkbootstrap> + +=head1 DESCRIPTION + +Mkbootstrap typically gets called from an extension Makefile. + +There is no C<*.bs> file supplied with the extension. Instead a +C<*_BS> file which has code for the special cases, like posix for +berkeley db on the NeXT. + +This file will get parsed, and produce a maybe empty +C<@DynaLoader::dl_resolve_using> array for the current architecture. +That will be extended by $BSLOADLIBS, which was computed by +ExtUtils::Liblist::ext(). If this array still is empty, we do nothing, +else we write a .bs file with an C<@DynaLoader::dl_resolve_using> +array. + +The C<*_BS> file can put some code into the generated C<*.bs> file by +placing it in C<$bscode>. This is a handy 'escape' mechanism that may +prove useful in complex situations. + +If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then +Mkbootstrap will automatically add a dl_findfile() call to the +generated C<*.bs> file. + +=cut diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm b/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm index 5c0173a5085..f47235d990b 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm @@ -7,7 +7,7 @@ use Exporter; use vars qw( @ISA @EXPORT $VERSION ); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; -$VERSION = '1.03'; +$VERSION = substr q$Revision: 1.2 $, 10; sub Mksymlists { my(%spec) = @_; @@ -40,6 +40,7 @@ sub Mksymlists { } # We'll need this if we ever add any OS which uses mod2fname +# not as pseudo-builtin. # require DynaLoader; if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) { $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]); @@ -47,7 +48,8 @@ sub Mksymlists { if ($osname eq 'aix') { _write_aix(\%spec); } elsif ($osname eq 'VMS') { _write_vms(\%spec) } - elsif ($osname =~ m|^os/?2$|i) { _write_os2(\%spec) } + elsif ($osname eq 'os2') { _write_os2(\%spec) } + elsif ($osname eq 'MSWin32') { _write_win32(\%spec) } else { croak("Don't know how to create linker option file for $osname\n"); } } @@ -92,13 +94,59 @@ while (($name, $exp)= each %{$data->{IMPORTS}}) { close DEF; } +sub _write_win32 { + my($data) = @_; + + require Config; + if (not $data->{DLBASE}) { + ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; + $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; + } + rename "$data->{FILE}.def", "$data->{FILE}_def.old"; + + open(DEF,">$data->{FILE}.def") + or croak("Can't create $data->{FILE}.def: $!\n"); + # put library name in quotes (it could be a keyword, like 'Alias') + print DEF "LIBRARY \"$data->{DLBASE}\"\n"; + print DEF "CODE LOADONCALL\n"; + print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; + print DEF "EXPORTS\n "; + my @syms; + # Export public symbols both with and without underscores to + # ensure compatibility between DLLs from different compilers + # NOTE: DynaLoader itself only uses the names without underscores, + # so this is only to cover the case when the extension DLL may be + # linked to directly from C. GSAR 97-07-10 + if ($Config::Config{'cc'} =~ /^bcc/i) { + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { + push @syms, "_$_", "$_ = _$_"; + } + } + else { + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) { + push @syms, "$_", "_$_ = $_"; + } + } + print DEF join("\n ",@syms, "\n") if @syms; + if (%{$data->{IMPORTS}}) { + print DEF "IMPORTS\n"; + my ($name, $exp); + while (($name, $exp)= each %{$data->{IMPORTS}}) { + print DEF " $name=$exp\n"; + } + } + close DEF; +} + sub _write_vms { my($data) = @_; require Config; # a reminder for once we do $^O + require ExtUtils::XSSymSet; my($isvax) = $Config::Config{'arch'} =~ /VAX/i; + my($set) = new ExtUtils::XSSymSet; my($sym); rename "$data->{FILE}.opt", "$data->{FILE}.opt_old"; @@ -114,13 +162,15 @@ sub _write_vms { # the GSMATCH criteria for a dynamic extension foreach $sym (@{$data->{FUNCLIST}}) { - if ($isvax) { print OPT "UNIVERSAL=$sym\n" } - else { print OPT "SYMBOL_VECTOR=($sym=PROCEDURE)\n"; } + my $safe = $set->addsym($sym); + if ($isvax) { print OPT "UNIVERSAL=$safe\n" } + else { print OPT "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; } } foreach $sym (@{$data->{DL_VARS}}) { + my $safe = $set->addsym($sym); print OPT "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; - if ($isvax) { print OPT "UNIVERSAL=$sym\n" } - else { print OPT "SYMBOL_VECTOR=($sym=DATA)\n"; } + if ($isvax) { print OPT "UNIVERSAL=$safe\n" } + else { print OPT "SYMBOL_VECTOR=($safe=DATA)\n"; } } close OPT; @@ -152,13 +202,15 @@ ExtUtils::Mksymlists - write linker options files for dynamic extension =head1 DESCRIPTION C<ExtUtils::Mksymlists> produces files used by the linker under some OSs -during the creation of shared libraries for synamic extensions. It is +during the creation of shared libraries for dynamic extensions. It is normally called from a MakeMaker-generated Makefile when the extension is built. The linker option file is generated by calling the function C<Mksymlists>, which is exported by default from C<ExtUtils::Mksymlists>. It takes one argument, a list of key-value pairs, in which the following keys are recognized: +=over + =item NAME This gives the name of the extension (I<e.g.> Tk::Canvas) for which @@ -212,6 +264,8 @@ extension itself (for instance, some linkers add an '_' to the name of the extension). If it is not specified, it is derived from the NAME attribute. It is presently used only by OS2. +=back + When calling C<Mksymlists>, one should always specify the NAME attribute. In most cases, this is all that's necessary. In the case of unusual extensions, however, the other attributes diff --git a/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm b/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm index d5596047fb7..57ea87c82fe 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm @@ -1,4 +1,7 @@ package ExtUtils::testlib; +$VERSION = substr q$Revision: 1.2 $, 10; +# $Id: testlib.pm,v 1.2 1997/11/30 07:57:32 millert Exp $ + use lib qw(blib/arch blib/lib); 1; __END__ diff --git a/gnu/usr.bin/perl/lib/ExtUtils/typemap b/gnu/usr.bin/perl/lib/ExtUtils/typemap index a9733d0f491..20cc96f0b55 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/typemap +++ b/gnu/usr.bin/perl/lib/ExtUtils/typemap @@ -45,6 +45,7 @@ FileHandle T_PTROBJ InputStream T_IN InOutStream T_INOUT OutputStream T_OUT +bool T_BOOL ############################################################################# INPUT @@ -78,6 +79,8 @@ T_INT $var = (int)SvIV($arg) T_ENUM $var = ($type)SvIV($arg) +T_BOOL + $var = (int)SvIV($arg) T_U_INT $var = (unsigned int)SvIV($arg) T_SHORT @@ -124,7 +127,7 @@ T_REF_IV_PTR else croak(\"$var is not of type ${ntype}\") T_PTROBJ - if (sv_isa($arg, \"${ntype}\")) { + if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } @@ -199,6 +202,8 @@ T_SYSRET } T_ENUM sv_setiv($arg, (IV)$var); +T_BOOL + $arg = boolSV($var); T_U_INT sv_setiv($arg, (IV)$var); T_SHORT diff --git a/gnu/usr.bin/perl/lib/ExtUtils/xsubpp b/gnu/usr.bin/perl/lib/ExtUtils/xsubpp index 8554bb5054e..04de166ad67 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/xsubpp +++ b/gnu/usr.bin/perl/lib/ExtUtils/xsubpp @@ -6,7 +6,7 @@ xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-typemap typemap>]... file.xs +B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs =head1 DESCRIPTION @@ -55,6 +55,10 @@ Disables the run time test that determines if the object file (derived from the C<.xs> file) and the C<.pm> files have the same version number. +=item B<-nolinenumbers> + +Prevents the inclusion of `#line' directives in the output. + =back =head1 ENVIRONMENT @@ -71,20 +75,32 @@ See the file F<changes.pod>. =head1 SEE ALSO -perl(1), perlxs(1), perlxstut(1), perlapi(1) +perl(1), perlxs(1), perlxstut(1) =cut -# Global Constants -$XSUBPP_version = "1.935"; require 5.002; +use Cwd; use vars '$cplusplus'; sub Q ; +# Global Constants + +$XSUBPP_version = "1.9505"; + +my ($Is_VMS, $SymSet); +if ($^O eq 'VMS') { + $Is_VMS = 1; + # Establish set of global symbols with max length 28, since xsubpp + # will later add the 'XS_' prefix. + require ExtUtils::XSSymSet; + $SymSet = new ExtUtils::XSSymSet 28; +} + $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n"; +$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; @@ -92,10 +108,11 @@ $except = ""; $WantPrototypes = -1 ; $WantVersionChk = 1 ; $ProtoUsed = 0 ; +$WantLineNumbers = 1 ; SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; - $spat = shift, next SWITCH if $flag eq 's'; + $spat = quotemeta shift, next SWITCH if $flag eq 's'; $cplusplus = 1, next SWITCH if $flag eq 'C++'; $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; @@ -103,6 +120,8 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; $except = " TRY", next SWITCH if $flag eq 'except'; push(@tm,shift), next SWITCH if $flag eq 'typemap'; + $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; + $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; (print "xsubpp version $XSUBPP_version\n"), exit if $flag eq 'v'; die $usage; @@ -115,19 +134,18 @@ else @ARGV == 1 or die $usage; ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# + or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# or ($dir, $filename) = ('.', $ARGV[0]); chdir($dir); -# Check for VMS; Config.pm may not be installed yet, but this routine -# is built into VMS perl -if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; } -else { $Is_VMS = 0; chomp($pwd = `pwd`); } +$pwd = cwd(); ++ $IncludedFiles{$ARGV[0]} ; my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); + sub TrimWhitespace { $_[0] =~ s/^\s+|\s+$//go ; @@ -169,6 +187,7 @@ foreach $typemap (@tm) { $current = \$junk; while (<TYPEMAP>) { next if /^\s*#/; + my $line_no = $. + 1; if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } @@ -183,7 +202,7 @@ foreach $typemap (@tm) { $type = TidyType($type) ; $type_kind{$type} = $kind ; # prototype defaults to '$' - $proto = '$' unless $proto ; + $proto = "\$" unless $proto ; warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") unless ValidProtoString($proto) ; $proto_letter{$type} = C_string($proto) ; @@ -215,6 +234,7 @@ $END = "!End!\n\n"; # "impossible" keyword (multiple newline) $BLOCK_re= '\s*(' . join('|', qw( REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE + SCOPE )) . "|$END)\\s*:"; # Input: ($_, @line) == unparsed input. @@ -226,11 +246,59 @@ sub check_keyword { } +if ($WantLineNumbers) { + { + package xsubpp::counter; + sub TIEHANDLE { + my ($class, $cfile) = @_; + my $buf = ""; + $SECTION_END_MARKER = "#line --- \"$cfile\""; + $line_no = 1; + bless \$buf; + } + + sub PRINT { + my $self = shift; + for (@_) { + $$self .= $_; + while ($$self =~ s/^([^\n]*\n)//) { + my $line = $1; + ++ $line_no; + $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; + print STDOUT $line; + } + } + } + + sub PRINTF { + my $self = shift; + my $fmt = shift; + $self->PRINT(sprintf($fmt, @_)); + } + + sub DESTROY { + # Not necessary if we're careful to end with a "\n" + my $self = shift; + print STDOUT $$self; + } + } + + my $cfile = $filename; + $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; + tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); + select PSEUDO_STDOUT; +} + sub print_section { - $_ = shift(@line) while !/\S/ && @line; + # the "do" is required for right semantics + do { $_ = shift(@line) } while !/\S/ && @line; + + print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") + if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { print "$_\n"; } + print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; } sub process_keyword($) @@ -440,6 +508,24 @@ sub PROTOTYPE_handler () } +sub SCOPE_handler () +{ + death("Error: Only 1 SCOPE declaration allowed per xsub") + if $scope_in_this_xsub ++ ; + + for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + next unless /\S/; + TrimWhitespace($_) ; + if ($_ =~ /^DISABLE/i) { + $ScopeThisXSUB = 0 + } + elsif ($_ =~ /^ENABLE/i) { + $ScopeThisXSUB = 1 + } + } + +} + sub PROTOTYPES_handler () { # the rest of the current line should contain either ENABLE or @@ -570,7 +656,7 @@ sub ProtoString ($) { my ($type) = @_ ; - $proto_letter{$type} or '$' ; + $proto_letter{$type} or "\$" ; } sub check_cpp { @@ -608,7 +694,7 @@ open($FH, $filename) or die "cannot open $filename: $!\n"; print <<EOM ; /* * This file was generated automatically by xsubpp version $XSUBPP_version from the - * contents of $filename. Don't edit this file, edit $filename instead. + * contents of $filename. Do not edit this file, edit $filename instead. * * ANY CHANGES MADE HERE WILL BE LOST! * @@ -617,6 +703,9 @@ print <<EOM ; EOM +print("#line 1 \"$filename\"\n") + if $WantLineNumbers; + while (<$FH>) { last if ($Module, $Package, $Prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; @@ -627,7 +716,6 @@ while (<$FH>) { $lastline = $_; $lastline_no = $.; - # Read next xsub into @line from ($lastline, <$FH>). sub fetch_para { # parse paragraph @@ -642,6 +730,7 @@ sub fetch_para { $Module = $1; $Package = defined($2) ? $2 : ''; # keep -w happy $Prefix = defined($3) ? $3 : ''; # keep -w happy + $Prefix = quotemeta $Prefix ; ($Module_cname = $Module) =~ s/\W/_/g; ($Packid = $Package) =~ tr/:/_/; $Packprefix = $Package; @@ -722,7 +811,9 @@ while (fetch_para()) { $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; } - death ("Code is not inside a function") + death ("Code is not inside a function" + ." (maybe last function was ended by a blank line " + ." followed by a a statement on column one?)") if $line[0] =~ /^\s/; # initialize info arrays @@ -737,7 +828,9 @@ while (fetch_para()) { undef(%arg_list) ; undef(@proto_arg) ; undef($proto_in_this_xsub) ; + undef($scope_in_this_xsub) ; $ProtoThisXSUB = $WantPrototypes ; + $ScopeThisXSUB = 0; $_ = shift(@line); while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) { @@ -748,7 +841,9 @@ while (fetch_para()) { if (check_keyword("BOOT")) { &check_cpp; - push (@BootCode, $_, @line, "") ; + push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") + if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; + push (@BootCode, @line, "") ; next PARAGRAPH ; } @@ -768,12 +863,14 @@ while (fetch_para()) { ($class, $func_name, $orig_args) = ($1, $2, $3) ; ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; - $Full_func_name = "${Packid}_$func_name"; + ($clean_func_name = $func_name) =~ s/^$Prefix//; + $Full_func_name = "${Packid}_$clean_func_name"; + if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } # Check for duplicate function definition for $tmp (@XSStack) { next unless defined $tmp->{functions}{$Full_func_name}; - Warn("Warning: duplicate function definition '$func_name' detected"); + Warn("Warning: duplicate function definition '$clean_func_name' detected"); last; } $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; @@ -781,7 +878,8 @@ while (fetch_para()) { @args = split(/\s*,\s*/, $orig_args); if (defined($class)) { - my $arg0 = ((defined($static) or $func_name =~ /^new/) ? "CLASS" : "THIS"); + my $arg0 = ((defined($static) or $func_name eq 'new') + ? "CLASS" : "THIS"); unshift(@args, $arg0); ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/; } @@ -802,7 +900,7 @@ while (fetch_para()) { $defaults{$args[$i]} = $2; $defaults{$args[$i]} =~ s/"/\\"/g; } - $proto_arg[$i+1] = '$' ; + $proto_arg[$i+1] = "\$" ; } if (defined($class)) { $func_args = join(", ", @args[1..$#args]); @@ -812,11 +910,16 @@ while (fetch_para()) { @args_match{@args} = 1..@args; $PPCODE = grep(/^\s*PPCODE\s*:/, @line); + $CODE = grep(/^\s*CODE\s*:/, @line); + # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) + # to set explicit return values. + $EXPLICIT_RETURN = ($CODE && + ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); $ALIAS = grep(/^\s*ALIAS\s*:/, @line); # print function header print Q<<"EOF"; -#XS(XS_${Packid}_$func_name) +#XS(XS_${Full_func_name}) #[[ # dXSARGS; EOF @@ -875,10 +978,15 @@ EOF $gotRETVAL = 0; INPUT_handler() ; - process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE") ; + process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE|SCOPE") ; + print Q<<"EOF" if $ScopeThisXSUB; +# ENTER; +# [[ +EOF + if (!$thisdone && defined($class)) { - if (defined($static) or $func_name =~ /^new/) { + if (defined($static) or $func_name eq 'new') { print "\tchar *"; $var_types{"CLASS"} = "char *"; &generate_init("char *", 1, "CLASS"); @@ -901,12 +1009,15 @@ EOF $args_match{"RETVAL"} = 0; $var_types{"RETVAL"} = $ret_type; } + print $deferred; - process_keyword("INIT|ALIAS|PROTOTYPE") ; + + process_keyword("INIT|ALIAS|PROTOTYPE") ; if (check_keyword("PPCODE")) { print_section(); death ("PPCODE must be last thing") if @line; + print "\tLEAVE;\n" if $ScopeThisXSUB; print "\tPUTBACK;\n\treturn;\n"; } elsif (check_keyword("CODE")) { print_section() ; @@ -920,13 +1031,13 @@ EOF $wantRETVAL = 1; } if (defined($static)) { - if ($func_name =~ /^new/) { + if ($func_name eq 'new') { $func_name = "$class"; } else { print "${class}::"; } } elsif (defined($class)) { - if ($func_name =~ /^new/) { + if ($func_name eq 'new') { $func_name .= " $class"; } else { print "THIS->"; @@ -954,6 +1065,13 @@ EOF # do cleanup process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; + print Q<<"EOF" if $ScopeThisXSUB; +# ]] +EOF + print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE; +# LEAVE; +EOF + # print function trailer print Q<<EOF; # ]] @@ -979,9 +1097,15 @@ EOF # croak(errbuf); EOF - print Q<<EOF unless $PPCODE; + if ($ret_type ne "void" or $EXPLICIT_RETURN) { + print Q<<EOF unless $PPCODE; # XSRETURN(1); EOF + } else { + print Q<<EOF unless $PPCODE; +# XSRETURN_EMPTY; +EOF + } print Q<<EOF; #]] @@ -995,11 +1119,11 @@ EOF if ($ProtoThisXSUB) { $newXS = "newXSproto"; - if ($ProtoThisXSUB == 2) { + if ($ProtoThisXSUB eq 2) { # User has specified empty prototype $proto = ', ""' ; } - elsif ($ProtoThisXSUB != 1) { + elsif ($ProtoThisXSUB ne 1) { # User has specified a prototype $proto = ', "' . $ProtoThisXSUB . '"'; } @@ -1066,8 +1190,9 @@ EOF if (@BootCode) { - print "\n /* Initialisation Section */\n" ; - print grep (s/$/\n/, @BootCode) ; + print "\n /* Initialisation Section */\n\n" ; + @line = @BootCode; + print_section(); print "\n /* End of Initialisation Section */\n\n" ; } @@ -1137,16 +1262,19 @@ sub generate_init { $subexpr =~ s/ntype/subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; $subexpr =~ s/\n\t/\n\t\t/g; - $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g; + $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; $expr =~ s/DO_ARRAY_ELEM/$subexpr/; } + if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments + $ScopeThisXSUB = 1; + } if (defined($defaults{$var})) { $expr =~ s/(\t+)/$1 /g; $expr =~ s/ /\t/g; eval qq/print "\\t$var;\\n"/; $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; - } elsif ($expr !~ /^\t\$var =/) { + } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) { eval qq/print "\\t$var;\\n"/; $deferred .= eval qq/"\\n$expr;\\n"/; } else { @@ -1186,11 +1314,27 @@ sub generate_output { eval "print qq\a$expr\a"; } elsif ($var eq 'RETVAL') { - if ($expr =~ /^\t\$arg = /) { + if ($expr =~ /^\t\$arg = new/) { + # We expect that $arg has refcnt 1, so we need to + # mortalize it. eval "print qq\a$expr\a"; print "\tsv_2mortal(ST(0));\n"; } + elsif ($expr =~ /^\s*\$arg\s*=/) { + # We expect that $arg has refcnt >=1, so we need + # to mortalize it. However, the extension may have + # returned the built-in perl value, which is + # read-only, thus not mortalizable. However, it is + # safe to leave it as it is, since it would be + # ignored by REFCNT_dec. Builtin values have REFCNT==0. + eval "print qq\a$expr\a"; + print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n"; + } else { + # Just hope that the entry would safely write it + # over an already mortalized value. By + # coincidence, something like $arg = &sv_undef + # works too. print "\tST(0) = sv_newmortal();\n"; eval "print qq\a$expr\a"; } @@ -1214,5 +1358,6 @@ sub Exit { # If this is VMS, the exit status has meaning to the shell, so we # use a predictable value (SS$_Normal or SS$_Abort) rather than an # arbitrary number. - exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; +# exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; + exit ($errors ? 1 : 0); } diff --git a/gnu/usr.bin/perl/lib/File/Basename.pm b/gnu/usr.bin/perl/lib/File/Basename.pm index daff148a638..e4863f8911a 100644 --- a/gnu/usr.bin/perl/lib/File/Basename.pm +++ b/gnu/usr.bin/perl/lib/File/Basename.pm @@ -2,8 +2,6 @@ package File::Basename; =head1 NAME -Basename - parse file specifications - fileparse - split a pathname into pieces basename - extract just the filename from a path @@ -34,16 +32,23 @@ pieces using the syntax of different operating systems. =item fileparse_set_fstype You select the syntax via the routine fileparse_set_fstype(). + If the argument passed to it contains one of the substrings -"VMS", "MSDOS", or "MacOS", the file specification syntax of that -operating system is used in future calls to fileparse(), -basename(), and dirname(). If it contains none of these -substrings, UNIX syntax is used. This pattern matching is +"VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification +syntax of that operating system is used in future calls to +fileparse(), basename(), and dirname(). If it contains none of +these substrings, UNIX syntax is used. This pattern matching is case-insensitive. If you've selected VMS syntax, and the file specification you pass to one of these routines contains a "/", they assume you are using UNIX emulation and apply the UNIX syntax rules instead, for that function call only. +If the argument passed to it contains one of the substrings "VMS", +"MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern +matching for suffix removal is performed without regard for case, +since those systems are not case-sensitive when opening existing files +(though some of them preserve case on file creation). + If you haven't called fileparse_set_fstype(), the syntax is chosen by examining the builtin variable C<$^O> according to these rules. @@ -61,8 +66,8 @@ B<name> is removed and prepended to B<suffix>. By proper use of C<@suffixlist>, you can remove file types or versions for examination. You are guaranteed that if you concatenate B<path>, B<name>, and -B<suffix> together in that order, the result will be identical to the -input file specification. +B<suffix> together in that order, the result will denote the same +file as the input file specification. =back @@ -70,14 +75,14 @@ input file specification. Using UNIX file syntax: - ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', + ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', '\.book\d+'); would yield $base eq 'draft' - $path eq '/virgil/aeneid', - $tail eq '.book7' + $path eq '/virgil/aeneid/', + $type eq '.book7' Similarly, using VMS syntax: @@ -90,120 +95,100 @@ would yield $dir eq 'Doc_Root:[Help]' $type eq '.Rnh' +=over + =item C<basename> The basename() routine returns the first element of the list produced -by calling fileparse() with the same arguments. It is provided for -compatibility with the UNIX shell command basename(1). +by calling fileparse() with the same arguments, except that it always +quotes metacharacters in the given suffixes. It is provided for +programmer compatibility with the UNIX shell command basename(1). =item C<dirname> The dirname() routine returns the directory portion of the input file specification. When using VMS or MacOS syntax, this is identical to the second element of the list produced by calling fileparse() with the same -input file specification. When using UNIX or MSDOS syntax, the return +input file specification. (Under VMS, if there is no directory information +in the input file specification, then the current default device and +directory are returned.) When using UNIX or MSDOS syntax, the return value conforms to the behavior of the UNIX shell command dirname(1). This is usually the same as the behavior of fileparse(), but differs in some cases. For example, for the input file specification F<lib/>, fileparse() considers the directory name to be F<lib/>, while dirname() considers the directory name to be F<.>). +=back + =cut require 5.002; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); +#use strict; +#use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase); +$VERSION = "2.5"; + # fileparse_set_fstype() - specify OS-based rules used in future # calls to routines in this package # -# Currently recognized values: VMS, MSDOS, MacOS -# Any other name uses Unix-style rules +# Currently recognized values: VMS, MSDOS, MacOS, AmigaOS, os2, RISCOS +# Any other name uses Unix-style rules and is case-sensitive sub fileparse_set_fstype { - my($old) = $Fileparse_fstype; - $Fileparse_fstype = $_[0] if $_[0]; - $old; + my @old = ($Fileparse_fstype, $Fileparse_igncase); + if (@_) { + $Fileparse_fstype = $_[0]; + $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32)/i); + } + wantarray ? @old : $old[0]; } # fileparse() - parse file specification # -# calling sequence: -# ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist); -# where $filespec is the file specification to be parsed, and -# @excludelist is a list of patterns which should be removed -# from the end of $filename. -# $filename is the part of $filespec after $prefix (i.e. the -# name of the file). The elements of @excludelist -# are compared to $filename, and if an -# $prefix is the path portion $filespec, up to and including -# the end of the last directory name -# $tail any characters removed from $filename because they -# matched an element of @excludelist. -# -# fileparse() first removes the directory specification from $filespec, -# according to the syntax of the OS (code is provided below to handle -# VMS, Unix, MSDOS and MacOS; you can pick the one you want using -# fileparse_set_fstype(), or you can accept the default, which is -# based on the information in the builtin variable $^O). It then compares -# each element of @excludelist to $filename, and if that element is a -# suffix of $filename, it is removed from $filename and prepended to -# $tail. By specifying the elements of @excludelist in the right order, -# you can 'nibble back' $filename to extract the portion of interest -# to you. -# -# For example, on a system running Unix, -# ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', -# '\.book\d+'); -# would yield $base == 'draft', -# $path == '/virgil/aeneid/' (note trailing slash) -# $tail == '.book7'. -# Similarly, on a system running VMS, -# ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*'); -# would yield $name == 'Rhetoric'; -# $dir == 'Doc_Root:[Help]', and -# $type == '.Rnh'. -# -# Version 2.2 13-Oct-1994 Charles Bailey bailey@genetics.upenn.edu +# Version 2.4 27-Sep-1996 Charles Bailey bailey@genetics.upenn.edu sub fileparse { my($fullname,@suffices) = @_; - my($fstype) = $Fileparse_fstype; - my($dirpath,$tail,$suffix); + my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); + my($dirpath,$tail,$suffix,$basename); if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { - ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/); - $dirpath = $ENV{'DEFAULT'} unless $dirpath; + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/); } } - if ($fstype =~ /^MSDOS/i) { - ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/); - $dirpath = '.\\' unless $dirpath; + if ($fstype =~ /^MS(DOS|Win32)/i) { + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/); + $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/; } - elsif ($fstype =~ /^MAC/i) { - ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/); + elsif ($fstype =~ /^MacOS/i) { + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); + } + elsif ($fstype =~ /^AmigaOS/i) { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + $dirpath = './' unless $dirpath; } elsif ($fstype !~ /^VMS/i) { # default to Unix - ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#); + ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); $dirpath = './' unless $dirpath; } if (@suffices) { $tail = ''; foreach $suffix (@suffices) { - if ($basename =~ /($suffix)$/) { + my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; + if ($basename =~ s/$pat//) { $tail = $1 . $tail; - $basename = $`; } } } wantarray ? ($basename,$dirpath,$tail) : $basename; - } @@ -213,7 +198,7 @@ sub basename { my($name) = shift; (fileparse($name, map("\Q$_\E",@_)))[0]; } - + # dirname() - returns device and directory portion of file specification # Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS @@ -228,25 +213,40 @@ sub dirname { if ($fstype =~ /VMS/i) { if ($_[0] =~ m#/#) { $fstype = '' } - else { return $dirname } + else { return $dirname || $ENV{DEFAULT} } } if ($fstype =~ /MacOS/i) { return $dirname } elsif ($fstype =~ /MSDOS/i) { - if ( $dirname =~ /:\\$/) { return $dirname } + $dirname =~ s/([^:])[\\\/]*$/$1/; + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s/([^:])[\\\/]*$/$1/; + } + } + elsif ($fstype =~ /MSWin32/i) { + $dirname =~ s/([^:])[\\\/]*$/$1/; + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s/([^:])[\\\/]*$/$1/; + } + } + elsif ($fstype =~ /AmigaOS/i) { + if ( $dirname =~ /:$/) { return $dirname } chop $dirname; - $dirname =~ s:[^\\]+$:: unless $basename; - $dirname = '.' unless $dirname; + $dirname =~ s#[^:/]+$## unless length($basename); } else { - if ( $dirname eq '/') { return $dirname } - chop $dirname; - $dirname =~ s:[^/]+$:: unless $basename; - $dirname = '.' unless $dirname; + $dirname =~ s:(.)/*$:$1:; + unless( length($basename) ) { + local($File::Basename::Fileparse_fstype) = $fstype; + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s:(.)/*$:$1:; + } } $dirname; } -$Fileparse_fstype = $^O; +fileparse_set_fstype $^O; 1; diff --git a/gnu/usr.bin/perl/lib/File/Copy.pm b/gnu/usr.bin/perl/lib/File/Copy.pm index 68460130109..e95168e24b8 100644 --- a/gnu/usr.bin/perl/lib/File/Copy.pm +++ b/gnu/usr.bin/perl/lib/File/Copy.pm @@ -2,66 +2,94 @@ # source code has been placed in the public domain by the author. # Please be kind and preserve the documentation. # +# Additions copyright 1996 by Charles Bailey. Permission is granted +# to distribute the revised code under the same terms as Perl itself. package File::Copy; -require Exporter; +use strict; use Carp; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big + © &syscopy &cp &mv); + +# Note that this module implements only *part* of the API defined by +# the File/Copy.pm module of the File-Tools-2.0 package. However, that +# package has not yet been updated to work with Perl 5.004, and so it +# would be a Bad Thing for the CPAN module to grab it and replace this +# module. Therefore, we set this module's version higher than 2.0. +$VERSION = '2.02'; -@ISA=qw(Exporter); -@EXPORT=qw(copy); -@EXPORT_OK=qw(copy cp); +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); -$File::Copy::VERSION = '1.5'; -$File::Copy::Too_Big = 1024 * 1024 * 2; +$Too_Big = 1024 * 1024 * 2; -sub VERSION { - # Version of File::Copy - return $File::Copy::VERSION; +sub _catname { # Will be replaced by File::Spec when it arrives + my($from, $to) = @_; + if (not defined &basename) { + require File::Basename; + import File::Basename 'basename'; + } + if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); } + elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); } + elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); } + else { $to .= '/' . basename($from); } } sub copy { - croak("Usage: copy( file1, file2 [, buffersize]) ") + croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") unless(@_ == 2 || @_ == 3); - if (($^O eq 'VMS' or $^O eq 'os2') && ref(\$to) ne 'GLOB' && - !(defined ref $to and (ref($to) eq 'GLOB' || - ref($to) eq 'FileHandle' || ref($to) eq 'VMS::Stdio'))) - { return File::Copy::syscopy($_[0],$_[1]) } - my $from = shift; my $to = shift; - my $recsep = $\; - my $closefrom=0; - my $closeto=0; - my ($size, $status, $r, $buf); - local(*FROM, *TO); - $\ = ''; + my $from_a_handle = (ref($from) + ? (ref($from) eq 'GLOB' + || UNIVERSAL::isa($from, 'GLOB') + || UNIVERSAL::isa($from, 'IO::Handle')) + : (ref(\$from) eq 'GLOB')); + my $to_a_handle = (ref($to) + ? (ref($to) eq 'GLOB' + || UNIVERSAL::isa($to, 'GLOB') + || UNIVERSAL::isa($to, 'IO::Handle')) + : (ref(\$to) eq 'GLOB')); + + if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { + $to = _catname($from, $to); + } - if (ref(\$from) eq 'GLOB') { - *FROM = $from; - } elsif (defined ref $from and - (ref($from) eq 'GLOB' || ref($from) eq 'FileHandle' || - ref($from) eq 'VMS::Stdio')) { - *FROM = *$from; - } else { - open(FROM,"<$from")||goto(fail_open1); - binmode FROM; - $closefrom = 1; + if (defined &syscopy && \&syscopy != \© + && !$to_a_handle + && !($from_a_handle && $^O eq 'os2')) # OS/2 cannot handle handles + { + return syscopy($from, $to); } - if (ref(\$to) eq 'GLOB') { - *TO = $to; - } elsif (defined ref $to and - (ref($to) eq 'GLOB' || ref($to) eq 'FileHandle' || - ref($to) eq 'VMS::Stdio')) { - *TO = *$to; + my $closefrom = 0; + my $closeto = 0; + my ($size, $status, $r, $buf); + local(*FROM, *TO); + local($\) = ''; + + if ($from_a_handle) { + *FROM = *$from{FILEHANDLE}; } else { - open(TO,">$to")||goto(fail_open2); - binmode TO; - $closeto=1; - } + $from = "./$from" if $from =~ /^\s/; + open(FROM, "< $from\0") or goto fail_open1; + binmode FROM or die "($!,$^E)"; + $closefrom = 1; + } + + if ($to_a_handle) { + *TO = *$to{FILEHANDLE}; + } else { + $to = "./$to" if $to =~ /^\s/; + open(TO,"> $to\0") or goto fail_open2; + binmode TO or die "($!,$^E)"; + $closeto = 1; + } if (@_) { $size = shift(@_) + 0; @@ -69,19 +97,25 @@ sub copy { } else { $size = -s FROM; $size = 1024 if ($size < 512); - $size = $File::Copy::Too_Big if ($size > $File::Copy::Too_Big); + $size = $Too_Big if ($size > $Too_Big); } - $buf = ''; - while(defined($r = read(FROM,$buf,$size)) && $r > 0) { - if (syswrite (TO,$buf,$r) != $r) { - goto fail_inner; + $! = 0; + for (;;) { + my ($r, $w, $t); + defined($r = sysread(FROM, $buf, $size)) + or goto fail_inner; + last unless $r; + for ($w = 0; $w < $r; $w += $t) { + $t = syswrite(TO, $buf, $r - $w, $w) + or goto fail_inner; } } - goto fail_inner unless(defined($r)); + close(TO) || goto fail_open2 if $closeto; close(FROM) || goto fail_open1 if $closefrom; - $\ = $recsep; + + # Use this idiom to avoid uninitialized value warning. return 1; # All of these contortions try to preserve error messages... @@ -100,14 +134,47 @@ sub copy { $! = $status unless $!; } fail_open1: - $\ = $recsep; return 0; } +sub move { + my($from,$to) = @_; + my($copied,$fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); + + if (-d $to && ! -d $from) { + $to = _catname($from, $to); + } + + ($tosz1,$tomt1) = (stat($to))[7,9]; + $fromsz = -s $from; + if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { + # will not rename with overwrite + unlink $to; + } + return 1 if rename $from, $to; + + ($sts,$ossts) = ($! + 0, $^E + 0); + # Did rename return an error even though it succeeded, because $to + # is on a remote NFS file system, and NFS lost the server's ack? + return 1 if defined($fromsz) && !-e $from && # $from disappeared + (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there + ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed + $tosz2 == $fromsz; # it's all there + + ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something + return 1 if ($copied = copy($from,$to)) && unlink($from); + + ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; + unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; + ($!,$^E) = ($sts,$ossts); + return 0; +} *cp = \© +*mv = \&move; + # &syscopy is an XSUB under OS/2 -*syscopy = ($^O eq 'VMS' ? \&rmscopy : \©) unless $^O eq 'os2'; +*syscopy = ($^O eq 'VMS' ? \&rmscopy : \©) unless defined &syscopy; 1; @@ -123,6 +190,7 @@ File::Copy - Copy files or filehandles copy("file1","file2"); copy("Copy.pm",\*STDOUT);' + move("/dev1/fileA","/dev2/fileB"); use POSIX; use File::Copy cp; @@ -132,16 +200,28 @@ File::Copy - Copy files or filehandles =head1 DESCRIPTION -The File::Copy module provides a basic function C<copy> which takes two +The File::Copy module provides two basic functions, C<copy> and +C<move>, which are useful for getting the contents of a file from +one place to another. + +=over 4 + +=item * + +The C<copy> function takes two parameters: a file to copy from and a file to copy to. Either argument may be a string, a FileHandle reference or a FileHandle glob. Obviously, if the first argument is a filehandle of some sort, it will be read from, and if it is a file I<name> it will be opened for reading. Likewise, the second argument will be -written to (and created if need be). Note that passing in +written to (and created if need be). + +B<Note that passing in files as handles instead of names may lead to loss of information on some operating systems; it is recommended that you use file -names whenever possible. +names whenever possible.> Files are opened in binary mode where +applicable. To get a consistent behavour when copying from a +filehandle to a file, use C<binmode> on the filehandle. An optional third parameter can be used to specify the buffer size used for copying. This is the number of bytes from the @@ -153,6 +233,24 @@ upon the file, but will generally be the whole file (up to 2Mb), or You may use the syntax C<use File::Copy "cp"> to get at the "cp" alias for this function. The syntax is I<exactly> the same. +=item * + +The C<move> function also takes two parameters: the current name +and the intended name of the file to be moved. If the destination +already exists and is a directory, and the source is not a +directory, then the source file will be renamed into the directory +specified by the destination. + +If possible, move() will simply rename the file. Otherwise, it copies +the file to the new location and deletes the original. If an error occurs +during this copy-and-delete process, you may be left with a (possibly partial) +copy of the file under the destination name. + +You may use the "mv" alias for this function in the same way that +you may use the "cp" alias for C<copy>. + +=back + File::Copy also provides the C<syscopy> routine, which copies the file specified in the first parameter to the file specified in the second parameter, preserving OS-specific attributes and file @@ -161,25 +259,28 @@ C<copy> routine. For VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> XSUB directly. -=head2 Special behavior under VMS +=head2 Special behavior if C<syscopy> is defined (VMS and OS/2) -If the second argument to C<copy> is not a file handle for an -already opened file, then C<copy> will perform an RMS copy of +If both arguments to C<copy> are not file handles, +then C<copy> will perform a "system copy" of the input file to a new output file, in order to preserve file attributes, indexed file structure, I<etc.> The buffer size -parameter is ignored. If the second argument to C<copy> is a -Perl handle to an opened file, then data is copied using Perl +parameter is ignored. If either argument to C<copy> is a +handle to an opened file, then data is copied using Perl operators, and no effort is made to preserve file attributes or record structure. -The RMS copy routine may also be called directly under VMS -as C<File::Copy::rmscopy> (or C<File::Copy::syscopy>, which -is just an alias for this routine). +The system copy routine may also be called directly under VMS and OS/2 +as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which +is the routine that does the actual work for syscopy). + +=over 4 =item rmscopy($from,$to[,$date_flag]) -The first and second arguments may be strings, typeglobs, or -typeglob references; they are used in all cases to obtain the +The first and second arguments may be strings, typeglobs, typeglob +references, or objects inheriting from IO::Handle; +they are used in all cases to obtain the I<filespec> of the input and output files, respectively. The name and type of the input file are used as defaults for the output file, if necessary. @@ -195,8 +296,8 @@ associated with an old version of that file after C<rmscopy> returns, not the newly created version.) The third parameter is an integer flag, which tells C<rmscopy> -how to handle timestamps. If it is < 0, none of the input file's -timestamps are propagated to the output file. If it is > 0, then +how to handle timestamps. If it is E<lt> 0, none of the input file's +timestamps are propagated to the output file. If it is E<gt> 0, then it is interpreted as a bitmask: if bit 0 (the LSB) is set, then timestamps other than the revision date are propagated; if bit 1 is set, the revision date is propagated. If the third parameter @@ -210,15 +311,17 @@ it defaults to 0. Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, it sets C<$!>, deletes the output file, and returns 0. +=back + =head1 RETURN -Returns 1 on success, 0 on failure. $! will be set if an error was -encountered. +All functions return 1 on success, 0 on failure. +$! will be set if an error was encountered. =head1 AUTHOR -File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995. -The VMS-specific code was added by Charles Bailey -I<E<lt>bailey@genetics.upenn.eduE<gt>> in March 1996. +File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, +and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996. =cut + diff --git a/gnu/usr.bin/perl/lib/File/Find.pm b/gnu/usr.bin/perl/lib/File/Find.pm index 02bacd8fc25..033cfe5e9de 100644 --- a/gnu/usr.bin/perl/lib/File/Find.pm +++ b/gnu/usr.bin/perl/lib/File/Find.pm @@ -31,6 +31,9 @@ C<"$File::Find::dir/$_">. You are chdir()'d to $File::Find::dir when the function is called. The function may set $File::Find::prune to prune the tree. +File::Find assumes that you don't alter the $_ variable. If you do then +make sure you return it to its original value before exiting your function. + This library is primarily for the C<find2perl> tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ @@ -62,6 +65,10 @@ that don't resolve: -l && !-e && print "bogus link: $File::Find::name\n"; } +=head1 BUGS + +There is no way to make find or finddepth follow symlinks. + =cut @ISA = qw(Exporter); @@ -70,27 +77,34 @@ that don't resolve: sub find { my $wanted = shift; - my $cwd = Cwd::fastcwd(); - my ($topdir,$topdev,$topino,$topmode,$topnlink); + 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) = stat($topdir)) + (($topdev,$topino,$topmode,$topnlink) = + ($Is_VMS ? stat($topdir) : lstat($topdir))) || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { ($dir,$_) = ($topdir,'.'); $name = $topdir; + $prune = 0; &$wanted; - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; ; - &finddir($wanted,$fixtopdir,$topnlink); + if (!$prune) { + my $fixtopdir = $topdir; + $fixtopdir =~ s,/$,, ; + $fixtopdir =~ s/\.dir$// if $Is_VMS; + $fixtopdir =~ s/\\dir$// if $Is_NT; + &finddir($wanted,$fixtopdir,$topnlink); + } } else { warn "Can't cd to $topdir: $!\n"; } } else { - unless (($dir,$_) = File::Basename::fileparse($topdir)) { + unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } $name = $topdir; @@ -142,6 +156,7 @@ sub finddir { if (!$prune && chdir $_) { $name =~ s/\.dir$// if $Is_VMS; + $name =~ s/\\dir$// if $Is_NT; &finddir($wanted,$name,$nlink); chdir '..'; } @@ -158,15 +173,19 @@ sub finddepth { $cwd = Cwd::fastcwd();; - my($topdir, $topdev, $topino, $topmode, $topnlink); + # Localize these rather than lexicalizing them for backwards + # compatibility. + local($topdir, $topdev, $topino, $topmode, $topnlink); foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = stat($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; + $fixtopdir =~ s/\\dir$// if $Is_NT; &finddepthdir($wanted,$fixtopdir,$topnlink); ($dir,$_) = ($fixtopdir,'.'); $name = $fixtopdir; @@ -177,9 +196,10 @@ sub finddepth { } } else { - unless (($dir,$_) = File::Basename::fileparse($topdir)) { + unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } + $name = $topdir; chdir $dir && &$wanted; } chdir $cwd; @@ -225,6 +245,7 @@ sub finddepthdir { if (chdir $_) { $name =~ s/\.dir$// if $Is_VMS; + $name =~ s/\\dir$// if $Is_NT; &finddepthdir($wanted,$name,$nlink); chdir '..'; } @@ -247,9 +268,13 @@ if ($^O eq 'VMS') { $Is_VMS = 1; $dont_use_nlink = 1; } +if ($^O =~ m:^mswin32:i) { + $Is_NT = 1; + $dont_use_nlink = 1; +} -$dont_use_nlink = 1 if $^O eq 'os2'; -$dont_use_nlink = 1 if $^O =~ m:^mswin32$:i ; +$dont_use_nlink = 1 + if $^O eq 'os2' || $^O eq 'msdos' || $^O eq 'amigaos'; 1; diff --git a/gnu/usr.bin/perl/lib/File/Path.pm b/gnu/usr.bin/perl/lib/File/Path.pm index 97cb66855dc..43856dfe7b9 100644 --- a/gnu/usr.bin/perl/lib/File/Path.pm +++ b/gnu/usr.bin/perl/lib/File/Path.pm @@ -14,9 +14,9 @@ C<rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);> =head1 DESCRIPTION -The C<mkpath> function provides a convenient way to create directories, even if -your C<mkdir> kernel call won't create more than one level of directory at a -time. C<mkpath> takes three arguments: +The C<mkpath> function provides a convenient way to create directories, even +if your C<mkdir> kernel call won't create more than one level of directory at +a time. C<mkpath> takes three arguments: =over 4 @@ -38,8 +38,8 @@ the numeric mode to use when creating the directories =back -It returns a list of all directories (including intermediates, determined using -the Unix '/' separator) created. +It returns a list of all directories (including intermediates, determined +using the Unix '/' separator) created. Similarly, the C<rmtree> function provides a convenient way to delete a subtree from the directory structure, much like the Unix command C<rm -r>. @@ -69,34 +69,50 @@ skip any files to which you do not have delete access (if running under VMS) or write access (if running under another OS). This will change in the future when a criterion for 'delete permission' under OSs other -than VMS is settled. (defaults to FALSE) +than VMS is settled. (defaults to FALSE) =back -It returns the number of files successfully deleted. Symlinks are +It returns the number of files successfully deleted. Symlinks are treated as ordinary files. +B<NOTE:> If the third parameter is not TRUE, C<rmtree> is B<unsecure> +in the face of failure or interruption. Files and directories which +were not deleted may be left with permissions reset to allow world +read and write access. Note also that the occurrence of errors in +rmtree can be determined I<only> by trapping diagnostic messages +using C<$SIG{__WARN__}>; it is not apparent from the return value. +Therefore, you must be extremely careful about using C<rmtree($foo,$bar,0> +in situations where security is an issue. + =head1 AUTHORS -Tim Bunce <Tim.Bunce@ig.co.uk> -Charles Bailey <bailey@genetics.upenn.edu> +Tim Bunce <F<Tim.Bunce@ig.co.uk>> and +Charles Bailey <F<bailey@genetics.upenn.edu>> =head1 REVISION -This module was last revised 14-Feb-1996, for perl 5.002. $VERSION is -1.01. +Current $VERSION is 1.04. =cut -$VERSION = "1.01"; # That's my hobby-horse, A.K. - -require 5.000; use Carp; -require Exporter; +use File::Basename (); +use DirHandle (); +use Exporter (); +use strict; + +use vars qw( $VERSION @ISA @EXPORT ); +$VERSION = "1.04"; @ISA = qw( Exporter ); @EXPORT = qw( mkpath rmtree ); -$Is_VMS = $^O eq 'VMS'; +my $Is_VMS = $^O eq 'VMS'; + +# These OSes complain if you want to remove a file that you have no +# write permission to: +my $force_writeable = ($^O eq 'os2' || $^O eq 'msdos' || $^O eq 'MSWin32' + || $^O eq 'amigaos'); sub mkpath { my($paths, $verbose, $mode) = @_; @@ -106,17 +122,19 @@ sub mkpath { local($")="/"; $mode = 0777 unless defined($mode); $paths = [$paths] unless ref $paths; - my(@created); - foreach $path (@$paths){ - next if -d $path; - my(@p); - foreach(split(/\//, $path)){ - push(@p, $_); - next if -d "@p/"; - print "mkdir @p\n" if $verbose; - mkdir("@p",$mode) || croak "mkdir @p: $!"; - push(@created, "@p"); - } + my(@created,$path); + foreach $path (@$paths) { + 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); + print "mkdir $path\n" if $verbose; + unless (mkdir($path,$mode)) { + # allow for another process to have created it meanwhile + croak "mkdir $path: $!" unless -d $path; + } + push(@created, $path); } @created; } @@ -126,40 +144,81 @@ sub rmtree { my(@files); my($count) = 0; $roots = [$roots] unless ref $roots; + $verbose ||= 0; + $safe ||= 0; + my($root); foreach $root (@{$roots}) { - $root =~ s#/$##; - if (not -l $root and -d _) { - opendir(D,$root); - ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS; - @files = map("$root/$_", grep $_!~/^\.{1,2}$/, readdir(D)); - closedir(D); - $count += rmtree(\@files,$verbose,$safe); - if ($safe && - ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { - print "skipped $root\n" if $verbose; - next; - } - print "rmdir $root\n" if $verbose; - (rmdir $root && ++$count) or carp "Can't remove directory $root: $!"; - } - else { - if ($safe && - ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { - print "skipped $root\n" if $verbose; - next; - } - print "unlink $root\n" if $verbose; - while (-e $root || -l $root) { # delete all versions under VMS - (unlink($root) && ++$count) - or carp "Can't unlink file $root: $!"; - } - } + $root =~ s#/$##; + (undef, undef, my $rp) = lstat $root or next; + $rp &= 07777; # don't forget setuid, setgid, sticky bits + if ( -d _ ) { + # notabene: 0777 is for making readable in the first place, + # it's also intended to change it to writable in case we have + # to recurse in which case we are better than rm -rf for + # subtrees with strange permissions + chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or carp "Can't make directory $root read+writeable: $!" + unless $safe; + + my $d = DirHandle->new($root) + or carp "Can't read $root: $!"; + @files = $d->read; + $d->close; + + # Deleting large numbers of files from VMS Files-11 filesystems + # is faster if done in reverse ASCIIbetical order + @files = reverse @files if $Is_VMS; + ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS; + @files = map("$root/$_", grep $_!~/^\.{1,2}$/,@files); + $count += rmtree(\@files,$verbose,$safe); + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $verbose; + next; + } + chmod 0777, $root + or carp "Can't make directory $root writeable: $!" + if $force_writeable; + print "rmdir $root\n" if $verbose; + if (rmdir $root) { + ++$count; + } + else { + carp "Can't remove directory $root: $!"; + chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or carp("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + } + else { + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $verbose; + next; + } + chmod 0666, $root + or carp "Can't make file $root writeable: $!" + if $force_writeable; + print "unlink $root\n" if $verbose; + # delete all versions under VMS + while (-e $root || -l $root) { + if (unlink $root) { + ++$count; + } + else { + carp "Can't unlink file $root: $!"; + if ($force_writeable) { + chmod $rp, $root + or carp("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + } + } + } } $count; } 1; - -__END__ diff --git a/gnu/usr.bin/perl/lib/FileCache.pm b/gnu/usr.bin/perl/lib/FileCache.pm index 3d01371b3b3..e1c5ec4c8a8 100644 --- a/gnu/usr.bin/perl/lib/FileCache.pm +++ b/gnu/usr.bin/perl/lib/FileCache.pm @@ -19,7 +19,7 @@ maximum. =head1 BUGS F<sys/param.h> lies with its C<NOFILE> define on some systems, -so you may have to set $cacheout::maxopen yourself. +so you may have to set $FileCache::cacheout_maxopen yourself. =cut @@ -53,7 +53,7 @@ sub cacheout { ($file) = @_; unless (defined $cacheout_maxopen) { if (open(PARAM,'/usr/include/sys/param.h')) { - local $.; + local ($_, $.); while (<PARAM>) { $cacheout_maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; diff --git a/gnu/usr.bin/perl/lib/Getopt/Long.pm b/gnu/usr.bin/perl/lib/Getopt/Long.pm index d6a4fddf7da..4f23f5d6c13 100644 --- a/gnu/usr.bin/perl/lib/Getopt/Long.pm +++ b/gnu/usr.bin/perl/lib/Getopt/Long.pm @@ -1,22 +1,15 @@ -# GetOpt::Long.pm -- POSIX compatible options parsing +# GetOpt::Long.pm -- Universal options parsing -# RCS Status : $Id: Long.pm,v 1.1 1996/08/19 10:12:44 downsj Exp $ +package Getopt::Long; + +# RCS Status : $Id: Long.pm,v 1.2 1997/11/30 07:57:41 millert Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Fri Feb 2 21:24:32 1996 -# Update Count : 347 +# Last Modified On: Wed Sep 17 12:20:10 1997 +# Update Count : 608 # Status : Released -package Getopt::Long; -require 5.000; -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); -$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/); -use strict; - =head1 NAME GetOptions - extended processing of command line options @@ -32,9 +25,10 @@ The Getopt::Long module implements an extended getopt function called GetOptions(). This function adheres to the POSIX syntax for command line options, with GNU extensions. In general, this means that options have long names instead of single letters, and are introduced with a -double dash "--". There is no bundling of command line options, as was -the case with the more traditional single-letter approach. For -example, the UNIX "ps" command can be given the command line "option" +double dash "--". Support for bundling of command line options, as was +the case with the more traditional single-letter approach, is provided +but not enabled by default. For example, the UNIX "ps" command can be +given the command line "option" -vax @@ -55,18 +49,19 @@ the value it can take. The option linkage is usually a reference to a variable that will be set when the option is used. For example, the following call to GetOptions: - &GetOptions("size=i" => \$offset); + GetOptions("size=i" => \$offset); will accept a command line option "size" that must have an integer value. With a command line of "--size 24" this will cause the variable $offset to get the value 24. Alternatively, the first argument to GetOptions may be a reference to -a HASH describing the linkage for the options. The following call is -equivalent to the example above: +a HASH describing the linkage for the options, or an object whose +class is based on a HASH. The following call is equivalent to the +example above: %optctl = ("size" => \$offset); - &GetOptions(\%optctl, "size=i"); + GetOptions(\%optctl, "size=i"); Linkage may be specified using either of the above methods, or both. Linkage specified in the argument list takes precedence over the @@ -81,7 +76,7 @@ followed by an argument specifier. Values for argument specifiers are: =over 8 -=item <none> +=item E<lt>noneE<gt> Option does not take an argument. The option variable will be set to 1. @@ -150,7 +145,7 @@ specified but a ref HASH is passed, GetOptions will place the value in the HASH. For example: %optctl = (); - &GetOptions (\%optctl, "size=i"); + GetOptions (\%optctl, "size=i"); will perform the equivalent of the assignment @@ -159,13 +154,24 @@ will perform the equivalent of the assignment For array options, a reference to an array is used, e.g.: %optctl = (); - &GetOptions (\%optctl, "sizes=i@"); + GetOptions (\%optctl, "sizes=i@"); with command line "-sizes 24 -sizes 48" will perform the equivalent of the assignment $optctl{"sizes"} = [24, 48]; +For hash options (an option whose argument looks like "name=value"), +a reference to a hash is used, e.g.: + + %optctl = (); + GetOptions (\%optctl, "define=s%"); + +with command line "--define foo=hello --define bar=world" will perform the +equivalent of the assignment + + $optctl{"define"} = {foo=>'hello', bar=>'world') + If no linkage is explicitly specified and no ref HASH is passed, GetOptions will put the value in a global variable named after the option, prefixed by "opt_". To yield a usable Perl variable, @@ -175,7 +181,7 @@ the variable $opt_fpp_struct_return. Note that this variable resides in the namespace of the calling program, not necessarily B<main>. For example: - &GetOptions ("size=i", "sizes=i@"); + GetOptions ("size=i", "sizes=i@"); with command line "-size 10 -sizes 24 -sizes 48" will perform the equivalent of the assignments @@ -187,7 +193,7 @@ A lone dash B<-> is considered an option, the corresponding Perl identifier is $opt_ . The linkage specifier can be a reference to a scalar, a reference to -an array or a reference to a subroutine. +an array, a reference to a hash or a reference to a subroutine. 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 @@ -196,6 +202,11 @@ overwritten. If a REF ARRAY is supplied, the new value is appended (pushed) to the referenced array. +If a REF HASH is supplied, the option value should look like "key" or +"key=value" (if the "=value" is omitted then a value of 1 is implied). +In this case, the element of the referenced hash with the key "key" +is assigned "value". + If a REF CODE is supplied, the referenced subroutine is called with two arguments: the option name and the option value. The option name is always the true name, not an abbreviation or alias. @@ -204,19 +215,21 @@ The option name is always the true name, not an abbreviation or alias. The option name may actually be a list of option names, separated by "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name -op this option. If no linkage is specified, options "foo", "bar" and +of this option. If no linkage is specified, options "foo", "bar" and "blech" all will set $opt_foo. Option names may be abbreviated to uniqueness, depending on -configuration variable $Getopt::Long::autoabbrev. +configuration option B<auto_abbrev>. =head2 Non-option call-back routine -A special option specifier, <>, can be used to designate a subroutine +A special option specifier, E<lt>E<gt>, can be used to designate a subroutine to handle non-option arguments. GetOptions will immediately call this subroutine for every non-option it encounters in the options list. This subroutine gets the name of the non-option passed. -This feature requires $Getopt::Long::order to have the value $PERMUTE. +This feature requires configuration option B<permute>, see section +CONFIGURATION OPTIONS. + See also the examples. =head2 Option starters @@ -242,13 +255,20 @@ In fact, the Perl 5 version of newgetopt.pl is just a wrapper around the module. If an "@" sign is appended to the argument specifier, the option is -treated as an array. Value(s) are not set, but pushed into array -@opt_name. This only applies if no linkage is supplied. +treated as an array. Value(s) are not set, but pushed into array +@opt_name. If explicit linkage is supplied, this must be a reference +to an ARRAY. -If configuration variable $Getopt::Long::getopt_compat is set to a -non-zero value, options that start with "+" may also include their -arguments, e.g. "+foo=bar". This is for compatiblity with older -implementations of the GNU "getopt" routine. +If an "%" sign is appended to the argument specifier, the option is +treated as a hash. Value(s) of the form "name=value" are set by +setting the element of the hash %opt_name with key "name" to "value" +(if the "=value" portion is omitted it defaults to 1). If explicit +linkage is supplied, this must be a reference to a HASH. + +If configuration option B<getopt_compat> is set (see section +CONFIGURATION OPTIONS), options that start with "+" or "-" may also +include their arguments, e.g. "+foo=bar". This is for compatiblity +with older implementations of the GNU "getopt" routine. If the first argument to GetOptions is a string consisting of only non-alphanumeric characters, it is taken to specify the option starter @@ -281,64 +301,90 @@ In GNU or POSIX format, option names and values can be combined: --bar= -> $opt_bar = '' --bar=-- -> $opt_bar = '--' -Example of using variabel references: +Example of using variable references: - $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); + $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); With command line options "-foo blech -bar 24 -ar xx -ar yy" this will result in: - $bar = 'blech' + $foo = 'blech' $opt_bar = 24 @ar = ('xx','yy') -Example of using the <> option specifier: +Example of using the E<lt>E<gt> option specifier: @ARGV = qw(-foo 1 bar -foo 2 blech); - &GetOptions("foo=i", \$myfoo, "<>", \&mysub); + GetOptions("foo=i", \$myfoo, "<>", \&mysub); Results: - &mysub("bar") will be called (with $myfoo being 1) - &mysub("blech") will be called (with $myfoo being 2) + mysub("bar") will be called (with $myfoo being 1) + mysub("blech") will be called (with $myfoo being 2) Compare this with: @ARGV = qw(-foo 1 bar -foo 2 blech); - &GetOptions("foo=i", \$myfoo); + GetOptions("foo=i", \$myfoo); This will leave the non-options in @ARGV: $myfoo -> 2 @ARGV -> qw(bar blech) -=head1 CONFIGURATION VARIABLES +=head1 CONFIGURATION OPTIONS + +B<GetOptions> can be configured by calling subroutine +B<Getopt::Long::config>. This subroutine takes a list of quoted +strings, each specifying a configuration option to be set, e.g. +B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g. +B<no_ignore_case>. Case does not matter. Multiple calls to B<config> +are possible. + +Previous versions of Getopt::Long used variables for the purpose of +configuring. Although manipulating these variables still work, it +is strongly encouraged to use the new B<config> routine. Besides, it +is much easier. -The following variables can be set to change the default behaviour of -GetOptions(): +The following options are available: =over 12 -=item $Getopt::Long::autoabbrev +=item default + +This option causes all configuration options to be reset to their +default values. + +=item auto_abbrev Allow option names to be abbreviated to uniqueness. -Default is 1 unless environment variable -POSIXLY_CORRECT has been set. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset. -=item $Getopt::Long::getopt_compat +=item getopt_compat Allow '+' to start options. -Default is 1 unless environment variable -POSIXLY_CORRECT has been set. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset. + +=item require_order -=item $Getopt::Long::order +Whether non-options are allowed to be mixed with +options. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case b<require_order> is reset. + +See also B<permute>, which is the opposite of B<require_order>. + +=item permute Whether non-options are allowed to be mixed with options. -Default is $REQUIRE_ORDER if environment variable -POSIXLY_CORRECT has been set, $PERMUTE otherwise. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<permute> is reset. +Note that B<permute> is the opposite of B<require_order>. -$PERMUTE means that +If B<permute> is set, this means that -foo arg1 -bar arg2 arg3 @@ -355,7 +401,7 @@ processed, except when B<--> is used: will call the call-back routine for arg1 and arg2, and terminate leaving arg2 in @ARGV. -If $Getopt::Long::order is $REQUIRE_ORDER, options processing +If B<require_order> is set, options processing terminates when the first non-option is encountered. -foo arg1 -bar arg2 arg3 @@ -364,11 +410,76 @@ is equivalent to -foo -- arg1 -bar arg2 arg3 -$RETURN_IN_ORDER is not supported by GetOptions(). +=item bundling (default: reset) + +Setting this variable to a non-zero value will allow single-character +options to be bundled. To distinguish bundles from long option names, +long options must be introduced with B<--> and single-character +options (and bundles) with B<->. For example, + + ps -vax --vax -=item $Getopt::Long::ignorecase +would be equivalent to + + ps -v -a -x --vax + +provided "vax", "v", "a" and "x" have been defined to be valid +options. + +Bundled options can also include a value in the bundle; this value has +to be the last part of the bundle, e.g. + + scale -h24 -w80 + +is equivalent to + + scale -h 24 -w 80 + +Note: resetting B<bundling> also resets B<bundling_override>. + +=item bundling_override (default: reset) + +If B<bundling_override> is set, bundling is enabled as with +B<bundling> but now long option names override option bundles. In the +above example, B<-vax> would be interpreted as the option "vax", not +the bundle "v", "a", "x". + +Note: resetting B<bundling_override> also resets B<bundling>. + +B<Note:> Using option bundling can easily lead to unexpected results, +especially when mixing long options and bundles. Caveat emptor. + +=item ignore_case (default: set) + +If set, case is ignored when matching options. + +Note: resetting B<ignore_case> also resets B<ignore_case_always>. + +=item ignore_case_always (default: reset) + +When bundling is in effect, case is ignored on single-character +options also. + +Note: resetting B<ignore_case_always> also resets B<ignore_case>. + +=item pass_through (default: reset) + +Unknown options are passed through in @ARGV instead of being flagged +as errors. This makes it possible to write wrapper scripts that +process only part of the user supplied options, and passes the +remaining options to some other program. + +This can be very confusing, especially when B<permute> is also set. + +=item debug (default: reset) + +Enable copious debugging output. + +=back -Ignore case when matching options. Default is 1. +=head1 OTHER USEFUL VARIABLES + +=over 12 =item $Getopt::Long::VERSION @@ -376,7 +487,7 @@ The version number of this Getopt::Long implementation in the format C<major>.C<minor>. This can be used to have Exporter check the version, e.g. - use Getopt::Long 2.00; + use Getopt::Long 3.00; You can inspect $Getopt::Long::major_version and $Getopt::Long::minor_version for the individual components. @@ -386,22 +497,13 @@ $Getopt::Long::minor_version for the individual components. Internal error flag. May be incremented from a call-back routine to cause options parsing to fail. -=item $Getopt::Long::debug - -Enable copious debugging output. Default is 0. - =back =cut -################ Introduction ################ -# -# This package implements an extended getopt function. This function -# adheres to the new syntax (long option names, no bundling). It tries -# to implement the better functionality of traditional, GNU and POSIX -# getopt functions. -# -# This program is Copyright 1990,1996 by Johan Vromans. +################ Copyright ################ + +# This program is Copyright 1990,1997 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 @@ -416,84 +518,87 @@ Enable copious debugging output. Default is 0. # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, # MA 02139, USA. -################ History ################ -# -# 13-Jan-1996 Johan Vromans -# Generalized the linkage interface. -# Eliminated the linkage argument. -# Add code references as a possible value for the option linkage. -# Add option specifier <> to have a call-back for non-options. -# -# 26-Dec-1995 Johan Vromans -# Import from netgetopt.pl. -# Turned into a decent module. -# Added linkage argument. - -################ Configuration Section ################ +################ Module Preamble ################ -# Values for $order. See GNU getopt.c for details. -($Getopt::Long::REQUIRE_ORDER, - $Getopt::Long::PERMUTE, - $Getopt::Long::RETURN_IN_ORDER) = (0..2); +use strict; -my $gen_prefix; # generic prefix (option starters) +BEGIN { + require 5.003; + use Exporter (); + use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/); -# Handle POSIX compliancy. -if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $gen_prefix = "(--|-)"; - $Getopt::Long::autoabbrev = 0; # no automatic abbrev of options - $Getopt::Long::getopt_compat = 0; # disallow '+' to start options - $Getopt::Long::order = $Getopt::Long::REQUIRE_ORDER; -} -else { - $gen_prefix = "(--|-|\\+)"; - $Getopt::Long::autoabbrev = 1; # automatic abbrev of options - $Getopt::Long::getopt_compat = 1; # allow '+' to start options - $Getopt::Long::order = $Getopt::Long::PERMUTE; + @ISA = qw(Exporter); + @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); + %EXPORT_TAGS = (); + @EXPORT_OK = qw(); } -# Other configurable settings. -$Getopt::Long::debug = 0; # for debugging -$Getopt::Long::error = 0; # error tally -$Getopt::Long::ignorecase = 1; # ignore case when matching options -($Getopt::Long::version, - $Getopt::Long::major_version, - $Getopt::Long::minor_version) = '$Revision: 1.1 $ ' =~ /: ((\d+)\.(\d+))/; -$Getopt::Long::version .= '*' if length('$Locker: $ ') > 12; +use vars @EXPORT, @EXPORT_OK; +# User visible variables. +use vars qw($error $debug $major_version $minor_version); +# Deprecated visible variables. +use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order + $passthrough); + +################ Local Variables ################ + +my $gen_prefix; # generic prefix (option starters) +my $argend; # option list terminator +my %opctl; # table of arg.specs (long and abbrevs) +my %bopctl; # table of arg.specs (bundles) +my @opctl; # the possible long option names +my $pkg; # current context. Needed if no linkage. +my %aliases; # alias table +my $genprefix; # so we can call the same module more +my $opt; # current option +my $arg; # current option value, if any +my $array; # current option is array typed +my $hash; # current option is hash typed +my $key; # hash key for a hash option + # than once in differing environments +my $config_defaults; # set config defaults +my $find_option; # helper routine ################ Subroutines ################ sub GetOptions { my @optionlist = @_; # local copy of the option descriptions - my $argend = '--'; # option list terminator - my %opctl; # table of arg.specs - my $pkg = (caller)[0]; # current context + $argend = '--'; # option list terminator + %opctl = (); # table of arg.specs (long and abbrevs) + %bopctl = (); # table of arg.specs (bundles) + $pkg = (caller)[0]; # current context # Needed if linkage is omitted. - my %aliases; # alias table + %aliases= (); # alias table my @ret = (); # accum for non-options my %linkage; # linkage my $userlinkage; # user supplied HASH - my $debug = $Getopt::Long::debug; # convenience - my $genprefix = $gen_prefix; # so we can call the same module more - # than once in differing environments - $Getopt::Long::error = 0; + $genprefix = $gen_prefix; # so we can call the same module many times + $error = 0; - print STDERR ("GetOptions $Getopt::Long::version", - " [GetOpt::Long $Getopt::Long::VERSION] -- ", + print STDERR ('GetOptions $Revision: 1.2 $ ', + "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", - " autoabbrev=$Getopt::Long::autoabbrev". - ",getopt_compat=$Getopt::Long::getopt_compat", + " (@ARGV)\n", + " autoabbrev=$autoabbrev". + ",bundling=$bundling", + ",getopt_compat=$getopt_compat", + ",order=$order", + ",\n ignorecase=$ignorecase", + ",passthrough=$passthrough", ",genprefix=\"$genprefix\"", - ",order=$Getopt::Long::order", - ",ignorecase=$Getopt::Long::ignorecase", ".\n") if $debug; # Check for ref HASH as first argument. + # First argument may be an object. It's OK to use this as long + # as it is really a hash underneath. $userlinkage = undef; - if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) { + if ( ref($optionlist[0]) and + "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) { $userlinkage = shift (@optionlist); + print STDERR ("=> user linkage: $userlinkage\n") if $debug; } # See if the first element of the optionlist contains option @@ -507,10 +612,11 @@ sub GetOptions { # Verify correctness of optionlist. %opctl = (); + %bopctl = (); while ( @optionlist > 0 ) { my $opt = shift (@optionlist); - # Strip leading prefix so people can specify "-foo=i" if they like. + # Strip leading prefix so people can specify "--foo=i" if they like. $opt = $' if $opt =~ /^($genprefix)+/; if ( $opt eq '<>' ) { @@ -523,35 +629,54 @@ sub GetOptions { unless ( @optionlist > 0 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { warn ("Option spec <> requires a reference to a subroutine\n"); - $Getopt::Long::error++; + $error++; next; } $linkage{'<>'} = shift (@optionlist); next; } - $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase; - if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) { + if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) { warn ("Error in option spec: \"", $opt, "\"\n"); - $Getopt::Long::error++; + $error++; next; } my ($o, $c, $a) = ($1, $2); + $c = '' unless defined $c; if ( ! defined $o ) { # empty -> '-' option - $opctl{$o = ''} = defined $c ? $c : ''; + $opctl{$o = ''} = $c; } else { # Handle alias names my @o = split (/\|/, $o); - $o = $o[0]; + my $linko = $o = $o[0]; + # Force an alias if the option name is not locase. + $a = $o unless $o eq lc($o); + $o = lc ($o) + if $ignorecase > 1 + || ($ignorecase + && ($bundling ? length($o) > 1 : 1)); + foreach ( @o ) { - if ( defined $c && $c eq '!' ) { - $opctl{"no$_"} = $c; - $c = ''; + if ( $bundling && length($_) == 1 ) { + $_ = lc ($_) if $ignorecase > 1; + if ( $c eq '!' ) { + $opctl{"no$_"} = $c; + warn ("Ignoring '!' modifier for short option $_\n"); + $c = ''; + } + $opctl{$_} = $bopctl{$_} = $c; + } + else { + $_ = lc ($_) if $ignorecase; + if ( $c eq '!' ) { + $opctl{"no$_"} = $c; + $c = ''; + } + $opctl{$_} = $c; } - $opctl{$_} = defined $c ? $c : ''; if ( defined $a ) { # Note alias. $aliases{$_} = $a; @@ -561,6 +686,7 @@ sub GetOptions { $a = $_; } } + $o = $linko; } # If no linkage is supplied in the @optionlist, copy it from @@ -584,14 +710,26 @@ sub GetOptions { if ( @optionlist > 0 && ref($optionlist[0]) ) { print STDERR ("=> link \"$o\" to $optionlist[0]\n") if $debug; - if ( ref($optionlist[0]) eq 'SCALAR' - || ref($optionlist[0]) eq 'ARRAY' - || ref($optionlist[0]) eq 'CODE' ) { + if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) { $linkage{$o} = shift (@optionlist); } + elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) { + $linkage{$o} = shift (@optionlist); + $opctl{$o} .= '@' + if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/; + $bopctl{$o} .= '@' + if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; + } + elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { + $linkage{$o} = shift (@optionlist); + $opctl{$o} .= '%' + if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/; + $bopctl{$o} .= '%' + if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/; + } else { warn ("Invalid option linkage for \"", $opt, "\"\n"); - $Getopt::Long::error++; + $error++; } } else { @@ -599,11 +737,16 @@ sub GetOptions { # Make sure a valid perl identifier results. my $ov = $o; $ov =~ s/\W/_/g; - if ( $c && $c =~ /@/ ) { + if ( $c =~ /@/ ) { print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n") if $debug; eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;"); } + elsif ( $c =~ /%/ ) { + print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;"); + } else { print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n") if $debug; @@ -613,12 +756,12 @@ sub GetOptions { } # Bail out if errors found. - return 0 if $Getopt::Long::error; + return 0 if $error; - # Sort the possible option names. - my @opctl = sort(keys (%opctl)) if $Getopt::Long::autoabbrev; + # Sort the possible long option names. + @opctl = sort(keys (%opctl)) if $autoabbrev; - # Show if debugging. + # Show the options tables if debugging. if ( $debug ) { my ($arrow, $k, $v); $arrow = "=> "; @@ -626,23 +769,21 @@ sub GetOptions { print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); $arrow = " "; } + $arrow = "=> "; + while ( ($k,$v) = each(%bopctl) ) { + print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n"); + $arrow = " "; + } } - my $opt; # current option - my $arg; # current option value - my $array; # current option is array typed - # Process argument list while ( @ARGV > 0 ) { - # >>> See also the continue block <<< - #### Get next argument #### $opt = shift (@ARGV); $arg = undef; - my $optarg = undef; - $array = 0; + $array = $hash = 0; print STDERR ("=> option \"", $opt, "\"\n") if $debug; #### Determine what we have #### @@ -651,33 +792,93 @@ sub GetOptions { if ( $opt eq $argend ) { # Finish. Push back accumulated arguments and return. unshift (@ARGV, @ret) - if $Getopt::Long::order == $Getopt::Long::PERMUTE; - return ($Getopt::Long::error == 0); - } - - if ( $opt =~ /^$genprefix/ ) { - # Looks like an option. - $opt = $'; # option name (w/o prefix) - # If it is a long opt, it may include the value. - if (($& eq "--" || ($Getopt::Long::getopt_compat && $& eq "+")) - && $opt =~ /^([^=]+)=/ ) { - $opt = $1; - $optarg = $'; - print STDERR ("=> option \"", $opt, - "\", optarg = \"$optarg\"\n") if $debug; - } + if $order == $PERMUTE; + return ($error == 0); + } + + my $tryopt = $opt; + # find_option operates on the GLOBAL $opt and $arg! + if ( &$find_option () ) { + + # find_option undefines $opt in case of errors. + next unless defined $opt; + + if ( defined $arg ) { + $opt = $aliases{$opt} if defined $aliases{$opt}; + + if ( defined $linkage{$opt} ) { + print STDERR ("=> ref(\$L{$opt}) -> ", + ref($linkage{$opt}), "\n") if $debug; + + if ( ref($linkage{$opt}) eq 'SCALAR' ) { + print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug; + ${$linkage{$opt}} = $arg; + } + elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( ref($linkage{$opt}) eq 'HASH' ) { + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } + elsif ( ref($linkage{$opt}) eq 'CODE' ) { + print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n") + if $debug; + &{$linkage{$opt}}($opt, $arg); + } + else { + print STDERR ("Invalid REF type \"", ref($linkage{$opt}), + "\" in linkage\n"); + die ("Getopt::Long -- internal error!\n"); + } + } + # No entry in linkage means entry in userlinkage. + elsif ( $array ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") + if $debug; + push (@{$userlinkage->{$opt}}, $arg); + } + else { + print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") + if $debug; + $userlinkage->{$opt} = [$arg]; + } + } + elsif ( $hash ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $userlinkage->{$opt}->{$key} = $arg; + } + else { + print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") + if $debug; + $userlinkage->{$opt} = {$key => $arg}; + } + } + else { + print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; + $userlinkage->{$opt} = $arg; + } + } } # Not an option. Save it if we $PERMUTE and don't have a <>. - elsif ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) { + elsif ( $order == $PERMUTE ) { # Try non-options call-back. my $cb; if ( (defined ($cb = $linkage{'<>'})) ) { - &$cb($opt); + &$cb($tryopt); } else { - push (@ret, $opt); + print STDERR ("=> saving \"$tryopt\" ", + "(not an option, may permute)\n") if $debug; + push (@ret, $tryopt); } next; } @@ -685,207 +886,353 @@ sub GetOptions { # ...otherwise, terminate. else { # Push this one back and exit. - unshift (@ARGV, $opt); - return ($Getopt::Long::error == 0); + unshift (@ARGV, $tryopt); + return ($error == 0); } - #### Look it up ### + } - $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase; + # Finish. + if ( $order == $PERMUTE ) { + # Push back accumulated arguments + print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") + if $debug && @ret > 0; + unshift (@ARGV, @ret) if @ret > 0; + } - my $tryopt = $opt; - if ( $Getopt::Long::autoabbrev ) { - my $pat; - - # Turn option name into pattern. - ($pat = $opt) =~ s/(\W)/\\$1/g; - # Look up in option names. - my @hits = grep (/^$pat/, @opctl); - print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ", - "out of ", 0+@opctl, "\n") if $debug; - - # Check for ambiguous results. - unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { - print STDERR ("Option ", $opt, " is ambiguous (", - join(", ", @hits), ")\n"); - $Getopt::Long::error++; - next; - } + return ($error == 0); +} - # Complete the option name, if appropriate. - if ( @hits == 1 && $hits[0] ne $opt ) { - $tryopt = $hits[0]; - print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") - if $debug; - } +sub config (@) { + my (@options) = @_; + my $opt; + foreach $opt ( @options ) { + my $try = lc ($opt); + my $action = 1; + if ( $try =~ /^no_?/ ) { + $action = 0; + $try = $'; } - - my $type; - unless ( defined ( $type = $opctl{$tryopt} ) ) { - print STDERR ("Unknown option: ", $opt, "\n"); - $Getopt::Long::error++; - next; + if ( $try eq 'default' or $try eq 'defaults' ) { + &$config_defaults () if $action; } - $opt = $tryopt; - print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; - - #### Determine argument status #### - - # If it is an option w/o argument, we're almost finished with it. - if ( $type eq '' || $type eq '!' ) { - if ( defined $optarg ) { - print STDERR ("Option ", $opt, " does not take an argument\n"); - $Getopt::Long::error++; - } - elsif ( $type eq '' ) { - $arg = 1; # supply explicit value - } - else { - substr ($opt, 0, 2) = ''; # strip NO prefix - $arg = 0; # supply explicit value - } - next; + elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { + $autoabbrev = $action; } + elsif ( $try eq 'getopt_compat' ) { + $getopt_compat = $action; + } + elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { + $ignorecase = $action; + } + elsif ( $try eq 'ignore_case_always' ) { + $ignorecase = $action ? 2 : 0; + } + elsif ( $try eq 'bundling' ) { + $bundling = $action; + } + elsif ( $try eq 'bundling_override' ) { + $bundling = $action ? 2 : 0; + } + elsif ( $try eq 'require_order' ) { + $order = $action ? $REQUIRE_ORDER : $PERMUTE; + } + elsif ( $try eq 'permute' ) { + $order = $action ? $PERMUTE : $REQUIRE_ORDER; + } + elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { + $passthrough = $action; + } + elsif ( $try eq 'debug' ) { + $debug = $action; + } + else { + $Carp::CarpLevel = 1; + Carp::croak("Getopt::Long: unknown config parameter \"$opt\"") + } + } +} - # Get mandatory status and type info. - my $mand; - ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; +# Modified from Exporter. This one handles 2.001 and 2.01 etc just like 2.1. +sub require_version { + no strict; + my ($self, $wanted) = @_; + my $pkg = ref $self || $self; + my $version = $ {"${pkg}::VERSION"} || "(undef)"; + + $wanted .= '.0' unless $wanted =~ /\./; + $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/; + $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/; + if ( $version < $wanted ) { + $version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e; + $wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e; + $Carp::CarpLevel = 1; + Carp::croak("$pkg $wanted required--this is only version $version") + } + $version; +} - # Check if there is an option argument available. - if ( defined $optarg ? ($optarg eq '') : (@ARGV <= 0) ) { +################ Private Subroutines ################ - # Complain if this option needs an argument. - if ( $mand eq "=" ) { - print STDERR ("Option ", $opt, " requires an argument\n"); - $Getopt::Long::error++; - } - if ( $mand eq ":" ) { - $arg = $type eq "s" ? '' : 0; - } - next; - } +$find_option = sub { - # Get (possibly optional) argument. - $arg = defined $optarg ? $optarg : shift (@ARGV); + return 0 unless $opt =~ /^$genprefix/; - #### Check if the argument is valid for this option #### + $opt = $'; + my ($starter) = $&; - if ( $type eq "s" ) { # string - # A mandatory string takes anything. - next if $mand eq "="; + my $optarg = undef; # value supplied with --opt=value + my $rest = undef; # remainder from unbundling - # An optional string takes almost anything. - next if defined $optarg; - next if $arg eq "-"; + # If it is a long option, it may include the value. + if (($starter eq "--" || $getopt_compat) + && $opt =~ /^([^=]+)=/ ) { + $opt = $1; + $optarg = $'; + print STDERR ("=> option \"", $opt, + "\", optarg = \"$optarg\"\n") if $debug; + } - # Check for option or option list terminator. - if ($arg eq $argend || - $arg =~ /^$genprefix.+/) { - # Push back. - unshift (@ARGV, $arg); - # Supply empty value. - $arg = ''; + #### Look it up ### + + my $tryopt = $opt; # option to try + my $optbl = \%opctl; # table to look it up (long names) + my $type; + + if ( $bundling && $starter eq '-' ) { + # Unbundle single letter option. + $rest = substr ($tryopt, 1); + $tryopt = substr ($tryopt, 0, 1); + $tryopt = lc ($tryopt) if $ignorecase > 1; + print STDERR ("=> $starter$tryopt unbundled from ", + "$starter$tryopt$rest\n") if $debug; + $rest = undef unless $rest ne ''; + $optbl = \%bopctl; # look it up in the short names table + + # If bundling == 2, long options can override bundles. + if ( $bundling == 2 and + defined ($type = $opctl{$tryopt.$rest}) ) { + print STDERR ("=> $starter$tryopt rebundled to ", + "$starter$tryopt$rest\n") if $debug; + $tryopt .= $rest; + undef $rest; + } + } + + # Try auto-abbreviation. + elsif ( $autoabbrev ) { + # Downcase if allowed. + $tryopt = $opt = lc ($opt) if $ignorecase; + # Turn option name into pattern. + my $pat = quotemeta ($opt); + # Look up in option names. + my @hits = grep (/^$pat/, @opctl); + print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", + "out of ", scalar(@opctl), "\n") if $debug; + + # Check for ambiguous results. + unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { + # See if all matches are for the same option. + my %hit; + foreach ( @hits ) { + $_ = $aliases{$_} if defined $aliases{$_}; + $hit{$_} = 1; } - next; + # Now see if it really is ambiguous. + unless ( keys(%hit) == 1 ) { + return 0 if $passthrough; + print STDERR ("Option ", $opt, " is ambiguous (", + join(", ", @hits), ")\n"); + $error++; + undef $opt; + return 1; + } + @hits = keys(%hit); } - if ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $arg !~ /^-?[0-9]+$/ ) { - if ( defined $optarg || $mand eq "=" ) { - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (number expected)\n"); - $Getopt::Long::error++; - undef $arg; # don't assign it - } - else { - # Push back. - unshift (@ARGV, $arg); - # Supply default value. - $arg = 0; - } - } - next; + # Complete the option name, if appropriate. + if ( @hits == 1 && $hits[0] ne $opt ) { + $tryopt = $hits[0]; + $tryopt = lc ($tryopt) if $ignorecase; + print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") + if $debug; } + } - if ( $type eq "f" ) { # fixed real number, int is also ok - if ( $arg !~ /^-?[0-9.]+$/ ) { - if ( defined $optarg || $mand eq "=" ) { - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (real number expected)\n"); - $Getopt::Long::error++; - undef $arg; # don't assign it - } - else { - # Push back. - unshift (@ARGV, $arg); - # Supply default value. - $arg = 0.0; - } - } - next; + # Map to all lowercase if ignoring case. + elsif ( $ignorecase ) { + $tryopt = lc ($opt); + } + + # Check validity by fetching the info. + $type = $optbl->{$tryopt} unless defined $type; + unless ( defined $type ) { + return 0 if $passthrough; + warn ("Unknown option: ", $opt, "\n"); + $error++; + return 1; + } + # Apparently valid. + $opt = $tryopt; + print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; + + #### Determine argument status #### + + # If it is an option w/o argument, we're almost finished with it. + if ( $type eq '' || $type eq '!' ) { + if ( defined $optarg ) { + return 0 if $passthrough; + print STDERR ("Option ", $opt, " does not take an argument\n"); + $error++; + undef $opt; + } + elsif ( $type eq '' ) { + $arg = 1; # supply explicit value } + else { + substr ($opt, 0, 2) = ''; # strip NO prefix + $arg = 0; # supply explicit value + } + unshift (@ARGV, $starter.$rest) if defined $rest; + return 1; + } - die ("GetOpt::Long internal error (Can't happen)\n"); + # Get mandatory status and type info. + my $mand; + ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/; + + # Check if there is an option argument available. + if ( defined $optarg ? ($optarg eq '') + : !(defined $rest || @ARGV > 0) ) { + # Complain if this option needs an argument. + if ( $mand eq "=" ) { + return 0 if $passthrough; + print STDERR ("Option ", $opt, " requires an argument\n"); + $error++; + undef $opt; + } + if ( $mand eq ":" ) { + $arg = $type eq "s" ? '' : 0; + } + return 1; } - continue { - if ( defined $arg ) { - $opt = $aliases{$opt} if defined $aliases{$opt}; + # Get (possibly optional) argument. + $arg = (defined $rest ? $rest + : (defined $optarg ? $optarg : shift (@ARGV))); - if ( defined $linkage{$opt} ) { - print STDERR ("=> ref(\$L{$opt}) -> ", - ref($linkage{$opt}), "\n") if $debug; + # Get key if this is a "name=value" pair for a hash option. + $key = undef; + if ($hash && defined $arg) { + ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1); + } - if ( ref($linkage{$opt}) eq 'SCALAR' ) { - print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug; - ${$linkage{$opt}} = $arg; - } - elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { - print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") - if $debug; - push (@{$linkage{$opt}}, $arg); - } - elsif ( ref($linkage{$opt}) eq 'CODE' ) { - print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n") - if $debug; - &{$linkage{$opt}}($opt, $arg); - } - else { - print STDERR ("Invalid REF type \"", ref($linkage{$opt}), - "\" in linkage\n"); - die ("Getopt::Long -- internal error!\n"); + #### Check if the argument is valid for this option #### + + if ( $type eq "s" ) { # string + # A mandatory string takes anything. + return 1 if $mand eq "="; + + # An optional string takes almost anything. + return 1 if defined $optarg || defined $rest; + return 1 if $arg eq "-"; # ?? + + # Check for option or option list terminator. + if ($arg eq $argend || + $arg =~ /^$genprefix.+/) { + # Push back. + unshift (@ARGV, $arg); + # Supply empty value. + $arg = ''; + } + } + + elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer + if ( $arg !~ /^-?[0-9]+$/ ) { + if ( defined $optarg || $mand eq "=" ) { + if ( $passthrough ) { + unshift (@ARGV, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return 0; } + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (number expected)\n"); + $error++; + undef $opt; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; } - # No entry in linkage means entry in userlinkage. - elsif ( $array ) { - if ( defined $userlinkage->{$opt} ) { - print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") - if $debug; - push (@{$userlinkage->{$opt}}, $arg); - } - else { - print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") - if $debug; - $userlinkage->{$opt} = [$arg]; + else { + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + # Supply default value. + $arg = 0; + } + } + } + + elsif ( $type eq "f" ) { # real number, int is also ok + if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) { + if ( defined $optarg || $mand eq "=" ) { + if ( $passthrough ) { + unshift (@ARGV, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return 0; } + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); + $error++; + undef $opt; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; } else { - print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; - $userlinkage->{$opt} = $arg; + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + # Supply default value. + $arg = 0.0; } } } - - # Finish. - if ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) { - # Push back accumulated arguments - unshift (@ARGV, @ret) if @ret > 0; + else { + die ("GetOpt::Long internal error (Can't happen)\n"); } + return 1; +}; + +$config_defaults = sub { + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $gen_prefix = "(--|-)"; + $autoabbrev = 0; # no automatic abbrev of options + $bundling = 0; # no bundling of single letter switches + $getopt_compat = 0; # disallow '+' to start options + $order = $REQUIRE_ORDER; + } + else { + $gen_prefix = "(--|-|\\+)"; + $autoabbrev = 1; # automatic abbrev of options + $bundling = 0; # bundling off by default + $getopt_compat = 1; # allow '+' to start options + $order = $PERMUTE; + } + # Other configurable settings. + $debug = 0; # for debugging + $error = 0; # error tally + $ignorecase = 1; # ignore case when matching options + $passthrough = 0; # leave unrecognized options alone +}; - return ($Getopt::Long::error == 0); -} +################ Initialization ################ + +# Values for $order. See GNU getopt.c for details. +($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); +# Version major/minor numbers. +($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; + +# Set defaults. +&$config_defaults (); ################ Package return ################ -# Returning 1 is so boring... -$Getopt::Long::major_version * 1000 + $Getopt::Long::minor_version; +1; diff --git a/gnu/usr.bin/perl/lib/Getopt/Std.pm b/gnu/usr.bin/perl/lib/Getopt/Std.pm index 4117ca7f8b5..27882935f99 100644 --- a/gnu/usr.bin/perl/lib/Getopt/Std.pm +++ b/gnu/usr.bin/perl/lib/Getopt/Std.pm @@ -11,9 +11,12 @@ getopts - Process single-character switches with switch clustering =head1 SYNOPSIS use Getopt::Std; - getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + + getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts getopts('oif:'); # -o & -i are boolean flags, -f takes an argument # Sets opt_* as a side effect. + getopts('oif:', \%opts); # options as above. Values in %opts =head1 DESCRIPTION @@ -24,6 +27,11 @@ 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. +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 +the argument or 1 if no argument is specified. + =cut @ISA = qw(Exporter); @@ -40,8 +48,8 @@ switch and the argument. # Usage: # getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. -sub getopt { - local($argumentative) = @_; +sub getopt ($;$) { + local($argumentative, $hash) = @_; local($_,$first,$rest); local $Exporter::ExportLevel; @@ -55,12 +63,22 @@ sub getopt { shift(@ARGV); $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; - push( @EXPORT, "\$opt_$first" ); + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + ${"opt_$first"} = $rest; + push( @EXPORT, "\$opt_$first" ); + } } else { - eval "\$opt_$first = 1;"; - push( @EXPORT, "\$opt_$first" ); + if (ref $hash) { + $$hash{$first} = 1; + } + else { + ${"opt_$first"} = 1; + push( @EXPORT, "\$opt_$first" ); + } if ($rest ne '') { $ARGV[0] = "-$rest"; } @@ -77,8 +95,8 @@ sub getopt { # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a # # side effect. -sub getopts { - local($argumentative) = @_; +sub getopts ($;$) { + local($argumentative, $hash) = @_; local(@args,$_,$first,$rest); local($errs) = 0; local $Exporter::ExportLevel; @@ -94,12 +112,22 @@ sub getopts { ++$errs unless @ARGV; $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; - push( @EXPORT, "\$opt_$first" ); + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + ${"opt_$first"} = $rest; + push( @EXPORT, "\$opt_$first" ); + } } else { - eval "\$opt_$first = 1"; - push( @EXPORT, "\$opt_$first" ); + if (ref $hash) { + $$hash{$first} = 1; + } + else { + ${"opt_$first"} = 1; + push( @EXPORT, "\$opt_$first" ); + } if($rest eq '') { shift(@ARGV); } diff --git a/gnu/usr.bin/perl/lib/I18N/Collate.pm b/gnu/usr.bin/perl/lib/I18N/Collate.pm index 0d8314e12e4..580ca39785c 100644 --- a/gnu/usr.bin/perl/lib/I18N/Collate.pm +++ b/gnu/usr.bin/perl/lib/I18N/Collate.pm @@ -4,6 +4,23 @@ package I18N::Collate; I18N::Collate - compare 8-bit scalar data according to the current locale + *** + + WARNING: starting from the Perl version 5.003_06 + the I18N::Collate interface for comparing 8-bit scalar data + according to the current locale + + HAS BEEN DEPRECATED + + That is, please do not use it anymore for any new applications + and please migrate the old applications away from it because its + functionality was integrated into the Perl core language in the + release 5.003_06. + + See the perllocale manual page for further information. + + *** + =head1 SYNOPSIS use I18N::Collate; @@ -23,30 +40,29 @@ You can compare $s1 and $s2 above with to extract the data itself, you'll need a dereference: $$s1 -This uses POSIX::setlocale(). The basic collation conversion is done by -strxfrm() which terminates at NUL characters being a decent C routine. -collate_xfrm() handles embedded NUL characters gracefully. Due to C<cmp> -and overload magic, C<lt>, C<le>, C<eq>, C<ge>, and C<gt> work also. The -available locales depend on your operating system; try whether C<locale --a> shows them or man pages for "locale" or "nlsinfo" or -the direct approach C<ls /usr/lib/nls/loc> or C<ls -/usr/lib/nls>. Not all the locales that your vendor supports -are necessarily installed: please consult your operating system's -documentation and possibly your local system administration. +This module uses POSIX::setlocale(). The basic collation conversion is +done by strxfrm() which terminates at NUL characters being a decent C +routine. collate_xfrm() handles embedded NUL characters gracefully. -The locale names are probably something like -C<"xx_XX.(ISO)?8859-N"> or C<"xx_XX.(ISO)?8859N">, for example -C<"fr_CH.ISO8859-1"> is the Swiss (CH) variant of French (fr), -ISO Latin (8859) 1 (-1) which is the Western European character set. +The available locales depend on your operating system; try whether +C<locale -a> shows them or man pages for "locale" or "nlsinfo" or the +direct approach C<ls /usr/lib/nls/loc> or C<ls /usr/lib/nls> or +C<ls /usr/lib/locale>. Not all the locales that your vendor supports +are necessarily installed: please consult your operating system's +documentation and possibly your local system administration. The +locale names are probably something like C<xx_XX.(ISO)?8859-N> or +C<xx_XX.(ISO)?8859N>, for example C<fr_CH.ISO8859-1> is the Swiss (CH) +variant of French (fr), ISO Latin (8859) 1 (-1) which is the Western +European character set. =cut # I18N::Collate.pm # -# Author: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi> +# Author: Jarkko Hietaniemi <F<jhi@iki.fi>> # Helsinki University of Technology, Finland # -# Acks: Guy Decoux <decoux@moulon.inra.fr> understood +# Acks: Guy Decoux <F<decoux@moulon.inra.fr>> understood # overloading magic much deeper than I and told # how to cut the size of this code by more than half. # (my first version did overload all of lt gt eq le ge cmp) @@ -87,7 +103,7 @@ ISO Latin (8859) 1 (-1) which is the Western European character set. # variant of French (fr), ISO Latin (8859) 1 (-1) # which is the Western European character set. # -# Updated: 19960104 1946 GMT +# Updated: 19961005 # # --- @@ -104,7 +120,35 @@ fallback 1 cmp collate_cmp ); -sub new { my $new = $_[1]; bless \$new } +sub new { + my $new = $_[1]; + + if ($^W && $] >= 5.003_06) { + unless ($please_use_I18N_Collate_even_if_deprecated) { + warn <<___EOD___; +*** + + WARNING: starting from the Perl version 5.003_06 + the I18N::Collate interface for comparing 8-bit scalar data + according to the current locale + + HAS BEEN DEPRECATED + + That is, please do not use it anymore for any new applications + and please migrate the old applications away from it because its + functionality was integrated into the Perl core language in the + release 5.003_06. + + See the perllocale manual page for further information. + +*** +___EOD___ + $please_use_I18N_Collate_even_if_deprecated++; + } + } + + bless \$new; +} sub setlocale { my ($category, $locale) = @_[0,1]; diff --git a/gnu/usr.bin/perl/lib/IPC/Open2.pm b/gnu/usr.bin/perl/lib/IPC/Open2.pm index 243412ef094..32282d62b39 100644 --- a/gnu/usr.bin/perl/lib/IPC/Open2.pm +++ b/gnu/usr.bin/perl/lib/IPC/Open2.pm @@ -1,7 +1,14 @@ package IPC::Open2; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + require 5.000; require Exporter; -use Carp; + +$VERSION = 1.01; +@ISA = qw(Exporter); +@EXPORT = qw(open2); =head1 NAME @@ -20,7 +27,16 @@ The open2() function spawns the given $cmd and connects $rdr for reading and $wtr for writing. It's what you think should work when you try - open(HANDLE, "|cmd args"); + open(HANDLE, "|cmd args|"); + +The write filehandle will have autoflush turned on. + +If $rdr is a string (that is, a bareword filehandle rather than a glob +or a reference) and it begins with ">&", then the child will send output +directly to that file handle. If $wtr is a string that begins with +"<&", then WTR will be closed in the parent, and the child will read +from it directly. In both cases, there will be a dup(2) instead of a +pipe(2) made. open2() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C</^open2:/>. @@ -38,19 +54,17 @@ a time. Programs like B<sort> that read their entire input stream first, however, are quite apt to cause deadlock. The big problem with this approach is that if you don't have control -over source code being run in the the child process, you can't control what it does -with pipe buffering. Thus you can't just open a pipe to C<cat -v> and continually -read and write a line from it. +over source code being run in the child process, you can't control +what it does with pipe buffering. Thus you can't just open a pipe to +C<cat -v> and continually read and write a line from it. =head1 SEE ALSO -See L<open3> for an alternative that handles STDERR as well. +See L<IPC::Open3> for an alternative that handles STDERR as well. This +function is really just a wrapper around open3(). =cut -@ISA = qw(Exporter); -@EXPORT = qw(open2); - # &open2: tom christiansen, <tchrist@convex.com> # # usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); @@ -67,41 +81,15 @@ See L<open3> for an alternative that handles STDERR as well. # # abort program if # rdr or wtr are null -# pipe or fork or exec fails +# a system call fails -$fh = 'FHOPEN000'; # package static in case called more than once +require IPC::Open3; sub open2 { - local($kidpid); - local($dad_rdr, $dad_wtr, @cmd) = @_; - - $dad_rdr ne '' || croak "open2: rdr should not be null"; - $dad_wtr ne '' || croak "open2: wtr should not be null"; - - # force unqualified filehandles into callers' package - local($package) = caller; - $dad_rdr =~ s/^[^']+$/$package'$&/ unless ref $dad_rdr; - $dad_wtr =~ s/^[^']+$/$package'$&/ unless ref $dad_wtr; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - - pipe($dad_rdr, $kid_wtr) || croak "open2: pipe 1 failed: $!"; - pipe($kid_rdr, $dad_wtr) || croak "open2: pipe 2 failed: $!"; - - if (($kidpid = fork) < 0) { - croak "open2: fork failed: $!"; - } elsif ($kidpid == 0) { - close $dad_rdr; close $dad_wtr; - open(STDIN, "<&$kid_rdr"); - open(STDOUT, ">&$kid_wtr"); - warn "execing @cmd\n" if $debug; - exec @cmd - or croak "open2: exec of @cmd failed"; - } - close $kid_rdr; close $kid_wtr; - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; + my ($read, $write, @cmd) = @_; + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + return IPC::Open3::_open3('open2', scalar caller, + $write, $read, '>&STDERR', @cmd); } -1; # so require is happy +1 diff --git a/gnu/usr.bin/perl/lib/IPC/Open3.pm b/gnu/usr.bin/perl/lib/IPC/Open3.pm index 234b4c911ff..5bae5057367 100644 --- a/gnu/usr.bin/perl/lib/IPC/Open3.pm +++ b/gnu/usr.bin/perl/lib/IPC/Open3.pm @@ -1,7 +1,18 @@ package IPC::Open3; + +use strict; +no strict 'refs'; # because users pass me bareword filehandles +use vars qw($VERSION @ISA @EXPORT $Fh $Me); + require 5.001; require Exporter; + use Carp; +use Symbol 'qualify'; + +$VERSION = 1.0101; +@ISA = qw(Exporter); +@EXPORT = qw(open3); =head1 NAME @@ -9,7 +20,7 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling =head1 SYNOPSIS - $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH + $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH, 'some cmd and args', 'optarg', ...); =head1 DESCRIPTION @@ -17,30 +28,46 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling Extremely similar to open2(), open3() spawns the given $cmd and connects RDRFH for reading, WTRFH for writing, and ERRFH for errors. If ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are -on the same file handle. +on the same file handle. The WTRFH will have autoflush turned on. -If WTRFH begins with "<&", then WTRFH will be closed in the parent, and +If WTRFH begins with "E<lt>&", then WTRFH will be closed in the parent, and the child will read from it directly. If RDRFH or ERRFH begins with -">&", then the child will send output directly to that file handle. In both -cases, there will be a dup(2) instead of a pipe(2) made. +"E<gt>&", then the child will send output directly to that file handle. +In both cases, there will be a dup(2) instead of a pipe(2) made. If you try to read from the child's stdout writer and their stderr writer, you'll have problems with blocking, which means you'll want to use select(), which means you'll have to use sysread() instead of normal stuff. -All caveats from open2() continue to apply. See L<open2> for details. +open3() returns the process ID of the child process. It doesn't return on +failure: it just raises an exception matching C</^open3:/>. -=cut +=head1 WARNING + +It will not create these file handles for you. You have to do this +yourself. So don't pass it empty variables expecting them to get filled +in for you. + +Additionally, this is very dangerous as you may block forever. It +assumes it's going to talk to something like B<bc>, both writing to it +and reading from it. This is presumably safe because you "know" that +commands like B<bc> will read a line at a time and output a line at a +time. Programs like B<sort> that read their entire input stream first, +however, are quite apt to cause deadlock. -@ISA = qw(Exporter); -@EXPORT = qw(open3); +The big problem with this approach is that if you don't have control +over source code being run in the child process, you can't control +what it does with pipe buffering. Thus you can't just open a pipe to +C<cat -v> and continually read and write a line from it. + +=cut # &open3: Marc Horowitz <marc@mit.edu> # derived mostly from &open2 by tom christiansen, <tchrist@convex.com> # fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com> # -# $Id: Open3.pm,v 1.1 1996/08/19 10:12:45 downsj Exp $ +# $Id: Open3.pm,v 1.2 1997/11/30 07:57:45 millert Exp $ # # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); # @@ -48,7 +75,7 @@ All caveats from open2() continue to apply. See L<open2> for details. # reading, wtr for writing, and err for errors. # if err is '', or the same as rdr, then stdout and # stderr of the child are on the same fh. returns pid -# of child, or 0 on failure. +# of child (or dies on failure). # if wtr begins with '<&', then wtr will be closed in the parent, and @@ -64,17 +91,43 @@ All caveats from open2() continue to apply. See L<open2> for details. # # abort program if # rdr or wtr are null -# pipe or fork or exec fails +# a system call fails -$fh = 'FHOPEN000'; # package static in case called more than once +$Fh = 'FHOPEN000'; # package static in case called more than once +$Me = 'open3 (bug)'; # you should never see this, it's always localized -sub open3 { - my($kidpid); - my($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - my($dup_wtr, $dup_rdr, $dup_err); +# Fatal.pm needs to be fixed WRT prototypes. + +sub xfork { + my $pid = fork; + defined $pid or croak "$Me: fork failed: $!"; + return $pid; +} + +sub xpipe { + pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!"; +} - $dad_wtr || croak "open3: wtr should not be null"; - $dad_rdr || croak "open3: rdr should not be null"; +# I tried using a * prototype character for the filehandle but it still +# disallows a bearword while compiling under strict subs. + +sub xopen { + open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!"; +} + +sub xclose { + close $_[0] or croak "$Me: close($_[0]) failed: $!"; +} + +my $do_spawn = $^O eq 'os2'; + +sub _open3 { + local $Me = shift; + my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; + my($dup_wtr, $dup_rdr, $dup_err, $kidpid); + + $dad_wtr or croak "$Me: wtr should not be null"; + $dad_rdr or croak "$Me: rdr should not be null"; $dad_err = $dad_rdr if ($dad_err eq ''); $dup_wtr = ($dad_wtr =~ s/^[<>]&//); @@ -82,63 +135,155 @@ sub open3 { $dup_err = ($dad_err =~ s/^[<>]&//); # force unqualified filehandles into callers' package - my($package) = caller; - $dad_wtr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_wtr; - $dad_rdr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_rdr; - $dad_err =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_err; + $dad_wtr = qualify $dad_wtr, $package; + $dad_rdr = qualify $dad_rdr, $package; + $dad_err = qualify $dad_err, $package; - my($kid_rdr) = ++$fh; - my($kid_wtr) = ++$fh; - my($kid_err) = ++$fh; + my $kid_rdr = ++$Fh; + my $kid_wtr = ++$Fh; + my $kid_err = ++$Fh; - if (!$dup_wtr) { - pipe($kid_rdr, $dad_wtr) || croak "open3: pipe 1 (stdin) failed: $!"; - } - if (!$dup_rdr) { - pipe($dad_rdr, $kid_wtr) || croak "open3: pipe 2 (stdout) failed: $!"; - } - if ($dad_err ne $dad_rdr && !$dup_err) { - pipe($dad_err, $kid_err) || croak "open3: pipe 3 (stderr) failed: $!"; - } + xpipe $kid_rdr, $dad_wtr if !$dup_wtr; + xpipe $dad_rdr, $kid_wtr if !$dup_rdr; + xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr; + + $kidpid = $do_spawn ? -1 : xfork; + if ($kidpid == 0) { # Kid + # If she wants to dup the kid's stderr onto her stdout I need to + # save a copy of her stdout before I put something else there. + if ($dad_rdr ne $dad_err && $dup_err + && fileno($dad_err) == fileno(STDOUT)) { + my $tmp = ++$Fh; + xopen($tmp, ">&$dad_err"); + $dad_err = $tmp; + } - if (($kidpid = fork) < 0) { - croak "open3: fork failed: $!"; - } elsif ($kidpid == 0) { if ($dup_wtr) { - open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); + xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr); } else { - close($dad_wtr); - open(STDIN, "<&$kid_rdr"); + xclose $dad_wtr; + xopen \*STDIN, "<&$kid_rdr"; + xclose $kid_rdr; } if ($dup_rdr) { - open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); + xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr); } else { - close($dad_rdr); - open(STDOUT, ">&$kid_wtr"); + xclose $dad_rdr; + xopen \*STDOUT, ">&$kid_wtr"; + xclose $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - open(STDERR, ">&$dad_err") - if (fileno(STDERR) != fileno($dad_err)); + xopen \*STDERR, ">&$dad_err" + if fileno(STDERR) != fileno($dad_err); } else { - close($dad_err); - open(STDERR, ">&$kid_err"); + xclose $dad_err; + xopen \*STDERR, ">&$kid_err"; + xclose $kid_err; } } else { - open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); + xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT); } local($")=(" "); exec @cmd or croak "open3: exec of @cmd failed"; - } + } elsif ($do_spawn) { + # All the bookkeeping of coincidence between handles is + # handled in spawn_with_handles. - close $kid_rdr; close $kid_wtr; close $kid_err; - if ($dup_wtr) { - close($dad_wtr); + my @close; + if ($dup_wtr) { + $kid_rdr = $dad_wtr; + push @close, \*{$kid_rdr}; + } else { + push @close, \*{$dad_wtr}, \*{$kid_rdr}; + } + if ($dup_rdr) { + $kid_wtr = $dad_rdr; + push @close, \*{$kid_wtr}; + } else { + push @close, \*{$dad_rdr}, \*{$kid_wtr}; + } + if ($dad_rdr ne $dad_err) { + if ($dup_err) { + $kid_err = $dad_err ; + push @close, \*{$kid_err}; + } else { + push @close, \*{$dad_err}, \*{$kid_err}; + } + } else { + $kid_err = $kid_wtr; + } + require IO::Pipe; + $kidpid = eval { + spawn_with_handles( [ { mode => 'r', + open_as => \*{$kid_rdr}, + handle => \*STDIN }, + { mode => 'w', + open_as => \*{$kid_wtr}, + handle => \*STDOUT }, + { mode => 'w', + open_as => \*{$kid_err}, + handle => \*STDERR }, + ], \@close, @cmd); + }; + die "open3: $@" if $@; } + xclose $kid_rdr if !$dup_wtr; + xclose $kid_wtr if !$dup_rdr; + xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err; + # If the write handle is a dup give it away entirely, close my copy + # of it. + xclose $dad_wtr if $dup_wtr; + select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe $kidpid; } -1; # so require is happy +sub open3 { + if (@_ < 4) { + local $" = ', '; + croak "open3(@_): not enough arguments"; + } + return _open3 'open3', scalar caller, @_ +} + +sub spawn_with_handles { + my $fds = shift; # Fields: handle, mode, open_as + my $close_in_child = shift; + my ($fd, $pid, @saved_fh, $saved, %saved, @errs); + require Fcntl; + + foreach $fd (@$fds) { + $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); + $saved{fileno $fd->{handle}} = $fd->{tmp_copy}; + } + foreach $fd (@$fds) { + bless $fd->{handle}, 'IO::Handle' + unless eval { $fd->{handle}->isa('IO::Handle') } ; + # If some of handles to redirect-to coincide with handles to + # redirect, we need to use saved variants: + $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as}, + $fd->{mode}); + } + # Stderr may be redirected below, so we save the err text: + foreach $fd (@$close_in_child) { + fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!" + unless $saved{fileno $fd}; # Do not close what we redirect! + } + + unless (@errs) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0; + } + + foreach $fd (@$fds) { + $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode}); + $fd->{tmp_copy}->close or croak "Can't close: $!"; + } + croak join "\n", @errs if @errs; + return $pid; +} + +1; # so require is happy diff --git a/gnu/usr.bin/perl/lib/Math/BigInt.pm b/gnu/usr.bin/perl/lib/Math/BigInt.pm index 68856aea6e0..422dca42fd6 100644 --- a/gnu/usr.bin/perl/lib/Math/BigInt.pm +++ b/gnu/usr.bin/perl/lib/Math/BigInt.pm @@ -106,13 +106,23 @@ sub bcmp { #(num_str, num_str) return cond_code sub cmp { # post-normalized compare for internal use local($cx, $cy) = @_; - $cx cmp $cy - && - ( - ord($cy) <=> ord($cx) - || - ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx) - ); + + return 0 if ($cx eq $cy); + + local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1)); + local($ld); + + if ($sx eq '+') { + return 1 if ($sy eq '-' || $cy eq '+0'); + $ld = length($cx) - length($cy); + return $ld if ($ld); + return $cx cmp $cy; + } else { # $sx eq '-' + return -1 if ($sy eq '+'); + $ld = length($cy) - length($cx); + return $ld if ($ld); + return $cy cmp $cx; + } } sub badd { #(num_str, num_str) return num_str @@ -161,11 +171,11 @@ 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); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5); + $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; } (@x, @y, $car); } @@ -204,7 +214,7 @@ sub mul { #(*int_num_array, *int_num_array) return int_num_array for $x (@x) { ($car, $cty) = (0, $[); for $y (@y) { - $prod = $x * $y + $prod[$cty] + $car; + $prod = $x * $y + ($prod[$cty] || 0) + $car; $prod[$cty++] = $prod - ($car = int($prod * 1e-5)) * 1e5; } diff --git a/gnu/usr.bin/perl/lib/Math/Complex.pm b/gnu/usr.bin/perl/lib/Math/Complex.pm index 969f3c2c79e..b3d7e6084f2 100644 --- a/gnu/usr.bin/perl/lib/Math/Complex.pm +++ b/gnu/usr.bin/perl/lib/Math/Complex.pm @@ -1,123 +1,1198 @@ -package Math::Complex; +# +# Complex numbers and associated mathematical functions +# -- Raphael Manfredi September 1996 +# -- Jarkko Hietaniemi March-October 1997 +# -- Daniel S. Lewart September-October 1997 +# require Exporter; +package Math::Complex; + +$VERSION = 1.05; + +# $Id: Complex.pm,v 1.2 1997/11/30 07:57:47 millert Exp $ + +use strict; -@ISA = ('Exporter'); +use vars qw($VERSION @ISA + @EXPORT %EXPORT_TAGS + $package $display + $i $ip2 $logn %logn); -# just to make use happy +@ISA = qw(Exporter); + +my @trig = qw( + pi + tan + csc cosec sec cot cotan + asin acos atan + acsc acosec asec acot acotan + sinh cosh tanh + csch cosech sech coth cotanh + asinh acosh atanh + acsch acosech asech acoth acotanh + ); + +@EXPORT = (qw( + i Re Im arg + sqrt log ln + log10 logn cbrt root + cplx cplxe + ), + @trig); + +%EXPORT_TAGS = ( + 'trig' => [@trig], +); use overload - '+' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); - bless [ $x1+$x2, $y1+$y2]; - }, - - '-' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); - bless [ $x1-$x2, $y1-$y2]; - }, - - '*' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); - bless [ $x1*$x2-$y1*$y2,$x1*$y2+$x2*$y1]; - }, - - '/' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); - my $q = $x2*$x2+$y2*$y2; - bless [($x1*$x2+$y1*$y2)/$q, ($y1*$x2-$y2*$x1)/$q]; - }, - - 'neg' => sub { my($x,$y) = @{$_[0]}; bless [ -$x, -$y]; - }, - - '~' => sub { my($x,$y) = @{$_[0]}; bless [ $x, -$y]; - }, - - 'abs' => sub { my($x,$y) = @{$_[0]}; sqrt $x*$x+$y*$y; - }, - - 'cos' => sub { my($x,$y) = @{$_[0]}; - my ($ab,$c,$s) = (exp $y, cos $x, sin $x); - my $abr = 1/(2*$ab); $ab /= 2; - bless [ ($abr+$ab)*$c, ($abr-$ab)*$s]; - }, - - 'sin' => sub { my($x,$y) = @{$_[0]}; - my ($ab,$c,$s) = (exp $y, cos $x, sin $x); - my $abr = 1/(2*$ab); $ab /= 2; - bless [ (-$abr-$ab)*$s, ($abr-$ab)*$c]; - }, - - 'exp' => sub { my($x,$y) = @{$_[0]}; - my ($ab,$c,$s) = (exp $x, cos $y, sin $y); - bless [ $ab*$c, $ab*$s ]; - }, - - 'sqrt' => sub { - my($zr,$zi) = @{$_[0]}; - my ($x, $y, $r, $w); - my $c = new Math::Complex (0,0); - if (($zr == 0) && ($zi == 0)) { - # nothing, $c already set - } - else { - $x = abs($zr); - $y = abs($zi); - if ($x >= $y) { - $r = $y/$x; - $w = sqrt($x) * sqrt(0.5*(1.0+sqrt(1.0+$r*$r))); - } - else { - $r = $x/$y; - $w = sqrt($y) * sqrt($y) * sqrt(0.5*($r+sqrt(1.0+$r*$r))); - } - if ( $zr >= 0) { - @$c = ($w, $zi/(2 * $w) ); - } - else { - $c->[1] = ($zi >= 0) ? $w : -$w; - $c->[0] = $zi/(2.0* $c->[1]); - } - } - return $c; - }, - - qw("" stringify) -; - -sub new { - my $class = shift; - my @C = @_; - bless \@C, $class; + '+' => \&plus, + '-' => \&minus, + '*' => \&multiply, + '/' => \÷, + '**' => \&power, + '<=>' => \&spaceship, + 'neg' => \&negate, + '~' => \&conjugate, + 'abs' => \&abs, + 'sqrt' => \&sqrt, + 'exp' => \&exp, + 'log' => \&log, + 'sin' => \&sin, + 'cos' => \&cos, + 'tan' => \&tan, + 'atan2' => \&atan2, + qw("" stringify); + +# +# Package globals +# + +$package = 'Math::Complex'; # Package name +$display = 'cartesian'; # Default display format + +# +# Object attributes (internal): +# cartesian [real, imaginary] -- cartesian form +# polar [rho, theta] -- polar form +# c_dirty cartesian form not up-to-date +# p_dirty polar form not up-to-date +# display display format (package's global when not set) +# + +# +# ->make +# +# Create a new complex number (cartesian form) +# +sub make { + my $self = bless {}, shift; + my ($re, $im) = @_; + $self->{'cartesian'} = [$re, $im]; + $self->{c_dirty} = 0; + $self->{p_dirty} = 1; + return $self; +} + +# +# ->emake +# +# Create a new complex number (exponential form) +# +sub emake { + my $self = bless {}, shift; + my ($rho, $theta) = @_; + if ($rho < 0) { + $rho = -$rho; + $theta = ($theta <= 0) ? $theta + pi() : $theta - pi(); + } + $self->{'polar'} = [$rho, $theta]; + $self->{p_dirty} = 0; + $self->{c_dirty} = 1; + return $self; +} + +sub new { &make } # For backward compatibility only. + +# +# cplx +# +# Creates a complex number from a (re, im) tuple. +# This avoids the burden of writing Math::Complex->make(re, im). +# +sub cplx { + my ($re, $im) = @_; + return $package->make($re, defined $im ? $im : 0); +} + +# +# cplxe +# +# Creates a complex number from a (rho, theta) tuple. +# This avoids the burden of writing Math::Complex->emake(rho, theta). +# +sub cplxe { + my ($rho, $theta) = @_; + return $package->emake($rho, defined $theta ? $theta : 0); +} + +# +# pi +# +# The number defined as pi = 180 degrees +# +use constant pi => 4 * atan2(1, 1); + +# +# pit2 +# +# The full circle +# +use constant pit2 => 2 * pi; + +# +# pip2 +# +# The quarter circle +# +use constant pip2 => pi / 2; + +# +# uplog10 +# +# Used in log10(). +# +use constant uplog10 => 1 / log(10); + +# +# i +# +# The number defined as i*i = -1; +# +sub i () { + return $i if ($i); + $i = bless {}; + $i->{'cartesian'} = [0, 1]; + $i->{'polar'} = [1, pip2]; + $i->{c_dirty} = 0; + $i->{p_dirty} = 0; + return $i; +} + +# +# Attribute access/set routines +# + +sub cartesian {$_[0]->{c_dirty} ? + $_[0]->update_cartesian : $_[0]->{'cartesian'}} +sub polar {$_[0]->{p_dirty} ? + $_[0]->update_polar : $_[0]->{'polar'}} + +sub set_cartesian { $_[0]->{p_dirty}++; $_[0]->{'cartesian'} = $_[1] } +sub set_polar { $_[0]->{c_dirty}++; $_[0]->{'polar'} = $_[1] } + +# +# ->update_cartesian +# +# Recompute and return the cartesian form, given accurate polar form. +# +sub update_cartesian { + my $self = shift; + my ($r, $t) = @{$self->{'polar'}}; + $self->{c_dirty} = 0; + return $self->{'cartesian'} = [$r * cos $t, $r * sin $t]; +} + +# +# +# ->update_polar +# +# Recompute and return the polar form, given accurate cartesian form. +# +sub update_polar { + my $self = shift; + my ($x, $y) = @{$self->{'cartesian'}}; + $self->{p_dirty} = 0; + return $self->{'polar'} = [0, 0] if $x == 0 && $y == 0; + return $self->{'polar'} = [sqrt($x*$x + $y*$y), atan2($y, $x)]; +} + +# +# (plus) +# +# Computes z1+z2. +# +sub plus { + my ($z1, $z2, $regular) = @_; + my ($re1, $im1) = @{$z1->cartesian}; + $z2 = cplx($z2) unless ref $z2; + my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + unless (defined $regular) { + $z1->set_cartesian([$re1 + $re2, $im1 + $im2]); + return $z1; + } + return (ref $z1)->make($re1 + $re2, $im1 + $im2); +} + +# +# (minus) +# +# Computes z1-z2. +# +sub minus { + my ($z1, $z2, $inverted) = @_; + my ($re1, $im1) = @{$z1->cartesian}; + $z2 = cplx($z2) unless ref $z2; + my ($re2, $im2) = @{$z2->cartesian}; + unless (defined $inverted) { + $z1->set_cartesian([$re1 - $re2, $im1 - $im2]); + return $z1; + } + return $inverted ? + (ref $z1)->make($re2 - $re1, $im2 - $im1) : + (ref $z1)->make($re1 - $re2, $im1 - $im2); + +} + +# +# (multiply) +# +# Computes z1*z2. +# +sub multiply { + my ($z1, $z2, $regular) = @_; + if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) { + # if both polar better use polar to avoid rounding errors + my ($r1, $t1) = @{$z1->polar}; + my ($r2, $t2) = @{$z2->polar}; + my $t = $t1 + $t2; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + unless (defined $regular) { + $z1->set_polar([$r1 * $r2, $t]); + return $z1; + } + return (ref $z1)->emake($r1 * $r2, $t); + } else { + my ($x1, $y1) = @{$z1->cartesian}; + if (ref $z2) { + my ($x2, $y2) = @{$z2->cartesian}; + return (ref $z1)->make($x1*$x2-$y1*$y2, $x1*$y2+$y1*$x2); + } else { + return (ref $z1)->make($x1*$z2, $y1*$z2); + } + } +} + +# +# _divbyzero +# +# Die on division by zero. +# +sub _divbyzero { + my $mess = "$_[0]: Division by zero.\n"; + + if (defined $_[1]) { + $mess .= "(Because in the definition of $_[0], the divisor "; + $mess .= "$_[1] " unless ($_[1] eq '0'); + $mess .= "is 0)\n"; + } + + my @up = caller(1); + + $mess .= "Died at $up[1] line $up[2].\n"; + + die $mess; +} + +# +# (divide) +# +# Computes z1/z2. +# +sub divide { + my ($z1, $z2, $inverted) = @_; + if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) { + # if both polar better use polar to avoid rounding errors + my ($r1, $t1) = @{$z1->polar}; + my ($r2, $t2) = @{$z2->polar}; + my $t; + if ($inverted) { + _divbyzero "$z2/0" if ($r1 == 0); + $t = $t2 - $t1; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + return (ref $z1)->emake($r2 / $r1, $t); + } else { + _divbyzero "$z1/0" if ($r2 == 0); + $t = $t1 - $t2; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + return (ref $z1)->emake($r1 / $r2, $t); + } + } else { + my ($d, $x2, $y2); + if ($inverted) { + ($x2, $y2) = @{$z1->cartesian}; + $d = $x2*$x2 + $y2*$y2; + _divbyzero "$z2/0" if $d == 0; + return (ref $z1)->make(($x2*$z2)/$d, -($y2*$z2)/$d); + } else { + my ($x1, $y1) = @{$z1->cartesian}; + if (ref $z2) { + ($x2, $y2) = @{$z2->cartesian}; + $d = $x2*$x2 + $y2*$y2; + _divbyzero "$z1/0" if $d == 0; + my $u = ($x1*$x2 + $y1*$y2)/$d; + my $v = ($y1*$x2 - $x1*$y2)/$d; + return (ref $z1)->make($u, $v); + } else { + _divbyzero "$z1/0" if $z2 == 0; + return (ref $z1)->make($x1/$z2, $y1/$z2); + } + } + } +} + +# +# _zerotozero +# +# Die on zero raised to the zeroth. +# +sub _zerotozero { + my $mess = "The zero raised to the zeroth power is not defined.\n"; + + my @up = caller(1); + + $mess .= "Died at $up[1] line $up[2].\n"; + + die $mess; +} + +# +# (power) +# +# Computes z1**z2 = exp(z2 * log z1)). +# +sub power { + my ($z1, $z2, $inverted) = @_; + my $z1z = $z1 == 0; + my $z2z = $z2 == 0; + _zerotozero if ($z1z and $z2z); + if ($inverted) { + return 0 if ($z2z); + return 1 if ($z1z or $z2 == 1); + } else { + return 0 if ($z1z); + return 1 if ($z2z or $z1 == 1); + } + return $inverted ? exp($z1 * log $z2) : exp($z2 * log $z1); +} + +# +# (spaceship) +# +# Computes z1 <=> z2. +# Sorts on the real part first, then on the imaginary part. Thus 2-4i > 3+8i. +# +sub spaceship { + my ($z1, $z2, $inverted) = @_; + my ($re1, $im1) = ref $z1 ? @{$z1->cartesian} : ($z1, 0); + my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + my $sgn = $inverted ? -1 : 1; + return $sgn * ($re1 <=> $re2) if $re1 != $re2; + return $sgn * ($im1 <=> $im2); +} + +# +# (negate) +# +# Computes -z. +# +sub negate { + my ($z) = @_; + if ($z->{c_dirty}) { + my ($r, $t) = @{$z->polar}; + $t = ($t <= 0) ? $t + pi : $t - pi; + return (ref $z)->emake($r, $t); + } + my ($re, $im) = @{$z->cartesian}; + return (ref $z)->make(-$re, -$im); +} + +# +# (conjugate) +# +# Compute complex's conjugate. +# +sub conjugate { + my ($z) = @_; + if ($z->{c_dirty}) { + my ($r, $t) = @{$z->polar}; + return (ref $z)->emake($r, -$t); + } + my ($re, $im) = @{$z->cartesian}; + return (ref $z)->make($re, -$im); +} + +# +# (abs) +# +# Compute complex's norm (rho). +# +sub abs { + my ($z) = @_; + my ($r, $t) = @{$z->polar}; + return $r; +} + +# +# arg +# +# Compute complex's argument (theta). +# +sub arg { + my ($z) = @_; + return ($z < 0 ? pi : 0) unless ref $z; + my ($r, $t) = @{$z->polar}; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + return $t; } +# +# (sqrt) +# +# Compute sqrt(z). +# +sub sqrt { + my ($z) = @_; + return $z >= 0 ? sqrt($z) : cplx(0, sqrt(-$z)) unless ref $z; + my ($re, $im) = @{$z->cartesian}; + return cplx($re < 0 ? (0, sqrt(-$re)) : (sqrt($re), 0)) if $im == 0; + my ($r, $t) = @{$z->polar}; + return (ref $z)->emake(sqrt($r), $t/2); +} + +# +# cbrt +# +# Compute cbrt(z) (cubic root). +# +sub cbrt { + my ($z) = @_; + return $z < 0 ? -exp(log(-$z)/3) : ($z > 0 ? exp(log($z)/3): 0) + unless ref $z; + my ($r, $t) = @{$z->polar}; + return (ref $z)->emake(exp(log($r)/3), $t/3); +} + +# +# _rootbad +# +# Die on bad root. +# +sub _rootbad { + my $mess = "Root $_[0] not defined, root must be positive integer.\n"; + + my @up = caller(1); + + $mess .= "Died at $up[1] line $up[2].\n"; + + die $mess; +} + +# +# root +# +# Computes all nth root for z, returning an array whose size is n. +# `n' must be a positive integer. +# +# The roots are given by (for k = 0..n-1): +# +# z^(1/n) = r^(1/n) (cos ((t+2 k pi)/n) + i sin ((t+2 k pi)/n)) +# +sub root { + my ($z, $n) = @_; + _rootbad($n) if ($n < 1 or int($n) != $n); + my ($r, $t) = ref $z ? @{$z->polar} : (abs($z), $z >= 0 ? 0 : pi); + my @root; + my $k; + my $theta_inc = pit2 / $n; + my $rho = $r ** (1/$n); + my $theta; + my $complex = ref($z) || $package; + for ($k = 0, $theta = $t / $n; $k < $n; $k++, $theta += $theta_inc) { + push(@root, $complex->emake($rho, $theta)); + } + return @root; +} + +# +# Re +# +# Return Re(z). +# sub Re { - my($x,$y) = @{$_[0]}; - $x; + my ($z) = @_; + return $z unless ref $z; + my ($re, $im) = @{$z->cartesian}; + return $re; } +# +# Im +# +# Return Im(z). +# sub Im { - my($x,$y) = @{$_[0]}; - $y; + my ($z) = @_; + return 0 unless ref $z; + my ($re, $im) = @{$z->cartesian}; + return $im; } -sub arg { - my($x,$y) = @{$_[0]}; - atan2($y,$x); +# +# (exp) +# +# Computes exp(z). +# +sub exp { + my ($z) = @_; + my ($x, $y) = @{$z->cartesian}; + return (ref $z)->emake(exp($x), $y); +} + +# +# _logofzero +# +# Die on logarithm of zero. +# +sub _logofzero { + my $mess = "$_[0]: Logarithm of zero.\n"; + + if (defined $_[1]) { + $mess .= "(Because in the definition of $_[0], the argument "; + $mess .= "$_[1] " unless ($_[1] eq '0'); + $mess .= "is 0)\n"; + } + + my @up = caller(1); + + $mess .= "Died at $up[1] line $up[2].\n"; + + die $mess; +} + +# +# (log) +# +# Compute log(z). +# +sub log { + my ($z) = @_; + unless (ref $z) { + _logofzero("log") if $z == 0; + return $z > 0 ? log($z) : cplx(log(-$z), pi); + } + my ($r, $t) = @{$z->polar}; + _logofzero("log") if $r == 0; + if ($t > pi()) { $t -= pit2 } + elsif ($t <= -pi()) { $t += pit2 } + return (ref $z)->make(log($r), $t); +} + +# +# ln +# +# Alias for log(). +# +sub ln { Math::Complex::log(@_) } + +# +# log10 +# +# Compute log10(z). +# + +sub log10 { + return Math::Complex::log($_[0]) * uplog10; +} + +# +# logn +# +# Compute logn(z,n) = log(z) / log(n) +# +sub logn { + my ($z, $n) = @_; + $z = cplx($z, 0) unless ref $z; + my $logn = $logn{$n}; + $logn = $logn{$n} = log($n) unless defined $logn; # Cache log(n) + return log($z) / $logn; +} + +# +# (cos) +# +# Compute cos(z) = (exp(iz) + exp(-iz))/2. +# +sub cos { + my ($z) = @_; + my ($x, $y) = @{$z->cartesian}; + my $ey = exp($y); + my $ey_1 = 1 / $ey; + return (ref $z)->make(cos($x) * ($ey + $ey_1)/2, + sin($x) * ($ey_1 - $ey)/2); +} + +# +# (sin) +# +# Compute sin(z) = (exp(iz) - exp(-iz))/2. +# +sub sin { + my ($z) = @_; + my ($x, $y) = @{$z->cartesian}; + my $ey = exp($y); + my $ey_1 = 1 / $ey; + return (ref $z)->make(sin($x) * ($ey + $ey_1)/2, + cos($x) * ($ey - $ey_1)/2); +} + +# +# tan +# +# Compute tan(z) = sin(z) / cos(z). +# +sub tan { + my ($z) = @_; + my $cz = cos($z); + _divbyzero "tan($z)", "cos($z)" if ($cz == 0); + return sin($z) / $cz; +} + +# +# sec +# +# Computes the secant sec(z) = 1 / cos(z). +# +sub sec { + my ($z) = @_; + my $cz = cos($z); + _divbyzero "sec($z)", "cos($z)" if ($cz == 0); + return 1 / $cz; +} + +# +# csc +# +# Computes the cosecant csc(z) = 1 / sin(z). +# +sub csc { + my ($z) = @_; + my $sz = sin($z); + _divbyzero "csc($z)", "sin($z)" if ($sz == 0); + return 1 / $sz; +} + +# +# cosec +# +# Alias for csc(). +# +sub cosec { Math::Complex::csc(@_) } + +# +# cot +# +# Computes cot(z) = cos(z) / sin(z). +# +sub cot { + my ($z) = @_; + my $sz = sin($z); + _divbyzero "cot($z)", "sin($z)" if ($sz == 0); + return cos($z) / $sz; +} + +# +# cotan +# +# Alias for cot(). +# +sub cotan { Math::Complex::cot(@_) } + +# +# acos +# +# Computes the arc cosine acos(z) = -i log(z + sqrt(z*z-1)). +# +sub acos { + my $z = $_[0]; + return atan2(sqrt(1-$z*$z), $z) if (! ref $z) && abs($z) <= 1; + my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + my $t1 = sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = sqrt(($x-1)*($x-1) + $y*$y); + my $alpha = ($t1 + $t2)/2; + my $beta = ($t1 - $t2)/2; + $alpha = 1 if $alpha < 1; + if ($beta > 1) { $beta = 1 } + elsif ($beta < -1) { $beta = -1 } + my $u = atan2(sqrt(1-$beta*$beta), $beta); + my $v = log($alpha + sqrt($alpha*$alpha-1)); + $v = -$v if $y > 0 || ($y == 0 && $x < -1); + return $package->make($u, $v); +} + +# +# asin +# +# Computes the arc sine asin(z) = -i log(iz + sqrt(1-z*z)). +# +sub asin { + my $z = $_[0]; + return atan2($z, sqrt(1-$z*$z)) if (! ref $z) && abs($z) <= 1; + my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0); + my $t1 = sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = sqrt(($x-1)*($x-1) + $y*$y); + my $alpha = ($t1 + $t2)/2; + my $beta = ($t1 - $t2)/2; + $alpha = 1 if $alpha < 1; + if ($beta > 1) { $beta = 1 } + elsif ($beta < -1) { $beta = -1 } + my $u = atan2($beta, sqrt(1-$beta*$beta)); + my $v = -log($alpha + sqrt($alpha*$alpha-1)); + $v = -$v if $y > 0 || ($y == 0 && $x < -1); + return $package->make($u, $v); +} + +# +# atan +# +# Computes the arc tangent atan(z) = i/2 log((i+z) / (i-z)). +# +sub atan { + my ($z) = @_; + return atan2($z, 1) unless ref $z; + _divbyzero "atan(i)" if ( $z == i); + _divbyzero "atan(-i)" if (-$z == i); + my $log = log((i + $z) / (i - $z)); + $ip2 = 0.5 * i unless defined $ip2; + return $ip2 * $log; +} + +# +# asec +# +# Computes the arc secant asec(z) = acos(1 / z). +# +sub asec { + my ($z) = @_; + _divbyzero "asec($z)", $z if ($z == 0); + return acos(1 / $z); +} + +# +# acsc +# +# Computes the arc cosecant acsc(z) = asin(1 / z). +# +sub acsc { + my ($z) = @_; + _divbyzero "acsc($z)", $z if ($z == 0); + return asin(1 / $z); +} + +# +# acosec +# +# Alias for acsc(). +# +sub acosec { Math::Complex::acsc(@_) } + +# +# acot +# +# Computes the arc cotangent acot(z) = atan(1 / z) +# +sub acot { + my ($z) = @_; + return ($z >= 0) ? atan2(1, $z) : atan2(-1, -$z) unless ref $z; + _divbyzero "acot(i)", if ( $z == i); + _divbyzero "acot(-i)" if (-$z == i); + return atan(1 / $z); +} + +# +# acotan +# +# Alias for acot(). +# +sub acotan { Math::Complex::acot(@_) } + +# +# cosh +# +# Computes the hyperbolic cosine cosh(z) = (exp(z) + exp(-z))/2. +# +sub cosh { + my ($z) = @_; + my $ex; + unless (ref $z) { + $ex = exp($z); + return ($ex + 1/$ex)/2; + } + my ($x, $y) = @{$z->cartesian}; + $ex = exp($x); + my $ex_1 = 1 / $ex; + return (ref $z)->make(cos($y) * ($ex + $ex_1)/2, + sin($y) * ($ex - $ex_1)/2); +} + +# +# sinh +# +# Computes the hyperbolic sine sinh(z) = (exp(z) - exp(-z))/2. +# +sub sinh { + my ($z) = @_; + my $ex; + unless (ref $z) { + $ex = exp($z); + return ($ex - 1/$ex)/2; + } + my ($x, $y) = @{$z->cartesian}; + $ex = exp($x); + my $ex_1 = 1 / $ex; + return (ref $z)->make(cos($y) * ($ex - $ex_1)/2, + sin($y) * ($ex + $ex_1)/2); +} + +# +# tanh +# +# Computes the hyperbolic tangent tanh(z) = sinh(z) / cosh(z). +# +sub tanh { + my ($z) = @_; + my $cz = cosh($z); + _divbyzero "tanh($z)", "cosh($z)" if ($cz == 0); + return sinh($z) / $cz; +} + +# +# sech +# +# Computes the hyperbolic secant sech(z) = 1 / cosh(z). +# +sub sech { + my ($z) = @_; + my $cz = cosh($z); + _divbyzero "sech($z)", "cosh($z)" if ($cz == 0); + return 1 / $cz; +} + +# +# csch +# +# Computes the hyperbolic cosecant csch(z) = 1 / sinh(z). +# +sub csch { + my ($z) = @_; + my $sz = sinh($z); + _divbyzero "csch($z)", "sinh($z)" if ($sz == 0); + return 1 / $sz; +} + +# +# cosech +# +# Alias for csch(). +# +sub cosech { Math::Complex::csch(@_) } + +# +# coth +# +# Computes the hyperbolic cotangent coth(z) = cosh(z) / sinh(z). +# +sub coth { + my ($z) = @_; + my $sz = sinh($z); + _divbyzero "coth($z)", "sinh($z)" if ($sz == 0); + return cosh($z) / $sz; +} + +# +# cotanh +# +# Alias for coth(). +# +sub cotanh { Math::Complex::coth(@_) } + +# +# acosh +# +# Computes the arc hyperbolic cosine acosh(z) = log(z + sqrt(z*z-1)). +# +sub acosh { + my ($z) = @_; + unless (ref $z) { + return log($z + sqrt($z*$z-1)) if $z >= 1; + $z = cplx($z, 0); + } + my ($re, $im) = @{$z->cartesian}; + if ($im == 0) { + return cplx(log($re + sqrt($re*$re - 1)), 0) if $re >= 1; + return cplx(0, atan2(sqrt(1-$re*$re), $re)) if abs($re) <= 1; + } + return log($z + sqrt($z*$z - 1)); +} + +# +# asinh +# +# Computes the arc hyperbolic sine asinh(z) = log(z + sqrt(z*z-1)) +# +sub asinh { + my ($z) = @_; + return log($z + sqrt($z*$z + 1)); +} + +# +# atanh +# +# Computes the arc hyperbolic tangent atanh(z) = 1/2 log((1+z) / (1-z)). +# +sub atanh { + my ($z) = @_; + unless (ref $z) { + return log((1 + $z)/(1 - $z))/2 if abs($z) < 1; + $z = cplx($z, 0); + } + _divbyzero 'atanh(1)', "1 - $z" if ($z == 1); + _logofzero 'atanh(-1)' if ($z == -1); + return 0.5 * log((1 + $z) / (1 - $z)); +} + +# +# asech +# +# Computes the hyperbolic arc secant asech(z) = acosh(1 / z). +# +sub asech { + my ($z) = @_; + _divbyzero 'asech(0)', $z if ($z == 0); + return acosh(1 / $z); } +# +# acsch +# +# Computes the hyperbolic arc cosecant acsch(z) = asinh(1 / z). +# +sub acsch { + my ($z) = @_; + _divbyzero 'acsch(0)', $z if ($z == 0); + return asinh(1 / $z); +} + +# +# acosech +# +# Alias for acosh(). +# +sub acosech { Math::Complex::acsch(@_) } + +# +# acoth +# +# Computes the arc hyperbolic cotangent acoth(z) = 1/2 log((1+z) / (z-1)). +# +sub acoth { + my ($z) = @_; + unless (ref $z) { + return log(($z + 1)/($z - 1))/2 if abs($z) > 1; + $z = cplx($z, 0); + } + _divbyzero 'acoth(1)', "$z - 1" if ($z == 1); + _logofzero 'acoth(-1)' if ($z == -1); + return log((1 + $z) / ($z - 1)) / 2; +} + +# +# acotanh +# +# Alias for acot(). +# +sub acotanh { Math::Complex::acoth(@_) } + +# +# (atan2) +# +# Compute atan(z1/z2). +# +sub atan2 { + my ($z1, $z2, $inverted) = @_; + my ($re1, $im1, $re2, $im2); + if ($inverted) { + ($re1, $im1) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + ($re2, $im2) = @{$z1->cartesian}; + } else { + ($re1, $im1) = @{$z1->cartesian}; + ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); + } + if ($im2 == 0) { + return cplx(atan2($re1, $re2), 0) if $im1 == 0; + return cplx(($im1<=>0) * pip2, 0) if $re2 == 0; + } + my $w = atan($z1/$z2); + my ($u, $v) = ref $w ? @{$w->cartesian} : ($w, 0); + $u += pi if $re2 < 0; + $u -= pit2 if $u > pi; + return cplx($u, $v); +} + +# +# display_format +# ->display_format +# +# Set (fetch if no argument) display format for all complex numbers that +# don't happen to have overridden it via ->display_format +# +# When called as a method, this actually sets the display format for +# the current object. +# +# Valid object formats are 'c' and 'p' for cartesian and polar. The first +# letter is used actually, so the type can be fully spelled out for clarity. +# +sub display_format { + my $self = shift; + my $format = undef; + + if (ref $self) { # Called as a method + $format = shift; + } else { # Regular procedure call + $format = $self; + undef $self; + } + + if (defined $self) { + return defined $self->{display} ? $self->{display} : $display + unless defined $format; + return $self->{display} = $format; + } + + return $display unless defined $format; + return $display = $format; +} + +# +# (stringify) +# +# Show nicely formatted complex number under its cartesian or polar form, +# depending on the current display format: +# +# . If a specific display format has been recorded for this object, use it. +# . Otherwise, use the generic current default for all complex numbers, +# which is a package global variable. +# sub stringify { - my($x,$y) = @{$_[0]}; - my($re,$im); + my ($z) = shift; + my $format; - $re = $x if ($x); - if ($y == 1) {$im = 'i';} - elsif ($y == -1){$im = '-i';} - elsif ($y) {$im = "${y}i"; } + $format = $display; + $format = $z->{display} if defined $z->{display}; - local $_ = $re.'+'.$im; - s/\+-/-/; - s/^\+//; - s/[\+-]$//; - $_ = 0 if ($_ eq ''); - return $_; + return $z->stringify_polar if $format =~ /^p/i; + return $z->stringify_cartesian; +} + +# +# ->stringify_cartesian +# +# Stringify as a cartesian representation 'a+bi'. +# +sub stringify_cartesian { + my $z = shift; + my ($x, $y) = @{$z->cartesian}; + my ($re, $im); + my $eps = 1e-14; + + $x = int($x + ($x < 0 ? -1 : 1) * $eps) + if int(abs($x)) != int(abs($x) + $eps); + $y = int($y + ($y < 0 ? -1 : 1) * $eps) + if int(abs($y)) != int(abs($y) + $eps); + + $re = "$x" if abs($x) >= $eps; + if ($y == 1) { $im = 'i' } + elsif ($y == -1) { $im = '-i' } + elsif (abs($y) >= $eps) { $im = $y . "i" } + + my $str = ''; + $str = $re if defined $re; + $str .= "+$im" if defined $im; + $str =~ s/\+-/-/; + $str =~ s/^\+//; + $str = '0' unless $str; + + return $str; +} + +# +# ->stringify_polar +# +# Stringify as a polar representation '[r,t]'. +# +sub stringify_polar { + my $z = shift; + my ($r, $t) = @{$z->polar}; + my $theta; + my $eps = 1e-14; + + return '[0,0]' if $r <= $eps; + + my $nt = $t / pit2; + $nt = ($nt - int($nt)) * pit2; + $nt += pit2 if $nt < 0; # Range [0, 2pi] + + if (abs($nt) <= $eps) { $theta = 0 } + elsif (abs(pi-$nt) <= $eps) { $theta = 'pi' } + + if (defined $theta) { + $r = int($r + ($r < 0 ? -1 : 1) * $eps) + if int(abs($r)) != int(abs($r) + $eps); + $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) + if ($theta ne 'pi' and + int(abs($theta)) != int(abs($theta) + $eps)); + return "\[$r,$theta\]"; + } + + # + # Okay, number is not a real. Try to identify pi/n and friends... + # + + $nt -= pit2 if $nt > pi; + my ($n, $k, $kpi); + + for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) { + $n = int($kpi / $nt + ($nt > 0 ? 1 : -1) * 0.5); + if (abs($kpi/$n - $nt) <= $eps) { + $theta = ($nt < 0 ? '-':''). + ($k == 1 ? 'pi':"${k}pi").'/'.abs($n); + last; + } + } + + $theta = $nt unless defined $theta; + + $r = int($r + ($r < 0 ? -1 : 1) * $eps) + if int(abs($r)) != int(abs($r) + $eps); + $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) + if ($theta !~ m(^-?\d*pi/\d+$) and + int(abs($theta)) != int(abs($theta) + $eps)); + + return "\[$r,$theta\]"; } 1; @@ -125,39 +1200,393 @@ __END__ =head1 NAME -Math::Complex - complex numbers package +Math::Complex - complex numbers and associated mathematical functions =head1 SYNOPSIS - use Math::Complex; - $i = new Math::Complex; + use Math::Complex; + + $z = Math::Complex->make(5, 6); + $t = 4 - 3*i + $z; + $j = cplxe(1, 2*pi/3); =head1 DESCRIPTION -Complex numbers declared as +This package lets you create and manipulate complex numbers. By default, +I<Perl> limits itself to real numbers, but an extra C<use> statement brings +full complex support, along with a full set of mathematical functions +typically associated with and/or extended to complex numbers. + +If you wonder what complex numbers are, they were invented to be able to solve +the following equation: + + x*x = -1 + +and by definition, the solution is noted I<i> (engineers use I<j> instead since +I<i> usually denotes an intensity, but the name does not matter). The number +I<i> is a pure I<imaginary> number. + +The arithmetics with pure imaginary numbers works just like you would expect +it with real numbers... you just have to remember that + + i*i = -1 + +so you have: + + 5i + 7i = i * (5 + 7) = 12i + 4i - 3i = i * (4 - 3) = i + 4i * 2i = -8 + 6i / 2i = 3 + 1 / i = -i + +Complex numbers are numbers that have both a real part and an imaginary +part, and are usually noted: + + a + bi + +where C<a> is the I<real> part and C<b> is the I<imaginary> part. The +arithmetic with complex numbers is straightforward. You have to +keep track of the real and the imaginary parts, but otherwise the +rules used for real numbers just apply: + + (4 + 3i) + (5 - 2i) = (4 + 5) + i(3 - 2) = 9 + i + (2 + i) * (4 - i) = 2*4 + 4i -2i -i*i = 8 + 2i + 1 = 9 + 2i + +A graphical representation of complex numbers is possible in a plane +(also called the I<complex plane>, but it's really a 2D plane). +The number + + z = a + bi + +is the point whose coordinates are (a, b). Actually, it would +be the vector originating from (0, 0) to (a, b). It follows that the addition +of two complex numbers is a vectorial addition. + +Since there is a bijection between a point in the 2D plane and a complex +number (i.e. the mapping is unique and reciprocal), a complex number +can also be uniquely identified with polar coordinates: + + [rho, theta] + +where C<rho> is the distance to the origin, and C<theta> the angle between +the vector and the I<x> axis. There is a notation for this using the +exponential form, which is: + + rho * exp(i * theta) + +where I<i> is the famous imaginary number introduced above. Conversion +between this form and the cartesian form C<a + bi> is immediate: + + a = rho * cos(theta) + b = rho * sin(theta) + +which is also expressed by this formula: + + z = rho * exp(i * theta) = rho * (cos theta + i * sin theta) + +In other words, it's the projection of the vector onto the I<x> and I<y> +axes. Mathematicians call I<rho> the I<norm> or I<modulus> and I<theta> +the I<argument> of the complex number. The I<norm> of C<z> will be +noted C<abs(z)>. + +The polar notation (also known as the trigonometric +representation) is much more handy for performing multiplications and +divisions of complex numbers, whilst the cartesian notation is better +suited for additions and subtractions. Real numbers are on the I<x> +axis, and therefore I<theta> is zero or I<pi>. - $i = Math::Complex->new(1,1); +All the common operations that can be performed on a real number have +been defined to work on complex numbers as well, and are merely +I<extensions> of the operations defined on real numbers. This means +they keep their natural meaning when there is no imaginary part, provided +the number is within their definition set. -can be manipulated with overloaded math operators. The operators +For instance, the C<sqrt> routine which computes the square root of +its argument is only defined for non-negative real numbers and yields a +non-negative real number (it is an application from B<R+> to B<R+>). +If we allow it to return a complex number, then it can be extended to +negative real numbers to become an application from B<R> to B<C> (the +set of complex numbers): - + - * / neg ~ abs cos sin exp sqrt + sqrt(x) = x >= 0 ? sqrt(x) : sqrt(-x)*i -are supported as well as +It can also be extended to be an application from B<C> to B<C>, +whilst its restriction to B<R> behaves as defined above by using +the following definition: - "" (stringify) + sqrt(z = [r,t]) = sqrt(r) * exp(i * t/2) -The methods +Indeed, a negative real number can be noted C<[x,pi]> (the modulus +I<x> is always non-negative, so C<[x,pi]> is really C<-x>, a negative +number) and the above definition states that - Re Im arg + sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i -are also provided. +which is exactly what we had defined for negative real numbers above. + +All the common mathematical functions defined on real numbers that +are extended to complex numbers share that same property of working +I<as usual> when the imaginary part is zero (otherwise, it would not +be called an extension, would it?). + +A I<new> operation possible on a complex number that is +the identity for real numbers is called the I<conjugate>, and is noted +with an horizontal bar above the number, or C<~z> here. + + z = a + bi + ~z = a - bi + +Simple... Now look: + + z * ~z = (a + bi) * (a - bi) = a*a + b*b + +We saw that the norm of C<z> was noted C<abs(z)> and was defined as the +distance to the origin, also known as: + + rho = abs(z) = sqrt(a*a + b*b) + +so + + z * ~z = abs(z) ** 2 + +If z is a pure real number (i.e. C<b == 0>), then the above yields: + + a * a = abs(a) ** 2 + +which is true (C<abs> has the regular meaning for real number, i.e. stands +for the absolute value). This example explains why the norm of C<z> is +noted C<abs(z)>: it extends the C<abs> function to complex numbers, yet +is the regular C<abs> we know when the complex number actually has no +imaginary part... This justifies I<a posteriori> our use of the C<abs> +notation for the norm. + +=head1 OPERATIONS + +Given the following notations: + + z1 = a + bi = r1 * exp(i * t1) + z2 = c + di = r2 * exp(i * t2) + z = <any complex or real number> + +the following (overloaded) operations are supported on complex numbers: + + z1 + z2 = (a + c) + i(b + d) + z1 - z2 = (a - c) + i(b - d) + z1 * z2 = (r1 * r2) * exp(i * (t1 + t2)) + z1 / z2 = (r1 / r2) * exp(i * (t1 - t2)) + z1 ** z2 = exp(z2 * log z1) + ~z1 = a - bi + abs(z1) = r1 = sqrt(a*a + b*b) + sqrt(z1) = sqrt(r1) * exp(i * t1/2) + exp(z1) = exp(a) * exp(i * b) + log(z1) = log(r1) + i*t1 + sin(z1) = 1/2i (exp(i * z1) - exp(-i * z1)) + cos(z1) = 1/2 (exp(i * z1) + exp(-i * z1)) + atan2(z1, z2) = atan(z1/z2) + +The following extra operations are supported on both real and complex +numbers: + + Re(z) = a + Im(z) = b + arg(z) = t + + cbrt(z) = z ** (1/3) + log10(z) = log(z) / log(10) + logn(z, n) = log(z) / log(n) + + tan(z) = sin(z) / cos(z) + + csc(z) = 1 / sin(z) + sec(z) = 1 / cos(z) + cot(z) = 1 / tan(z) + + asin(z) = -i * log(i*z + sqrt(1-z*z)) + acos(z) = -i * log(z + i*sqrt(1-z*z)) + atan(z) = i/2 * log((i+z) / (i-z)) + + acsc(z) = asin(1 / z) + asec(z) = acos(1 / z) + acot(z) = atan(1 / z) = -i/2 * log((i+z) / (z-i)) + + sinh(z) = 1/2 (exp(z) - exp(-z)) + cosh(z) = 1/2 (exp(z) + exp(-z)) + tanh(z) = sinh(z) / cosh(z) = (exp(z) - exp(-z)) / (exp(z) + exp(-z)) + + csch(z) = 1 / sinh(z) + sech(z) = 1 / cosh(z) + coth(z) = 1 / tanh(z) + + asinh(z) = log(z + sqrt(z*z+1)) + acosh(z) = log(z + sqrt(z*z-1)) + atanh(z) = 1/2 * log((1+z) / (1-z)) + + acsch(z) = asinh(1 / z) + asech(z) = acosh(1 / z) + acoth(z) = atanh(1 / z) = 1/2 * log((1+z) / (z-1)) + +I<log>, I<csc>, I<cot>, I<acsc>, I<acot>, I<csch>, I<coth>, +I<acosech>, I<acotanh>, have aliases I<ln>, I<cosec>, I<cotan>, +I<acosec>, I<acotan>, I<cosech>, I<cotanh>, I<acosech>, I<acotanh>, +respectively. + +The I<root> function is available to compute all the I<n> +roots of some complex, where I<n> is a strictly positive integer. +There are exactly I<n> such roots, returned as a list. Getting the +number mathematicians call C<j> such that: + + 1 + j + j*j = 0; + +is a simple matter of writing: + + $j = ((root(1, 3))[1]; + +The I<k>th root for C<z = [r,t]> is given by: + + (root(z, n))[k] = r**(1/n) * exp(i * (t + 2*k*pi)/n) + +The I<spaceship> comparison operator, E<lt>=E<gt>, is also defined. In +order to ensure its restriction to real numbers is conform to what you +would expect, the comparison is run on the real part of the complex +number first, and imaginary parts are compared only when the real +parts match. + +=head1 CREATION + +To create a complex number, use either: + + $z = Math::Complex->make(3, 4); + $z = cplx(3, 4); + +if you know the cartesian form of the number, or + + $z = 3 + 4*i; + +if you like. To create a number using the polar form, use either: + + $z = Math::Complex->emake(5, pi/3); + $x = cplxe(5, pi/3); + +instead. The first argument is the modulus, the second is the angle +(in radians, the full circle is 2*pi). (Mnemonic: C<e> is used as a +notation for complex numbers in the polar form). + +It is possible to write: + + $x = cplxe(-3, pi/4); + +but that will be silently converted into C<[3,-3pi/4]>, since the modulus +must be non-negative (it represents the distance to the origin in the complex +plane). + +=head1 STRINGIFICATION + +When printed, a complex number is usually shown under its cartesian +form I<a+bi>, but there are legitimate cases where the polar format +I<[r,t]> is more appropriate. + +By calling the routine C<Math::Complex::display_format> and supplying either +C<"polar"> or C<"cartesian">, you override the default display format, +which is C<"cartesian">. Not supplying any argument returns the current +setting. + +This default can be overridden on a per-number basis by calling the +C<display_format> method instead. As before, not supplying any argument +returns the current display format for this number. Otherwise whatever you +specify will be the new display format for I<this> particular number. + +For instance: + + use Math::Complex; + + Math::Complex::display_format('polar'); + $j = ((root(1, 3))[1]; + print "j = $j\n"; # Prints "j = [1,2pi/3] + $j->display_format('cartesian'); + print "j = $j\n"; # Prints "j = -0.5+0.866025403784439i" + +The polar format attempts to emphasize arguments like I<k*pi/n> +(where I<n> is a positive integer and I<k> an integer within [-9,+9]). + +=head1 USAGE + +Thanks to overloading, the handling of arithmetics with complex numbers +is simple and almost transparent. + +Here are some examples: + + use Math::Complex; + + $j = cplxe(1, 2*pi/3); # $j ** 3 == 1 + print "j = $j, j**3 = ", $j ** 3, "\n"; + print "1 + j + j**2 = ", 1 + $j + $j**2, "\n"; + + $z = -16 + 0*i; # Force it to be a complex + print "sqrt($z) = ", sqrt($z), "\n"; + + $k = exp(i * 2*pi/3); + print "$j - $k = ", $j - $k, "\n"; + +=head1 ERRORS DUE TO DIVISION BY ZERO + +The division (/) and the following functions + + tan + sec + csc + cot + asec + acsc + atan + acot + tanh + sech + csch + coth + atanh + asech + acsch + acoth + +cannot be computed for all arguments because that would mean dividing +by zero or taking logarithm of zero. These situations cause fatal +runtime errors looking like this + + cot(0): Division by zero. + (Because in the definition of cot(0), the divisor sin(0) is 0) + Died at ... + +or + + atanh(-1): Logarithm of zero. + Died at... + +For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>, +C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the +C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the +C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the +C<atan>, C<acot>, the argument cannot be C<i> (the imaginary unit). +For the C<atan>, C<acoth>, the argument cannot be C<-i> (the negative +imaginary unit). For the C<tan>, C<sec>, C<tanh>, C<sech>, the +argument cannot be I<pi/2 + k * pi>, where I<k> is any integer. =head1 BUGS -sqrt() should return two roots, but only returns one. +Saying C<use Math::Complex;> exports many mathematical routines in the +caller environment and even overrides some (C<sqrt>, C<log>). +This is construed as a feature by the Authors, actually... ;-) + +All routines expect to be given real or complex numbers. Don't attempt to +use BigFloat, since Perl has currently no rule to disambiguate a '+' +operation (for instance) between two overloaded entities. =head1 AUTHORS -Dave Nadler, Tom Christiansen, Tim Bunce, Larry Wall. +Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>> and +Jarkko Hietaniemi <F<jhi@iki.fi>>. + +Extensive patches by Daniel S. Lewart <F<d-lewart@uiuc.edu>>. =cut + +# eof diff --git a/gnu/usr.bin/perl/lib/Net/Ping.pm b/gnu/usr.bin/perl/lib/Net/Ping.pm index 3ba88d57518..91077ddad1c 100644 --- a/gnu/usr.bin/perl/lib/Net/Ping.pm +++ b/gnu/usr.bin/perl/lib/Net/Ping.pm @@ -1,106 +1,550 @@ package Net::Ping; -# Authors: karrer@bernina.ethz.ch (Andreas Karrer) -# pmarquess@bfsec.bt.co.uk (Paul Marquess) - -require 5.002 ; +# Author: mose@ccsn.edu (Russell Mosemann) +# +# Authors of the original pingecho(): +# karrer@bernina.ethz.ch (Andreas Karrer) +# pmarquess@bfsec.bt.co.uk (Paul Marquess) +# +# Copyright (c) 1996 Russell Mosemann. All rights reserved. This +# program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +require 5.002; require Exporter; -use strict ; -use vars qw(@ISA @EXPORT $VERSION $tcp_proto $echo_port) ; +use strict; +use vars qw(@ISA @EXPORT $VERSION + $def_timeout $def_proto $max_datasize); +use FileHandle; +use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET + inet_aton sockaddr_in ); +use Carp; @ISA = qw(Exporter); -@EXPORT = qw(ping pingecho); -$VERSION = 1.01; - -use Socket 'PF_INET', 'AF_INET', 'SOCK_STREAM'; -use Carp ; - -$tcp_proto = (getprotobyname('tcp'))[2]; -$echo_port = (getservbyname('echo', 'tcp'))[2]; - -sub ping { - croak "ping not implemented yet. Use pingecho()"; -} +@EXPORT = qw(pingecho); +$VERSION = 2.02; +# Constants -sub pingecho { +$def_timeout = 5; # Default timeout to wait for a reply +$def_proto = "udp"; # Default protocol to use for pinging +$max_datasize = 1024; # Maximum data bytes in a packet - croak "usage: pingecho host [timeout]" - unless @_ == 1 or @_ == 2 ; +# Description: The pingecho() subroutine is provided for backward +# compatibility with the original Net::Ping. It accepts a host +# name/IP and an optional timeout in seconds. Create a tcp ping +# object and try pinging the host. The result of the ping is returned. - my ($host, $timeout) = @_; - my ($saddr, $ip); - my ($ret) ; - local (*PINGSOCK); +sub pingecho +{ + my ($host, # Name or IP number of host to ping + $timeout # Optional timeout in seconds + ) = @_; + my ($p); # A ping object - # check if $host is alive by connecting to its echo port, within $timeout - # (default 5) seconds. returns 1 if OK, 0 if no answer, 0 if host not found + $p = Net::Ping->new("tcp", $timeout); + $p->ping($host); # Going out of scope closes the connection +} - $timeout = 5 unless $timeout; +# Description: The new() method creates a new ping object. Optional +# parameters may be specified for the protocol to use, the timeout in +# seconds and the size in bytes of additional data which should be +# included in the packet. +# After the optional parameters are checked, the data is constructed +# and a socket is opened if appropriate. The object is returned. + +sub new +{ + my ($this, + $proto, # Optional protocol to use for pinging + $timeout, # Optional timeout in seconds + $data_size # Optional additional bytes of data + ) = @_; + my $class = ref($this) || $this; + my $self = {}; + my ($cnt, # Count through data bytes + $min_datasize # Minimum data bytes required + ); + + bless($self, $class); + + $proto = $def_proto unless $proto; # Determine the protocol + croak("Protocol for ping must be \"tcp\", \"udp\" or \"icmp\"") + unless $proto =~ m/^(tcp|udp|icmp)$/; + $self->{"proto"} = $proto; + + $timeout = $def_timeout unless $timeout; # Determine the timeout + croak("Default timeout for ping must be greater than 0 seconds") + if $timeout <= 0; + $self->{"timeout"} = $timeout; + + $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size + $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp"; + croak("Data for ping must be from $min_datasize to $max_datasize bytes") + if ($data_size < $min_datasize) || ($data_size > $max_datasize); + $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte + $self->{"data_size"} = $data_size; + + $self->{"data"} = ""; # Construct data bytes + for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++) + { + $self->{"data"} .= chr($cnt % 256); + } + + $self->{"seq"} = 0; # For counting packets + if ($self->{"proto"} eq "udp") # Open a socket + { + $self->{"proto_num"} = (getprotobyname('udp'))[2] || + croak("Can't udp protocol by name"); + $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] || + croak("Can't get udp echo port by name"); + $self->{"fh"} = FileHandle->new(); + socket($self->{"fh"}, &PF_INET(), &SOCK_DGRAM(), + $self->{"proto_num"}) || + croak("udp socket error - $!"); + } + elsif ($self->{"proto"} eq "icmp") + { + croak("icmp ping requires root privilege") if $>; + $self->{"proto_num"} = (getprotobyname('icmp'))[2] || + croak("Can't get icmp protocol by name"); + $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid + $self->{"fh"} = FileHandle->new(); + socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) || + croak("icmp socket error - $!"); + } + elsif ($self->{"proto"} eq "tcp") # Just a file handle for now + { + $self->{"proto_num"} = (getprotobyname('tcp'))[2] || + croak("Can't get tcp protocol by name"); + $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] || + croak("Can't get tcp echo port by name"); + $self->{"fh"} = FileHandle->new(); + } + + + return($self); +} - if ($host =~ /^\s*((\d+\.){3}\d+)\s*$/) - { $ip = pack ('C4', split (/\./, $1)) } +# Description: Ping a host name or IP number with an optional timeout. +# First lookup the host, and return undef if it is not found. Otherwise +# perform the specific ping method based on the protocol. Return the +# result of the ping. + +sub ping +{ + my ($self, + $host, # Name or IP number of host to ping + $timeout # Seconds after which ping times out + ) = @_; + my ($ip, # Packed IP number of $host + $ret # The return value + ); + + croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3; + $timeout = $self->{"timeout"} unless $timeout; + croak("Timeout must be greater than 0 seconds") if $timeout <= 0; + + $ip = inet_aton($host); + return(undef) unless defined($ip); # Does host exist? + + if ($self->{"proto"} eq "udp") + { + $ret = $self->ping_udp($ip, $timeout); + } + elsif ($self->{"proto"} eq "icmp") + { + $ret = $self->ping_icmp($ip, $timeout); + } + elsif ($self->{"proto"} eq "tcp") + { + $ret = $self->ping_tcp($ip, $timeout); + } else - { $ip = (gethostbyname($host))[4] } - - return 0 unless $ip; # "no such host" + { + croak("Unknown protocol \"$self->{proto}\" in ping()"); + } + return($ret); +} - $saddr = pack('S n a4 x8', AF_INET, $echo_port, $ip); - $SIG{'ALRM'} = sub { die } ; - alarm($timeout); - +sub ping_icmp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + + my $ICMP_ECHOREPLY = 0; # ICMP packet types + my $ICMP_ECHO = 8; + my $icmp_struct = "C2 S3 A"; # Structure of a minimal ICMP packet + my $subcode = 0; # No ICMP subcode for ECHO and ECHOREPLY + my $flags = 0; # No special flags when opening a socket + my $port = 0; # No port with ICMP + + my ($saddr, # sockaddr_in with port and ip + $checksum, # Checksum of ICMP packet + $msg, # ICMP packet to send + $len_msg, # Length of $msg + $rbits, # Read bits, filehandles for reading + $nfound, # Number of ready filehandles found + $finish_time, # Time ping should be finished + $done, # set to 1 when we are done + $ret, # Return value + $recv_msg, # Received message including IP header + $from_saddr, # sockaddr_in of sender + $from_port, # Port packet was sent from + $from_ip, # Packed IP of sender + $from_type, # ICMP type + $from_subcode, # ICMP subcode + $from_chk, # ICMP packet checksum + $from_pid, # ICMP packet id + $from_seq, # ICMP packet sequence + $from_msg # ICMP message + ); + + $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence + $checksum = 0; # No checksum for starters + $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode, + $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); + $checksum = Net::Ping->checksum($msg); + $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode, + $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); + $len_msg = length($msg); + $saddr = sockaddr_in($port, $ip); + send($self->{"fh"}, $msg, $flags, $saddr); # Send the message + + $rbits = ""; + vec($rbits, $self->{"fh"}->fileno(), 1) = 1; $ret = 0; + $done = 0; + $finish_time = time() + $timeout; # Must be done by this time + while (!$done && $timeout > 0) # Keep trying if we have time + { + $nfound = select($rbits, undef, undef, $timeout); # Wait for packet + $timeout = $finish_time - time(); # Get remaining time + if (!defined($nfound)) # Hmm, a strange error + { + $ret = undef; + $done = 1; + } + elsif ($nfound) # Got a packet from somewhere + { + $recv_msg = ""; + $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, $flags); + ($from_port, $from_ip) = sockaddr_in($from_saddr); + ($from_type, $from_subcode, $from_chk, + $from_pid, $from_seq, $from_msg) = + unpack($icmp_struct . $self->{"data_size"}, + substr($recv_msg, length($recv_msg) - $len_msg, + $len_msg)); + if (($from_type == $ICMP_ECHOREPLY) && + ($from_ip eq $ip) && + ($from_pid == $self->{"pid"}) && # Does the packet check out? + ($from_seq == $self->{"seq"})) + { + $ret = 1; # It's a winner + $done = 1; + } + } + else # Oops, timed out + { + $done = 1; + } + } + return($ret) +} + +# Description: Do a checksum on the message. Basically sum all of +# the short words and fold the high order bits into the low order bits. + +sub checksum +{ + my ($class, + $msg # The message to checksum + ) = @_; + my ($len_msg, # Length of the message + $num_short, # The number of short words in the message + $short, # One short word + $chk # The checksum + ); + + $len_msg = length($msg); + $num_short = $len_msg / 2; + $chk = 0; + foreach $short (unpack("S$num_short", $msg)) + { + $chk += $short; + } # Add the odd byte in + $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2; + $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low + return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement +} + +# Description: Perform a tcp echo ping. Since a tcp connection is +# host specific, we have to open and close each connection here. We +# can't just leave a socket open. Because of the robust nature of +# tcp, it will take a while before it gives up trying to establish a +# connection. Therefore, we have to set the alarm to break out of the +# connection sooner if the timeout expires. No data bytes are actually +# sent since the successful establishment of a connection is proof +# enough of the reachability of the remote host. Also, tcp is +# expensive and doesn't need our help to add to the overhead. + +sub ping_tcp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + my ($saddr, # sockaddr_in with port and ip + $ret # The return value + ); + + socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) || + croak("tcp socket error - $!"); + $saddr = sockaddr_in($self->{"port_num"}, $ip); + + $SIG{'ALRM'} = sub { die }; + alarm($timeout); # Interrupt connect() if we have to + + $ret = 0; # Default to unreachable eval <<'EOM' ; - return unless socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ; - return unless connect(PINGSOCK, $saddr) ; - $ret=1 ; + return unless connect($self->{"fh"}, $saddr); + $ret = 1; EOM alarm(0); - close(PINGSOCK); - $ret; + $self->{"fh"}->close(); + return($ret); +} + +# Description: Perform a udp echo ping. Construct a message of +# at least the one-byte sequence number and any additional data bytes. +# Send the message out and wait for a message to come back. If we +# get a message, make sure all of its parts match. If they do, we are +# done. Otherwise go back and wait for the message until we run out +# of time. Return the result of our efforts. + +sub ping_udp +{ + my ($self, + $ip, # Packed IP number of the host + $timeout # Seconds after which ping times out + ) = @_; + + my $flags = 0; # Nothing special on open + + my ($saddr, # sockaddr_in with port and ip + $ret, # The return value + $msg, # Message to be echoed + $finish_time, # Time ping should be finished + $done, # Set to 1 when we are done pinging + $rbits, # Read bits, filehandles for reading + $nfound, # Number of ready filehandles found + $from_saddr, # sockaddr_in of sender + $from_msg, # Characters echoed by $host + $from_port, # Port message was echoed from + $from_ip # Packed IP number of sender + ); + + $saddr = sockaddr_in($self->{"port_num"}, $ip); + $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence + $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any + send($self->{"fh"}, $msg, $flags, $saddr); # Send it + + $rbits = ""; + vec($rbits, $self->{"fh"}->fileno(), 1) = 1; + $ret = 0; # Default to unreachable + $done = 0; + $finish_time = time() + $timeout; # Ping needs to be done by then + while (!$done && $timeout > 0) + { + $nfound = select($rbits, undef, undef, $timeout); # Wait for response + $timeout = $finish_time - time(); # Get remaining time + + if (!defined($nfound)) # Hmm, a strange error + { + $ret = undef; + $done = 1; + } + elsif ($nfound) # A packet is waiting + { + $from_msg = ""; + $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags); + ($from_port, $from_ip) = sockaddr_in($from_saddr); + if (($from_ip eq $ip) && # Does the packet check out? + ($from_port == $self->{"port_num"}) && + ($from_msg eq $msg)) + { + $ret = 1; # It's a winner + $done = 1; + } + } + else # Oops, timed out + { + $done = 1; + } + } + return($ret); } +# Description: Close the connection unless we are using the tcp +# protocol, since it will already be closed. + +sub close +{ + my ($self) = @_; + + $self->{"fh"}->close() unless $self->{"proto"} eq "tcp"; +} + + 1; __END__ -=cut - =head1 NAME -Net::Ping, pingecho - check a host for upness +Net::Ping - check a remote host for reachability =head1 SYNOPSIS use Net::Ping; - print "'jimmy' is alive and kicking\n" if pingecho('jimmy', 10) ; - -=head1 DESCRIPTION -This module contains routines to test for the reachability of remote hosts. -Currently the only routine implemented is pingecho(). + $p = Net::Ping->new(); + print "$host is alive.\n" if $p->ping($host); + $p->close(); + + $p = Net::Ping->new("icmp"); + foreach $host (@host_array) + { + print "$host is "; + print "NOT " unless $p->ping($host, 2); + print "reachable.\n"; + sleep(1); + } + $p->close(); + + $p = Net::Ping->new("tcp", 2); + while ($stop_time > time()) + { + print "$host not reachable ", scalar(localtime()), "\n" + unless $p->ping($host); + sleep(300); + } + undef($p); + + # For backward compatibility + print "$host is alive.\n" if pingecho($host); -pingecho() uses a TCP echo (I<not> an ICMP one) to determine if the -remote host is reachable. This is usually adequate to tell that a remote -host is available to rsh(1), ftp(1), or telnet(1) onto. +=head1 DESCRIPTION -=head2 Parameters +This module contains methods to test the reachability of remote +hosts on a network. A ping object is first created with optional +parameters, a variable number of hosts may be pinged multiple +times and then the connection is closed. + +You may choose one of three different protocols to use for the ping. +With the "tcp" protocol the ping() method attempts to establish a +connection to the remote host's echo port. If the connection is +successfully established, the remote host is considered reachable. No +data is actually echoed. This protocol does not require any special +privileges but has higher overhead than the other two protocols. + +Specifying the "udp" protocol causes the ping() method to send a udp +packet to the remote host's echo port. If the echoed packet is +received from the remote host and the received packet contains the +same data as the packet that was sent, the remote host is considered +reachable. This protocol does not require any special privileges. + +If the "icmp" protocol is specified, the ping() method sends an icmp +echo message to the remote host, which is what the UNIX ping program +does. If the echoed message is received from the remote host and +the echoed information is correct, the remote host is considered +reachable. Specifying the "icmp" protocol requires that the program +be run as root or that the program be setuid to root. + +=head2 Functions + +=over 4 + +=item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]); + +Create a new ping object. All of the parameters are optional. $proto +specifies the protocol to use when doing a ping. The current choices +are "tcp", "udp" or "icmp". The default is "udp". + +If a default timeout ($def_timeout) in seconds is provided, it is used +when a timeout is not given to the ping() method (below). The timeout +must be greater than 0 and the default, if not specified, is 5 seconds. + +If the number of data bytes ($bytes) is given, that many data bytes +are included in the ping packet sent to the remote host. The number of +data bytes is ignored if the protocol is "tcp". The minimum (and +default) number of data bytes is 1 if the protocol is "udp" and 0 +otherwise. The maximum number of data bytes that can be specified is +1024. + +=item $p->ping($host [, $timeout]); + +Ping the remote host and wait for a response. $host can be either the +hostname or the IP number of the remote host. The optional timeout +must be greater than 0 seconds and defaults to whatever was specified +when the ping object was created. If the hostname cannot be found or +there is a problem with the IP number, undef is returned. Otherwise, +1 is returned if the host is reachable and 0 if it is not. For all +practical purposes, undef and 0 and can be treated as the same case. + +=item $p->close(); + +Close the network connection for this ping object. The network +connection is also closed by "undef $p". The network connection is +automatically closed if the ping object goes out of scope (e.g. $p is +local to a subroutine and you leave the subroutine). + +=item pingecho($host [, $timeout]); + +To provide backward compatibility with the previous version of +Net::Ping, a pingecho() subroutine is available with the same +functionality as before. pingecho() uses the tcp protocol. The +return values and parameters are the same as described for the ping() +method. This subroutine is obsolete and may be removed in a future +version of Net::Ping. -=over 5 +=back -=item hostname +=head1 WARNING -The remote host to check, specified either as a hostname or as an IP address. +pingecho() or a ping object with the tcp protocol use alarm() to +implement the timeout. So, don't use alarm() in your program while +you are using pingecho() or a ping object with the tcp protocol. The +udp and icmp protocols do not use alarm() to implement the timeout. -=item timeout +=head1 NOTES -The timeout in seconds. If not specified it will default to 5 seconds. +There will be less network overhead (and some efficiency in your +program) if you specify either the udp or the icmp protocol. The tcp +protocol will generate 2.5 times or more traffic for each ping than +either udp or icmp. If many hosts are pinged frequently, you may wish +to implement a small wait (e.g. 25ms or more) between each ping to +avoid flooding your network with packets. -=back +The icmp protocol requires that the program be run as root or that it +be setuid to root. The tcp and udp protocols do not require special +privileges, but not all network devices implement the echo protocol +for tcp or udp. -=head1 WARNING +Local hosts should normally respond to pings within milliseconds. +However, on a very congested network it may take up to 3 seconds or +longer to receive an echo packet from the remote host. If the timeout +is set too low under these conditions, it will appear that the remote +host is not reachable (which is almost the truth). -pingecho() uses alarm to implement the timeout, so don't set another alarm -while you are using it. +Reachability doesn't necessarily mean that the remote host is actually +functioning beyond its ability to echo packets. +Because of a lack of anything better, this module uses its own +routines to pack and unpack ICMP packets. It would be better for a +separate module to be written which understands all of the different +kinds of ICMP packets. +=cut diff --git a/gnu/usr.bin/perl/lib/Pod/Functions.pm b/gnu/usr.bin/perl/lib/Pod/Functions.pm index a775cf61654..3cc9b385a00 100644 --- a/gnu/usr.bin/perl/lib/Pod/Functions.pm +++ b/gnu/usr.bin/perl/lib/Pod/Functions.pm @@ -5,7 +5,7 @@ package Pod::Functions; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(%Kinds %Type %Flavor %Type_Descriptions @Type_Order); +@EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order); %Type_Description = ( 'ARRAY' => 'Functions for real @ARRAYs', @@ -193,6 +193,7 @@ my Misc,Namespace declare and assign a local variable (lexical scoping) next Flow iterate a block prematurely no Modules unimport some module symbols or semantics at compile time package Modules,Objects,Namespace declare a separate global namespace +prototype Flow,Misc get the prototype (if any) of a subroutine oct String,Math convert a string to an octal number open File open a file, pipe, or descriptor opendir File open a directory diff --git a/gnu/usr.bin/perl/lib/Pod/Text.pm b/gnu/usr.bin/perl/lib/Pod/Text.pm index ac4f72b688b..2b6c6b62971 100644 --- a/gnu/usr.bin/perl/lib/Pod/Text.pm +++ b/gnu/usr.bin/perl/lib/Pod/Text.pm @@ -1,7 +1,5 @@ package Pod::Text; -# Version 1.01 - =head1 NAME Pod::Text - convert POD data to formatted ASCII text @@ -14,7 +12,7 @@ Pod::Text - convert POD data to formatted ASCII text Also: - pod2text < input.pod + pod2text [B<-a>] [B<->I<width>] < input.pod =head1 DESCRIPTION @@ -27,14 +25,16 @@ will be used to simulate bold and underlined text. A separate F<pod2text> program is included that is primarily a wrapper for Pod::Text. -The single function C<pod2text()> can take one or two arguments. The first -should be the name of a file to read the pod from, or "<&STDIN" to read from +The single function C<pod2text()> can take the optional options B<-a> +for an alternative output format, then a B<->I<width> option with the +max terminal width, followed by one or two arguments. The first +should be the name of a file to read the pod from, or "E<lt>&STDIN" to read from STDIN. A second argument, if provided, should be a filehandle glob where output should be sent. =head1 AUTHOR -Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> +Tom Christiansen E<lt>F<tchrist@mox.perl.com>E<gt> =head1 TODO @@ -49,8 +49,13 @@ require Exporter; @ISA = Exporter; @EXPORT = qw(pod2text); +use vars qw($VERSION); +$VERSION = "1.0203"; + $termcap=0; +$opt_alt_format = 0; + #$use_format=1; $UNDL = "\x1b[4m"; @@ -59,8 +64,7 @@ $BOLD = "\x1b[1m"; $NORM = "\x1b[0m"; sub pod2text { -local($file,*OUTPUT) = @_; -*OUTPUT = *STDOUT if @_<2; +shift if $opt_alt_format = ($_[0] eq '-a'); if($termcap and !$setuptermcap) { $setuptermcap=1; @@ -73,11 +77,18 @@ if($termcap and !$setuptermcap) { } $SCREEN = ($_[0] =~ /^-(\d+)/ && (shift, $1)) - || ($ENV{TERMCAP} =~ /co#(\d+)/)[0] || $ENV{COLUMNS} - || (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0] + || ($ENV{TERMCAP} =~ /co#(\d+)/)[0] + || ($^O ne 'MSWin32' && (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0]) || 72; +@_ = ("<&STDIN") unless @_; +local($file,*OUTPUT) = @_; +*OUTPUT = *STDOUT if @_<2; + +local $: = $:; +$: = " \n" if $opt_alt_format; # Do not break ``-L/lib/'' into ``- L/lib/''. + $/ = ""; $FANCY = 0; @@ -86,6 +97,7 @@ $cutting = 1; $DEF_INDENT = 4; $indent = $DEF_INDENT; $needspace = 0; +$begun = ""; open(IN, $file) || die "Couldn't open $file: $!"; @@ -94,6 +106,15 @@ POD_DIRECTIVE: while (<IN>) { next unless /^=/; $cutting = 0; } + if ($begun) { + if (/^=end\s+$begun/) { + $begun = ""; + } + elsif ($begun eq "text") { + print OUTPUT $_; + } + next; + } 1 while s{^(.*?)(\t+)(.*)$}{ $1 . (' ' x (length($2) * 8 - length($1) % 8)) @@ -101,11 +122,26 @@ POD_DIRECTIVE: while (<IN>) { }me; # Translate verbatim paragraph if (/^\s/) { - $needspace = 1; output($_); next; } + if (/^=for\s+(\S+)\s*(.*)/s) { + if ($1 eq "text") { + print OUTPUT $2,""; + } else { + # ignore unknown for + } + next; + } + elsif (/^=begin\s+(\S+)\s*(.*)/s) { + $begun = $1; + if ($1 eq "text") { + print OUTPUT $2.""; + } + next; + } + sub prepare_for_output { s/\s*$/\n/; @@ -116,14 +152,19 @@ sub prepare_for_output { $maxnest = 10; while ($maxnest-- && /[A-Z]</) { unless ($FANCY) { - s/C<(.*?)>/`$1'/g; + if ($opt_alt_format) { + s/[BC]<(.*?)>/``$1''/sg; + s/F<(.*?)>/"$1"/sg; + } else { + s/C<(.*?)>/`$1'/sg; + } } else { - s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/ge; + s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/sge; } # s/[IF]<(.*?)>/italic($1)/ge; - s/I<(.*?)>/*$1*/g; + s/I<(.*?)>/*$1*/sg; # s/[CB]<(.*?)>/bold($1)/ge; - s/X<.*?>//g; + s/X<.*?>//sg; # LREF: a manpage(3f) s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the $1$2 manpage:g; # LREF: an =item on another manpage @@ -167,9 +208,9 @@ sub prepare_for_output { ? "the section on \"$2\" in the $1 manpage" : "the section on \"$2\"" } - }gex; + }sgex; - s/[A-Z]<(.*?)>/$1/g; + s/[A-Z]<(.*?)>/$1/sg; } clear_noremap(1); } @@ -184,10 +225,18 @@ sub prepare_for_output { if ($Cmd eq 'cut') { $cutting = 1; } + elsif ($Cmd eq 'pod') { + $cutting = 0; + } elsif ($Cmd eq 'head1') { makespace(); + if ($opt_alt_format) { + print OUTPUT "\n"; + s/^(.+?)[ \t]*$/==== $1 ====/; + } print OUTPUT; # print OUTPUT uc($_); + $needspace = $opt_alt_format; } elsif ($Cmd eq 'head2') { makespace(); @@ -195,7 +244,13 @@ sub prepare_for_output { #print ' ' x $DEF_INDENT, $_; # print "\xA7"; s/(\w)/\xA7 $1/ if $FANCY; - print OUTPUT ' ' x ($DEF_INDENT/2), $_, "\n"; + if ($opt_alt_format) { + s/^(.+?)[ \t]*$/== $1 ==/; + print OUTPUT "\n", $_; + } else { + print OUTPUT ' ' x ($DEF_INDENT/2), $_, "\n"; + } + $needspace = $opt_alt_format; } elsif ($Cmd eq 'over') { push(@indent,$indent); @@ -204,7 +259,6 @@ sub prepare_for_output { elsif ($Cmd eq 'back') { $indent = pop(@indent); warn "Unmatched =back\n" unless defined $indent; - $needspace = 1; } elsif ($Cmd eq 'item') { makespace(); @@ -223,7 +277,7 @@ sub prepare_for_output { IP_output($paratag, $_); } else { local($indent) = $indent[$#index - 1] || $DEF_INDENT; - output($_); + output($_, 0); } } } @@ -317,7 +371,9 @@ sub IP_output { s/\s+/ /g; s/^ //; $str = "format OUTPUT = \n" - . (" " x ($tag_indent)) + . (($opt_alt_format && $tag_indent > 1) + ? ":" . " " x ($tag_indent - 1) + : " " x ($tag_indent)) . '@' . ('<' x ($indent - $tag_indent - 1)) . "^" . ("<" x ($cols - 1)) . "\n" . '$tag, $_' @@ -345,6 +401,7 @@ sub output { } else { s/^/' ' x $indent/gem; s/^\s+\n$/\n/gm; + s/^ /: /s if defined($reformat) && $opt_alt_format; print OUTPUT; } } @@ -357,9 +414,8 @@ sub noremap { sub init_noremap { die "unmatched init" if $mapready++; - if ( /[\200-\377]/ ) { - warn "hit bit char in input stream"; - } + #mask off high bit characters in input stream + s/([\200-\377])/"E<".ord($1).">"/ge; } sub clear_noremap { @@ -370,15 +426,21 @@ sub clear_noremap { # otherwise the interative \w<> processing would have # been hosed by the E<gt> s { - E< - ( [A-Za-z]+ ) + E< + ( + ( \d+ ) + | ( [A-Za-z]+ ) + ) > } { do { - defined $HTML_Escapes{$1} - ? do { $HTML_Escapes{$1} } + defined $2 + ? chr($2) + : + defined $HTML_Escapes{$3} + ? do { $HTML_Escapes{$3} } : do { - warn "Unknown escape: $& in $_"; + warn "Unknown escape: E<$1> in $_"; "E<$1>"; } } diff --git a/gnu/usr.bin/perl/lib/Search/Dict.pm b/gnu/usr.bin/perl/lib/Search/Dict.pm index 295da6b31d2..9a229a7bc02 100644 --- a/gnu/usr.bin/perl/lib/Search/Dict.pm +++ b/gnu/usr.bin/perl/lib/Search/Dict.pm @@ -37,7 +37,7 @@ sub look { my($size, $blksize) = @stat[7,11]; $blksize ||= 8192; $key =~ s/[^\w\s]//g if $dict; - $key =~ tr/A-Z/a-z/ if $fold; + $key = lc $key if $fold; my($min, $max, $mid) = (0, int($size / $blksize)); while ($max - $min > 1) { $mid = int(($max + $min) / 2); @@ -47,7 +47,7 @@ sub look { $_ = <FH>; chop; s/[^\w\s]//g if $dict; - tr/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; if (defined($_) && $_ lt $key) { $min = $mid; } @@ -61,11 +61,11 @@ sub look { <FH> if $min; for (;;) { $min = tell(FH); - $_ = <FH> + defined($_ = <FH>) or last; chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; last if $_ ge $key; } seek(FH,$min,0); diff --git a/gnu/usr.bin/perl/lib/SelectSaver.pm b/gnu/usr.bin/perl/lib/SelectSaver.pm index 4c764bedcf1..5f569222fcc 100644 --- a/gnu/usr.bin/perl/lib/SelectSaver.pm +++ b/gnu/usr.bin/perl/lib/SelectSaver.pm @@ -38,8 +38,10 @@ use Symbol; sub new { @_ >= 1 && @_ <= 2 or croak 'usage: new SelectSaver [FILEHANDLE]'; - my $fh = (@_ > 1) ? (select qualify($_[1], caller)) : select; - bless [$fh], $_[0]; + my $fh = select; + my $self = bless [$fh], $_[0]; + select qualify($_[1], caller) if @_ > 1; + $self; } sub DESTROY { diff --git a/gnu/usr.bin/perl/lib/SelfLoader.pm b/gnu/usr.bin/perl/lib/SelfLoader.pm index e3da9ebadbc..f93841c862a 100644 --- a/gnu/usr.bin/perl/lib/SelfLoader.pm +++ b/gnu/usr.bin/perl/lib/SelfLoader.pm @@ -3,25 +3,26 @@ use Carp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(AUTOLOAD); -$VERSION = 1.06; sub Version {$VERSION} +$VERSION = 1.07; sub Version {$VERSION} $DEBUG = 0; my %Cache; # private cache for all SelfLoader's client packages AUTOLOAD { print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if $DEBUG; - my $code = $Cache{$AUTOLOAD}; - unless ($code) { + my $SL_code = $Cache{$AUTOLOAD}; + unless ($SL_code) { # Maybe this pack had stubs before __DATA__, and never initialized. # Or, this maybe an automatic DESTROY method call when none exists. $AUTOLOAD =~ m/^(.*)::/; SelfLoader->_load_stubs($1) unless exists $Cache{"${1}::<DATA"}; - $code = $Cache{$AUTOLOAD}; - $code = "sub $AUTOLOAD { }" if (!$code and $AUTOLOAD =~ m/::DESTROY$/); - croak "Undefined subroutine $AUTOLOAD" unless $code; + $SL_code = $Cache{$AUTOLOAD}; + $SL_code = "sub $AUTOLOAD { }" + if (!$SL_code and $AUTOLOAD =~ m/::DESTROY$/); + croak "Undefined subroutine $AUTOLOAD" unless $SL_code; } - print STDERR "SelfLoader::AUTOLOAD eval: $code\n" if $DEBUG; - eval $code; + print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if $DEBUG; + eval $SL_code; if ($@) { $@ =~ s/ at .*\n//; croak $@; @@ -44,8 +45,8 @@ sub _load_stubs { unless fileno($fh); $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached - while($line = <$fh> and $line !~ m/^__END__/) { - if ($line =~ m/^sub\s+([\w:]+)\s*(\([\$\@\;\%\\]*\))?/) { # A sub declared + while(defined($line = <$fh>) and $line !~ m/^__END__/) { + if ($line =~ m/^sub\s+([\w:]+)\s*(\([\\\$\@\%\&\*\;]*\))?/) { push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype)); $protoype = $2; @lines = ($line); @@ -119,117 +120,123 @@ SelfLoader - load functions only on demand =head1 DESCRIPTION This module tells its users that functions in the FOOBAR package are to be -autoloaded from after the __DATA__ token. See also L<perlsub/"Autoloading">. +autoloaded from after the C<__DATA__> token. See also +L<perlsub/"Autoloading">. =head2 The __DATA__ token -The __DATA__ token tells the perl compiler that the perl code -for compilation is finished. Everything after the __DATA__ token +The C<__DATA__> token tells the perl compiler that the perl code +for compilation is finished. Everything after the C<__DATA__> token is available for reading via the filehandle FOOBAR::DATA, -where FOOBAR is the name of the current package when the __DATA__ -token is reached. This works just the same as __END__ does in -package 'main', but for other modules data after __END__ is not -automatically retreivable , whereas data after __DATA__ is. -The __DATA__ token is not recognized in versions of perl prior to +where FOOBAR is the name of the current package when the C<__DATA__> +token is reached. This works just the same as C<__END__> does in +package 'main', but for other modules data after C<__END__> is not +automatically retreivable , whereas data after C<__DATA__> is. +The C<__DATA__> token is not recognized in versions of perl prior to 5.001m. -Note that it is possible to have __DATA__ tokens in the same package -in multiple files, and that the last __DATA__ token in a given +Note that it is possible to have C<__DATA__> tokens in the same package +in multiple files, and that the last C<__DATA__> token in a given package that is encountered by the compiler is the one accessible -by the filehandle. This also applies to __END__ and main, i.e. if -the 'main' program has an __END__, but a module 'require'd (_not_ 'use'd) -by that program has a 'package main;' declaration followed by an '__DATA__', -then the DATA filehandle is set to access the data after the __DATA__ -in the module, _not_ the data after the __END__ token in the 'main' +by the filehandle. This also applies to C<__END__> and main, i.e. if +the 'main' program has an C<__END__>, but a module 'require'd (_not_ 'use'd) +by that program has a 'package main;' declaration followed by an 'C<__DATA__>', +then the C<DATA> filehandle is set to access the data after the C<__DATA__> +in the module, _not_ the data after the C<__END__> token in the 'main' program, since the compiler encounters the 'require'd file later. =head2 SelfLoader autoloading -The SelfLoader works by the user placing the __DATA__ -token _after_ perl code which needs to be compiled and -run at 'require' time, but _before_ subroutine declarations +The B<SelfLoader> works by the user placing the C<__DATA__> +token I<after> perl code which needs to be compiled and +run at 'require' time, but I<before> subroutine declarations that can be loaded in later - usually because they may never be called. -The SelfLoader will read from the FOOBAR::DATA filehandle to -load in the data after __DATA__, and load in any subroutine +The B<SelfLoader> will read from the FOOBAR::DATA filehandle to +load in the data after C<__DATA__>, and load in any subroutine when it is called. The costs are the one-time parsing of the -data after __DATA__, and a load delay for the _first_ +data after C<__DATA__>, and a load delay for the _first_ call of any autoloaded function. The benefits (hopefully) are a speeded up compilation phase, with no need to load functions which are never used. -The SelfLoader will stop reading from __DATA__ if -it encounters the __END__ token - just as you would expect. -If the __END__ token is present, and is followed by the -token DATA, then the SelfLoader leaves the FOOBAR::DATA +The B<SelfLoader> will stop reading from C<__DATA__> if +it encounters the C<__END__> token - just as you would expect. +If the C<__END__> token is present, and is followed by the +token DATA, then the B<SelfLoader> leaves the FOOBAR::DATA filehandle open on the line after that token. -The SelfLoader exports the AUTOLOAD subroutine to the -package using the SelfLoader, and this loads the called +The B<SelfLoader> exports the C<AUTOLOAD> subroutine to the +package using the B<SelfLoader>, and this loads the called subroutine when it is first called. There is no advantage to putting subroutines which will _always_ -be called after the __DATA__ token. +be called after the C<__DATA__> token. =head2 Autoloading and package lexicals A 'my $pack_lexical' statement makes the variable $pack_lexical -local _only_ to the file up to the __DATA__ token. Subroutines +local _only_ to the file up to the C<__DATA__> token. Subroutines declared elsewhere _cannot_ see these types of variables, just as if you declared subroutines in the package but in another file, they cannot see these variables. So specifically, autoloaded functions cannot see package -lexicals (this applies to both the SelfLoader and the Autoloader). +lexicals (this applies to both the B<SelfLoader> and the Autoloader). +The C<vars> pragma provides an alternative to defining package-level +globals that will be visible to autoloaded routines. See the documentation +on B<vars> in the pragma section of L<perlmod>. =head2 SelfLoader and AutoLoader -The SelfLoader can replace the AutoLoader - just change 'use AutoLoader' -to 'use SelfLoader' (though note that the SelfLoader exports +The B<SelfLoader> can replace the AutoLoader - just change 'use AutoLoader' +to 'use SelfLoader' (though note that the B<SelfLoader> exports the AUTOLOAD function - but if you have your own AUTOLOAD and are using the AutoLoader too, you probably know what you're doing), -and the __END__ token to __DATA__. You will need perl version 5.001m +and the C<__END__> token to C<__DATA__>. You will need perl version 5.001m or later to use this (version 5.001 with all patches up to patch m). -There is no need to inherit from the SelfLoader. +There is no need to inherit from the B<SelfLoader>. -The SelfLoader works similarly to the AutoLoader, but picks up the -subs from after the __DATA__ instead of in the 'lib/auto' directory. +The B<SelfLoader> works similarly to the AutoLoader, but picks up the +subs from after the C<__DATA__> instead of in the 'lib/auto' directory. There is a maintainance gain in not needing to run AutoSplit on the module at installation, and a runtime gain in not needing to keep opening and closing files to load subs. There is a runtime loss in needing -to parse the code after the __DATA__. +to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and +another view of these distinctions can be found in that module's +documentation. =head2 __DATA__, __END__, and the FOOBAR::DATA filehandle. This section is only relevant if you want to use -the FOOBAR::DATA together with the SelfLoader. - -Data after the __DATA__ token in a module is read using the -FOOBAR::DATA filehandle. __END__ can still be used to denote the end -of the __DATA__ section if followed by the token DATA - this is supported -by the SelfLoader. The FOOBAR::DATA filehandle is left open if an __END__ -followed by a DATA is found, with the filehandle positioned at the start -of the line after the __END__ token. If no __END__ token is present, -or an __END__ token with no DATA token on the same line, then the filehandle -is closed. - -The SelfLoader reads from wherever the current -position of the FOOBAR::DATA filehandle is, until the -EOF or __END__. This means that if you want to use +the C<FOOBAR::DATA> together with the B<SelfLoader>. + +Data after the C<__DATA__> token in a module is read using the +FOOBAR::DATA filehandle. C<__END__> can still be used to denote the end +of the C<__DATA__> section if followed by the token DATA - this is supported +by the B<SelfLoader>. The C<FOOBAR::DATA> filehandle is left open if an +C<__END__> followed by a DATA is found, with the filehandle positioned at +the start of the line after the C<__END__> token. If no C<__END__> token is +present, or an C<__END__> token with no DATA token on the same line, then +the filehandle is closed. + +The B<SelfLoader> reads from wherever the current +position of the C<FOOBAR::DATA> filehandle is, until the +EOF or C<__END__>. This means that if you want to use that filehandle (and ONLY if you want to), you should either 1. Put all your subroutine declarations immediately after -the __DATA__ token and put your own data after those -declarations, using the __END__ token to mark the end -of subroutine declarations. You must also ensure that the SelfLoader -reads first by calling 'SelfLoader->load_stubs();', or by using a +the C<__DATA__> token and put your own data after those +declarations, using the C<__END__> token to mark the end +of subroutine declarations. You must also ensure that the B<SelfLoader> +reads first by calling 'SelfLoader-E<gt>load_stubs();', or by using a function which is selfloaded; or -2. You should read the FOOBAR::DATA filehandle first, leaving +2. You should read the C<FOOBAR::DATA> filehandle first, leaving the handle open and positioned at the first line of subroutine declarations. @@ -252,11 +259,11 @@ need for stubs as far as autoloading is concerned. For modules which ARE classes, and need to handle inherited methods, stubs are needed to ensure that the method inheritance mechanism works properly. You can load the stubs into the module at 'require' time, by -adding the statement 'SelfLoader->load_stubs();' to the module to do +adding the statement 'SelfLoader-E<gt>load_stubs();' to the module to do this. -The alternative is to put the stubs in before the __DATA__ token BEFORE -releasing the module, and for this purpose the Devel::SelfStubber +The alternative is to put the stubs in before the C<__DATA__> token BEFORE +releasing the module, and for this purpose the C<Devel::SelfStubber> module is available. However this does require the extra step of ensuring that the stubs are in the module. If this is done I strongly recommend that this is done BEFORE releasing the module - it should NOT be done @@ -265,10 +272,10 @@ at install time in general. =head1 Multiple packages and fully qualified subroutine names Subroutines in multiple packages within the same file are supported - but you -should note that this requires exporting the SelfLoader::AUTOLOAD to +should note that this requires exporting the C<SelfLoader::AUTOLOAD> to every package which requires it. This is done automatically by the -SelfLoader when it first loads the subs into the cache, but you should -really specify it in the initialization before the __DATA__ by putting +B<SelfLoader> when it first loads the subs into the cache, but you should +really specify it in the initialization before the C<__DATA__> by putting a 'use SelfLoader' statement in each package. Fully qualified subroutine names are also supported. For example, @@ -278,8 +285,9 @@ Fully qualified subroutine names are also supported. For example, package baz; sub dob {32} -will all be loaded correctly by the SelfLoader, and the SelfLoader +will all be loaded correctly by the B<SelfLoader>, and the B<SelfLoader> will ensure that the packages 'foo' and 'baz' correctly have the -SelfLoader AUTOLOAD method when the data after __DATA__ is first parsed. +B<SelfLoader> C<AUTOLOAD> method when the data after C<__DATA__> is first +parsed. =cut diff --git a/gnu/usr.bin/perl/lib/Shell.pm b/gnu/usr.bin/perl/lib/Shell.pm index bb44b5398b5..f4ef431cc54 100644 --- a/gnu/usr.bin/perl/lib/Shell.pm +++ b/gnu/usr.bin/perl/lib/Shell.pm @@ -21,7 +21,7 @@ AUTOLOAD { my $cmd = $AUTOLOAD; $cmd =~ s/^.*:://; eval qq { - sub $AUTOLOAD { + *$AUTOLOAD = sub { if (\@_ < 1) { `$cmd`; } diff --git a/gnu/usr.bin/perl/lib/Symbol.pm b/gnu/usr.bin/perl/lib/Symbol.pm index 67808af082a..6807e74479a 100644 --- a/gnu/usr.bin/perl/lib/Symbol.pm +++ b/gnu/usr.bin/perl/lib/Symbol.pm @@ -23,6 +23,10 @@ Symbol - manipulate Perl symbols and their names print qualify(\*x), "\n"; # returns \*x print qualify(\*x, "FOO"), "\n"; # returns \*x + use strict refs; + print { qualify_to_ref $fh } "foo!\n"; + $ref = qualify_to_ref $name, $pkg; + =head1 DESCRIPTION C<Symbol::gensym> creates an anonymous glob and returns a reference @@ -34,7 +38,7 @@ support anonymous globs, C<Symbol::ungensym> is also provided. But it doesn't do anything. C<Symbol::qualify> turns unqualified symbol names into qualified -variable names (e.g. "myvar" -> "MyPackage::myvar"). If it is given a +variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a second parameter, C<qualify> uses it as the default package; otherwise, it uses the package of its caller. Regardless, global variable names (e.g. "STDOUT", "ENV", "SIG") are always qualfied with @@ -44,29 +48,35 @@ Qualification applies only to symbol names (strings). References are left unchanged under the assumption that they are glob references, which are qualified by their nature. +C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it +returns a glob ref rather than a symbol name, so you can use the result +even if C<use strict 'refs'> is in effect. + =cut BEGIN { require 5.002; } require Exporter; @ISA = qw(Exporter); +@EXPORT = qw(gensym ungensym qualify qualify_to_ref); -@EXPORT = qw(gensym ungensym qualify); +$VERSION = 1.02; my $genpkg = "Symbol::"; my $genseq = 0; -my %global; -while (<DATA>) { - chomp; - $global{$_} = 1; -} -close DATA; +my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT); +# +# Note that we never _copy_ the glob; we just make a ref to it. +# If we did copy it, then SVf_FAKE would be set on the copy, and +# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work. +# sub gensym () { my $name = "GEN" . $genseq++; - local *{$genpkg . $name}; - \delete ${$genpkg}{$name}; + my $ref = \*{$genpkg . $name}; + delete $$genpkg{$name}; + $ref; } sub ungensym ($) {} @@ -87,14 +97,8 @@ sub qualify ($;$) { $name; } -1; +sub qualify_to_ref ($;$) { + return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller }; +} -__DATA__ -ARGV -ARGVOUT -ENV -INC -SIG -STDERR -STDIN -STDOUT +1; diff --git a/gnu/usr.bin/perl/lib/Sys/Hostname.pm b/gnu/usr.bin/perl/lib/Sys/Hostname.pm index 2c40361b51a..95f9a99a7ab 100644 --- a/gnu/usr.bin/perl/lib/Sys/Hostname.pm +++ b/gnu/usr.bin/perl/lib/Sys/Hostname.pm @@ -25,7 +25,7 @@ All nulls, returns, and newlines are removed from the result. =head1 AUTHOR -David Sundstrom <sunds@asictest.sc.ti.com> +David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt> Texas Instruments @@ -39,7 +39,7 @@ sub hostname { if ($^O eq 'VMS') { # method 2 - no sockets ==> return DECnet node name - eval {gethostbyname('me')}; + eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] }; if ($@) { return $host = $ENV{'SYS$NODE'}; } # method 3 - has someone else done the job already? It's common for the @@ -60,10 +60,16 @@ sub hostname { Carp::croak "Cannot get host name of local machine"; } + elsif ($^O eq 'MSWin32') { + ($host) = gethostbyname('localhost'); + chomp($host = `hostname 2> NUL`) unless defined $host; + return $host; + } else { # Unix # method 2 - syscall is preferred since it avoids tainting problems eval { + local $SIG{__DIE__}; { package main; require "syscall.ph"; @@ -72,18 +78,34 @@ sub hostname { syscall(&main::SYS_gethostname, $host, 65) == 0; } + # method 2a - syscall using systeminfo instead of gethostname + # -- needed on systems like Solaris + || eval { + local $SIG{__DIE__}; + { + package main; + require "sys/syscall.ph"; + require "sys/systeminfo.ph"; + } + $host = "\0" x 65; ## preload scalar + syscall(&main::SYS_systeminfo, &main::SI_HOSTNAME, $host, 65) != -1; + } + # method 3 - trusty old hostname command || eval { + local $SIG{__DIE__}; $host = `(hostname) 2>/dev/null`; # bsdish } # method 4 - sysV uname command (may truncate) || eval { + local $SIG{__DIE__}; $host = `uname -n 2>/dev/null`; ## sysVish } # method 5 - Apollo pre-SR10 || eval { + local $SIG{__DIE__}; ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6); } diff --git a/gnu/usr.bin/perl/lib/Sys/Syslog.pm b/gnu/usr.bin/perl/lib/Sys/Syslog.pm index f02a2b516c3..709f5785f5d 100644 --- a/gnu/usr.bin/perl/lib/Sys/Syslog.pm +++ b/gnu/usr.bin/perl/lib/Sys/Syslog.pm @@ -7,6 +7,7 @@ use Carp; @EXPORT = qw(openlog closelog setlogmask syslog); use Socket; +use Sys::Hostname; # adapted from syslog.pl # @@ -23,7 +24,7 @@ Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX use Sys::Syslog; openlog $ident, $logopt, $facility; - syslog $priority, $mask, $format, @args; + syslog $priority, $format, @args; $oldmask = setlogmask $mask_priority; closelog; @@ -43,9 +44,9 @@ I<$ident> is prepended to every message. I<$logopt> contains one or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>. I<$facility> specifies the part of the system -=item syslog $priority, $mask, $format, @args +=item syslog $priority, $format, @args -If I<$priority> and I<$mask> permit, logs I<($format, @args)> +If I<$priority> permits, logs I<($format, @args)> printed as by C<printf(3V)>, with the addition that I<%m> is replaced with C<"$!"> (the latest error message). @@ -53,6 +54,20 @@ is replaced with C<"$!"> (the latest error message). Sets log mask I<$mask_priority> and returns the old mask. +=item setlogsock $sock_type (added in 5.004_03) + +Sets the socket type to be used for the next call to +C<openlog()> or C<syslog()>. + +A value of 'unix' will connect to the UNIX domain socket returned by +C<_PATH_LOG> in F<syslog.ph>. If F<syslog.ph> fails to define +C<_PATH_LOG>, C<setlogsock> returns C<undef>; otherwise a true value is +returned. A value of 'inet' will connect to an INET socket returned by +getservbyname(). Any other value croaks. + +The default is for the INET socket to be used. + + =item closelog Closes the log file. @@ -69,9 +84,12 @@ Note that C<openlog> now takes three arguments, just like C<openlog(3)>. closelog(); syslog('debug', 'this is the last test'); + + setlogsock('unix'); openlog("$program $$", 'ndelay', 'user'); syslog('notice', 'fooprogram: this is really done'); + setlogsock('inet'); $! = 55; syslog('info', 'problem was %m'); # %m == $! in syslog(3) @@ -85,12 +103,12 @@ L<syslog(3)> =head1 AUTHOR -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<lwall@sems.com>E<gt> +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>. +UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt> +with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list. =cut -$host = hostname() unless $host; # set $Syslog::host to change - require 'syslog.ph'; $maskpri = &LOG_UPTO(&LOG_DEBUG); @@ -115,6 +133,22 @@ sub setlogmask { $oldmask; } +sub setlogsock { + local($setsock) = shift; + if (lc($setsock) eq 'unix') { + if (defined &_PATH_LOG) { + $sock_unix = 1; + } else { + return undef; + } + } elsif (lc($setsock) eq 'inet') { + undef($sock_unix); + } else { + croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; + } + return 1; +} + sub syslog { local($priority) = shift; local($mask) = shift; @@ -155,7 +189,7 @@ sub syslog { $whoami = $ident; - if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { + if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) { $whoami = $1; $mask = $2; } @@ -173,7 +207,7 @@ sub syslog { $message = sprintf ($mask, @_); $sum = $numpri + $numfac; - unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { + unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) { if ($lo_cons) { if ($pid = fork) { unless ($lo_nowait) { @@ -192,23 +226,31 @@ sub syslog { sub xlate { local($name) = @_; - $name =~ y/a-z/A-Z/; + $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "Sys::Syslog::$name"; - eval(&$name) || -1; + defined &$name ? &$name : -1; } sub connect { unless ($host) { require Sys::Hostname; - $host = Sys::Hostname::hostname(); + my($host_uniq) = Sys::Hostname::hostname(); + ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) + } + unless ( $sock_unix ) { + my $udp = getprotobyname('udp'); + my $syslog = getservbyname('syslog','udp'); + my $this = sockaddr_in($syslog, INADDR_ANY); + my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); + socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; + } else { + my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; + my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; + socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "open: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; } - my $udp = getprotobyname('udp'); - my $syslog = getservbyname('syslog','udp'); - my $this = sockaddr_in($syslog, INADDR_ANY); - my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); - socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $!"; local($old) = select(SYSLOG); $| = 1; select($old); $connected = 1; } diff --git a/gnu/usr.bin/perl/lib/Term/Cap.pm b/gnu/usr.bin/perl/lib/Term/Cap.pm index 656889591a6..5703405c9d2 100644 --- a/gnu/usr.bin/perl/lib/Term/Cap.pm +++ b/gnu/usr.bin/perl/lib/Term/Cap.pm @@ -104,8 +104,11 @@ as C<$self-E<gt>{TERMCAP}>. sub termcap_path { ## private my @termcap_path; # $TERMCAP, if it's a filespec - push(@termcap_path, $ENV{TERMCAP}) if ((exists $ENV{TERMCAP}) && - ($ENV{TERMCAP} =~ /^\//)); + push(@termcap_path, $ENV{TERMCAP}) + if ((exists $ENV{TERMCAP}) && + (($^O eq 'os2' || $^O eq 'MSWin32') + ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/i + : $ENV{TERMCAP} =~ /^\//)); if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) { # Add the users $TERMPATH push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH})) @@ -185,16 +188,20 @@ sub Tgetent { ## public -- static method # This is eval'ed inside the while loop for each file $search = q{ - while ($_ = <TERMCAP>) { + while (<TERMCAP>) { next if /^\\t/ || /^#/; if ($_ =~ m/(^|\\|)${termpat}[:|]/o) { chomp; s/^[^:]*:// if $first++; $state = 0; - while ($_ =~ s/\\\\$//) { $_ .= <TERMCAP>; chomp; } + while ($_ =~ s/\\\\$//) { + defined(my $x = <TERMCAP>) or last; + $_ .= $x; chomp; + } last; } } + defined $entry or $entry = ''; $entry .= $_; }; diff --git a/gnu/usr.bin/perl/lib/Term/Complete.pm b/gnu/usr.bin/perl/lib/Term/Complete.pm index 6faef2296ed..275aadeb651 100644 --- a/gnu/usr.bin/perl/lib/Term/Complete.pm +++ b/gnu/usr.bin/perl/lib/Term/Complete.pm @@ -28,7 +28,8 @@ The following command characters are defined: =over 4 -=item <tab> +=item E<lt>tabE<gt> + Attempts word completion. Cannot be changed. @@ -42,7 +43,7 @@ Defined by I<$Term::Complete::complete>. Erases the current input. Defined by I<$Term::Complete::kill>. -=item <del>, <bs> +=item E<lt>delE<gt>, E<lt>bsE<gt> Erases one character. Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>. @@ -55,7 +56,7 @@ Bell sounds when word completion fails. =head1 BUGS -The completion charater <tab> cannot be changed. +The completion charater E<lt>tabE<gt> cannot be changed. =head1 AUTHOR @@ -71,6 +72,8 @@ CONFIG: { } sub Complete { + my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); + $prompt = shift; if (ref $_[0] || $_[0] =~ /^\*/) { @cmp_lst = sort @{$_[0]}; @@ -110,7 +113,8 @@ sub Complete { # (^U) kill $_ eq $kill && do { if ($r) { - undef($r, $return); + undef $r; + undef $return; print("\r\n"); redo LOOP; } diff --git a/gnu/usr.bin/perl/lib/Term/ReadLine.pm b/gnu/usr.bin/perl/lib/Term/ReadLine.pm index 2ce74231867..b6923dd1e7c 100644 --- a/gnu/usr.bin/perl/lib/Term/ReadLine.pm +++ b/gnu/usr.bin/perl/lib/Term/ReadLine.pm @@ -33,7 +33,7 @@ or as $term->addhistory('row'); -where $term is a return value of Term::ReadLine->Init. +where $term is a return value of Term::ReadLine-E<gt>Init. =over 12 @@ -74,7 +74,13 @@ history. Returns the old value. =item C<findConsole> returns an array with two strings that give most appropriate names for -files for input and output using conventions C<"<$in">, C<"E<gt>out">. +files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">. + +=item Attribs + +returns a reference to a hash which describes internal configuration +of the package. Names of keys in this hash conform to standard +conventions with the leading C<rl_> stripped. =item C<Features> @@ -86,26 +92,79 @@ C<MinLine> method is not dummy. C<autohistory> should be present if lines are put into history automatically (maybe subject to C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy. +If C<Features> method reports a feature C<attribs> as present, the +method C<Attribs> is not dummy. + =back +=head1 Additional supported functions + Actually C<Term::ReadLine> can use some other package, that will support reacher set of commands. +All these commands are callable via method interface and have names +which conform to standard conventions with the leading C<rl_> stripped. + +The stub package included with the perl distribution allows some +additional methods: + +=over 12 + +=item C<tkRunning> + +makes Tk event loop run when waiting for user input (i.e., during +C<readline> method). + +=item C<ornaments> + +makes the command line stand out by using termcap data. The argument +to C<ornaments> should be 0, 1, or a string of a form +C<"aa,bb,cc,dd">. Four components of this string should be names of +I<terminal capacities>, first two will be issued to make the prompt +standout, last two to make the input line standout. + +=item C<newTTY> + +takes two arguments which are input filehandle and output filehandle. +Switches to use these filehandles. + +=back + +One can check whether the currently loaded ReadLine package supports +these methods by checking for corresponding C<Features>. + =head1 EXPORTS None +=head1 ENVIRONMENT + +The variable C<PERL_RL> governs which ReadLine clone is loaded. If the +value is false, a dummy interface is used. If the value is true, it +should be tail of the name of the package to use, such as C<Perl> or +C<Gnu>. + +If the variable is not set, the best available package is loaded. + =cut package Term::ReadLine::Stub; +@ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; $DB::emacs = $DB::emacs; # To peacify -w +*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; sub ReadLine {'Term::ReadLine::Stub'} sub readline { - my ($in,$out,$str) = @{shift()}; - print $out shift; - $str = scalar <$in>; + my $self = shift; + my ($in,$out,$str) = @$self; + print $out $rl_term_set[0], shift, $rl_term_set[1], $rl_term_set[2]; + $self->register_Tk + if not $Term::ReadLine::registered and $Term::ReadLine::toloop + and defined &Tk::DoOneEvent; + #$str = scalar <$in>; + $str = $self->get_line; + print $out $rl_term_set[3]; # bug in 5.000: chomping empty string creats length -1: chomp $str if defined $str; $str; @@ -117,13 +176,16 @@ sub findConsole { if (-e "/dev/tty") { $console = "/dev/tty"; - } elsif (-e "con") { + } elsif (-e "con" or $^O eq 'MSWin32') { $console = "con"; } else { $console = "sys\$command"; } - if (defined $ENV{'OS2_SHELL'}) { # In OS/2 + if ($^O eq 'amigaos') { + $console = undef; + } + elsif ($^O eq 'os2') { if ($DB::emacs) { $console = undef; } else { @@ -163,13 +225,40 @@ sub new { bless [$FIN, $FOUT]; } } + +sub newTTY { + my ($self, $in, $out) = @_; + $self->[0] = $in; + $self->[1] = $out; + my $sel = select($out); + $| = 1; # for DB::OUT + select($sel); +} + sub IN { shift->[0] } sub OUT { shift->[1] } sub MinLine { undef } -sub Features { {} } +sub Attribs { {} } + +my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1); +sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? -eval "use Term::ReadLine::Gnu;" or eval "use Term::ReadLine::Perl;"; + +my $which = $ENV{PERL_RL}; +if ($which) { + if ($which =~ /\bgnu\b/i){ + eval "use Term::ReadLine::Gnu;"; + } elsif ($which =~ /\bperl\b/i) { + eval "use Term::ReadLine::Perl;"; + } else { + eval "use Term::ReadLine::$which;"; + } +} elsif (defined $which) { # Defined but false + # Do nothing fancy +} else { + eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1"; +} #require FileHandle; @@ -184,6 +273,71 @@ if (defined &Term::ReadLine::Gnu::readline) { @ISA = qw(Term::ReadLine::Stub); } +package Term::ReadLine::TermCap; + +# Prompt-start, prompt-end, command-line-start, command-line-end +# -- zero-width beautifies to emit around prompt and the command line. +@rl_term_set = ("","","",""); +# string encoded: +$rl_term_set = ',,,'; + +sub LoadTermCap { + return if defined $terminal; + + require Term::Cap; + $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. +} + +sub ornaments { + shift; + return $rl_term_set unless @_; + $rl_term_set = shift; + $rl_term_set ||= ',,,'; + $rl_term_set = 'us,ue,md,me' if $rl_term_set == 1; + my @ts = split /,/, $rl_term_set, 4; + eval { LoadTermCap }; + warn("Cannot find termcap: $@\n"), return unless defined $terminal; + @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts; + return $rl_term_set; +} + + +package Term::ReadLine::Tk; + +$count_handle = $count_DoOne = $count_loop = 0; + +sub handle {$giveup = 1; $count_handle++} + +sub Tk_loop { + # Tk->tkwait('variable',\$giveup); # needs Widget + $count_DoOne++, Tk::DoOneEvent(0) until $giveup; + $count_loop++; + $giveup = 0; +} + +sub register_Tk { + my $self = shift; + $Term::ReadLine::registered++ + or Tk->fileevent($self->IN,'readable',\&handle); +} + +sub tkRunning { + $Term::ReadLine::toloop = $_[1] if @_ > 1; + $Term::ReadLine::toloop; +} + +sub get_c { + my $self = shift; + $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; + return getc $self->IN; +} + +sub get_line { + my $self = shift; + $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; + my $in = $self->IN; + return scalar <$in>; +} 1; diff --git a/gnu/usr.bin/perl/lib/Test/Harness.pm b/gnu/usr.bin/perl/lib/Test/Harness.pm index 7d899a69f92..f5fc3d8cc55 100644 --- a/gnu/usr.bin/perl/lib/Test/Harness.pm +++ b/gnu/usr.bin/perl/lib/Test/Harness.pm @@ -1,18 +1,41 @@ package Test::Harness; +BEGIN {require 5.002;} use Exporter; use Benchmark; use Config; use FileHandle; -use vars qw($VERSION $verbose $switches); -require 5.002; +use strict; -$VERSION = "1.07"; +use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest + @ISA @EXPORT @EXPORT_OK); +$have_devel_corestack = 0; + +$VERSION = "1.1502"; @ISA=('Exporter'); @EXPORT= qw(&runtests); @EXPORT_OK= qw($verbose $switches); +format STDOUT_TOP = +Failed Test Status Wstat Total Fail Failed List of failed +------------------------------------------------------------------------------- +. + +format STDOUT = +@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +{ $curtest->{name}, + $curtest->{estat}, + $curtest->{wstat}, + $curtest->{max}, + $curtest->{failed}, + $curtest->{percent}, + $curtest->{canon} +} +~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $curtest->{canon} +. + $verbose = 0; $switches = "-w"; @@ -20,100 +43,194 @@ $switches = "-w"; sub runtests { my(@tests) = @_; local($|) = 1; - my($test,$te,$ok,$next,$max,$pct); + my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests); my $totmax = 0; my $files = 0; my $bad = 0; my $good = 0; my $total = @tests; - local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children + + # pass -I flags to children + my $old5lib = $ENV{PERL5LIB}; + local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); + + if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g } my $t_start = new Benchmark; while ($test = shift(@tests)) { $te = $test; chop($te); + if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./; } print "$te" . '.' x (20 - length($te)); my $fh = new FileHandle; - $fh->open("$^X $switches $test|") || (print "can't run. $!\n"); + $fh->open($test) or print "can't open $test. $!\n"; + my $first = <$fh>; + 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|"; + $cmd = "MCR $cmd" if $^O eq 'VMS'; + $fh->open($cmd) or print "can't run $test. $!\n"; $ok = $next = $max = 0; @failed = (); while (<$fh>) { if( $verbose ){ print $_; } - unless (/^\s*\#/) { - if (/^1\.\.([0-9]+)/) { - $max = $1; - $totmax += $max; - $files++; - $next = 1; - } elsif ($max && /^(not\s+)?ok\b/) { - my $this = $next; - if (/^not ok\s*(\d*)/){ - $this = $1 if $1 > 0; - push @failed, $this; - } elsif (/^ok\s*(\d*)/) { - $this = $1 if $1 > 0; - $ok++; - $totok++; - } - if ($this > $next) { - # warn "Test output counter mismatch [test $this]\n"; - # no need to warn probably - push @failed, $next..$this-1; - } elsif ($this < $next) { - #we have seen more "ok" lines than the number suggests - warn "Aborting test: output counter mismatch [test $this answered when test $next expected]\n"; - last; - } - $next = $this + 1; + if (/^1\.\.([0-9]+)/) { + $max = $1; + $totmax += $max; + $files++; + $next = 1; + } elsif ($max && /^(not\s+)?ok\b/) { + my $this = $next; + if (/^not ok\s*(\d*)/){ + $this = $1 if $1 > 0; + push @failed, $this; + } elsif (/^ok\s*(\d*)/) { + $this = $1 if $1 > 0; + $ok++; + $totok++; + } + if ($this > $next) { + # warn "Test output counter mismatch [test $this]\n"; + # no need to warn probably + push @failed, $next..$this-1; + } elsif ($this < $next) { + #we have seen more "ok" lines than the number suggests + warn "Confused test output: test $this answered after test ", $next-1, "\n"; + $next = $this; } + $next = $this + 1; } } $fh->close; # must close to reap child resource values my $wstatus = $?; - my $estatus = $wstatus >> 8; - if ($ok == $max && $next == $max+1 && ! $estatus) { - print "ok\n"; + my $estatus; + $estatus = ($^O eq 'VMS' + ? eval 'use vmsish "status"; $estatus = $?' + : $wstatus >> 8); + if ($wstatus) { + my ($failed, $canon, $percent) = ('??', '??'); + printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n", + $wstatus,$wstatus; + print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; + if (corestatus($wstatus)) { # until we have a wait module + if ($have_devel_corestack) { + Devel::CoreStack::stack($^X); + } else { + print "\ttest program seems to have generated a core\n"; + } + } + $bad++; + if ($max) { + if ($next == $max + 1 and not @failed) { + print "\tafter all the subtests completed successfully\n"; + $percent = 0; + $failed = 0; # But we do not set $canon! + } else { + push @failed, $next..$max; + $failed = @failed; + (my $txt, $canon) = canonfailed($max,@failed); + $percent = 100*(scalar @failed)/$max; + print "DIED. ",$txt; + } + } + $failedtests{$test} = { canon => $canon, max => $max || '??', + failed => $failed, + name => $test, percent => $percent, + estat => $estatus, wstat => $wstatus, + }; + } elsif ($ok == $max && $next == $max+1) { + if ($max) { + print "ok\n"; + } else { + print "skipping test on this platform\n"; + } $good++; } elsif ($max) { if ($next <= $max) { push @failed, $next..$max; } if (@failed) { - print canonfailed($max,@failed); + my ($txt, $canon) = canonfailed($max,@failed); + print $txt; + $failedtests{$test} = { canon => $canon, max => $max, + failed => scalar @failed, + name => $test, percent => 100*(scalar @failed)/$max, + estat => '', wstat => '', + }; } else { - print "Don't know which tests failed for some reason\n"; + print "Don't know which tests failed: got $ok ok, expected $max\n"; + $failedtests{$test} = { canon => '??', max => $max, + failed => '??', + name => $test, percent => undef, + estat => '', wstat => '', + }; } $bad++; } elsif ($next == 0) { print "FAILED before any test output arrived\n"; $bad++; - } - if ($wstatus) { - print "\tTest returned status $estatus (wstat $wstatus)\n"; + $failedtests{$test} = { canon => '??', max => '??', + failed => '??', + name => $test, percent => undef, + estat => '', wstat => '', + }; } } my $t_total = timediff(new Benchmark, $t_start); + if ($^O eq 'VMS') { + if (defined $old5lib) { + $ENV{PERL5LIB} = $old5lib; + } else { + delete $ENV{PERL5LIB}; + } + } if ($bad == 0 && $totmax) { print "All tests successful.\n"; } elsif ($total==0){ die "FAILED--no tests were run for some reason.\n"; } elsif ($totmax==0) { my $blurb = $total==1 ? "script" : "scripts"; - die "FAILED--$total test $blurb could be run, alas -- no output ever seen\n"; + die "FAILED--$total test $blurb could be run, alas--no output ever seen\n"; } else { $pct = sprintf("%.2f", $good / $total * 100); my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.", $totmax - $totok, $totmax, 100*$totok/$totmax; - if ($bad == 1) { - die "Failed 1 test script, $pct% okay.$subpct\n"; - } else { + my $script; + for $script (sort keys %failedtests) { + $curtest = $failedtests{$script}; + write; + } + if ($bad) { die "Failed $bad/$total test scripts, $pct% okay.$subpct\n"; } } printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop')); + + return ($bad == 0 && $totmax) ; +} + +my $tried_devel_corestack; +sub corestatus { + my($st) = @_; + my($ret); + + eval {require 'wait.ph'}; + if ($@) { + SWITCH: { + $ret = ($st & 0200); # Tim says, this is for 90% + } + } else { + $ret = WCOREDUMP($st); + } + + eval { require Devel::CoreStack; $have_devel_corestack++ } + unless $tried_devel_corestack++; + + $ret; } sub canonfailed ($@) { @@ -125,6 +242,7 @@ sub canonfailed ($@) { my @canon = (); my $min; my $last = $min = shift @failed; + my $canon; if (@failed) { for (@failed, $failed[-1]) { # don't forget the last one if ($_ > $last+1 || $_ == $last) { @@ -139,13 +257,16 @@ sub canonfailed ($@) { } local $" = ", "; push @result, "FAILED tests @canon\n"; + $canon = "@canon"; } else { push @result, "FAILED test $last\n"; + $canon = $last; } push @result, "\tFailed $failed/$max tests, "; push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n"; - join "", @result; + my $txt = join "", @result; + ($txt, $canon); } 1; @@ -165,22 +286,21 @@ runtests(@tests); Perl test scripts print to standard output C<"ok N"> for each single test, where C<N> is an increasing sequence of integers. The first line -output by a standard test scxript is C<"1..M"> with C<M> being the +output by a standard test script is C<"1..M"> with C<M> being the number of tests that should be run within the test -script. Test::Harness::runscripts(@tests) runs all the testscripts +script. Test::Harness::runtests(@tests) runs all the testscripts named as arguments and checks standard output for the expected C<"ok N"> strings. -After all tests have been performed, runscripts() prints some +After all tests have been performed, runtests() prints some performance statistics that are computed by the Benchmark module. =head2 The test script output Any output from the testscript to standard error is ignored and bypassed, thus will be seen by the user. Lines written to standard -output that look like perl comments (start with C</^\s*\#/>) are -discarded. Lines containing C</^(not\s+)?ok\b/> are interpreted as -feedback for runtests(). +output containing C</^(not\s+)?ok\b/> are interpreted as feedback for +runtests(). All other lines are discarded. It is tolerated if the test numbers after C<ok> are omitted. In this case Test::Harness maintains temporarily its own counter until the @@ -201,12 +321,16 @@ will generate Failed 3/6 tests, 50.00% okay The global variable $Test::Harness::verbose is exportable and can be -used to let runscripts() display the standard output of the script +used to let runtests() display the standard output of the script without altering the behavior otherwise. +The global variable $Test::Harness::switches is exportable and can be +used to set perl command line options used for running the test +script(s). The default value is C<-w>. + =head1 EXPORT -C<&runscripts> is exported by Test::Harness per default. +C<&runtests> is exported by Test::Harness per default. =head1 DIAGNOSTICS @@ -224,7 +348,7 @@ above are printed. =item C<Test returned status %d (wstat %d)> -Scripts that return a non-zero exit status, both $?>>8 and $? are +Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are printed in a message similar to the above. =item C<Failed 1 test, %.2f%% okay. %s> @@ -244,8 +368,8 @@ See L<Benchmark> for the underlying timing routines. Either Tim Bunce or Andreas Koenig, we don't know. What we know for sure is, that it was inspired by Larry Wall's TEST script that came -with perl distributions for ages. Current maintainer is Andreas -Koenig. +with perl distributions for ages. Numerous anonymous contributors +exist. Current maintainer is Andreas Koenig. =head1 BUGS diff --git a/gnu/usr.bin/perl/lib/Text/Abbrev.pm b/gnu/usr.bin/perl/lib/Text/Abbrev.pm index d12dfb36a69..ae6797c81ac 100644 --- a/gnu/usr.bin/perl/lib/Text/Abbrev.pm +++ b/gnu/usr.bin/perl/lib/Text/Abbrev.pm @@ -8,19 +8,25 @@ abbrev - create an abbreviation table from a list =head1 SYNOPSIS - use Abbrev; - abbrev *HASH, LIST + use Text::Abbrev; + abbrev $hashref, LIST =head1 DESCRIPTION Stores all unambiguous truncations of each element of LIST -as keys key in the associative array indicated by C<*hash>. +as keys key in the associative array referenced to by C<$hashref>. The values are the original list elements. =head1 EXAMPLE - abbrev(*hash,qw("list edit send abort gripe")); + $hashref = abbrev qw(list edit send abort gripe); + + %hash = abbrev qw(list edit send abort gripe); + + abbrev $hashref, qw(list edit send abort gripe); + + abbrev(*hash, qw(list edit send abort gripe)); =cut @@ -33,17 +39,26 @@ The values are the original list elements. # $long = $foo{$short}; sub abbrev { - local(*domain) = shift; - @cmp = @_; - %domain = (); + my (%domain); + my ($name, $ref, $glob); + + if (ref($_[0])) { # hash reference preferably + $ref = shift; + } elsif ($_[0] =~ /^\*/) { # looks like a glob (deprecated) + $glob = shift; + } + my @cmp = @_; + foreach $name (@_) { - @extra = split(//,$name); - $abbrev = shift(@extra); - $len = 1; - foreach $cmp (@cmp) { + my @extra = split(//,$name); + my $abbrev = shift(@extra); + my $len = 1; + my $cmp; + WORD: foreach $cmp (@cmp) { next if $cmp eq $name; while (substr($cmp,0,$len) eq $abbrev) { - $abbrev .= shift(@extra); + last WORD unless @extra; + $abbrev .= shift(@extra); ++$len; } } @@ -53,6 +68,19 @@ sub abbrev { $domain{$abbrev} = $name; } } + if ($ref) { + %$ref = %domain; + return; + } elsif ($glob) { # old style + local (*hash) = $glob; + %hash = %domain; + return; + } + if (wantarray) { + %domain; + } else { + \%domain; + } } 1; diff --git a/gnu/usr.bin/perl/lib/Text/ParseWords.pm b/gnu/usr.bin/perl/lib/Text/ParseWords.pm index 89951387ef6..62da1d273fe 100644 --- a/gnu/usr.bin/perl/lib/Text/ParseWords.pm +++ b/gnu/usr.bin/perl/lib/Text/ParseWords.pm @@ -1,11 +1,13 @@ package Text::ParseWords; require 5.000; -require Exporter; -require AutoLoader; use Carp; -@ISA = qw(Exporter AutoLoader); +require AutoLoader; +*AUTOLOAD = \&AutoLoader::AUTOLOAD; + +require Exporter; +@ISA = qw(Exporter); @EXPORT = qw(shellwords quotewords); @EXPORT_OK = qw(old_shellwords); @@ -35,7 +37,6 @@ 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. @@ -88,43 +89,49 @@ sub quotewords { # 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). - local($delim, $keep, @lines) = @_; - local(@words,$snippet,$field,$_); + my ($delim, $keep, @lines) = @_; + my (@words, $snippet, $field); + + local $_ = join ('', @lines); - $_ = join('', @lines); - while ($_) { + while (length) { $field = ''; + for (;;) { - $snippet = ''; - if (s/^"(([^"\\]|\\[\\"])*)"//) { + $snippet = ''; + + if (s/^"([^"\\]*(\\.[^"\\]*)*)"//) { $snippet = $1; - $snippet = "\"$snippet\"" if ($keep); + $snippet = qq|"$snippet"| if $keep; } - elsif (s/^'(([^'\\]|\\[\\'])*)'//) { + elsif (s/^'([^'\\]*(\\.[^'\\]*)*)'//) { $snippet = $1; - $snippet = "'$snippet'" if ($keep); + $snippet = "'$snippet'" if $keep; } elsif (/^["']/) { - croak "Unmatched quote"; + croak 'Unmatched quote'; } - elsif (s/^\\(.)//) { - $snippet = $1; - $snippet = "\\$snippet" if ($keep); - } - elsif (!$_ || s/^$delim//) { - last; + elsif (s/^\\(.)//) { + $snippet = $1; + $snippet = "\\$snippet" if $keep; + } + elsif (!length || s/^$delim//) { + last; } else { - while ($_ && !(/^$delim/ || /^['"\\]/)) { - $snippet .= substr($_, 0, 1); - substr($_, 0, 1) = ''; - } + while (length && !(/^$delim/ || /^['"\\]/)) { + $snippet .= substr ($_, 0, 1); + substr($_, 0, 1) = ''; + } } + $field .= $snippet; } - push(@words, $field); + + push @words, $field; } - @words; + + return @words; } diff --git a/gnu/usr.bin/perl/lib/Text/Soundex.pm b/gnu/usr.bin/perl/lib/Text/Soundex.pm index 8723c4739f6..a70c14219a5 100644 --- a/gnu/usr.bin/perl/lib/Text/Soundex.pm +++ b/gnu/usr.bin/perl/lib/Text/Soundex.pm @@ -5,7 +5,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(&soundex $soundex_nocode); -# $Id: Soundex.pm,v 1.1 1996/08/19 10:12:51 downsj Exp $ +# $Id: Soundex.pm,v 1.2 1997/11/30 07:58:05 millert Exp $ # # Implementation of soundex algorithm as described by Knuth in volume # 3 of The Art of Computer Programming, with ideas stolen from Ian @@ -23,8 +23,8 @@ require Exporter; # Lukasiewicz, Lissajous -> L222 # # $Log: Soundex.pm,v $ -# Revision 1.1 1996/08/19 10:12:51 downsj -# Initial revision +# Revision 1.2 1997/11/30 07:58:05 millert +# perl 5.004_04 # # Revision 1.2 1994/03/24 00:30:27 mike # Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> @@ -51,7 +51,7 @@ sub soundex foreach (@s) { - tr/a-z/A-Z/; + $_ = uc $_; tr/A-Z//cd; if ($_ eq '') diff --git a/gnu/usr.bin/perl/lib/Text/Tabs.pm b/gnu/usr.bin/perl/lib/Text/Tabs.pm index 2481d81ec6b..acd7afb7d6f 100644 --- a/gnu/usr.bin/perl/lib/Text/Tabs.pm +++ b/gnu/usr.bin/perl/lib/Text/Tabs.pm @@ -1,43 +1,3 @@ -# -# expand and unexpand tabs as per the unix expand and -# unexpand programs. -# -# expand and unexpand operate on arrays of lines. Do not -# feed strings that contain newlines to them. -# -# David Muir Sharnoff <muir@idiom.com> -# -# Version: 9/21/95 -# - -=head1 NAME - -Text::Tabs -- expand and unexpand tabs - -=head1 SYNOPSIS - - use Text::Tabs; - - #$tabstop = 8; # Defaults - print expand("Hello\tworld"); - print unexpand("Hello, world"); - $tabstop = 4; - print join("\n",expand(split(/\n/, - "Hello\tworld,\nit's a nice day.\n" - ))); - -=head1 DESCRIPTION - -This module expands and unexpands tabs into spaces, as per the unix expand -and unexpand programs. Either function should be passed an array of strings -(newlines may I<not> be included, and should be used to split an incoming -string into separate elements.) which will be processed and returned. - -=head1 AUTHOR - -David Muir Sharnoff <muir@idiom.com> - -=cut package Text::Tabs; @@ -46,35 +6,92 @@ require Exporter; @ISA = (Exporter); @EXPORT = qw(expand unexpand $tabstop); -$tabstop = 8; +use vars qw($VERSION $tabstop $debug); +$VERSION = 96.121201; + +use strict; + +BEGIN { + $tabstop = 8; + $debug = 0; +} sub expand { my @l = @_; for $_ (@l) { - 1 while s/^([^\t]*)(\t+)/ - $1 . (" " x - ($tabstop * length($2) - - (length($1) % $tabstop))) - /e; + 1 while s/(^|\n)([^\t\n]*)(\t+)/ + $1. $2 . (" " x + ($tabstop * length($3) + - (length($2) % $tabstop))) + /sex; } return @l if wantarray; - return @l[0]; + return $l[0]; } sub unexpand { - my @l = &expand(@_); + my @l = @_; my @e; + my $x; + my $line; + my @lines; + my $lastbit; for $x (@l) { - @e = split(/(.{$tabstop})/,$x); - for $_ (@e) { - s/ +$/\t/; + @lines = split("\n", $x, -1); + for $line (@lines) { + $line = expand($line); + @e = split(/(.{$tabstop})/,$line,-1); + $lastbit = pop(@e); + $lastbit = '' unless defined $lastbit; + $lastbit = "\t" + if $lastbit eq " "x$tabstop; + for $_ (@e) { + if ($debug) { + my $x = $_; + $x =~ s/\t/^I\t/gs; + print "sub on '$x'\n"; + } + s/ +$/\t/; + } + $line = join('',@e, $lastbit); } - $x = join('',@e); + $x = join("\n", @lines); } return @l if wantarray; - return @l[0]; + return $l[0]; } 1; +__END__ + + +=head1 NAME + +Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1) + +=head1 SYNOPSIS + +use Text::Tabs; + +$tabstop = 4; +@lines_without_tabs = expand(@lines_with_tabs); +@lines_with_tabs = unexpand(@lines_without_tabs); + +=head1 DESCRIPTION + +Text::Tabs does about what the unix utilities expand(1) and unexpand(1) +do. Given a line with tabs in it, expand will replace the tabs with +the appropriate number of spaces. Given a line with or without tabs in +it, unexpand will add tabs when it can save bytes by doing so. Invisible +compression with plain ascii! + +=head1 BUGS + +expand doesn't handle newlines very quickly -- do not feed it an +entire document in one string. Instead feed it an array of lines. + +=head1 AUTHOR + +David Muir Sharnoff <muir@idiom.com> diff --git a/gnu/usr.bin/perl/lib/Text/Wrap.pm b/gnu/usr.bin/perl/lib/Text/Wrap.pm index b665752f942..0910a2ab345 100644 --- a/gnu/usr.bin/perl/lib/Text/Wrap.pm +++ b/gnu/usr.bin/perl/lib/Text/Wrap.pm @@ -1,93 +1,145 @@ - package Text::Wrap; -# -# This is a very simple paragraph formatter. It formats one -# paragraph at a time by wrapping and indenting text. -# -# Usage: -# -# use Text::Wrap; -# -# print wrap($initial_tab,$subsequent_tab,@text); -# -# You can also set the number of columns to wrap before: -# -# $Text::Wrap::columns = 135; # <= width of screen -# -# use Text::Wrap qw(wrap $columns); -# $columns = 70; -# -# -# The first line will be printed with $initial_tab prepended. All -# following lines will have $subsequent_tab prepended. -# -# Example: -# -# print wrap("\t","","This is a bit of text that ..."); -# -# David Muir Sharnoff <muir@idiom.com> -# Version: 9/21/95 -# - -=head1 NAME - -Text::Wrap -- wrap text into a paragraph - -=head1 SYNOPSIS - - use Text::Wrap; - - $Text::Wrap::columns = 20; # Default - print wrap("\t","",Hello, world, it's a nice day, isn't it?"); - -=head1 DESCRIPTION - -This module is a simple paragraph formatter that wraps text into a paragraph -and indents each line. The single exported function, wrap(), takes three -arguments. The first is included before the first output line, and the -second argument is included before each subsequest output line. The third -argument is the text to be wrapped. - -=head1 AUTHOR - -David Muir Sharnoff <muir@idiom.com> - -=cut - require Exporter; @ISA = (Exporter); @EXPORT = qw(wrap); @EXPORT_OK = qw($columns); +$VERSION = 97.011701; + +use vars qw($VERSION $columns $debug); +use strict; + BEGIN { - $Text::Wrap::columns = 76; # <= screen width + $columns = 76; # <= screen width + $debug = 0; } -use Text::Tabs; -use strict; +use Text::Tabs qw(expand unexpand); sub wrap { my ($ip, $xp, @t) = @_; - my $r; + my $r = ""; my $t = expand(join(" ",@t)); my $lead = $ip; - my $ll = $Text::Wrap::columns - length(expand($lead)) - 1; - if ($t =~ s/^([^\n]{0,$ll})\s//) { - $r .= unexpand($lead . $1 . "\n"); + 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; - my $ll = $Text::Wrap::columns - length(expand($lead)) - 1; - while ($t =~ s/^([^\n]{0,$ll})\s//) { - $r .= unexpand($lead . $1 . "\n"); + $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; } + die "couldn't wrap '$t'" if length($t) > $ll; - $r .= $t; + + print "-----------$r---------\n" if $debug; + + print "Finish up with '$lead', '$t'\n" if $debug; + + $r .= $lead . $t if $t ne ""; + + print "-----------$r---------\n" if $debug;; return $r; } 1; +__END__ + +=head1 NAME + +Text::Wrap - line wrapping to form simple paragraphs + +=head1 SYNOPSIS + + use Text::Wrap + + print wrap($initial_tab, $subsequent_tab, @text); + + use Text::Wrap qw(wrap $columns); + + $columns = 132; + +=head1 DESCRIPTION + +Text::Wrap::wrap() is a very simple paragraph formatter. It formats a +single paragraph at a time by breaking lines at word boundries. +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. + +=head1 EXAMPLE + + print wrap("\t","","This is a bit of text that forms + a normal book-style paragraph"); + +=head1 BUGS + +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. + +=head1 AUTHOR + +David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and +others. + +=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/gnu/usr.bin/perl/lib/Tie/Hash.pm b/gnu/usr.bin/perl/lib/Tie/Hash.pm index 9a9d059a7f7..2117c54c183 100644 --- a/gnu/usr.bin/perl/lib/Tie/Hash.pm +++ b/gnu/usr.bin/perl/lib/Tie/Hash.pm @@ -26,8 +26,8 @@ Tie::Hash, Tie::StdHash - base class definitions for tied hashes package main; - tie %new_hash, NewHash; - tie %new_std_hash, NewStdHash; + tie %new_hash, 'NewHash'; + tie %new_std_hash, 'NewStdHash'; =head1 DESCRIPTION @@ -98,7 +98,7 @@ L<Config> module. While these do not utilize B<Tie::Hash>, they serve as good working examples. =cut - + use Carp; sub new { diff --git a/gnu/usr.bin/perl/lib/Tie/Scalar.pm b/gnu/usr.bin/perl/lib/Tie/Scalar.pm index 2db02ae1daf..ef27dc1398c 100644 --- a/gnu/usr.bin/perl/lib/Tie/Scalar.pm +++ b/gnu/usr.bin/perl/lib/Tie/Scalar.pm @@ -26,8 +26,8 @@ Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars package main; - tie $new_scalar, NewScalar; - tie $new_std_scalar, NewStdScalar; + tie $new_scalar, 'NewScalar'; + tie $new_std_scalar, 'NewStdScalar'; =head1 DESCRIPTION diff --git a/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm b/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm index a01c66ef8d5..44c2140c7be 100644 --- a/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm +++ b/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm @@ -8,7 +8,7 @@ Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing require Tie::SubstrHash; - tie %myhash, Tie::SubstrHash, $key_len, $value_len, $table_size; + tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size; =head1 DESCRIPTION @@ -144,13 +144,17 @@ sub hashkey { $hash = 2; for (unpack('C*', $key)) { $hash = $hash * 33 + $_; + &_hashwrap if $hash >= 1e13; } - $hash = $hash - int($hash / $tsize) * $tsize - if $hash >= $tsize; + &_hashwrap if $hash >= $tsize; $hash = 1 unless $hash; $hashbase = $hash; } +sub _hashwrap { + $hash -= int($hash / $tsize) * $tsize; +} + sub rehash { $hash += $hashbase; $hash -= $tsize if $hash >= $tsize; diff --git a/gnu/usr.bin/perl/lib/Time/Local.pm b/gnu/usr.bin/perl/lib/Time/Local.pm index 451c7fa20c7..eef412d46d7 100644 --- a/gnu/usr.bin/perl/lib/Time/Local.pm +++ b/gnu/usr.bin/perl/lib/Time/Local.pm @@ -8,7 +8,7 @@ use Carp; =head1 NAME -Time::Local - efficiently compute tome from local and GMT time +Time::Local - efficiently compute time from local and GMT time =head1 SYNOPSIS @@ -39,53 +39,78 @@ after the 1st of January, 2038 on most machines. =cut -@epoch = localtime(0); -$tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT -if ($tzmin > 0) { - $tzmin = 24 * 60 - $tzmin; # minutes west of GMT - $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line -} +BEGIN { + $SEC = 1; + $MIN = 60 * $SEC; + $HR = 60 * $MIN; + $DAY = 24 * $HR; + $epoch = (localtime(2*$DAY))[5]; # Allow for bugs near localtime == 0. + + $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; -$SEC = 1; -$MIN = 60 * $SEC; -$HR = 60 * $MIN; -$DAYS = 24 * $HR; -$YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; +} sub timegm { $ym = pack(C2, @_[5,4]); $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0; - $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; + return -1 if $cheat<0 and $^O ne 'VMS'; + $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; } sub timelocal { - $time = &timegm + $tzmin*$MIN; - return -1 if $cheat<0; - @test = localtime($time); + my $t = &timegm; + my $tt = $t; + + my (@lt) = localtime($t); + my (@gt) = gmtime($t); + if ($t < $DAY and ($lt[5] >= 70 or $gt[5] >= 70 )) { + # Wrap error, too early a date + # Try a safer date + $tt = $DAY; + @lt = localtime($tt); + @gt = gmtime($tt); + } + + my $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR; + + my($lday,$gday) = ($lt[7],$gt[7]); + if($lt[5] > $gt[5]) { + $tzsec -= $DAY; + } + elsif($gt[5] > $lt[5]) { + $tzsec += $DAY; + } + else { + $tzsec += ($gt[7] - $lt[7]) * $DAY; + } + + $tzsec += $HR if($lt[8]); + + $time = $t + $tzsec; + return -1 if $cheat<0 and $^O ne 'VMS'; + @test = localtime($time + ($tt - $t)); $time -= $HR if $test[2] != $_[2]; $time; } sub cheat { $year = $_[5]; + $year -= 1900 + if $year > 1900; $month = $_[4]; - croak "Month out of range 0..11 in timelocal.pl" - if $month > 11 || $month < 0; - croak "Day out of range 1..31 in timelocal.pl" - if $_[3] > 31 || $_[3] < 1; - croak "Hour out of range 0..23 in timelocal.pl" - if $_[2] > 23 || $_[2] < 0; - croak "Minute out of range 0..59 in timelocal.pl" - if $_[1] > 59 || $_[1] < 0; - croak "Second out of range 0..59 in timelocal.pl" - if $_[0] > 59 || $_[0] < 0; + croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0; + croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1; + croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0; + croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0; + croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0; $guess = $^T; @g = gmtime($guess); - $year += $YearFix if $year < $epoch[5]; + $year += $YearFix if $year < $epoch; $lastguess = ""; + $counter = 0; while ($diff = $year - $g[5]) { - $guess += $diff * (363 * $DAYS); + croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255; + $guess += $diff * (363 * $DAY); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ return -1; #date beyond this machine's integer limit @@ -93,7 +118,8 @@ sub cheat { $lastguess = $thisguess; } while ($diff = $month - $g[4]) { - $guess += $diff * (27 * $DAYS); + croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255; + $guess += $diff * (27 * $DAY); @g = gmtime($guess); if (($thisguess = "@g") eq $lastguess){ return -1; #date beyond this machine's integer limit @@ -105,7 +131,7 @@ sub cheat { return -1; #date beyond this machine's integer limit } $g[3]--; - $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; + $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAY; $cheat{$ym} = $guess; } diff --git a/gnu/usr.bin/perl/lib/abbrev.pl b/gnu/usr.bin/perl/lib/abbrev.pl index c233d4af7e6..62975e66f32 100644 --- a/gnu/usr.bin/perl/lib/abbrev.pl +++ b/gnu/usr.bin/perl/lib/abbrev.pl @@ -17,7 +17,7 @@ sub main'abbrev { $len = 1; foreach $cmp (@cmp) { next if $cmp eq $name; - while (substr($cmp,0,$len) eq $abbrev) { + while (@extra && substr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } diff --git a/gnu/usr.bin/perl/lib/bigfloat.pl b/gnu/usr.bin/perl/lib/bigfloat.pl index 9ad171f295a..d687c784f1c 100644 --- a/gnu/usr.bin/perl/lib/bigfloat.pl +++ b/gnu/usr.bin/perl/lib/bigfloat.pl @@ -41,8 +41,10 @@ $rnd_mode = 'even'; sub main'fnorm { #(string) return fnum_str local($_) = @_; s/\s+//g; # strip white space - if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') { - &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6)); + if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ + && ($2 ne '' || defined($4))) { + my $x = defined($4) ? $4 : ''; + &norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6)); } else { 'NaN'; } diff --git a/gnu/usr.bin/perl/lib/bigint.pl b/gnu/usr.bin/perl/lib/bigint.pl index e6ba644e3b3..bfd2efa88c8 100644 --- a/gnu/usr.bin/perl/lib/bigint.pl +++ b/gnu/usr.bin/perl/lib/bigint.pl @@ -103,13 +103,23 @@ sub main'bcmp { #(num_str, num_str) return cond_code sub cmp { # post-normalized compare for internal use local($cx, $cy) = @_; - $cx cmp $cy - && - ( - ord($cy) <=> ord($cx) - || - ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx) - ); + return 0 if ($cx eq $cy); + + local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1)); + local($ld); + + if ($sx eq '+') { + return 1 if ($sy eq '-' || $cy eq '+0'); + $ld = length($cx) - length($cy); + return $ld if ($ld); + return $cx cmp $cy; + } else { # $sx eq '-' + return -1 if ($sy eq '+'); + $ld = length($cy) - length($cx); + return $ld if ($ld); + return $cy cmp $cx; + } + } sub main'badd { #(num_str, num_str) return num_str @@ -158,11 +168,11 @@ 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); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5); + $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; } (@x, @y, $car); } diff --git a/gnu/usr.bin/perl/lib/cacheout.pl b/gnu/usr.bin/perl/lib/cacheout.pl index 48d594bf825..64378cffc6f 100644 --- a/gnu/usr.bin/perl/lib/cacheout.pl +++ b/gnu/usr.bin/perl/lib/cacheout.pl @@ -35,7 +35,7 @@ $seq = 0; $numopen = 0; if (open(PARAM,'/usr/include/sys/param.h')) { - local($.); + local($_, $.); while (<PARAM>) { $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; } diff --git a/gnu/usr.bin/perl/lib/chat2.inter b/gnu/usr.bin/perl/lib/chat2.inter deleted file mode 100644 index 6934f1cc285..00000000000 --- a/gnu/usr.bin/perl/lib/chat2.inter +++ /dev/null @@ -1,495 +0,0 @@ -Article 20992 of comp.lang.perl: -Path: netlabs!news.cerf.net!mvb.saic.com!MathWorks.Com!europa.eng.gtefsd.com!howland.reston.ans.net!cs.utexas.edu!swrinde!ihnp4.ucsd.edu!ames!koriel!male.EBay.Sun.COM!jethro.Corp.Sun.COM!eric -From: eric.arnold@sun.com (Eric Arnold) -Newsgroups: comp.lang.perl -Subject: Re: Need a bidirectional filter for interactive Unix applications -Date: 15 Apr 94 21:24:03 GMT -Organization: Sun Microsystems -Lines: 478 -Sender: news@sun.com -Message-ID: <ERIC.94Apr15212403@sun.com> -References: <dgfCo9F2J.Jzw@netcom.com> <1994Apr15.110134.4581@chemabs.uucp> -NNTP-Posting-Host: animus.corp.sun.com -X-Newsreader: prn Ver 1.09 -In-reply-to: btf64@cas.org's message of Fri, 15 Apr 1994 11:01:34 GMT - -In article <1994Apr15.110134.4581@chemabs.uucp> - btf64@cas.org (Bernard T. French) writes: - ->In article <dgfCo9F2J.Jzw@netcom.com> dgf@netcom.com (David Feldman) writes: ->>I need to write a bidirectional filter that would (ideally) sit between a -.. ->>program's stdin & stdout to point to a pty pair known to perl. The perl app- ->>lication would talk to the user's crt/keyboard, translate (application-specific) ->>the input & output streams, and pass these as appropriate to/from the pty pair, -.. -> -> I'm afraid I can't offer you a perl solution, but err..... there is a ->Tcl solution. There is a Tcl extension called "expect" that is designed to - -There *is* an old, established Perl solution: "chat2.pl" which does -everything (well, basically) "expect" does but you get it in the -expressive Perl environment. "chat2.pl" is delivered with the Perl -source. - -Randal: "interact()" still hasn't made it into Perl5alpha8 -"chat2.pl", so I've included a version which does. - --Eric - - -## chat.pl: chat with a server -## V2.01.alpha.7 91/06/16 -## Randal L. Schwartz - -package chat; - -$sockaddr = 'S n a4 x8'; -chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4]; -$thisproc = pack($sockaddr, 2, 0, $thisaddr); - -# *S = symbol for current I/O, gets assigned *chatsymbol.... -$next = "chatsymbol000000"; # next one -$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++ - - -## $handle = &chat'open_port("server.address",$port_number); -## opens a named or numbered TCP server - -sub open_port { ## public - local($server, $port) = @_; - - local($serveraddr,$serverproc); - - *S = ++$next; - if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) { - $serveraddr = pack('C4', $1, $2, $3, $4); - } else { - local(@x) = gethostbyname($server); - return undef unless @x; - $serveraddr = $x[4]; - } - $serverproc = pack($sockaddr, 2, $port, $serveraddr); - unless (socket(S, 2, 1, 6)) { - # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp' - # but who the heck would change these anyway? (:-) - ($!) = ($!, close(S)); # close S while saving $! - return undef; - } - unless (bind(S, $thisproc)) { - ($!) = ($!, close(S)); # close S while saving $! - return undef; - } - unless (connect(S, $serverproc)) { - ($!) = ($!, close(S)); # close S while saving $! - return undef; - } - select((select(S), $| = 1)[0]); - $next; # return symbol for switcharound -} - -## ($host, $port, $handle) = &chat'open_listen([$port_number]); -## opens a TCP port on the current machine, ready to be listened to -## if $port_number is absent or zero, pick a default port number -## process must be uid 0 to listen to a low port number - -sub open_listen { ## public - - *S = ++$next; - local($thisport) = shift || 0; - local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr); - local(*NS) = "__" . time; - unless (socket(NS, 2, 1, 6)) { - # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp' - # but who the heck would change these anyway? (:-) - ($!) = ($!, close(NS)); - return undef; - } - unless (bind(NS, $thisproc_local)) { - ($!) = ($!, close(NS)); - return undef; - } - unless (listen(NS, 1)) { - ($!) = ($!, close(NS)); - return undef; - } - select((select(NS), $| = 1)[0]); - local($family, $port, @myaddr) = - unpack("S n C C C C x8", getsockname(NS)); - $S{"needs_accept"} = *NS; # so expect will open it - (@myaddr, $port, $next); # returning this -} - -## $handle = &chat'open_proc("command","arg1","arg2",...); -## opens a /bin/sh on a pseudo-tty - -sub open_proc { ## public - local(@cmd) = @_; - - *S = ++$next; - local(*TTY) = "__TTY" . time; - local($pty,$tty,$pty_handle) = &_getpty(S,TTY); - - #local($pty,$tty,$pty_handle) = &getpty(S,TTY); - #$Tty = $tty; - - die "Cannot find a new pty" unless defined $pty; - local($pid) = fork; - die "Cannot fork: $!" unless defined $pid; - unless ($pid) { - close STDIN; close STDOUT; close STDERR; - #close($pty_handle); - setpgrp(0,$$); - if (open(DEVTTY, "/dev/tty")) { - ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY - close DEVTTY; - } - open(STDIN,"<&TTY"); - open(STDOUT,">&TTY"); - open(STDERR,">&STDOUT"); - die "Oops" unless fileno(STDERR) == 2; # sanity - close(S); - - exec @cmd; - die "Cannot exec @cmd: $!"; - } - close(TTY); - $PID{$next} = $pid; - $next; # return symbol for switcharound - -} - -# $S is the read-ahead buffer - -## $return = &chat'expect([$handle,] $timeout_time, -## $pat1, $body1, $pat2, $body2, ... ) -## $handle is from previous &chat'open_*(). -## $timeout_time is the time (either relative to the current time, or -## absolute, ala time(2)) at which a timeout event occurs. -## $pat1, $pat2, and so on are regexs which are matched against the input -## stream. If a match is found, the entire matched string is consumed, -## and the corresponding body eval string is evaled. -## -## Each pat is a regular-expression (probably enclosed in single-quotes -## in the invocation). ^ and $ will work, respecting the current value of $*. -## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded. -## If pat is 'EOF', the body is executed if the process exits before -## the other patterns are seen. -## -## Pats are scanned in the order given, so later pats can contain -## general defaults that won't be examined unless the earlier pats -## have failed. -## -## The result of eval'ing body is returned as the result of -## the invocation. Recursive invocations are not thought -## through, and may work only accidentally. :-) -## -## undef is returned if either a timeout or an eof occurs and no -## corresponding body has been defined. -## I/O errors of any sort are treated as eof. - -$nextsubname = "expectloop000000"; # used for subroutines - -sub expect { ## public - if ($_[0] =~ /$nextpat/) { - *S = shift; - } - local($endtime) = shift; - - local($timeout,$eof) = (1,1); - local($caller) = caller; - local($rmask, $nfound, $timeleft, $thisbuf); - local($cases, $pattern, $action, $subname); - $endtime += time if $endtime < 600_000_000; - - if (defined $S{"needs_accept"}) { # is it a listen socket? - local(*NS) = $S{"needs_accept"}; - delete $S{"needs_accept"}; - $S{"needs_close"} = *NS; - unless(accept(S,NS)) { - ($!) = ($!, close(S), close(NS)); - return undef; - } - select((select(S), $| = 1)[0]); - } - - # now see whether we need to create a new sub: - - unless ($subname = $expect_subname{$caller,@_}) { - # nope. make a new one: - $expect_subname{$caller,@_} = $subname = $nextsubname++; - - $cases .= <<"EDQ"; # header is funny to make everything elsif's -sub $subname { - LOOP: { - if (0) { ; } -EDQ - while (@_) { - ($pattern,$action) = splice(@_,0,2); - if ($pattern =~ /^eof$/i) { - $cases .= <<"EDQ"; - elsif (\$eof) { - package $caller; - $action; - } -EDQ - $eof = 0; - } elsif ($pattern =~ /^timeout$/i) { - $cases .= <<"EDQ"; - elsif (\$timeout) { - package $caller; - $action; - } -EDQ - $timeout = 0; - } else { - $pattern =~ s#/#\\/#g; - $cases .= <<"EDQ"; - elsif (\$S =~ /$pattern/) { - \$S = \$'; - package $caller; - $action; - } -EDQ - } - } - $cases .= <<"EDQ" if $eof; - elsif (\$eof) { - undef; - } -EDQ - $cases .= <<"EDQ" if $timeout; - elsif (\$timeout) { - undef; - } -EDQ - $cases .= <<'ESQ'; - else { - $rmask = ""; - vec($rmask,fileno(S),1) = 1; - ($nfound, $rmask) = - select($rmask, undef, undef, $endtime - time); - if ($nfound) { - $nread = sysread(S, $thisbuf, 1024); - if ($nread > 0) { - $S .= $thisbuf; - } else { - $eof++, redo LOOP; # any error is also eof - } - } else { - $timeout++, redo LOOP; # timeout - } - redo LOOP; - } - } -} -ESQ - eval $cases; die "$cases:\n$@" if $@; - } - $eof = $timeout = 0; - do $subname(); -} - -## &chat'print([$handle,] @data) -## $handle is from previous &chat'open(). -## like print $handle @data - -sub print { ## public - if ($_[0] =~ /$nextpat/) { - *S = shift; - } - print S @_; -} - -## &chat'close([$handle,]) -## $handle is from previous &chat'open(). -## like close $handle - -sub close { ## public - local($pid); - if ($_[0] =~ /$nextpat/) { - $pid = $PID{$_[0]}; - *S = shift; - } else { - $pid = $PID{$next}; - } - close(S); - waitpid($pid,0); - if (defined $S{"needs_close"}) { # is it a listen socket? - local(*NS) = $S{"needs_close"}; - delete $S{"needs_close"}; - close(NS); - } -} - -## @ready_handles = &chat'select($timeout, @handles) -## select()'s the handles with a timeout value of $timeout seconds. -## Returns an array of handles that are ready for I/O. -## Both user handles and chat handles are supported (but beware of -## stdio's buffering for user handles). - -sub select { ## public - local($timeout) = shift; - local(@handles) = @_; - local(%handlename) = (); - local(%ready) = (); - local($caller) = caller; - local($rmask) = ""; - for (@handles) { - if (/$nextpat/o) { # one of ours... see if ready - local(*SYM) = $_; - if (length($SYM)) { - $timeout = 0; # we have a winner - $ready{$_}++; - } - $handlename{fileno($_)} = $_; - } else { - $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_; - } - } - for (sort keys %handlename) { - vec($rmask, $_, 1) = 1; - } - select($rmask, undef, undef, $timeout); - for (sort keys %handlename) { - $ready{$handlename{$_}}++ if vec($rmask,$_,1); - } - sort keys %ready; -} - -# ($pty,$tty) = $chat'_getpty(PTY,TTY): -# internal procedure to get the next available pty. -# opens pty on handle PTY, and matching tty on handle TTY. -# returns undef if can't find a pty. - -sub _getpty { ## private - local($_PTY,$_TTY) = @_; - $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; - $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; - local($pty,$tty); - for $bank (112..127) { - next unless -e sprintf("/dev/pty%c0", $bank); - for $unit (48..57) { - $pty = sprintf("/dev/pty%c%c", $bank, $unit); - open($_PTY,"+>$pty") || next; - select((select($_PTY), $| = 1)[0]); - ($tty = $pty) =~ s/pty/tty/; - open($_TTY,"+>$tty") || next; - select((select($_TTY), $| = 1)[0]); - system "stty nl>$tty"; - return ($pty,$tty,$_PTY); - } - } - undef; -} - - -sub getpty { - local( $pty_handle, $tty_handle ) = @_; - -print "--------in getpty----------\n"; - $pty_handle =~ s/^([^']+)$/(caller)[$[]."'".$1/e; - $pty_handle =~ s/^([^']+)$/(caller)[$[]."'".$1/e; - - #$pty_handle = ++$next_handle; - chop( @ptys = `ls /dev/pty*` ); - - for $pty ( @ptys ) - { - open($pty_handle,"+>$pty") || next; - select((select($pty_handle), $| = 1)[0]); - ($tty = $pty) =~ s/pty/tty/; - - open($tty_handle,"+>$tty") || next; - select((select($tty_handle), $| = 1)[0]); - ($tty = $pty) =~ s/pty/tty/; - - return ($pty, $tty, $pty_handle ); - } - return undef; -} - - - -# from: Randal L. Schwartz - -# Usage: -# -# ($chathandle = &chat'open_proc("/bin/sh")) || die "cannot open shell"; -# system("stty cbreak raw -echo >/dev/tty\n"); -# &chat'interact($chathandle); -# &chat'close($chathandle); -# system("stty -cbreak -raw echo >/dev/tty\n"); - -sub interact -{ - local( $chathandle ) = @_; - - &chat'print($chathandle, "stty sane\n"); - select(STDOUT) ; $| = 1; # unbuffer STDOUT - - #print "tty=$Tty,whoami=",`whoami`,"\n"; - #&change_utmp( "", $Tty, "eric", "", time() ); - - { - @ready = &chat'select(30, STDIN,$chathandle); - print "after select, ready=",join(",",@ready),"\n"; - #(warn "[waiting]"), redo unless @ready; - if (grep($_ eq $chathandle, @ready)) { - print "checking $chathandle\n"; - last unless $text = &chat'expect($chathandle,0,'[\s\S]+','$&'); - print "$chathandle OK\n"; - print "got=($text)"; - #print $text; - } - if (grep($_ eq STDIN, @ready)) { - print "checking STDIN\n"; - last unless sysread(STDIN,$buf,1024) > 0; - print "STDIN OK\n"; - &chat'print($chathandle,$buf); - } - redo; - } - #&change_utmp( $Tty, "$Tty", "", "", 0 ); - print "leaving interact, \$!=$!\n"; -} - -## $handle = &chat'open_duphandle(handle); -## duplicates an input file handle to conform to chat format - -sub open_duphandle { ## public - *S = ++$next; - open(S,"<&$_[0]"); - $next; # return symbol for switcharound -} - -#Here is an example which uses this routine. -# -# # The following lines makes stdin unbuffered -# -# $BSD = -f '/vmunix'; -# -# if ($BSD) { -# system "stty cbreak </dev/tty >/dev/tty 2>&1"; -# } -# else { -# system "stty", '-icanon'; -# system "stty", 'eol', '^A'; -# } -# -# require 'mychat2.pl'; -# -# &chat'open_duphandle(STDIN); -# -# print -# &chat'expect(3, -# '[A-Z]', '" :-)"', -# '.', '" :-("', -# TIMEOUT, '"-o-"', -# EOF, '"\$\$"'), -# "\n"; - - -1; - - diff --git a/gnu/usr.bin/perl/lib/complete.pl b/gnu/usr.bin/perl/lib/complete.pl index 1e08f9145ae..539f2f77983 100644 --- a/gnu/usr.bin/perl/lib/complete.pl +++ b/gnu/usr.bin/perl/lib/complete.pl @@ -35,7 +35,7 @@ CONFIG: { sub Complete { package Complete; - local($[,$return) = 0; + local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); if ($_[1] =~ /^StB\0/) { ($prompt, *_) = @_; } @@ -75,7 +75,8 @@ sub Complete { # (^U) kill $_ eq $kill && do { if ($r) { - undef($r, $return); + undef $r; + undef $return; print("\r\n"); redo LOOP; } diff --git a/gnu/usr.bin/perl/lib/diagnostics.pm b/gnu/usr.bin/perl/lib/diagnostics.pm index 3560f2d708d..78bf4457cba 100644 --- a/gnu/usr.bin/perl/lib/diagnostics.pm +++ b/gnu/usr.bin/perl/lib/diagnostics.pm @@ -1,18 +1,4 @@ -#!/usr/local/bin/perl -eval 'exec perl -S $0 ${1+"$@"}' - if 0; - -use Config; -if ($^O eq 'VMS') { - $diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlib'}) . - '/pod/perldiag.pod'; -} -else { $diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod"; } - package diagnostics; -require 5.001; -use English; -use Carp; =head1 NAME @@ -41,9 +27,9 @@ Aa a program: =head2 The C<diagnostics> Pragma This module extends the terse diagnostics normally emitted by both the -perl compiler and the perl interpeter, augmenting them wtih the more +perl compiler and the perl interpeter, augmenting them with the more explicative and endearing descriptions found in L<perldiag>. Like the -other pragmata, it affects to compilation phase of your program rather +other pragmata, it affects the compilation phase of your program rather than merely the execution phase. To use in your program as a pragma, merely invoke @@ -62,8 +48,8 @@ However, you may control there behaviour at runtime using the disable() and enable() methods to turn them off and on respectively. The B<-verbose> flag first prints out the L<perldiag> introduction before -any other diagnostics. The $diagnostics::PRETTY can generate nicer escape -sequences for pgers. +any other diagnostics. The $diagnostics::PRETTY variable can generate nicer +escape sequences for pagers. =head2 The I<splain> Program @@ -98,7 +84,7 @@ afterwards, do this: ./splain < test.out Note that this is not in general possible in shells of more dubious heritage, -as the theorectical +as the theoretical (perl -w test.pl >/dev/tty) >& test.out ./splain < test.out @@ -143,7 +129,7 @@ runtime. Otherwise, they may be embedded in the file itself when the splain package is built. See the F<Makefile> for details. If an extant $SIG{__WARN__} handler is discovered, it will continue -to be honored, but only after the diagnostic::splainthis() function +to be honored, but only after the diagnostics::splainthis() function (the module's $SIG{__WARN__} interceptor) has had its way with your warnings. @@ -159,27 +145,44 @@ Not being able to say "no diagnostics" is annoying, but may not be insurmountable. The C<-pretty> directive is called too late to affect matters. -You have to to this instead, and I<before> you load the module. +You have to do this instead, and I<before> you load the module. BEGIN { $diagnostics::PRETTY = 1 } I could start up faster by delaying compilation until it should be -needed, but this gets a "panic: top_level" -when using the pragma form in 5.001e. +needed, but this gets a "panic: top_level" when using the pragma form +in Perl 5.001e. While it's true that this documentation is somewhat subserious, if you use a program named I<splain>, you should expect a bit of whimsy. =head1 AUTHOR -Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995. +Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. =cut +require 5.001; +use Carp; + +use Config; +($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; +if ($^O eq 'VMS') { + require VMS::Filespec; + $privlib = VMS::Filespec::unixify($privlib); + $archlib = VMS::Filespec::unixify($archlib); +} +@trypod = ("$archlib/pod/perldiag.pod", + "$privlib/pod/perldiag-$].pod", + "$privlib/pod/perldiag.pod"); +# handy for development testing of new warnings etc +unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; +($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; + $DEBUG ||= 0; my $WHOAMI = ref bless []; # nobody's business, prolly not even mine -$OUTPUT_AUTOFLUSH = 1; +$| = 1; local $_; @@ -191,7 +194,8 @@ CONFIG: { unless (caller) { $standalone++; require Getopt::Std; - Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]"; + Getopt::Std::getopts('pdvf:') + or die "Usage: $0 [-v] [-p] [-f splainpod]"; $PODFILE = $opt_f if $opt_f; $DEBUG = 2 if $opt_d; $VERBOSE = $opt_v; @@ -315,7 +319,9 @@ EOFUNC } next; } - $header = $1; + + # strip formatting directives in =item line + ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; if ($header =~ /%[sd]/) { $rhs = $lhs = $header; @@ -328,13 +334,15 @@ EOFUNC #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; $lhs =~ s/\377([^\377]*)$/\Q$1\E/; $lhs =~ s/\377//g; + $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all } - $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; + $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; } else { $transmo .= " m{^\Q$header\E} && return 1;\n"; } - print STDERR "Already saw $header" if $msg{$header}; + print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" + if $msg{$header}; $msg{$header} = ''; } @@ -353,7 +361,7 @@ EOFUNC if ($standalone) { if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } - while ($error = <>) { + while (defined ($error = <>)) { splainthis($error) || print THITHER $error; } exit; @@ -415,10 +423,27 @@ sub warn_trap { sub death_trap { my $exception = $_[0]; - splainthis($exception); + + # See if we are coming from anywhere within an eval. If so we don't + # want to explain the exception because it's going to get caught. + my $in_eval = 0; + my $i = 0; + while (1) { + my $caller = (caller($i++))[3] or last; + if ($caller eq '(eval)') { + $in_eval = 1; + last; + } + } + + splainthis($exception) unless $in_eval; if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; - $SIG{__DIE__} = $SIG{__WARN__} = ''; + + # We don't want to unset these if we're coming from an eval because + # then we've turned off diagnostics. (Actually what does this next + # line do? -PSeibel) + $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval; local($Carp::CarpLevel) = 1; confess "Uncaught exception from user code:\n\t$exception"; # up we go; where we stop, nobody knows, but i think we die now @@ -428,6 +453,7 @@ sub death_trap { sub splainthis { local $_ = shift; + local $\; ### &finish_compilation unless %msg; s/\.?\n+$//; my $orig = $_; @@ -481,7 +507,7 @@ sub unescape { exists $HTML_Escapes{$1} ? do { $HTML_Escapes{$1} } : do { - warn "Unknown escape: $& in $_"; + warn "Unknown escape: E<$1> in $_"; "E<$1>"; } } @@ -490,7 +516,7 @@ sub unescape { sub shorten { my $line = $_[0]; - if (length $line > 79) { + if (length($line) > 79 and index($line, "\n") == -1) { my $space_place = rindex($line, ' ', 79); if ($space_place != -1) { substr($line, $space_place, 1) = "\n\t"; diff --git a/gnu/usr.bin/perl/lib/dotsh.pl b/gnu/usr.bin/perl/lib/dotsh.pl index 8e9d9620e59..877467eb961 100644 --- a/gnu/usr.bin/perl/lib/dotsh.pl +++ b/gnu/usr.bin/perl/lib/dotsh.pl @@ -53,8 +53,8 @@ sub dotsh { open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n"; while (<_SH_ENV>) { chop; - /=/; - $ENV{$`} = $'; + m/^([^=]*)=(.*)/s; + $ENV{$1} = $2; } close (_SH_ENV); system "rm -f /tmp/_sh_env$$"; diff --git a/gnu/usr.bin/perl/lib/dumpvar.pl b/gnu/usr.bin/perl/lib/dumpvar.pl index 06c09305816..c32bc2fb5e1 100644 --- a/gnu/usr.bin/perl/lib/dumpvar.pl +++ b/gnu/usr.bin/perl/lib/dumpvar.pl @@ -25,6 +25,7 @@ $subdump = 1; sub main::dumpValue { local %address; + local $^W=0; (print "undef\n"), return unless defined $_[0]; (print &stringify($_[0]), "\n"), return unless ref $_[0]; dumpvar::unwrap($_[0],0); @@ -116,9 +117,9 @@ sub unwrap { # Check for reused addresses if (ref $v) { - ($address) = $v =~ /(0x[0-9a-f]+)/ ; + ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; if (defined $address) { - ($type) = $v =~ /=(.*?)\(/ ; + ($type) = $v =~ /=(.*?)\([^=]+$/ ; $address{$address}++ ; if ( $address{$address} > 1 ) { print "${sp}-> REUSED_ADDRESS\n" ; @@ -134,7 +135,7 @@ sub unwrap { } } - if ( ref $v eq 'HASH' or $type eq 'HASH') { + if ( UNIVERSAL::isa($v, 'HASH') ) { @sortKeys = sort keys(%$v) ; undef $more ; $tHashDepth = $#sortKeys ; @@ -167,7 +168,7 @@ sub unwrap { } print "$sp empty hash\n" unless @sortKeys; print "$sp$more" if defined $more ; - } elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') { + } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { $tArrayDepth = $#{$v} ; undef $more ; $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 @@ -197,13 +198,13 @@ sub unwrap { } print "$sp empty array\n" unless @$v; print "$sp$more" if defined $more ; - } elsif ( ref $v eq 'SCALAR' or ref $v eq 'REF' or $type eq 'SCALAR' ) { + } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { print "$sp-> "; DumpElem $$v, $s; - } elsif ( ref $v eq 'CODE' or $type eq 'CODE' ) { + } elsif ( UNIVERSAL::isa($v, 'CODE') ) { print "$sp-> "; dumpsub (0, $v); - } elsif (ref $v eq 'GLOB') { + } elsif ( UNIVERSAL::isa($v, 'GLOB') ) { print "$sp-> ",&stringify($$v,1),"\n"; if ($globPrint) { $s += 3; @@ -222,8 +223,8 @@ sub unwrap { sub matchvar { $_[0] eq $_[1] or - ($_[1] =~ /^([!~])(.)/) and - ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$'/}); + ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and + ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/}); } sub compactDump { @@ -319,7 +320,7 @@ sub findsubs { sub main::dumpvar { my ($package,@vars) = @_; - local(%address,$key,$val); + local(%address,$key,$val,$^W); $package .= "::" unless $package =~ /::$/; *stab = *{"main::"}; while ($package =~ /(\w+?::)/g){ diff --git a/gnu/usr.bin/perl/lib/find.pl b/gnu/usr.bin/perl/lib/find.pl index 40e613e97ee..ee5dc5d1506 100644 --- a/gnu/usr.bin/perl/lib/find.pl +++ b/gnu/usr.bin/perl/lib/find.pl @@ -29,80 +29,19 @@ # # Set the variable $dont_use_nlink if you're using AFS, since AFS cheats. -sub find { - chop($cwd = `pwd`); - foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) - || (warn("Can't stat $topdir: $!\n"), next); - if (-d _) { - if (chdir($topdir)) { - ($dir,$_) = ($topdir,'.'); - $name = $topdir; - &wanted; - ($fixtopdir = $topdir) =~ s,/$,, ; - &finddir($fixtopdir,$topnlink); - } - else { - warn "Can't cd to $topdir: $!\n"; - } - } - else { - unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { - ($dir,$_) = ('.', $topdir); - } - $name = $topdir; - chdir $dir && &wanted; - } - chdir $cwd; - } -} - -sub finddir { - local($dir,$nlink) = @_; - local($dev,$ino,$mode,$subcount); - local($name); - - # Get the list of files in the current directory. - - opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); - local(@filenames) = readdir(DIR); - closedir(DIR); +use File::Find (); - 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 = $prune = 0; - $name = "$dir/$_"; - &wanted; - if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? +*name = *File::Find::name; +*prune = *File::Find::prune; +*dir = *File::Find::dir; +*topdir = *File::Find::topdir; +*topdev = *File::Find::topdev; +*topino = *File::Find::topino; +*topmode = *File::Find::topmode; +*topnlink = *File::Find::topnlink; - # Get link count and check for directoriness. - - ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink; - - if (-d _) { - - # It really is a directory, so do it recursively. - - if (!$prune && chdir $_) { - &finddir($name,$nlink); - chdir '..'; - } - --$subcount; - } - } - } - } +sub find { + &File::Find::find(\&wanted, @_); } + 1; diff --git a/gnu/usr.bin/perl/lib/finddepth.pl b/gnu/usr.bin/perl/lib/finddepth.pl index 1fe6a375b6c..bfa44bb1bc9 100644 --- a/gnu/usr.bin/perl/lib/finddepth.pl +++ b/gnu/usr.bin/perl/lib/finddepth.pl @@ -27,79 +27,20 @@ # ($prune = 1); # } -sub finddepth { - chop($cwd = `pwd`); - foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) - || (warn("Can't stat $topdir: $!\n"), next); - if (-d _) { - if (chdir($topdir)) { - ($fixtopdir = $topdir) =~ s,/$,, ; - &finddepthdir($fixtopdir,$topnlink); - ($dir,$_) = ($fixtopdir,'.'); - $name = $fixtopdir; - &wanted; - } - else { - warn "Can't cd to $topdir: $!\n"; - } - } - else { - unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { - ($dir,$_) = ('.', $topdir); - } - chdir $dir && &wanted; - } - chdir $cwd; - } -} - -sub finddepthdir { - local($dir,$nlink) = @_; - local($dev,$ino,$mode,$subcount); - local($name); - - # Get the list of files in the current directory. - - opendir(DIR,'.') || warn "Can't open $dir: $!\n"; - local(@filenames) = readdir(DIR); - closedir(DIR); - if ($nlink == 2) { # 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 = $prune = 0; - $name = "$dir/$_"; - if ($subcount > 0) { # Seen all the subdirs? +use File::Find (); - # Get link count and check for directoriness. +*name = *File::Find::name; +*prune = *File::Find::prune; +*dir = *File::Find::dir; +*topdir = *File::Find::topdir; +*topdev = *File::Find::topdev; +*topino = *File::Find::topino; +*topmode = *File::Find::topmode; +*topnlink = *File::Find::topnlink; - ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink; - - if (-d _) { - - # It really is a directory, so do it recursively. - - if (!$prune && chdir $_) { - &finddepthdir($name,$nlink); - chdir '..'; - } - --$subcount; - } - } - &wanted; - } - } +sub finddepth { + &File::Find::finddepth(\&wanted, @_); } + 1; diff --git a/gnu/usr.bin/perl/lib/ftp.pl b/gnu/usr.bin/perl/lib/ftp.pl index a0f926430cb..61848fea5d4 100644 --- a/gnu/usr.bin/perl/lib/ftp.pl +++ b/gnu/usr.bin/perl/lib/ftp.pl @@ -5,10 +5,10 @@ # based on original version by Alan R. Martello <al@ee.pitt.edu> # And by A.Macpherson@bnr.co.uk for multi-homed hosts # -# $Header: /cvs/OpenBSD/src/gnu/usr.bin/perl/lib/Attic/ftp.pl,v 1.1 1996/08/19 10:12:34 downsj Exp $ +# $Header: /cvs/OpenBSD/src/gnu/usr.bin/perl/lib/Attic/ftp.pl,v 1.2 1997/11/30 07:56:58 millert Exp $ # $Log: ftp.pl,v $ -# Revision 1.1 1996/08/19 10:12:34 downsj -# Initial revision +# Revision 1.2 1997/11/30 07:56:58 millert +# perl 5.004_04 # # Revision 1.17 1993/04/21 10:06:54 lmjm # Send all status reports to STDERR not to STDOUT (to allow use by ftpcat). @@ -91,8 +91,9 @@ # Initial revision # -require 'chat2.pl'; -eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" || die "socket.ph missing: $!\n"; +require 'chat2.pl'; # into main +eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" + || die "socket.ph missing: $!\n"; package ftp; @@ -143,7 +144,7 @@ $real_site = ""; $ftp_show = 0; sub ftp'debug { - $ftp_show = @_[0]; + $ftp_show = $_[0]; # if( $ftp_show ){ # print STDERR "ftp debugging on\n"; # } @@ -151,7 +152,7 @@ sub ftp'debug sub ftp'set_timeout { - $timeout = @_[0]; + $timeout = $_[0]; $timeout_open = $timeout; $timeout_read = 20 * $timeout; if( $ftp_show ){ @@ -248,7 +249,7 @@ sub ftp'login local( $remote_user, $remote_password ) = @_; if( $proxy ){ - &ftp'send( "USER $remote_user@$site" ); + &ftp'send( "USER $remote_user\@$site" ); } else { &ftp'send( "USER $remote_user" ); diff --git a/gnu/usr.bin/perl/lib/getcwd.pl b/gnu/usr.bin/perl/lib/getcwd.pl index 8db8e20c069..9dd694500c6 100644 --- a/gnu/usr.bin/perl/lib/getcwd.pl +++ b/gnu/usr.bin/perl/lib/getcwd.pl @@ -44,9 +44,9 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; - closedir(getcwd'PARENT); #'); - return ''; + # warn "lstat($dotdots/$dir): $!"; + # closedir(getcwd'PARENT); #'); + # return ''; } } while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] || @@ -54,7 +54,7 @@ sub getcwd } $cwd = "$dir/$cwd"; closedir(getcwd'PARENT); #'); - } while ($dir); + } while ($dir ne ''); chop($cwd); $cwd; } diff --git a/gnu/usr.bin/perl/lib/getopt.pl b/gnu/usr.bin/perl/lib/getopt.pl index a6023c80bc9..f871e418501 100644 --- a/gnu/usr.bin/perl/lib/getopt.pl +++ b/gnu/usr.bin/perl/lib/getopt.pl @@ -24,10 +24,10 @@ sub Getopt { shift(@ARGV); $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; + ${"opt_$first"} = $rest; } else { - eval "\$opt_$first = 1;"; + ${"opt_$first"} = 1; if ($rest ne '') { $ARGV[0] = "-$rest"; } diff --git a/gnu/usr.bin/perl/lib/getopts.pl b/gnu/usr.bin/perl/lib/getopts.pl index a0818d1e3a0..852aae89b18 100644 --- a/gnu/usr.bin/perl/lib/getopts.pl +++ b/gnu/usr.bin/perl/lib/getopts.pl @@ -8,23 +8,22 @@ sub Getopts { local($argumentative) = @_; local(@args,$_,$first,$rest); local($errs) = 0; - local($[) = 0; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); $pos = index($argumentative,$first); - if($pos >= $[) { - if($args[$pos+1] eq ':') { + if($pos >= 0) { + if($pos < $#args && $args[$pos+1] eq ':') { shift(@ARGV); if($rest eq '') { ++$errs unless @ARGV; $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; + ${"opt_$first"} = $rest; } else { - eval "\$opt_$first = 1"; + ${"opt_$first"} = 1; if($rest eq '') { shift(@ARGV); } diff --git a/gnu/usr.bin/perl/lib/importenv.pl b/gnu/usr.bin/perl/lib/importenv.pl index d56f32633b8..c28ffd054d4 100644 --- a/gnu/usr.bin/perl/lib/importenv.pl +++ b/gnu/usr.bin/perl/lib/importenv.pl @@ -8,7 +8,7 @@ local($tmp,$key) = ''; -foreach $key (keys(ENV)) { +foreach $key (keys(%ENV)) { $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; } eval $tmp; diff --git a/gnu/usr.bin/perl/lib/lib.pm b/gnu/usr.bin/perl/lib/lib.pm index 546ae87b891..4d32f963551 100644 --- a/gnu/usr.bin/perl/lib/lib.pm +++ b/gnu/usr.bin/perl/lib/lib.pm @@ -1,20 +1,30 @@ package lib; +use vars qw(@ORIG_INC); use Config; my $archname = $Config{'archname'}; -@ORIG_INC = (); # (avoid typo warning) @ORIG_INC = @INC; # take a handy copy of 'original' value sub import { shift; foreach (reverse @_) { + ## Ignore this if not defined. + next unless defined($_); + if ($_ eq '') { + require Carp; + Carp::carp("Empty compile time value given to use lib"); + # at foo.pl line ... + } unshift(@INC, $_); # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. - unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; + if (-d "$_/$archname") { + unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; + unshift(@INC, "$_/$archname/$]") if -d "$_/$archname/$]/auto"; + } } } @@ -60,7 +70,6 @@ It is typically used to add extra directories to perl's search path so that later C<use> or C<require> statements will find modules which are not located on perl's default search path. - =head2 ADDING DIRECTORIES TO @INC The parameters to C<use lib> are added to the start of the perl search @@ -80,7 +89,6 @@ architecture specific directory and is added to @INC in front of $dir. If LIST includes both $dir and $dir/$archname then $dir/$archname will be added to @INC twice (if $dir/$archname/auto exists). - =head2 DELETING DIRECTORIES FROM @INC You should normally only add directories to @INC. If you need to @@ -106,7 +114,6 @@ architecture specific directory and is also deleted from @INC. If LIST includes both $dir and $dir/$archname then $dir/$archname will be deleted from @INC twice (if $dir/$archname/auto exists). - =head2 RESTORING ORIGINAL @INC When the lib module is first loaded it records the current value of @INC @@ -118,7 +125,7 @@ can say =head1 SEE ALSO -AddINC - optional module which deals with paths relative to the source file. +FindBin - optional module which deals with paths relative to the source file. =head1 AUTHOR diff --git a/gnu/usr.bin/perl/lib/look.pl b/gnu/usr.bin/perl/lib/look.pl index 4c14e64727a..e8dc8aacb6a 100644 --- a/gnu/usr.bin/perl/lib/look.pl +++ b/gnu/usr.bin/perl/lib/look.pl @@ -10,7 +10,7 @@ sub look { $blksize,$blocks) = stat(FH); $blksize = 8192 unless $blksize; $key =~ s/[^\w\s]//g if $dict; - $key =~ y/A-Z/a-z/ if $fold; + $key = lc $key if $fold; $max = int($size / $blksize); while ($max - $min > 1) { $mid = int(($max + $min) / 2); @@ -19,7 +19,7 @@ sub look { $_ = <FH>; chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; if ($_ lt $key) { $min = $mid; } @@ -33,7 +33,7 @@ sub look { while (<FH>) { chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; last if $_ ge $key; $min = tell(FH); } diff --git a/gnu/usr.bin/perl/lib/newgetopt.pl b/gnu/usr.bin/perl/lib/newgetopt.pl index 38cad59c73e..0b7eed8bfe9 100644 --- a/gnu/usr.bin/perl/lib/newgetopt.pl +++ b/gnu/usr.bin/perl/lib/newgetopt.pl @@ -1,6 +1,6 @@ # newgetopt.pl -- new options parsing. # Now just a wrapper around the Getopt::Long module. -# $Id: newgetopt.pl,v 1.15 1995/12/26 14:57:33 jv Exp $ +# $Id: newgetopt.pl,v 1.17 1996-10-02 11:17:16+02 jv Exp $ { package newgetopt; @@ -15,12 +15,16 @@ $getopt_compat = 0; # disallow '+' to start options $option_start = "(--|-)"; $order = $REQUIRE_ORDER; + $bundling = 0; + $passthrough = 0; } else { $autoabbrev = 1; # automatic abbrev of options $getopt_compat = 1; # allow '+' to start options $option_start = "(--|-|\\+)"; $order = $PERMUTE; + $bundling = 0; + $passthrough = 0; } # Other configurable settings. @@ -45,8 +49,14 @@ sub NGetOpt { if defined $newgetopt::option_start; $Getopt::Long::order = $newgetopt::order if defined $newgetopt::order; + $Getopt::Long::bundling = $newgetopt::bundling + if defined $newgetopt::bundling; $Getopt::Long::ignorecase = $newgetopt::ignorecase if defined $newgetopt::ignorecase; + $Getopt::Long::ignorecase = $newgetopt::ignorecase + if defined $newgetopt::ignorecase; + $Getopt::Long::passthrough = $newgetopt::passthrough + if defined $newgetopt::passthrough; &GetOptions; } diff --git a/gnu/usr.bin/perl/lib/open2.pl b/gnu/usr.bin/perl/lib/open2.pl index dcd68a8cd3a..8cf08c2e8bd 100644 --- a/gnu/usr.bin/perl/lib/open2.pl +++ b/gnu/usr.bin/perl/lib/open2.pl @@ -1,54 +1,12 @@ -# &open2: tom christiansen, <tchrist@convex.com> +# This is a compatibility interface to IPC::Open2. New programs should +# do # -# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args'); -# or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); +# use IPC::Open2; # -# spawn the given $cmd and connect $rdr for -# reading and $wtr for writing. return pid -# of child, or 0 on failure. -# -# WARNING: this is dangerous, as you may block forever -# unless you are very careful. -# -# $wtr is left unbuffered. -# -# abort program if -# rdr or wtr are null -# pipe or fork or exec fails - -package open2; -$fh = 'FHOPEN000'; # package static in case called more than once - -sub main'open2 { - local($kidpid); - local($dad_rdr, $dad_wtr, @cmd) = @_; - - $dad_rdr ne '' || die "open2: rdr should not be null"; - $dad_wtr ne '' || die "open2: wtr should not be null"; - - # force unqualified filehandles into callers' package - local($package) = caller; - $dad_rdr =~ s/^[^']+$/$package'$&/; - $dad_wtr =~ s/^[^']+$/$package'$&/; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - - pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!"; - pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!"; +# instead of +# +# require 'open2.pl'; - if (($kidpid = fork) < 0) { - die "open2: fork failed: $!"; - } elsif ($kidpid == 0) { - close $dad_rdr; close $dad_wtr; - open(STDIN, "<&$kid_rdr"); - open(STDOUT, ">&$kid_wtr"); - warn "execing @cmd\n" if $debug; - exec @cmd; - die "open2: exec of @cmd failed"; - } - close $kid_rdr; close $kid_wtr; - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; -} -1; # so require is happy +package main; +use IPC::Open2 'open2'; +1 diff --git a/gnu/usr.bin/perl/lib/open3.pl b/gnu/usr.bin/perl/lib/open3.pl index 7c8b6ae2884..7fcc9318610 100644 --- a/gnu/usr.bin/perl/lib/open3.pl +++ b/gnu/usr.bin/perl/lib/open3.pl @@ -1,106 +1,12 @@ -# &open3: Marc Horowitz <marc@mit.edu> -# derived mostly from &open2 by tom christiansen, <tchrist@convex.com> +# This is a compatibility interface to IPC::Open3. New programs should +# do # -# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ +# use IPC::Open3; # -# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); +# instead of # -# spawn the given $cmd and connect rdr for -# reading, wtr for writing, and err for errors. -# if err is '', or the same as rdr, then stdout and -# stderr of the child are on the same fh. returns pid -# of child, or 0 on failure. +# require 'open3.pl'; - -# if wtr begins with '>&', then wtr will be closed in the parent, and -# the child will read from it directly. if rdr or err begins with -# '>&', then the child will send output directly to that fd. In both -# cases, there will be a dup() instead of a pipe() made. - - -# WARNING: this is dangerous, as you may block forever -# unless you are very careful. -# -# $wtr is left unbuffered. -# -# abort program if -# rdr or wtr are null -# pipe or fork or exec fails - -package open3; - -$fh = 'FHOPEN000'; # package static in case called more than once - -sub main'open3 { - local($kidpid); - local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - local($dup_wtr, $dup_rdr, $dup_err); - - $dad_wtr || die "open3: wtr should not be null"; - $dad_rdr || die "open3: rdr should not be null"; - $dad_err = $dad_rdr if ($dad_err eq ''); - - $dup_wtr = ($dad_wtr =~ s/^\>\&//); - $dup_rdr = ($dad_rdr =~ s/^\>\&//); - $dup_err = ($dad_err =~ s/^\>\&//); - - # force unqualified filehandles into callers' package - local($package) = caller; - $dad_wtr =~ s/^[^']+$/$package'$&/; - $dad_rdr =~ s/^[^']+$/$package'$&/; - $dad_err =~ s/^[^']+$/$package'$&/; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - local($kid_err) = ++$fh; - - if (!$dup_wtr) { - pipe($kid_rdr, $dad_wtr) || die "open3: pipe 1 (stdin) failed: $!"; - } - if (!$dup_rdr) { - pipe($dad_rdr, $kid_wtr) || die "open3: pipe 2 (stdout) failed: $!"; - } - if ($dad_err ne $dad_rdr && !$dup_err) { - pipe($dad_err, $kid_err) || die "open3: pipe 3 (stderr) failed: $!"; - } - - if (($kidpid = fork) < 0) { - die "open2: fork failed: $!"; - } elsif ($kidpid == 0) { - if ($dup_wtr) { - open(STDIN, ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); - } else { - close($dad_wtr); - open(STDIN, ">&$kid_rdr"); - } - if ($dup_rdr) { - open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); - } else { - close($dad_rdr); - open(STDOUT, ">&$kid_wtr"); - } - if ($dad_rdr ne $dad_err) { - if ($dup_err) { - open(STDERR, ">&$dad_err") - if (fileno(STDERR) != fileno($dad_err)); - } else { - close($dad_err); - open(STDERR, ">&$kid_err"); - } - } else { - open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); - } - local($")=(" "); - exec @cmd; - die "open2: exec of @cmd failed"; - } - - close $kid_rdr; close $kid_wtr; close $kid_err; - if ($dup_wtr) { - close($dad_wtr); - } - - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; -} -1; # so require is happy +package main; +use IPC::Open3 'open3'; +1 diff --git a/gnu/usr.bin/perl/lib/overload.pm b/gnu/usr.bin/perl/lib/overload.pm index 54d2cbb4411..c9044db0dc5 100644 --- a/gnu/usr.bin/perl/lib/overload.pm +++ b/gnu/usr.bin/perl/lib/overload.pm @@ -1,12 +1,27 @@ package overload; +sub nil {} + sub OVERLOAD { $package = shift; my %arg = @_; - my $hash = \%{$package . "::OVERLOAD"}; + my ($sub, $fb); + $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching. + *{$package . "::()"} = \&nil; # Make it findable via fetchmethod. for (keys %arg) { - $hash->{$_} = $arg{$_}; + if ($_ eq 'fallback') { + $fb = $arg{$_}; + } else { + $sub = $arg{$_}; + if (not ref $sub and $sub !~ /::/) { + $ {$package . "::(" . $_} = $sub; + $sub = \&nil; + } + #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n"; + *{$package . "::(" . $_} = \&{ $sub }; + } } + ${$package . "::()"} = $fb; # Make it findable too (fallback only). } sub import { @@ -18,44 +33,73 @@ sub import { sub unimport { $package = (caller())[0]; - my $hash = \%{$package . "::OVERLOAD"}; + ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table shift; for (@_) { - delete $hash->{$_}; + if ($_ eq 'fallback') { + undef $ {$package . "::()"}; + } else { + delete $ {$package . "::"}{"(" . $_}; + } } } sub Overloaded { - defined ($package = ref $_[0]) and defined %{$package . "::OVERLOAD"}; + my $package = shift; + $package = ref $package if ref $package; + $package->can('()'); +} + +sub ov_method { + my $globref = shift; + return undef unless $globref; + my $sub = \&{*$globref}; + return $sub if $sub ne \&nil; + return shift->can($ {*$globref}); } sub OverloadedStringify { - defined ($package = ref $_[0]) and - defined %{$package . "::OVERLOAD"} and - exists $ {$package . "::OVERLOAD"}{'""'} and - defined &{$ {$package . "::OVERLOAD"}{'""'}}; + my $package = shift; + $package = ref $package if ref $package; + #$package->can('(""') + ov_method mycan($package, '(""'), $package; } sub Method { - defined ($package = ref $_[0]) and - defined %{$package . "::OVERLOAD"} and - $ {$package . "::OVERLOAD"}{$_[1]}; + my $package = shift; + $package = ref $package if ref $package; + #my $meth = $package->can('(' . shift); + ov_method mycan($package, '(' . shift), $package; + #return $meth if $meth ne \&nil; + #return $ {*{$meth}}; } sub AddrRef { - $package = ref $_[0]; - bless $_[0], Overload::Fake; # Non-overloaded package + my $package = ref $_[0]; + return "$_[0]" unless $package; + bless $_[0], overload::Fake; # Non-overloaded package my $str = "$_[0]"; bless $_[0], $package; # Back - $str; + $package . substr $str, index $str, '='; } sub StrVal { - (OverloadedStringify) ? - (AddrRef) : + (OverloadedStringify($_[0])) ? + (AddrRef(shift)) : "$_[0]"; } +sub mycan { # Real can would leave stubs. + my ($package, $meth) = @_; + return \*{$package . "::$meth"} if defined &{$package . "::$meth"}; + my $p; + foreach $p (@{$package . "::ISA"}) { + my $out = mycan($p, $meth); + return $out if $out; + } + return undef; +} + 1; __END__ @@ -105,9 +149,10 @@ the "class" C<Number> (or one of its base classes) for the assignment form C<*=> of multiplication. Arguments of this directive come in (key, value) pairs. Legal values -are values legal inside a C<&{ ... }> call, so the name of a subroutine, -a reference to a subroutine, or an anonymous subroutine will all work. -Legal keys are listed below. +are values legal inside a C<&{ ... }> call, so the name of a +subroutine, a reference to a subroutine, or an anonymous subroutine +will all work. Note that values specified as strings are +interpreted as methods, not subroutines. Legal keys are listed below. The subroutine C<add> will be called to execute C<$a+$b> if $a is a reference to an object blessed into the package C<Number>, or if $a is @@ -117,6 +162,10 @@ C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical methods refer to methods triggered by an overloaded mathematical operator.) +Since overloading respects inheritance via the @ISA hierarchy, the +above declaration would also trigger overloading of C<+> and C<*=> in +all the packages which inherit from C<Number>. + =head2 Calling Conventions for Binary Operations The functions specified in the C<use overload ...> directive are called @@ -186,7 +235,9 @@ arrays, C<cmp> is used to compare values subject to C<use overload>. "&", "^", "|", "neg", "!", "~", "C<neg>" stands for unary minus. If the method for C<neg> is not -specified, it can be autogenerated using the method for subtraction. +specified, it can be autogenerated using the method for +subtraction. If the method for "C<!>" is not specified, it can be +autogenerated using the methods for "C<bool>", or "C<\"\">", or "C<0+>". =item * I<Increment and decrement> @@ -201,7 +252,7 @@ postfix form. "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", If C<abs> is unavailable, it can be autogenerated using methods -for "<" or "<=>" combined with either unary minus or subtraction. +for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction. =item * I<Boolean, string and numeric conversion> @@ -223,12 +274,46 @@ see L<SPECIAL SYMBOLS FOR C<use overload>>. See L<"Fallback"> for an explanation of when a missing method can be autogenerated. +=head2 Inheritance and overloading + +Inheritance interacts with overloading in two ways. + +=over + +=item Strings as values of C<use overload> directive + +If C<value> in + + use overload key => value; + +is a string, it is interpreted as a method name. + +=item Overloading of an operation is inherited by derived classes + +Any class derived from an overloaded class is also overloaded. The +set of overloaded methods is the union of overloaded methods of all +the ancestors. If some method is overloaded in several ancestor, then +which description will be used is decided by the usual inheritance +rules: + +If C<A> inherits from C<B> and C<C> (in this order), C<B> overloads +C<+> with C<\&D::plus_sub>, and C<C> overloads C<+> by C<"plus_meth">, +then the subroutine C<D::plus_sub> will be called to implement +operation C<+> for an object in package C<A>. + +=back + +Note that since the value of the C<fallback> key is not a subroutine, +its inheritance is not governed by the above rules. In the current +implementation, the value of C<fallback> in the first overloaded +ancestor is used, but this is accidental and subject to change. + =head1 SPECIAL SYMBOLS FOR C<use overload> Three keys are recognized by Perl that are not covered by the above description. -=head2 Last Resort +=head2 Last Resort C<"nomethod"> should be followed by a reference to a function of four parameters. If defined, it is called when the overloading mechanism @@ -275,6 +360,9 @@ C<"nomethod"> value, and if this is missing, raises an exception. =back +B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone +yet, see L<"Inheritance and overloading">. + =head2 Copy Constructor The value for C<"="> is a reference to a function with three @@ -361,6 +449,11 @@ can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>). can be expressed in terms of subtraction. +=item I<Negation> + +C<!> and C<not> can be expressed in terms of boolean conversion, or +string or numerical conversion. + =item I<Concatenation> can be expressed in terms of string conversion. @@ -369,7 +462,7 @@ can be expressed in terms of string conversion. can be expressed in terms of its "spaceship" counterpart: either C<E<lt>=E<gt>> or C<cmp>: - + <, >, <=, >=, ==, != in terms of <=> lt, gt, le, ge, eq, ne in terms of cmp @@ -433,31 +526,40 @@ Returns C<undef> or a reference to the method that implements C<op>. What follows is subject to change RSN. -The table of methods for all operations is cached as magic in the -symbol table hash for the package. The table is rechecked for changes due to -C<use overload>, C<no overload>, and @ISA only during -C<bless>ing; so if they are changed dynamically, you'll need an -additional fake C<bless>ing to update the table. - -(Every SVish thing has a magic queue, and magic is an entry in that queue. -This is how a single variable may participate in multiple forms of magic -simultaneously. For instance, environment variables regularly have two -forms at once: their %ENV magic and their taint magic.) +The table of methods for all operations is cached in magic for the +symbol table hash for the package. The cache is invalidated during +processing of C<use overload>, C<no overload>, new function +definitions, and changes in @ISA. However, this invalidation remains +unprocessed until the next C<bless>ing into the package. Hence if you +want to change overloading structure dynamically, you'll need an +additional (fake) C<bless>ing to update the table. + +(Every SVish thing has a magic queue, and magic is an entry in that +queue. This is how a single variable may participate in multiple +forms of magic simultaneously. For instance, environment variables +regularly have two forms at once: their %ENV magic and their taint +magic. However, the magic which implements overloading is applied to +the stashes, which are rarely used directly, thus should not slow down +Perl.) If an object belongs to a package using overload, it carries a special flag. Thus the only speed penalty during arithmetic operations without overloading is the checking of this flag. -In fact, if C<use overload> is not present, there is almost no overhead for -overloadable operations, so most programs should not suffer measurable -performance penalties. A considerable effort was made to minimize the overhead -when overload is used and the current operation is overloadable but -the arguments in question do not belong to packages using overload. When -in doubt, test your speed with C<use overload> and without it. So far there -have been no reports of substantial speed degradation if Perl is compiled -with optimization turned on. - -There is no size penalty for data if overload is not used. +In fact, if C<use overload> is not present, there is almost no overhead +for overloadable operations, so most programs should not suffer +measurable performance penalties. A considerable effort was made to +minimize the overhead when overload is used in some package, but the +arguments in question do not belong to packages using overload. When +in doubt, test your speed with C<use overload> and without it. So far +there have been no reports of substantial speed degradation if Perl is +compiled with optimization turned on. + +There is no size penalty for data if overload is not used. The only +size penalty if overload is used in some package is that I<all> the +packages acquire a magic during the next C<bless>ing into the +package. This magic is three-words-long for packages without +overloading, and carries the cache tabel if the package is overloaded. Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is carried out before any operation that can imply an assignment to the @@ -469,19 +571,31 @@ to be changed are constant (but this is not enforced). =head1 AUTHOR -Ilya Zakharevich <F<ilya@math.mps.ohio-state.edu>>. +Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>. =head1 DIAGNOSTICS When Perl is run with the B<-Do> switch or its equivalent, overloading induces diagnostic messages. +Using the C<m> command of Perl debugger (see L<perldebug>) one can +deduce which operations are overloaded (and which ancestor triggers +this overloading). Say, if C<eq> is overloaded, then the method C<(eq> +is shown by debugger. The method C<()> corresponds to the C<fallback> +key (in fact a presence of this method shows that this package has +overloading enabled, and it is what is used by the C<Overloaded> +function). + =head1 BUGS -Because it is used for overloading, the per-package associative array -%OVERLOAD now has a special meaning in Perl. +Because it is used for overloading, the per-package hash %OVERLOAD now +has a special meaning in Perl. The symbol table is filled with names +looking like line-noise. -As shipped, mathemagical properties are not inherited via the @ISA tree. +For the purpose of inheritance every overloaded package behaves as if +C<fallback> is present (possibly undefined). This may create +interesting effects if some package is not overloaded, but inherits +from two overloaded packages. This document is confusing. diff --git a/gnu/usr.bin/perl/lib/perl5db.pl b/gnu/usr.bin/perl/lib/perl5db.pl index 5c8d2727b72..d5dbfbdd68b 100644 --- a/gnu/usr.bin/perl/lib/perl5db.pl +++ b/gnu/usr.bin/perl/lib/perl5db.pl @@ -2,7 +2,8 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$header = 'perl5db.pl patch level 0.94'; +$VERSION = 1.01; +$header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl @@ -16,14 +17,35 @@ $header = 'perl5db.pl patch level 0.94'; # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. # -# Perl supplies the values for @line and %sub. It effectively inserts -# a &DB'DB(<linenum>); in front of every place that can have a +# Perl supplies the values for %sub. It effectively inserts +# a &DB'DB(); in front of every place that can have a # breakpoint. Instead of a subroutine call it calls &DB::sub with # $DB::sub being the called subroutine. It also inserts a BEGIN # {require 'perl5db.pl'} before the first line. # +# After each `require'd file is compiled, but before it is executed, a +# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the +# $filename is the expanded name of the `require'd file (as found as +# value of %INC). +# +# Additional services from Perl interpreter: +# +# if caller() is called from the package DB, it provides some +# additional data. +# +# The array @{$main::{'_<'.$filename} is the line-by-line contents of +# $filename. +# +# The hash %{'_<'.$filename} contains breakpoints and action (it is +# keyed by line number), and individual entries are settable (as +# opposed to the whole hash). Only true/false is important to the +# interpreter, though the values used by perl5db.pl have the form +# "$break_condition\0$action". Values are magical in numeric context. +# +# The scalar ${'_<'.$filename} contains "_<$filename". +# # Note that no subroutine call is possible until &DB::sub is defined -# (for subroutines defined outside this file). In fact the same is +# (for subroutines defined outside of the package DB). In fact the same is # true if $deep is not defined. # # $Log: perldb.pl,v $ @@ -63,6 +85,65 @@ $header = 'perl5db.pl patch level 0.94'; # information into db.out. (If you interrupt it, you would better # reset LineInfo to something "interactive"!) # +################################################################## +# Changelog: + +# A lot of things changed after 0.94. First of all, core now informs +# debugger about entry into XSUBs, overloaded operators, tied operations, +# BEGIN and END. Handy with `O f=2'. + +# This can make debugger a little bit too verbose, please be patient +# and report your problems promptly. + +# Now the option frame has 3 values: 0,1,2. + +# Note that if DESTROY returns a reference to the object (or object), +# the deletion of data may be postponed until the next function call, +# due to the need to examine the return value. + +# Changes: 0.95: `v' command shows versions. +# Changes: 0.96: `v' command shows version of readline. +# primitive completion works (dynamic variables, subs for `b' and `l', +# options). Can `p %var' +# Better help (`h <' now works). New commands <<, >>, {, {{. +# {dump|print}_trace() coded (to be able to do it from <<cmd). +# `c sub' documented. +# At last enough magic combined to stop after the end of debuggee. +# !! should work now (thanks to Emacs bracket matching an extra +# `]' in a regexp is caught). +# `L', `D' and `A' span files now (as documented). +# Breakpoints in `require'd code are possible (used in `R'). +# Some additional words on internal work of debugger. +# `b load filename' implemented. +# `b postpone subr' implemented. +# now only `q' exits debugger (overwriteable on $inhibit_exit). +# When restarting debugger breakpoints/actions persist. +# Buglet: When restarting debugger only one breakpoint/action per +# autoloaded function persists. +# Changes: 0.97: NonStop will not stop in at_exit(). +# Option AutoTrace implemented. +# Trace printed differently if frames are printed too. +# new `inhibitExit' option. +# printing of a very long statement interruptible. +# Changes: 0.98: New command `m' for printing possible methods +# 'l -' is a synonim for `-'. +# Cosmetic bugs in printing stack trace. +# `frame' & 8 to print "expanded args" in stack trace. +# Can list/break in imported subs. +# new `maxTraceLen' option. +# frame & 4 and frame & 8 granted. +# new command `m' +# nonstoppable lines do not have `:' near the line number. +# `b compile subname' implemented. +# Will not use $` any more. +# `-' behaves sane now. +# Changes: 0.99: Completion for `f', `m'. +# `m' will remove duplicate names instead of duplicate functions. +# `b load' strips trailing whitespace. +# completion ignores leading `|'; takes into account current package +# when completing a subroutine name (same for `l'). + +#################################################################### # Needed for the statement after exec(): @@ -76,12 +157,11 @@ warn ( # Do not ;-) $dumpvar::quoteHighBit, $dumpvar::printUndef, $dumpvar::globPrint, - $readline::Tk_toloop, $dumpvar::usageOnly, @ARGS, $Carp::CarpLevel, $panic, - $first_time, + $second_time, ) if 0; # Command-line + PERLLIB: @@ -91,16 +171,14 @@ warn ( # Do not ;-) $trace = $signal = $single = 0; # Uninitialized warning suppression # (local $^W cannot help - other packages!). -@stack = (0); - -$option{PrintRet} = 1; +$inhibit_exit = $option{PrintRet} = 1; @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages compactDump veryCompact quote HighBit undefPrint - globPrint PrintRet UsageOnly frame - TTY noTTY ReadLine NonStop LineInfo - recallCommand ShellBang pager tkRunning - signalLevel warnLevel dieLevel); + globPrint PrintRet UsageOnly frame AutoTrace + TTY noTTY ReadLine NonStop LineInfo maxTraceLen + recallCommand ShellBang pager tkRunning ornaments + signalLevel warnLevel dieLevel inhibit_exit); %optionVars = ( hashDepth => \$dumpvar::hashDepth, @@ -110,9 +188,11 @@ $option{PrintRet} = 1; HighBit => \$dumpvar::quoteHighBit, undefPrint => \$dumpvar::printUndef, globPrint => \$dumpvar::globPrint, - tkRunning => \$readline::Tk_toloop, UsageOnly => \$dumpvar::usageOnly, - frame => \$frame, + frame => \$frame, + AutoTrace => \$trace, + inhibit_exit => \$inhibit_exit, + maxTraceLen => \$maxtrace, ); %optionAction = ( @@ -130,6 +210,8 @@ $option{PrintRet} = 1; signalLevel => \&signalLevel, warnLevel => \&warnLevel, dieLevel => \&dieLevel, + tkRunning => \&tkRunning, + ornaments => \&ornaments, ); %optionRequire = ( @@ -140,12 +222,19 @@ $option{PrintRet} = 1; # These guys may be defined in $ENV{PERL5DB} : $rl = 1 unless defined $rl; +$warnLevel = 1 unless defined $warnLevel; +$dieLevel = 1 unless defined $dieLevel; +$signalLevel = 1 unless defined $signalLevel; +$pre = [] unless defined $pre; +$post = [] unless defined $post; +$pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager; &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; +$maxtrace = 400 unless defined $maxtrace; if (-e "/dev/tty") { $rcfile=".perldb"; @@ -169,9 +258,12 @@ if (exists $ENV{PERLDB_RESTART}) { delete $ENV{PERLDB_RESTART}; # $restart = 1; @hist = get_list('PERLDB_HIST'); - my @visited = get_list("PERLDB_VISITED"); - for (0 .. $#visited) { - %{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_"); + %break_on_load = get_list("PERLDB_ON_LOAD"); + %postponed = get_list("PERLDB_POSTPONE"); + my @had_breakpoints= get_list("PERLDB_VISITED"); + for (0 .. $#had_breakpoints) { + my %pf = get_list("PERLDB_FILE_$_"); + $postponed_file{$had_breakpoints[$_]} = \%pf if %pf; } my %opt = get_list("PERLDB_OPT"); my ($opt,$val); @@ -181,6 +273,10 @@ if (exists $ENV{PERLDB_RESTART}) { } @INC = get_list("PERLDB_INC"); @ini_INC = @INC; + $pretype = [get_list("PERLDB_PRETYPE")]; + $pre = [get_list("PERLDB_PRE")]; + $post = [get_list("PERLDB_POST")]; + @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead); } if ($notty) { @@ -194,14 +290,18 @@ if ($notty) { if (-e "/dev/tty") { $console = "/dev/tty"; - } elsif (-e "con") { + } elsif (-e "con" or $^O eq 'MSWin32') { $console = "con"; } else { $console = "sys\$command"; } + if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) { + $console = undef; + } + # Around a bug: - if (defined $ENV{OS2_SHELL} and $emacs) { # In OS/2 + if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2 $console = undef; } @@ -249,41 +349,28 @@ if (defined &afterinit) { # May be defined in $rcfile &afterinit(); } +$I_m_init = 1; + ############################################################ Subroutines sub DB { - unless ($first_time++) { # Do when-running init - if ($runnonstop) { # Disable until signal + # _After_ the perl program is compiled, $single is set to 1: + if ($single and not $second_time++) { + if ($runnonstop) { # Disable until signal for ($i=0; $i <= $#stack; ) { $stack[$i++] &= ~1; } $single = 0; - return; + # return; # Would not print trace! } - # Define a subroutine in which we will stop -# eval <<'EOE'; -# sub at_end::db {"Debuggee terminating";} -# END { -# $DB::step = 1; -# print $OUT "Debuggee terminating.\n"; -# &at_end::db;} -# EOE } + $runnonstop = 0 if $single or $signal; # Disable it if interactive. &save; - if ($doret) { - $doret = 0; - if ($option{PrintRet}) { - print $OUT "$retctx context return from $lastsub:", - ($retctx eq 'list') ? "\n" : " " ; - dumpit( ($retctx eq 'list') ? \@ret : $ret ); - } - } ($package, $filename, $line) = caller; $filename_ini = $filename; $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas - local(*dbline) = "::_<$filename"; - install_breakpoints($filename) unless $visited{$filename}++; + local(*dbline) = $main::{'_<' . $filename}; $max = $#dbline; if (($stop,$action) = split(/\0/,$dbline{$line})) { if ($stop eq '1') { @@ -293,7 +380,9 @@ sub DB { $dbline{$line} =~ s/;9($|\0)/$1/; } } - if ($single || $trace || $signal) { + my $was_signal = $signal; + $signal = 0; + if ($single || $trace || $was_signal) { $term || &setterm; if ($emacs) { $position = "\032\032$filename:$line:0\n"; @@ -305,48 +394,60 @@ sub DB { $after = ($dbline[$line] =~ /\n$/ ? '' : "\n"); if (length($prefix) > 30) { $position = "$prefix$line):\n$line:\t$dbline[$line]$after"; - print $LINEINFO $position; $prefix = ""; $infix = ":\t"; } else { $infix = "):\t"; $position = "$prefix$line$infix$dbline[$line]$after"; + } + if ($frame) { + print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after"; + } else { print $LINEINFO $position; } for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi last if $dbline[$i] =~ /^\s*[\;\}\#\n]/; + last if $signal; $after = ($dbline[$i] =~ /\n$/ ? '' : "\n"); $incr_pos = "$prefix$i$infix$dbline[$i]$after"; - print $LINEINFO $incr_pos; $position .= $incr_pos; + if ($frame) { + print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after"; + } else { + print $LINEINFO $incr_pos; + } } } } $evalarg = $action, &eval if $action; - if ($single || $signal) { + if ($single || $was_signal) { local $level = $level + 1; - $evalarg = $pre, &eval if $pre; + foreach $evalarg (@$pre) { + &eval; + } print $OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; + $incr = -1; # for backward motion. + @typeahead = @$pretype, @typeahead; CMD: while (($term || &setterm), + ($term_pid == $$ or &resetterm), defined ($cmd=&readline(" DB" . ('<' x $level) . ($#hist+1) . ('>' x $level) . " "))) { - #{ # <-- Do we know what this brace is for? $single = 0; $signal = 0; $cmd =~ s/\\$/\n/ && do { $cmd .= &readline(" cont: "); redo CMD; }; - $cmd =~ /^q$/ && exit 0; $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; PIPE: { ($i) = split(/\s+/,$cmd); eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i}; + $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^h$/ && do { print $OUT $help; next CMD; }; @@ -355,8 +456,10 @@ sub DB { next CMD; }; $cmd =~ /^h\s+(\S)$/ && do { my $asked = "\Q$1"; - if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) { + if ($help =~ /^$asked/m) { + while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) { print $OUT $1; + } } else { print $OUT "`$asked' is not a debugger command.\n"; } @@ -373,6 +476,8 @@ sub DB { } } next CMD; }; + $cmd =~ /^v$/ && do { + list_versions(); next CMD}; $cmd =~ s/^X\b/V $package/; $cmd =~ /^V$/ && do { $cmd = "V $package"; }; @@ -383,6 +488,7 @@ sub DB { do 'dumpvar.pl' unless defined &main::dumpvar; if (defined &main::dumpvar) { local $frame = 0; + local $doret = -2; &main::dumpvar($packname,@vars); } else { print $OUT "dumpvar.pl not available.\n"; @@ -390,9 +496,14 @@ sub DB { select ($savout); next CMD; }; $cmd =~ s/^x\b/ / && do { # So that will be evaled - $onetimeDump = 1; }; + $onetimeDump = 'dump'; }; + $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do { + methods($1); next CMD}; + $cmd =~ s/^m\b/ / && do { # So this will be evaled + $onetimeDump = 'methods'; }; $cmd =~ /^f\b\s*(.*)/ && do { $file = $1; + $file =~ s/\s+$//; if (!$file) { print $OUT "The old f command is now the r command.\n"; print $OUT "The new f command switches filenames.\n"; @@ -400,32 +511,37 @@ sub DB { } if (!defined $main::{'_<' . $file}) { if (($try) = grep(m#^_<.*$file#, keys %main::)) {{ - $file = substr($try,2); - print "\n$file:\n"; + $try = substr($try,2); + print $OUT "Choosing $try matching `$file':\n"; + $file = $try; }} } if (!defined $main::{'_<' . $file}) { - print $OUT "There's no code here matching $file.\n"; + print $OUT "No file matching `$file' is loaded.\n"; next CMD; } elsif ($file ne $filename) { - *dbline = "::_<$file"; - $visited{$file}++; + *dbline = $main::{'_<' . $file}; $max = $#dbline; $filename = $file; $start = 1; $cmd = "l"; - } }; + } else { + print $OUT "Already in $file.\n"; + next CMD; + } + }; + $cmd =~ s/^l\s+-\s*$/-/; $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do { $subname = $1; $subname =~ s/\'/::/; - $subname = "main::".$subname unless $subname =~ /::/; + $subname = $package."::".$subname + unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; - @pieces = split(/:/,$sub{$subname}); + @pieces = split(/:/,find_sub($subname)); $subrange = pop @pieces; $file = join(':', @pieces); if ($file ne $filename) { - *dbline = "::_<$file"; - $visited{$file}++; + *dbline = $main::{'_<' . $file}; $max = $#dbline; $filename = $file; } @@ -439,9 +555,10 @@ sub DB { next CMD; } }; $cmd =~ /^\.$/ && do { + $incr = -1; # for backward motion. $start = $line; $filename = $filename_ini; - *dbline = "::_<$filename"; + *dbline = $main::{'_<' . $filename}; $max = $#dbline; print $LINEINFO $position; next CMD }; @@ -452,8 +569,10 @@ sub DB { #print $OUT 'l ' . $start . '-' . ($start + $incr); $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^-$/ && do { + $start -= $incr + $window + 1; + $start = 1 if $start <= 0; $incr = $window - 1; - $cmd = 'l ' . ($start-$window*2) . '+'; }; + $cmd = 'l ' . ($start) . '+'; }; $cmd =~ /^l$/ && do { $incr = $window - 1; $cmd = 'l ' . $start . '-' . ($start + $incr); }; @@ -468,6 +587,7 @@ sub DB { $i = $2; $i = $line if $i eq '.'; $i = 1 if $i < 1; + $incr = $end - $i; if ($emacs) { print $OUT "\032\032$filename:$i:0\n"; $i = $end; @@ -477,7 +597,7 @@ sub DB { $arrow = ($i==$line and $filename eq $filename_ini) ? '==>' - : ':' ; + : ($dbline[$i]+0 ? ':' : ' ') ; $arrow .= 'b' if $stop; $arrow .= 'a' if $action; print $OUT "$i$arrow\t", $dbline[$i]; @@ -488,7 +608,13 @@ sub DB { $start = $max if $start > $max; next CMD; }; $cmd =~ /^D$/ && do { - print $OUT "Deleting all breakpoints...\n"; + print $OUT "Deleting all breakpoints...\n"; + my $file; + for $file (keys %had_breakpoints) { + local *dbline = $main::{'_<' . $file}; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/^[^\0]+//; @@ -497,19 +623,89 @@ sub DB { } } } - next CMD; }; + } + undef %postponed; + undef %postponed_file; + undef %break_on_load; + undef %had_breakpoints; + next CMD; }; $cmd =~ /^L$/ && do { + my $file; + for $file (keys %had_breakpoints) { + local *dbline = $main::{'_<' . $file}; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max; $i++) { if (defined $dbline{$i}) { - print $OUT "$i:\t", $dbline[$i]; + print "$file:\n" unless $was++; + print $OUT " $i:\t", $dbline[$i]; ($stop,$action) = split(/\0/, $dbline{$i}); - print $OUT " break if (", $stop, ")\n" + print $OUT " break if (", $stop, ")\n" if $stop; - print $OUT " action: ", $action, "\n" + print $OUT " action: ", $action, "\n" if $action; last if $signal; } } + } + if (%postponed) { + print $OUT "Postponed breakpoints in subroutines:\n"; + my $subname; + for $subname (keys %postponed) { + print $OUT " $subname\t$postponed{$subname}\n"; + last if $signal; + } + } + my @have = map { # Combined keys + keys %{$postponed_file{$_}} + } keys %postponed_file; + if (@have) { + print $OUT "Postponed breakpoints in files:\n"; + my ($file, $line); + for $file (keys %postponed_file) { + my $db = $postponed_file{$file}; + print $OUT " $file:\n"; + for $line (sort {$a <=> $b} keys %$db) { + print $OUT " $line:\n"; + my ($stop,$action) = split(/\0/, $$db{$line}); + print $OUT " break if (", $stop, ")\n" + if $stop; + print $OUT " action: ", $action, "\n" + if $action; + last if $signal; + } + last if $signal; + } + } + if (%break_on_load) { + print $OUT "Breakpoints on load:\n"; + my $file; + for $file (keys %break_on_load) { + print $OUT " $file\n"; + last if $signal; + } + } + next CMD; }; + $cmd =~ /^b\b\s*load\b\s*(.*)/ && do { + my $file = $1; $file =~ s/\s+$//; + { + $break_on_load{$file} = 1; + $break_on_load{$::INC{$file}} = 1 if $::INC{$file}; + $file .= '.pm', redo unless $file =~ /\./; + } + $had_breakpoints{$file} = 1; + print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n"; + next CMD; }; + $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { + my $cond = $3 || '1'; + my ($subname, $break) = ($2, $1 eq 'postpone'); + $subname =~ s/\'/::/; + $subname = "${'package'}::" . $subname + unless $subname =~ /::/; + $subname = "main".$subname if substr($subname,0,2) eq "::"; + $postponed{$subname} = $break + ? "break +0 if $cond" : "compile"; next CMD; }; $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { $subname = $1; @@ -519,12 +715,12 @@ sub DB { unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; # Filename below can contain ':' - ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/); + ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); $i += 0; if ($i) { $filename = $file; - *dbline = "::_<$filename"; - $visited{$filename}++; + *dbline = $main::{'_<' . $filename}; + $had_breakpoints{$filename} = 1; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; $dbline{$i} =~ s/^[^\0]*/$cond/; @@ -538,6 +734,7 @@ sub DB { if ($dbline[$i] == 0) { print $OUT "Line $i not breakable.\n"; } else { + $had_breakpoints{$filename} = 1; $dbline{$i} =~ s/^[^\0]*/$cond/; } next CMD; }; @@ -547,13 +744,20 @@ sub DB { delete $dbline{$i} if $dbline{$i} eq ''; next CMD; }; $cmd =~ /^A$/ && do { + my $file; + for $file (keys %had_breakpoints) { + local *dbline = $main::{'_<' . $file}; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/\0[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; } } - next CMD; }; + } + next CMD; }; $cmd =~ /^O\s*$/ && do { for (@options) { &dump_option($_); @@ -562,11 +766,26 @@ sub DB { $cmd =~ /^O\s*(\S.*)/ && do { parse_options($1); next CMD; }; + $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE + push @$pre, action($1); + next CMD; }; + $cmd =~ /^>>\s*(.*)/ && do { + push @$post, action($1); + next CMD; }; $cmd =~ /^<\s*(.*)/ && do { - $pre = action($1); + $pre = [], next CMD unless $1; + $pre = [action($1)]; next CMD; }; $cmd =~ /^>\s*(.*)/ && do { - $post = action($1); + $post = [], next CMD unless $1; + $post = [action($1)]; + next CMD; }; + $cmd =~ /^\{\{\s*(.*)/ && do { + push @$pretype, $1; + next CMD; }; + $cmd =~ /^\{\s*(.*)/ && do { + $pretype = [], next CMD unless $1; + $pretype = [$1]; next CMD; }; $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { $i = $1; $j = $3; @@ -578,22 +797,27 @@ sub DB { } next CMD; }; $cmd =~ /^n$/ && do { + end_report(), next CMD if $finished and $level <= 1; $single = 2; $laststep = $cmd; last CMD; }; $cmd =~ /^s$/ && do { + end_report(), next CMD if $finished and $level <= 1; $single = 1; $laststep = $cmd; last CMD; }; $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { - $i = $1; + end_report(), next CMD if $finished and $level <= 1; + $subname = $i = $1; if ($i =~ /\D/) { # subroutine name - ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/); + $subname = $package."::".$subname + unless $subname =~ /::/; + ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); $i += 0; if ($i) { $filename = $file; - *dbline = "::_<$filename"; - $visited{$filename}++; + *dbline = $main::{'_<' . $filename}; + $had_breakpoints{$filename}++; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; } else { @@ -613,11 +837,12 @@ sub DB { } last CMD; }; $cmd =~ /^r$/ && do { + end_report(), next CMD if $finished and $level <= 1; $stack[$#stack] |= 1; - $doret = 1; + $doret = $option{PrintRet} ? $#stack - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { - print $OUT "Warning: a lot of settings and command-line options may be lost!\n"; + print $OUT "Warning: some settings and command-line options may be lost!\n"; my (@script, @flags, $cl); push @flags, '-w' if $ini_warn; # Put all the old includes at the start to get @@ -638,52 +863,67 @@ sub DB { set_list("PERLDB_HIST", $term->Features->{getHistory} ? $term->GetHistory : @hist); - my @visited = keys %visited; - set_list("PERLDB_VISITED", @visited); + my @had_breakpoints = keys %had_breakpoints; + set_list("PERLDB_VISITED", @had_breakpoints); set_list("PERLDB_OPT", %option); - for (0 .. $#visited) { - *dbline = "::_<$visited[$_]"; - set_list("PERLDB_FILE_$_", %dbline); + set_list("PERLDB_ON_LOAD", %break_on_load); + my @hard; + for (0 .. $#had_breakpoints) { + my $file = $had_breakpoints[$_]; + *dbline = $main::{'_<' . $file}; + next unless %dbline or $postponed_file{$file}; + (push @hard, $file), next + if $file =~ /^\(eval \d+\)$/; + my @add; + @add = %{$postponed_file{$file}} + if $postponed_file{$file}; + set_list("PERLDB_FILE_$_", %dbline, @add); } + for (@hard) { # Yes, really-really... + # Find the subroutines in this eval + *dbline = $main::{'_<' . $_}; + my ($quoted, $sub, %subs, $line) = quotemeta $_; + for $sub (keys %sub) { + next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/; + $subs{$sub} = [$1, $2]; + } + unless (%subs) { + print $OUT + "No subroutines in $_, ignoring breakpoints.\n"; + next; + } + LINES: for $line (keys %dbline) { + # One breakpoint per sub only: + my ($offset, $sub, $found); + SUBS: for $sub (keys %subs) { + if ($subs{$sub}->[1] >= $line # Not after the subroutine + and (not defined $offset # Not caught + or $offset < 0 )) { # or badly caught + $found = $sub; + $offset = $line - $subs{$sub}->[0]; + $offset = "+$offset", last SUBS if $offset >= 0; + } + } + if (defined $offset) { + $postponed{$found} = + "break $offset if $dbline{$line}"; + } else { + print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n"; + } + } + } + set_list("PERLDB_POSTPONE", %postponed); + set_list("PERLDB_PRETYPE", @$pretype); + set_list("PERLDB_PRE", @$pre); + set_list("PERLDB_POST", @$post); + set_list("PERLDB_TYPEAHEAD", @typeahead); $ENV{PERLDB_RESTART} = 1; #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS"; exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS; print $OUT "exec failed: $!\n"; last CMD; }; $cmd =~ /^T$/ && do { - local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub); - for ($i = 1; - ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); - $i++) { - @a = (); - for $arg (@args) { - $_ = "$arg"; - s/([\'\\])/\\$1/g; - s/([^\0]*)/'$1'/ - unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - push(@a, $_); - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - $e =~ s/\n\s*\;\s*\Z// if $e; - $e =~ s/[\\\']/\\$1/g if $e; - if ($r) { - $s = "require '$e'"; - } elsif (defined $r) { - $s = "eval '$e'"; - } elsif ($s eq '(eval)') { - $s = "eval {...}"; - } - $f = "file `$f'" unless $f eq '-e'; - push(@sub, "$w$s$a called from $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print $OUT $sub[$i]; - } + print_trace($OUT, 1); # skip DB next CMD; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; @@ -697,6 +937,7 @@ sub DB { $pat = $inpat; } $end = $start; + $incr = -1; eval ' for (;;) { ++$start; @@ -725,6 +966,7 @@ sub DB { $pat = $inpat; } $end = $start; + $incr = -1; eval ' for (;;) { --$start; @@ -747,8 +989,8 @@ sub DB { $cmd = $hist[$i] . "\n"; print $OUT $cmd; redo CMD; }; - $cmd =~ /^$sh$sh\s*/ && do { - &system($'); + $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { + &system($1); next CMD; }; $cmd =~ /^$rc([^$rc].*)$/ && do { $pat = "^$1"; @@ -766,8 +1008,8 @@ sub DB { $cmd =~ /^$sh$/ && do { &system($ENV{SHELL}||"/bin/sh"); next CMD; }; - $cmd =~ /^$sh\s*/ && do { - &system($ENV{SHELL}||"/bin/sh","-c",$'); + $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do { + &system($ENV{SHELL}||"/bin/sh","-c",$1); next CMD; }; $cmd =~ /^H\b\s*(-(\d+))?/ && do { $end = $2?($#hist-$2):0; @@ -777,8 +1019,8 @@ sub DB { unless $hist[$i] =~ /^.?$/; }; next CMD; }; - $cmd =~ s/^p$/print \$DB::OUT \$_/; - $cmd =~ s/^p\b/print \$DB::OUT /; + $cmd =~ s/^p$/print {\$DB::OUT} \$_/; + $cmd =~ s/^p\b/print {\$DB::OUT} /; $cmd =~ /^=/ && do { if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { $alias{$k}="s~$k~$v~"; @@ -812,7 +1054,7 @@ sub DB { } next CMD; } - $SIG{PIPE}= "DB::catch" if $pager =~ /^\|/ + $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/ && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE}; $selected= select(OUT); $|= 1; @@ -824,11 +1066,10 @@ sub DB { $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'}; } # PIPE: - #} # <-- Do we know what this brace is for? $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; - } else { + } elsif ($term_pid == $$) { print $OUT "\n"; } } continue { # CMD: @@ -841,7 +1082,7 @@ sub DB { ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?; open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT"); open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); - $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq "DB::catch"; + $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch; # Will stop ignoring SIGPIPE if done like nohup(1) # does SIGINT but Perl doesn't give us a choice. } else { @@ -852,8 +1093,9 @@ sub DB { $piped= ""; } } # CMD: - if ($post) { - $evalarg = $post; &eval; + $exiting = 1 unless defined $cmd; + foreach $evalarg (@$post) { + &eval; } } # if ($single || $signal) ($@, $!, $,, $/, $\, $^W) = @saved; @@ -864,23 +1106,43 @@ sub DB { # BEGIN {warn 4} sub sub { - print $LINEINFO ' ' x $#stack, "entering $sub\n" if $frame; + my ($al, $ret, @ret) = ""; + if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { + $al = " for $$sub"; + } push(@stack, $single); $single &= 1; $single |= 4 if $#stack == $deep; + ($frame & 4 + ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "), + # Why -1? But it works! :-( + print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) + : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame; if (wantarray) { @ret = &$sub; $single |= pop(@stack); - $retctx = "list"; - $lastsub = $sub; -print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame; + ($frame & 4 + ? ( (print $LINEINFO ' ' x $#stack, "out "), + print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) + : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; + print ($OUT ($frame & 16 ? ' ' x $#stack : ""), + "list context return from $sub:\n"), dumpit( \@ret ), + $doret = -2 if $doret eq $#stack or $frame & 16; @ret; } else { - $ret = &$sub; + if (defined wantarray) { + $ret = &$sub; + } else { + &$sub; undef $ret; + }; $single |= pop(@stack); - $retctx = "scalar"; - $lastsub = $sub; -print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame; + ($frame & 4 + ? ( (print $LINEINFO ' ' x $#stack, "out "), + print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) + : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2; + print ($OUT ($frame & 16 ? ' ' x $#stack : ""), + "scalar context return from $sub: "), dumpit( $ret ), + $doret = -2 if $doret eq $#stack or $frame & 16; $ret; } } @@ -905,38 +1167,161 @@ sub eval { $^D = $od; } my $at = $@; + local $saved[0]; # Preserve the old value of $@ eval "&DB::save"; if ($at) { print $OUT $at; - } elsif ($onetimeDump) { + } elsif ($onetimeDump eq 'dump') { dumpit(\@res); + } elsif ($onetimeDump eq 'methods') { + methods($res[0]); } } -sub install_breakpoints { - my $filename = shift; - return unless exists $postponed{$filename}; - my %break = %{$postponed{$filename}}; - for (keys %break) { - my $i = $_; - #if (/\D/) { # Subroutine name - #} - $dbline{$i} = $break{$_}; # Cannot be done before the file is around +sub postponed_sub { + my $subname = shift; + if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) { + my $offset = $1 || 0; + # Filename below can contain ':' + my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/); + if ($i) { + $i += $offset; + local *dbline = $main::{'_<' . $file}; + local $^W = 0; # != 0 is magical below + $had_breakpoints{$file}++; + my $max = $#dbline; + ++$i until $dbline[$i] != 0 or $i >= $max; + $dbline{$i} = delete $postponed{$subname}; + } else { + print $OUT "Subroutine $subname not found.\n"; + } + return; + } + elsif ($postponed{$subname} eq 'compile') { $signal = 1 } + #print $OUT "In postponed_sub for `$subname'.\n"; +} + +sub postponed { + return &postponed_sub + unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. + # Cannot be done before the file is compiled + local *dbline = shift; + my $filename = $dbline; + $filename =~ s/^_<//; + $signal = 1, print $OUT "'$filename' loaded...\n" + if $break_on_load{$filename}; + print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame; + return unless $postponed_file{$filename}; + $had_breakpoints{$filename}++; + #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic + my $key; + for $key (keys %{$postponed_file{$filename}}) { + $dbline{$key} = $ {$postponed_file{$filename}}{$key}; } + delete $postponed_file{$filename}; } sub dumpit { local ($savout) = select($OUT); - do 'dumpvar.pl' unless defined &main::dumpValue; + my $osingle = $single; + my $otrace = $trace; + $single = $trace = 0; + local $frame = 0; + local $doret = -2; + unless (defined &main::dumpValue) { + do 'dumpvar.pl'; + } if (defined &main::dumpValue) { - local $frame = 0; &main::dumpValue(shift); } else { print $OUT "dumpvar.pl not available.\n"; } + $single = $osingle; + $trace = $otrace; select ($savout); } +# Tied method do not create a context, so may get wrong message: + +sub print_trace { + my $fh = shift; + my @sub = dump_trace($_[0] + 1, $_[1]); + my $short = $_[2]; # Print short report, next one for sub name + my $s; + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + local $" = ', '; + my $args = defined $sub[$i]{args} + ? "(@{ $sub[$i]{args} })" + : '' ; + $args = (substr $args, 0, $maxtrace - 3) . '...' + if length $args > $maxtrace; + my $file = $sub[$i]{file}; + $file = $file eq '-e' ? $file : "file `$file'" unless $short; + $s = $sub[$i]{sub}; + $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace; + if ($short) { + my $sub = @_ >= 4 ? $_[3] : $s; + print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n"; + } else { + print $fh "$sub[$i]{context} = $s$args" . + " called from $file" . + " line $sub[$i]{line}\n"; + } + } +} + +sub dump_trace { + my $skip = shift; + my $count = shift || 1e9; + $skip++; + $count += $skip; + my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context); + my $nothard = not $frame & 8; + local $frame = 0; # Do not want to trace this. + my $otrace = $trace; + $trace = 0; + for ($i = $skip; + $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); + $i++) { + @a = (); + for $arg (@args) { + my $type; + if (not defined $arg) { + push @a, "undef"; + } elsif ($nothard and tied $arg) { + push @a, "tied"; + } elsif ($nothard and $type = ref $arg) { + push @a, "ref($type)"; + } else { + local $_ = "$arg"; # Safe to stringify now - should not call f(). + s/([\'\\])/\\$1/g; + s/(.*)/'$1'/s + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + push(@a, $_); + } + } + $context = $context ? '@' : "\$"; + $args = $h ? [@a] : undef; + $e =~ s/\n\s*\;\s*\Z// if $e; + $e =~ s/([\\\'])/\\$1/g if $e; + if ($r) { + $sub = "require '$e'"; + } elsif (defined $r) { + $sub = "eval '$e'"; + } elsif ($sub eq '(eval)') { + $sub = "eval {...}"; + } + push(@sub, {context => $context, sub => $sub, args => $args, + file => $file, line => $line}); + last if $signal; + } + $trace = $otrace; + @sub; +} + sub action { my $action = shift; while ($action =~ s/\\$//) { @@ -972,7 +1357,9 @@ sub system { sub setterm { local $frame = 0; - eval "require Term::ReadLine;" or die $@; + local $doret = -2; + local @stack = @stack; # Prevent growth by failing `use'. + eval { require Term::ReadLine } or die $@; if ($notty) { if ($tty) { open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!"; @@ -995,9 +1382,13 @@ sub setterm { } else { $term = new Term::ReadLine 'perldb', $IN, $OUT; - $readline::rl_basic_word_break_characters .= "[:" - if defined $readline::rl_basic_word_break_characters - and index($readline::rl_basic_word_break_characters, ":") == -1; + $rl_attribs = $term->Attribs; + $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' + if defined $rl_attribs->{basic_word_break_characters} + and index($rl_attribs->{basic_word_break_characters}, ":") == -1; + $rl_attribs->{special_prefixes} = '$@&%'; + $rl_attribs->{completer_word_break_characters} .= '$@&%'; + $rl_attribs->{completion_function} = \&db_complete; } $LINEINFO = $OUT unless defined $LINEINFO; $lineinfo = $console unless defined $lineinfo; @@ -1005,6 +1396,30 @@ sub setterm { if ($term->Features->{setHistory} and "@hist" ne "?") { $term->SetHistory(@hist); } + ornaments($ornaments) if defined $ornaments; + $term_pid = $$; +} + +sub resetterm { # We forked, so we need a different TTY + $term_pid = $$; + if (defined &get_fork_TTY) { + &get_fork_TTY; + } elsif (not defined $fork_TTY + and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' + and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { + # Possibly _inside_ XTERM + open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\ + sleep 10000000' |]; + $fork_TTY = <XT>; + chomp $fork_TTY; + } + if (defined $fork_TTY) { + TTY($fork_TTY); + undef $fork_TTY; + } else { + print $OUT "Forked, but do not know how to change a TTY.\n", + "Define \$DB::fork_TTY or get_fork_TTY().\n"; + } } sub readline { @@ -1017,11 +1432,20 @@ sub readline { return $got; } local $frame = 0; + local $doret = -2; $term->readline(@_); } sub dump_option { my ($opt, $val)= @_; + $val = option_val($opt,'N/A'); + $val =~ s/([\\\'])/\\$1/g; + printf $OUT "%20s = '%s'\n", $opt, $val; +} + +sub option_val { + my ($opt, $default)= @_; + my $val; if (defined $optionVars{$opt} and defined $ {$optionVars{$opt}}) { $val = $ {$optionVars{$opt}}; @@ -1032,12 +1456,11 @@ sub dump_option { and not defined $option{$opt} or defined $optionVars{$opt} and not defined $ {$optionVars{$opt}}) { - $val = 'N/A'; + $val = $default; } else { $val = $option{$opt}; } - $val =~ s/[\\\']/\\$&/g; - printf $OUT "%20s = '%s'\n", $opt, $val; + $val } sub parse_options { @@ -1070,7 +1493,8 @@ sub parse_options { print $OUT "Unknown option `$opt'\n" unless $matches; print $OUT "Ambiguous option `$opt'\n" if $matches > 1; $option{$option} = $val if $matches == 1 and defined $val; - eval "local \$frame = 0; require '$optionRequire{$option}'" + eval "local \$frame = 0; local \$doret = -2; + require '$optionRequire{$option}'" if $matches == 1 and defined $optionRequire{$option} and defined $val; $ {$optionVars{$option}} = $val if $matches == 1 @@ -1091,7 +1515,7 @@ sub set_list { for $i (0 .. $#list) { $val = $list[$i]; $val =~ s/\\/\\\\/g; - $val =~ s/[\0-\37\177\200-\377]/"\\0x" . unpack('H2',$&)/eg; + $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg; $ENV{"$ {stem}_$i"} = $val; } } @@ -1111,6 +1535,7 @@ sub get_list { sub catch { $signal = 1; + return; # Put nothing on the stack - malloc/free land! } sub warn { @@ -1120,38 +1545,56 @@ sub warn { } sub TTY { - if ($term) { - &warn("Too late to set TTY!\n") if @_; - } else { - $tty = shift if @_; - } + if (@_ and $term and $term->Features->{newTTY}) { + my ($in, $out) = shift; + if ($in =~ /,/) { + ($in, $out) = split /,/, $in, 2; + } else { + $out = $in; + } + open IN, $in or die "cannot open `$in' for read: $!"; + open OUT, ">$out" or die "cannot open `$out' for write: $!"; + $term->newTTY(\*IN, \*OUT); + $IN = \*IN; + $OUT = \*OUT; + return $tty = $in; + } elsif ($term and @_) { + &warn("Too late to set TTY, enabled on next `R'!\n"); + } + $tty = shift if @_; $tty or $console; } sub noTTY { if ($term) { - &warn("Too late to set noTTY!\n") if @_; - } else { - $notty = shift if @_; + &warn("Too late to set noTTY, enabled on next `R'!\n") if @_; } + $notty = shift if @_; $notty; } sub ReadLine { if ($term) { - &warn("Too late to set ReadLine!\n") if @_; - } else { - $rl = shift if @_; + &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_; } + $rl = shift if @_; $rl; } +sub tkRunning { + if ($ {$term->Features}{tkRunning}) { + return $term->tkRunning(@_); + } else { + print $OUT "tkRunning not supported by current ReadLine package.\n"; + 0; + } +} + sub NonStop { if ($term) { - &warn("Too late to set up NonStop mode!\n") if @_; - } else { - $runnonstop = shift if @_; + &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_; } + $runnonstop = shift if @_; $runnonstop; } @@ -1175,6 +1618,16 @@ sub shellBang { $psh; } +sub ornaments { + if (defined $term) { + local ($warnLevel,$dieLevel) = (0, 1); + return '' unless $term->Features->{ornaments}; + eval { $term->ornaments(@_) } || ''; + } else { + $ornaments = shift; + } +} + sub recallCommand { if (@_) { $rc = quotemeta shift; @@ -1200,6 +1653,29 @@ sub LineInfo { $lineinfo; } +sub list_versions { + my %version; + my $file; + for (keys %INC) { + $file = $_; + s,\.p[lm]$,,i ; + s,/,::,g ; + s/^perl5db$/DB/; + s/^Term::ReadLine::readline$/readline/; + if (defined $ { $_ . '::VERSION' }) { + $version{$file} = "$ { $_ . '::VERSION' } from "; + } + $version{$file} .= $INC{$file}; + } + do 'dumpvar.pl' unless defined &main::dumpValue; + if (defined &main::dumpValue) { + local $frame = 0; + &main::dumpValue(\%version); + } else { + print $OUT "dumpvar.pl not available.\n"; + } +} + sub sethelp { $help = " T Stack trace. @@ -1207,8 +1683,8 @@ s [expr] Single step [in expr]. n [expr] Next, steps over subroutine calls [in expr]. <CR> Repeat last n or s command. r Return from current subroutine. -c [line] Continue; optionally inserts a one-time-only breakpoint - at the specified line. +c [line|sub] Continue; optionally inserts a one-time-only breakpoint + at the specified position. l min+incr List incr+1 lines starting at min. l min-max List lines min through max. l line List single line. @@ -1217,10 +1693,10 @@ l List next window of lines. - List previous window of lines. w [line] List window around line. . Return to the executed line. -f filename Switch to viewing filename. +f filename Switch to viewing filename. Must be loaded. /pattern/ Search forwards for pattern; final / is optional. ?pattern? Search backwards for pattern; final ? is optional. -L List all breakpoints and actions for the current file. +L List all breakpoints and actions. S [[!]pattern] List subroutine names [not] matching pattern. t Toggle trace mode. t expr Trace through execution of expr. @@ -1229,6 +1705,12 @@ b [line] [condition] condition breaks if it evaluates to true, defaults to '1'. b subname [condition] Set breakpoint at first line of subroutine. +b load filename Set breakpoint on `require'ing the given file. +b postpone subname [condition] + Set breakpoint at first line of subroutine after + it is compiled. +b compile subname + Stop after the subroutine is compiled. d [line] Delete the breakpoint for line. D Delete all breakpoints. a [line] command @@ -1240,11 +1722,17 @@ V [pkg [vars]] List some (default all) variables in package (default current). Use ~pattern and !pattern for positive and negative regexps. X [vars] Same as \"V currentpackage [vars]\". x expr Evals expression in array context, dumps the result. +m expr Evals expression in array context, prints methods callable + on the first element of the result. +m class Prints methods callable via the given class. O [opt[=val]] [opt\"val\"] [opt?]... Set or query values of options. val defaults to 1. opt can be abbreviated. Several options can be listed. recallCommand, ShellBang: chars used to recall command or spawn shell; pager: program for output of \"|cmd\"; + tkRunning: run Tk while prompting (with ReadLine); + signalLevel warnLevel dieLevel: level of verbosity; + inhibit_exit Allows stepping off the end of the script. The following options affect what happens with V, X, and x commands: arrayDepth, hashDepth: print only first N elements ('' for all); compactDump, veryCompact: change style of array and hash dump; @@ -1252,15 +1740,20 @@ O [opt[=val]] [opt\"val\"] [opt?]... DumpDBFiles: dump arrays holding debugged files; DumpPackages: dump symbol tables of packages; quote, HighBit, undefPrint: change style of string dump; - tkRunning: run Tk while prompting (with ReadLine); - signalLevel warnLevel dieLevel: level of verbosity; Option PrintRet affects printing of return value after r command, frame affects printing messages on entry and exit from subroutines. + AutoTrace affects printing messages on every possible breaking point. + maxTraceLen gives maximal length of evals/args listed in stack trace. + ornaments affects screen appearance of the command line. During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options TTY, noTTY, - ReadLine, and NonStop there. -< command Define command to run before each prompt. -> command Define command to run after each prompt. + ReadLine, and NonStop there (or use `R' after you set them). +< command Define Perl command to run before each prompt. +<< command Add to the list of Perl commands to run before each prompt. +> command Define Perl command to run after each prompt. +>> command Add to the list of Perl commands to run after each prompt. +\{ commandline Define debugger command to run before each prompt. +\{{ commandline Add to the list of debugger commands to run before each prompt. $prc number Redo a previous command (default previous command). $prc -number Redo number'th-to-last command. $prc pattern Redo last command that started with pattern. @@ -1270,16 +1763,20 @@ $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " See 'O shellBang' too. H -number Display last number commands (default all). -p expr Same as \"print DB::OUT expr\" in current package. +p expr Same as \"print {DB::OUT} expr\" in current package. |dbcmd Run debugger command, piping DB::OUT to current pager. ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well. \= [alias value] Define a command alias, or list current aliases. command Execute as a perl statement in current package. -R Pure-man-restart of debugger, debugger state and command-line - options are lost. +v Show versions of loaded modules. +R Pure-man-restart of debugger, some of debugger state + and command-line options may be lost. + Currently the following setting are preserved: + history, breakpoints and actions, debugger Options + and the following command-line options: -w, -I, -e. h [db_command] Get help [on a specific debugger command], enter |h to page. h h Summary of debugger commands. -q or ^D Quit. +q or ^D Quit. Set \$DB::finished to 0 to debug global destruction. "; $summary = <<"END_SUM"; @@ -1288,12 +1785,12 @@ List/search source lines: Control script execution: - or . List previous/current line s [expr] Single step [in expr] w [line] List around line n [expr] Next, steps over subs f filename View source in file <CR> Repeat last n or s - /pattern/ Search forward r Return from subroutine - ?pattern? Search backward c [line] Continue until line + /pattern/ ?patt? Search forw/backw r Return from subroutine + v Show versions of modules c [ln|sub] Continue until position Debugger controls: L List break pts & actions O [...] Set debugger options t [expr] Toggle trace [trace expr] - < command Command for before prompt b [ln] [c] Set breakpoint - > command Command for after prompt b sub [c] Set breakpoint for sub + <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint + >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub $prc [N|pat] Redo a previous command d [line] Delete a breakpoint H [-num] Display last num commands D Delete all breakpoints = [a val] Define/list an alias a [ln] cmd Do cmd before line @@ -1301,66 +1798,71 @@ Debugger controls: L List break pts & actions |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess q or ^D Quit R Attempt a restart Data Examination: expr Execute perl code, also see: s,n,t expr + x|m expr Evals expr in array context, dumps the result or lists methods. + p expr Print expression (uses script's current package). S [[!]pat] List subroutine names [not] matching pattern V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern. X [Vars] Same as \"V current_package [Vars]\". - x expr Evals expression in array context, dumps the result. - p expr Print expression (uses script's current package). END_SUM - # '); # Fix balance of Emacs parsing + # ')}}; # Fix balance of Emacs parsing } sub diesignal { local $frame = 0; - $SIG{'ABRT'} = DEFAULT; + local $doret = -2; + $SIG{'ABRT'} = 'DEFAULT'; kill 'ABRT', $$ if $panic++; - print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue - local $SIG{__WARN__} = ''; - require Carp; - local $Carp::CarpLevel = 2; # mydie + confess - &warn(Carp::longmess("Signal @_")); + if (defined &Carp::longmess) { + local $SIG{__WARN__} = ''; + local $Carp::CarpLevel = 2; # mydie + confess + &warn(Carp::longmess("Signal @_")); + } + else { + print $DB::OUT "Got signal @_\n"; + } kill 'ABRT', $$; } sub dbwarn { local $frame = 0; + local $doret = -2; local $SIG{__WARN__} = ''; - require Carp; - #&warn("Entering dbwarn\n"); + local $SIG{__DIE__} = ''; + eval { require Carp } if defined $^S; # If error/warning during compilation, + # require may be broken. + warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"), + return unless defined &Carp::longmess; my ($mysingle,$mytrace) = ($single,$trace); $single = 0; $trace = 0; my $mess = Carp::longmess(@_); ($single,$trace) = ($mysingle,$mytrace); - #&warn("Warning in dbwarn\n"); &warn($mess); - #&warn("Exiting dbwarn\n"); } sub dbdie { local $frame = 0; + local $doret = -2; local $SIG{__DIE__} = ''; local $SIG{__WARN__} = ''; my $i = 0; my $ineval = 0; my $sub; - #&warn("Entering dbdie\n"); - if ($dieLevel != 2) { - while ((undef,undef,undef,$sub) = caller(++$i)) { - $ineval = 1, last if $sub eq '(eval)'; - } - { + if ($dieLevel > 2) { local $SIG{__WARN__} = \&dbwarn; - &warn(@_) if $dieLevel > 2; # Ineval is false during destruction? - } - #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2; - die @_ if $ineval and $dieLevel < 2; + &warn(@_); # Yell no matter what + return; } - require Carp; + if ($dieLevel < 2) { + die @_ if $^S; # in eval propagate + } + eval { require Carp } if defined $^S; # If error/warning during compilation, + # require may be broken. + die(@_, "\nCannot print stack trace, load with -MCarp option to see stack") + unless defined &Carp::longmess; # We do not want to debug this chunk (automatic disabling works # inside DB::DB, but not in Carp). my ($mysingle,$mytrace) = ($single,$trace); $single = 0; $trace = 0; my $mess = Carp::longmess(@_); ($single,$trace) = ($mysingle,$mytrace); - #&warn("dieing loudly in dbdie\n"); die $mess; } @@ -1369,7 +1871,7 @@ sub warnLevel { $prevwarn = $SIG{__WARN__} unless $warnLevel; $warnLevel = shift; if ($warnLevel) { - $SIG{__WARN__} = 'DB::dbwarn'; + $SIG{__WARN__} = \&DB::dbwarn; } else { $SIG{__WARN__} = $prevwarn; } @@ -1382,10 +1884,11 @@ sub dieLevel { $prevdie = $SIG{__DIE__} unless $dieLevel; $dieLevel = shift; if ($dieLevel) { - $SIG{__DIE__} = 'DB::dbdie'; # if $dieLevel < 2; - #$SIG{__DIE__} = 'DB::diehard' if $dieLevel >= 2; + $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2; + #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2; print $OUT "Stack dump during die enabled", - ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"; + ( $dieLevel == 1 ? " outside of evals" : ""), ".\n" + if $I_m_init; print $OUT "Dump printed too.\n" if $dieLevel > 2; } else { $SIG{__DIE__} = $prevdie; @@ -1401,8 +1904,8 @@ sub signalLevel { $prevbus = $SIG{BUS} unless $signalLevel; $signalLevel = shift; if ($signalLevel) { - $SIG{SEGV} = 'DB::diesignal'; - $SIG{BUS} = 'DB::diesignal'; + $SIG{SEGV} = \&DB::diesignal; + $SIG{BUS} = \&DB::diesignal; } else { $SIG{SEGV} = $prevsegv; $SIG{BUS} = $prevbus; @@ -1411,6 +1914,46 @@ sub signalLevel { $signalLevel; } +sub find_sub { + my $subr = shift; + return unless defined &$subr; + $sub{$subr} or do { + $subr = \&$subr; # Hard reference + my $s; + for (keys %sub) { + $s = $_, last if $subr eq \&$_; + } + $sub{$s} if $s; + } +} + +sub methods { + my $class = shift; + $class = ref $class if ref $class; + local %seen; + local %packs; + methods_via($class, '', 1); + methods_via('UNIVERSAL', 'UNIVERSAL', 0); +} + +sub methods_via { + my $class = shift; + return if $packs{$class}++; + my $prefix = shift; + my $prepend = $prefix ? "via $prefix: " : ''; + my $name; + for $name (grep {defined &{$ {"$ {class}::"}{$_}}} + sort keys %{"$ {class}::"}) { + next if $seen{ $name }++; + print $DB::OUT "$prepend$name\n"; + } + return unless shift; # Recurse? + for $name (@{"$ {class}::ISA"}) { + $prepend = $prefix ? $prefix . " -> $name" : $name; + methods_via($name, $prepend, 1); + } +} + # The following BEGIN is very handy if debugger goes havoc, debugging debugger? BEGIN { # This does not compile, alas. @@ -1423,24 +1966,123 @@ BEGIN { # This does not compile, alas. $window = 10; $preview = 3; $sub = ''; - #$SIG{__WARN__} = "DB::dbwarn"; - #$SIG{__DIE__} = 'DB::dbdie'; - #$SIG{SEGV} = "DB::diesignal"; - #$SIG{BUS} = "DB::diesignal"; - $SIG{INT} = "DB::catch"; - #$SIG{FPE} = "DB::catch"; - #warn "SIGFPE installed"; - $warnLevel = 1 unless defined $warnLevel; - $dieLevel = 1 unless defined $dieLevel; - $signalLevel = 1 unless defined $signalLevel; + $SIG{INT} = \&DB::catch; + # This may be enabled to debug debugger: + #$warnLevel = 1 unless defined $warnLevel; + #$dieLevel = 1 unless defined $dieLevel; + #$signalLevel = 1 unless defined $signalLevel; $db_stop = 0; # Compiler warning $db_stop = 1 << 30; $level = 0; # Level of recursive debugging + # @stack and $doret are needed in sub sub, which is called for DB::postponed. + # Triggers bug (?) in perl is we postpone this until runtime: + @postponed = @stack = (0); + $doret = -2; + $frame = 0; } BEGIN {$^W = $ini_warn;} # Switch warnings back #use Carp; # This did break, left for debuggin +sub db_complete { + # Specific code for b c l V m f O, &blah, $blah, @blah, %blah + my($text, $line, $start) = @_; + my ($itext, $search, $prefix, $pack) = + ($text, "^\Q$ {'package'}::\E([^:]+)\$"); + + return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines + (map { /$search/ ? ($1) : () } keys %sub) + if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/; + return sort grep /^\Q$text/, values %INC # files + if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/; + return sort map {($_, db_complete($_ . "::", "V ", 2))} + grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages + if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/; + return sort map {($_, db_complete($_ . "::", "V ", 2))} + grep !/^main::/, + grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'} + # packages + if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ + and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1; + if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files + # We may want to complete to (eval 9), so $text may be wrong + $prefix = length($1) - length($text); + $text = $1; + return sort + map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0 + } + if ((substr $text, 0, 1) eq '&') { # subroutines + $text = substr $text, 1; + $prefix = "&"; + return sort map "$prefix$_", + grep /^\Q$text/, + (keys %sub), + (map { /$search/ ? ($1) : () } + keys %sub); + } + if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package + $pack = ($1 eq 'main' ? '' : $1) . '::'; + $prefix = (substr $text, 0, 1) . $1 . '::'; + $text = $2; + my @out + = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ; + if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { + return db_complete($out[0], $line, $start); + } + return sort @out; + } + if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main) + $pack = ($package eq 'main' ? '' : $package) . '::'; + $prefix = substr $text, 0, 1; + $text = substr $text, 1; + my @out = map "$prefix$_", grep /^\Q$text/, + (grep /^_?[a-zA-Z]/, keys %$pack), + ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ; + if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { + return db_complete($out[0], $line, $start); + } + return sort @out; + } + if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space + my @out = grep /^\Q$text/, @options; + my $val = option_val($out[0], undef); + my $out = '? '; + if (not defined $val or $val =~ /[\n\r]/) { + # Can do nothing better + } elsif ($val =~ /\s/) { + my $found; + foreach $l (split //, qq/\"\'\#\|/) { + $out = "$l$val$l ", last if (index $val, $l) == -1; + } + } else { + $out = "=$val "; + } + # Default to value if one completion, to question if many + $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? '); + return sort @out; + } + return $term->filename_list($text); # filenames +} + +sub end_report { + print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n" +} + +END { + $finished = $inhibit_exit; # So that some keys may be disabled. + # Do not stop in at_exit() and destructors on exit: + $DB::single = !$exiting && !$runnonstop; + DB::fake::at_exit() unless $exiting or $runnonstop; +} + +package DB::fake; + +sub at_exit { + "Debugged program terminated. Use `q' to quit or `R' to restart."; +} + +package DB; # Do not trace this 1; below! + 1; diff --git a/gnu/usr.bin/perl/lib/sigtrap.pm b/gnu/usr.bin/perl/lib/sigtrap.pm index e099ac46581..c081123b6b4 100644 --- a/gnu/usr.bin/perl/lib/sigtrap.pm +++ b/gnu/usr.bin/perl/lib/sigtrap.pm @@ -2,38 +2,84 @@ package sigtrap; =head1 NAME -sigtrap - Perl pragma to enable stack backtrace on unexpected signals - -=head1 SYNOPSIS - - use sigtrap; - use sigtrap qw(BUS SEGV PIPE SYS ABRT TRAP); - -=head1 DESCRIPTION - -The C<sigtrap> pragma initializes some default signal handlers that print -a stack dump of your Perl program, then sends itself a SIGABRT. This -provides a nice starting point if something horrible goes wrong. - -By default, handlers are installed for the ABRT, BUS, EMT, FPE, ILL, PIPE, -QUIT, SEGV, SYS, TERM, and TRAP signals. - -See L<perlmod/Pragmatic Modules>. +sigtrap - Perl pragma to enable simple signal handling =cut -require Carp; +use Carp; + +$VERSION = 1.02; +$Verbose ||= 0; sub import { - my $pack = shift; - my @sigs = @_; - @sigs or @sigs = qw(QUIT ILL TRAP ABRT EMT FPE BUS SEGV SYS PIPE TERM); - foreach $sig (@sigs) { - $SIG{$sig} = 'sigtrap::trap'; + my $pkg = shift; + my $handler = \&handler_traceback; + my $saw_sig = 0; + my $untrapped = 0; + local $_; + + Arg_loop: + while (@_) { + $_ = shift; + if (/^[A-Z][A-Z0-9]*$/) { + $saw_sig++; + unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') { + print "Installing handler $handler for $_\n" if $Verbose; + $SIG{$_} = $handler; + } + } + elsif ($_ eq 'normal-signals') { + unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM)); + } + elsif ($_ eq 'error-signals') { + unshift @_, grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP)); + } + elsif ($_ eq 'old-interface-signals') { + unshift @_, + grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP)); + } + elsif ($_ eq 'stack-trace') { + $handler = \&handler_traceback; + } + elsif ($_ eq 'die') { + $handler = \&handler_die; + } + elsif ($_ eq 'handler') { + @_ or croak "No argument specified after 'handler'"; + $handler = shift; + unless (ref $handler or $handler eq 'IGNORE' + or $handler eq 'DEFAULT') { + require Symbol; + $handler = Symbol::qualify($handler, (caller)[0]); + } + } + elsif ($_ eq 'untrapped') { + $untrapped = 1; + } + elsif ($_ eq 'any') { + $untrapped = 0; + } + elsif ($_ =~ /^\d/) { + $VERSION >= $_ or croak "sigtrap.pm version $_ required," + . " but this is only version $VERSION"; + } + else { + croak "Unrecognized argument $_"; + } + } + unless ($saw_sig) { + @_ = qw(old-interface-signals); + goto Arg_loop; } } -sub trap { +sub handler_die { + croak "Caught a SIG$_[0]"; +} + +sub handler_traceback { package DB; # To get subroutine args. $SIG{'ABRT'} = DEFAULT; kill 'ABRT', $$ if $panic++; @@ -77,3 +123,167 @@ sub trap { } 1; + +__END__ + +=head1 SYNOPSIS + + use sigtrap; + use sigtrap qw(stack-trace old-interface-signals); # equivalent + use sigtrap qw(BUS SEGV PIPE ABRT); + use sigtrap qw(die INT QUIT); + use sigtrap qw(die normal-signals); + use sigtrap qw(die untrapped normal-signals); + use sigtrap qw(die untrapped normal-signals + stack-trace any error-signals); + use sigtrap 'handler' => \&my_handler, 'normal-signals'; + use sigtrap qw(handler my_handler normal-signals + stack-trace error-signals); + +=head1 DESCRIPTION + +The B<sigtrap> pragma is a simple interface to installing signal +handlers. You can have it install one of two handlers supplied by +B<sigtrap> itself (one which provides a Perl stack trace and one which +simply C<die()>s), or alternately you can supply your own handler for it +to install. It can be told only to install a handler for signals which +are either untrapped or ignored. It has a couple of lists of signals to +trap, plus you can supply your own list of signals. + +The arguments passed to the C<use> statement which invokes B<sigtrap> +are processed in order. When a signal name or the name of one of +B<sigtrap>'s signal lists is encountered a handler is immediately +installed, when an option is encountered it affects subsequently +installed handlers. + +=head1 OPTIONS + +=head2 SIGNAL HANDLERS + +These options affect which handler will be used for subsequently +installed signals. + +=over 4 + +=item B<stack-trace> + +The handler used for subsequently installed signals outputs a Perl stack +trace to STDERR and then tries to dump core. This is the default signal +handler. + +=item B<die> + +The handler used for subsequently installed signals calls C<die> +(actually C<croak>) with a message indicating which signal was caught. + +=item B<handler> I<your-handler> + +I<your-handler> will be used as the handler for subsequently installed +signals. I<your-handler> can be any value which is valid as an +assignment to an element of C<%SIG>. + +=back + +=head2 SIGNAL LISTS + +B<sigtrap> has a few built-in lists of signals to trap. They are: + +=over 4 + +=item B<normal-signals> + +These are the signals which a program might normally expect to encounter +and which by default cause it to terminate. They are HUP, INT, PIPE and +TERM. + +=item B<error-signals> + +These signals usually indicate a serious problem with the Perl +interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL, +QUIT, SEGV, SYS and TRAP. + +=item B<old-interface-signals> + +These are the signals which were trapped by default by the old +B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, +SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to +B<sigtrap>, this list is used. + +=back + +For each of these three lists, the collection of signals set to be +trapped is checked before trapping; if your architecture does not +implement a particular signal, it will not be trapped but rather +silently ignored. + +=head2 OTHER + +=over 4 + +=item B<untrapped> + +This token tells B<sigtrap> to install handlers only for subsequently +listed signals which aren't already trapped or ignored. + +=item B<any> + +This token tells B<sigtrap> to install handlers for all subsequently +listed signals. This is the default behavior. + +=item I<signal> + +Any argument which looks like a signal name (that is, +C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a +handler for that name. + +=item I<number> + +Require that at least version I<number> of B<sigtrap> is being used. + +=back + +=head1 EXAMPLES + +Provide a stack trace for the old-interface-signals: + + use sigtrap; + +Ditto: + + use sigtrap qw(stack-trace old-interface-signals); + +Provide a stack trace on the 4 listed signals only: + + use sigtrap qw(BUS SEGV PIPE ABRT); + +Die on INT or QUIT: + + use sigtrap qw(die INT QUIT); + +Die on HUP, INT, PIPE or TERM: + + use sigtrap qw(die normal-signals); + +Die on HUP, INT, PIPE or TERM, except don't change the behavior for +signals which are already trapped or ignored: + + use sigtrap qw(die untrapped normal-signals); + +Die on receipt one of an of the B<normal-signals> which is currently +B<untrapped>, provide a stack trace on receipt of B<any> of the +B<error-signals>: + + use sigtrap qw(die untrapped normal-signals + stack-trace any error-signals); + +Install my_handler() as the handler for the B<normal-signals>: + + use sigtrap 'handler', \&my_handler, 'normal-signals'; + +Install my_handler() as the handler for the normal-signals, provide a +Perl stack trace on receipt of one of the error-signals: + + use sigtrap qw(handler my_handler normal-signals + stack-trace error-signals); + +=cut diff --git a/gnu/usr.bin/perl/lib/splain b/gnu/usr.bin/perl/lib/splain deleted file mode 100644 index f40c51e0308..00000000000 --- a/gnu/usr.bin/perl/lib/splain +++ /dev/null @@ -1,503 +0,0 @@ -#!/usr/local/bin/perl -eval 'exec perl -S $0 ${1+"$@"}' - if 0; - -use Config; -$diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod"; - -package diagnostics; -require 5.001; -use English; -use Carp; - -=head1 NAME - -diagnostics - Perl compiler pragma to force verbose warning diagnostics - -splain - standalone program to do the same thing - -=head1 SYNOPSIS - -As a pragma: - - use diagnostics; - use diagnostics -verbose; - - enable diagnostics; - disable diagnostics; - -Aa a program: - - perl program 2>diag.out - splain [-v] [-p] diag.out - - -=head1 DESCRIPTION - -=head2 The C<diagnostics> Pragma - -This module extends the terse diagnostics normally emitted by both the -perl compiler and the perl interpeter, augmenting them wtih the more -explicative and endearing descriptions found in L<perldiag>. Like the -other pragmata, it affects to compilation phase of your program rather -than merely the execution phase. - -To use in your program as a pragma, merely invoke - - use diagnostics; - -at the start (or near the start) of your program. (Note -that this I<does> enable perl's B<-w> flag.) Your whole -compilation will then be subject(ed :-) to the enhanced diagnostics. -These still go out B<STDERR>. - -Due to the interaction between runtime and compiletime issues, -and because it's probably not a very good idea anyway, -you may not use C<no diagnostics> to turn them off at compiletime. -However, you may control there behaviour at runtime using the -disable() and enable() methods to turn them off and on respectively. - -The B<-verbose> flag first prints out the L<perldiag> introduction before -any other diagnostics. The $diagnostics::PRETTY can generate nicer escape -sequences for pgers. - -=head2 The I<splain> Program - -While apparently a whole nuther program, I<splain> is actually nothing -more than a link to the (executable) F<diagnostics.pm> module, as well as -a link to the F<diagnostics.pod> documentation. The B<-v> flag is like -the C<use diagnostics -verbose> directive. -The B<-p> flag is like the -$diagnostics::PRETTY variable. Since you're post-processing with -I<splain>, there's no sense in being able to enable() or disable() processing. - -Output from I<splain> is directed to B<STDOUT>, unlike the pragma. - -=head1 EXAMPLES - -The following file is certain to trigger a few errors at both -runtime and compiletime: - - use diagnostics; - print NOWHERE "nothing\n"; - print STDERR "\n\tThis message should be unadorned.\n"; - warn "\tThis is a user warning"; - print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: "; - my $a, $b = scalar <STDIN>; - print "\n"; - print $x/$y; - -If you prefer to run your program first and look at its problem -afterwards, do this: - - perl -w test.pl 2>test.out - ./splain < test.out - -Note that this is not in general possible in shells of more dubious heritage, -as the theorectical - - (perl -w test.pl >/dev/tty) >& test.out - ./splain < test.out - -Because you just moved the existing B<stdout> to somewhere else. - -If you don't want to modify your source code, but still have on-the-fly -warnings, do this: - - exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- - -Nifty, eh? - -If you want to control warnings on the fly, do something like this. -Make sure you do the C<use> first, or you won't be able to get -at the enable() or disable() methods. - - use diagnostics; # checks entire compilation phase - print "\ntime for 1st bogus diags: SQUAWKINGS\n"; - print BOGUS1 'nada'; - print "done with 1st bogus\n"; - - disable diagnostics; # only turns off runtime warnings - print "\ntime for 2nd bogus: (squelched)\n"; - print BOGUS2 'nada'; - print "done with 2nd bogus\n"; - - enable diagnostics; # turns back on runtime warnings - print "\ntime for 3rd bogus: SQUAWKINGS\n"; - print BOGUS3 'nada'; - print "done with 3rd bogus\n"; - - disable diagnostics; - print "\ntime for 4th bogus: (squelched)\n"; - print BOGUS4 'nada'; - print "done with 4th bogus\n"; - -=head1 INTERNALS - -Diagnostic messages derive from the F<perldiag.pod> file when available at -runtime. Otherwise, they may be embedded in the file itself when the -splain package is built. See the F<Makefile> for details. - -If an extant $SIG{__WARN__} handler is discovered, it will continue -to be honored, but only after the diagnostic::splainthis() function -(the module's $SIG{__WARN__} interceptor) has had its way with your -warnings. - -There is a $diagnostics::DEBUG variable you may set if you're desperately -curious what sorts of things are being intercepted. - - BEGIN { $diagnostics::DEBUG = 1 } - - -=head1 BUGS - -Not being able to say "no diagnostics" is annoying, but may not be -insurmountable. - -The C<-pretty> directive is called too late to affect matters. -You have to to this instead, and I<before> you load the module. - - BEGIN { $diagnostics::PRETTY = 1 } - -I could start up faster by delaying compilation until it should be -needed, but this gets a "panic: top_level" -when using the pragma form in 5.001e. - -While it's true that this documentation is somewhat subserious, if you use -a program named I<splain>, you should expect a bit of whimsy. - -=head1 AUTHOR - -Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995. - -=cut - -$DEBUG ||= 0; -my $WHOAMI = ref bless []; # nobody's business, prolly not even mine - -$OUTPUT_AUTOFLUSH = 1; - -local $_; - -CONFIG: { - $opt_p = $opt_d = $opt_v = $opt_f = ''; - %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = (); - %exact_duplicate = (); - - unless (caller) { - $standalone++; - require Getopt::Std; - Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]"; - $PODFILE = $opt_f if $opt_f; - $DEBUG = 2 if $opt_d; - $VERBOSE = $opt_v; - $PRETTY = $opt_p; - } - - if (open(POD_DIAG, $PODFILE)) { - warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; - last CONFIG; - } - - if (caller) { - INCPATH: { - for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { - warn "Checking $file\n" if $DEBUG; - if (open(POD_DIAG, $file)) { - while (<POD_DIAG>) { - next unless /^__END__\s*# wish diag dbase were more accessible/; - print STDERR "podfile is $file\n" if $DEBUG; - last INCPATH; - } - } - } - } - } else { - print STDERR "podfile is <DATA>\n" if $DEBUG; - *POD_DIAG = *main::DATA; - } -} -if (eof(POD_DIAG)) { - die "couldn't find diagnostic data in $PODFILE @INC $0"; -} - - -%HTML_2_Troff = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "A\\*'", # capital A, acute accent - # etc - -); - -%HTML_2_Latin_1 = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "\xC1" # capital A, acute accent - - # etc -); - -%HTML_2_ASCII_7 = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "A" # capital A, acute accent - # etc -); - -*HTML_Escapes = do { - if ($standalone) { - $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; - } else { - \%HTML_2_Latin_1; - } -}; - -*THITHER = $standalone ? *STDOUT : *STDERR; - -$transmo = <<EOFUNC; -sub transmo { - local \$^W = 0; # recursive warnings we do NOT need! - study; -EOFUNC - -### sub finish_compilation { # 5.001e panic: top_level for embedded version - print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; - ### local - $RS = ''; - local $_; - while (<POD_DIAG>) { - #s/(.*)\n//; - #$header = $1; - - unescape(); - if ($PRETTY) { - sub noop { return $_[0] } # spensive for a noop - sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } - sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } - s/[BC]<(.*?)>/bold($1)/ges; - s/[LIF]<(.*?)>/italic($1)/ges; - } else { - s/[BC]<(.*?)>/$1/gs; - s/[LIF]<(.*?)>/$1/gs; - } - unless (/^=/) { - if (defined $header) { - if ( $header eq 'DESCRIPTION' && - ( /Optional warnings are enabled/ - || /Some of these messages are generic./ - ) ) - { - next; - } - s/^/ /gm; - $msg{$header} .= $_; - } - next; - } - unless ( s/=item (.*)\s*\Z//) { - - if ( s/=head1\sDESCRIPTION//) { - $msg{$header = 'DESCRIPTION'} = ''; - } - next; - } - $header = $1; - - if ($header =~ /%[sd]/) { - $rhs = $lhs = $header; - #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { - if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { - $lhs =~ s/\\%s/.*?/g; - } else { - # if i had lookbehind negations, i wouldn't have to do this \377 noise - $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; - #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; - $lhs =~ s/\377([^\377]*)$/\Q$1\E/; - $lhs =~ s/\377//g; - } - $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; - } else { - $transmo .= " m{^\Q$header\E} && return 1;\n"; - } - - print STDERR "Already saw $header" if $msg{$header}; - - $msg{$header} = ''; - } - - - close POD_DIAG unless *main::DATA eq *POD_DIAG; - - die "No diagnostics?" unless %msg; - - $transmo .= " return 0;\n}\n"; - print STDERR $transmo if $DEBUG; - eval $transmo; - die $@ if $@; - $RS = "\n"; -### } - -if ($standalone) { - if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } - while ($error = <>) { - splainthis($error) || print THITHER $error; - } - exit; -} else { - $old_w = 0; $oldwarn = ''; $olddie = ''; -} - -sub import { - shift; - $old_w = $^W; - $^W = 1; # yup, clobbered the global variable; tough, if you - # want diags, you want diags. - return if $SIG{__WARN__} eq \&warn_trap; - - for (@_) { - - /^-d(ebug)?$/ && do { - $DEBUG++; - next; - }; - - /^-v(erbose)?$/ && do { - $VERBOSE++; - next; - }; - - /^-p(retty)?$/ && do { - print STDERR "$0: I'm afraid it's too late for prettiness.\n"; - $PRETTY++; - next; - }; - - warn "Unknown flag: $_"; - } - - $oldwarn = $SIG{__WARN__}; - $olddie = $SIG{__DIE__}; - $SIG{__WARN__} = \&warn_trap; - $SIG{__DIE__} = \&death_trap; -} - -sub enable { &import } - -sub disable { - shift; - $^W = $old_w; - return unless $SIG{__WARN__} eq \&warn_trap; - $SIG{__WARN__} = $oldwarn; - $SIG{__DIE__} = $olddie; -} - -sub warn_trap { - my $warning = $_[0]; - if (caller eq $WHOAMI or !splainthis($warning)) { - print STDERR $warning; - } - &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; -}; - -sub death_trap { - my $exception = $_[0]; - splainthis($exception); - if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } - &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; - $SIG{__DIE__} = $SIG{__WARN__} = ''; - local($Carp::CarpLevel) = 1; - confess "Uncaught exception from user code:\n\t$exception"; - # up we go; where we stop, nobody knows, but i think we die now - # but i'm deeply afraid of the &$olddie guy reraising and us getting - # into an indirect recursion loop -}; - -sub splainthis { - local $_ = shift; - ### &finish_compilation unless %msg; - s/\.?\n+$//; - my $orig = $_; - # return unless defined; - if ($exact_duplicate{$_}++) { - return 1; - } - s/, <.*?> (?:line|chunk).*$//; - $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; - s/^\((.*)\)$/$1/; - return 0 unless &transmo; - $orig = shorten($orig); - if ($old_diag{$_}) { - autodescribe(); - print THITHER "$orig (#$old_diag{$_})\n"; - $wantspace = 1; - } else { - autodescribe(); - $old_diag{$_} = ++$count; - print THITHER "\n" if $wantspace; - $wantspace = 0; - print THITHER "$orig (#$old_diag{$_})\n"; - if ($msg{$_}) { - print THITHER $msg{$_}; - } else { - if (0 and $standalone) { - print THITHER " **** Error #$old_diag{$_} ", - ($real ? "is" : "appears to be"), - " an unknown diagnostic message.\n\n"; - } - return 0; - } - } - return 1; -} - -sub autodescribe { - if ($VERBOSE and not $count) { - print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), - "\n$msg{DESCRIPTION}\n"; - } -} - -sub unescape { - s { - E< - ( [A-Za-z]+ ) - > - } { - do { - exists $HTML_Escapes{$1} - ? do { $HTML_Escapes{$1} } - : do { - warn "Unknown escape: $& in $_"; - "E<$1>"; - } - } - }egx; -} - -sub shorten { - my $line = $_[0]; - if (length $line > 79) { - my $space_place = rindex($line, ' ', 79); - if ($space_place != -1) { - substr($line, $space_place, 1) = "\n\t"; - } - } - return $line; -} - - -# have to do this: RS isn't set until run time, but we're executing at compile time -$RS = "\n"; - -1 unless $standalone; # or it'll complain about itself -__END__ # wish diag dbase were more accessible diff --git a/gnu/usr.bin/perl/lib/strict.pm b/gnu/usr.bin/perl/lib/strict.pm index 6f6028cad4e..8492e933fd6 100644 --- a/gnu/usr.bin/perl/lib/strict.pm +++ b/gnu/usr.bin/perl/lib/strict.pm @@ -55,7 +55,7 @@ name without fully qualifying it. This disables the poetry optimization, generating a compile-time error if you try to use a bareword identifier that's not a subroutine, unless it -appears in curly braces or on the left hand side of the "=>" symbol. +appears in curly braces or on the left hand side of the "=E<gt>" symbol. use strict 'subs'; @@ -74,10 +74,11 @@ See L<perlmod/Pragmatic Modules>. sub bits { my $bits = 0; + my $sememe; foreach $sememe (@_) { - $bits |= 0x00000002 if $sememe eq 'refs'; - $bits |= 0x00000200 if $sememe eq 'subs'; - $bits |= 0x00000400 if $sememe eq 'vars'; + $bits |= 0x00000002, next if $sememe eq 'refs'; + $bits |= 0x00000200, next if $sememe eq 'subs'; + $bits |= 0x00000400, next if $sememe eq 'vars'; } $bits; } diff --git a/gnu/usr.bin/perl/lib/subs.pm b/gnu/usr.bin/perl/lib/subs.pm index 84c913a346a..512bc9be9a5 100644 --- a/gnu/usr.bin/perl/lib/subs.pm +++ b/gnu/usr.bin/perl/lib/subs.pm @@ -15,9 +15,15 @@ This will predeclare all the subroutine whose names are in the list, allowing you to use them without parentheses even before they're declared. -See L<perlmod/Pragmatic Modules> and L<strict/subs>. +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +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>. =cut + require 5.000; sub import { diff --git a/gnu/usr.bin/perl/lib/syslog.pl b/gnu/usr.bin/perl/lib/syslog.pl index 29c3a1cc9af..9e03399e4df 100644 --- a/gnu/usr.bin/perl/lib/syslog.pl +++ b/gnu/usr.bin/perl/lib/syslog.pl @@ -37,7 +37,7 @@ if ($] >= 5) { require 'syslog.ph'; - eval 'use Socket' || + eval 'use Socket; 1' || eval { require "socket.ph" } || require "sys/socket.ph"; @@ -140,10 +140,10 @@ sub main'syslog { sub xlate { local($name) = @_; - $name =~ y/a-z/A-Z/; + $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "syslog'$name"; - eval(&$name) || -1; + defined &$name ? &$name : -1; } sub connect { diff --git a/gnu/usr.bin/perl/lib/termcap.pl b/gnu/usr.bin/perl/lib/termcap.pl index e8f108df067..37313432fde 100644 --- a/gnu/usr.bin/perl/lib/termcap.pl +++ b/gnu/usr.bin/perl/lib/termcap.pl @@ -14,7 +14,7 @@ sub Tgetent { local($TERMCAP,$_,$entry,$loop,$field); warn "Tgetent: no ospeed set" unless $ospeed; - foreach $key (keys(TC)) { + foreach $key (keys %TC) { delete $TC{$key}; } $TERM = $ENV{'TERM'} unless $TERM; @@ -63,6 +63,9 @@ sub Tgetent { $entry = $1; $_ = $2; s/\\E/\033/g; + s/\\(200)/pack('c',0)/eg; # NUL character + s/\\(0\d\d)/pack('c',oct($1))/eg; # octal + s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; s/\\n/\n/g; s/\\r/\r/g; diff --git a/gnu/usr.bin/perl/lib/timelocal.pl b/gnu/usr.bin/perl/lib/timelocal.pl index 75f1ac1851a..ad322756e38 100644 --- a/gnu/usr.bin/perl/lib/timelocal.pl +++ b/gnu/usr.bin/perl/lib/timelocal.pl @@ -4,106 +4,15 @@ ;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); ;# $time = timegm($sec,$min,$hours,$mday,$mon,$year); -;# These routines are quite efficient and yet are always guaranteed to agree -;# with localtime() and gmtime(). We manage this by caching the start times -;# of any months we've seen before. If we know the start time of the month, -;# we can always calculate any time within the month. The start times -;# themselves are guessed by successive approximation starting at the -;# current time, since most dates seen in practice are close to the -;# current date. Unlike algorithms that do a binary search (calling gmtime -;# once for each bit of the time value, resulting in 32 calls), this algorithm -;# calls it at most 6 times, and usually only once or twice. If you hit -;# the month cache, of course, it doesn't call it at all. +;# This file has been superseded by the Time::Local library module. +;# It is implemented as a call to that module for backwards compatibility +;# with code written for perl4; new code should use Time::Local directly. -;# timelocal is implemented using the same cache. We just assume that we're -;# translating a GMT time, and then fudge it when we're done for the timezone -;# and daylight savings arguments. The timezone is determined by examining -;# the result of localtime(0) when the package is initialized. The daylight -;# savings offset is currently assumed to be one hour. +;# The current implementation shares with the original the questionable +;# behavior of defining the timelocal() and timegm() functions in the +;# namespace of whatever package was current when the first instance of +;# C<require 'timelocal.pl';> was executed in a program. -;# Both routines return -1 if the integer limit is hit. I.e. for dates -;# after the 1st of January, 2038 on most machines. +use Time::Local; -CONFIG: { - package timelocal; - - local($[) = 0; - @epoch = localtime(0); - $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT - if ($tzmin > 0) { - $tzmin = 24 * 60 - $tzmin; # minutes west of GMT - $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line - } - - $SEC = 1; - $MIN = 60 * $SEC; - $HR = 60 * $MIN; - $DAYS = 24 * $HR; - $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; - 1; -} - -sub timegm { - package timelocal; - - local($[) = 0; - $ym = pack(C2, @_[5,4]); - $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0; - $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; -} - -sub timelocal { - package timelocal; - - local($[) = 0; - $time = &main'timegm + $tzmin*$MIN; - return -1 if $cheat<0; - @test = localtime($time); - $time -= $HR if $test[2] != $_[2]; - $time; -} - -package timelocal; - -sub cheat { - $year = $_[5]; - $month = $_[4]; - die "Month out of range 0..11 in timelocal.pl\n" - if $month > 11 || $month < 0; - die "Day out of range 1..31 in timelocal.pl\n" - if $_[3] > 31 || $_[3] < 1; - die "Hour out of range 0..23 in timelocal.pl\n" - if $_[2] > 23 || $_[2] < 0; - die "Minute out of range 0..59 in timelocal.pl\n" - if $_[1] > 59 || $_[1] < 0; - die "Second out of range 0..59 in timelocal.pl\n" - if $_[0] > 59 || $_[0] < 0; - $guess = $^T; - @g = gmtime($guess); - $year += $YearFix if $year < $epoch[5]; - $lastguess = ""; - while ($diff = $year - $g[5]) { - $guess += $diff * (363 * $DAYS); - @g = gmtime($guess); - if (($thisguess = "@g") eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $lastguess = $thisguess; - } - while ($diff = $month - $g[4]) { - $guess += $diff * (27 * $DAYS); - @g = gmtime($guess); - if (($thisguess = "@g") eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $lastguess = $thisguess; - } - @gfake = gmtime($guess-1); #still being sceptic - if ("@gfake" eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $g[3]--; - $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; - $cheat{$ym} = $guess; -} +*timelocal::cheat = \&Time::Local::cheat; diff --git a/gnu/usr.bin/perl/lib/validate.pl b/gnu/usr.bin/perl/lib/validate.pl index 21d0505ad4d..ec4a04b5436 100644 --- a/gnu/usr.bin/perl/lib/validate.pl +++ b/gnu/usr.bin/perl/lib/validate.pl @@ -91,11 +91,11 @@ sub valmess { $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } - print stderr $mess,"\n"; + print STDERR $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; - print stderr "Can't do $this.\n"; + print STDERR "Can't do $this.\n"; } if ($disposition eq 'die') { exit 1; } ++$warnings; diff --git a/gnu/usr.bin/perl/lib/vars.pm b/gnu/usr.bin/perl/lib/vars.pm index b9519291c4b..5723ac6c2cb 100644 --- a/gnu/usr.bin/perl/lib/vars.pm +++ b/gnu/usr.bin/perl/lib/vars.pm @@ -1,30 +1,22 @@ package vars; -=head1 NAME - -vars - Perl pragma to predeclare global variable names - -=head1 SYNOPSIS - - use vars qw($frob @mung %seen); - -=head1 DESCRIPTION +require 5.002; -This will predeclare all the variables whose names are -in the list, allowing you to use them under "use strict", and -disabling any typo warnings. - -See L<perlmod/Pragmatic Modules>. - -=cut -require 5.000; -use Carp; +# The following require can't be removed during maintenance +# releases, sadly, because of the risk of buggy code that does +# require Carp; Carp::croak "..."; without brackets dying +# if Carp hasn't been loaded in earlier compile time. :-( +# We'll let those bugs get found on the development track. +require Carp if $] < 5.00450; sub import { my $callpack = caller; my ($pack, @imports, $sym, $ch) = @_; foreach $sym (@imports) { - croak "Can't declare another package's variables" if $sym =~ /::/; + if ($sym =~ /::/) { + require Carp; + Carp::croak("Can't declare another package's variables"); + } ($ch, $sym) = unpack('a1a*', $sym); *{"${callpack}::$sym"} = ( $ch eq "\$" ? \$ {"${callpack}::$sym"} @@ -32,8 +24,43 @@ sub import { : $ch eq "\%" ? \% {"${callpack}::$sym"} : $ch eq "\*" ? \* {"${callpack}::$sym"} : $ch eq "\&" ? \& {"${callpack}::$sym"} - : croak "'$ch$sym' is not a valid variable name\n"); + : do { + require Carp; + Carp::croak("'$ch$sym' is not a valid variable name\n"); + }); } }; 1; +__END__ + +=head1 NAME + +vars - Perl pragma to predeclare global variable names + +=head1 SYNOPSIS + + use vars qw($frob @mung %seen); + +=head1 DESCRIPTION + +This will predeclare all the variables whose names are +in the list, allowing you to use them under "use strict", and +disabling any typo warnings. + +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +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>. + +Packages such as the B<AutoLoader> and B<SelfLoader> that delay +loading of subroutines within packages can create problems with +package lexicals defined using C<my()>. While the B<vars> pragma +cannot duplicate the effect of package lexicals (total transparency +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>. + +=cut |