diff options
Diffstat (limited to 'gnu/usr.bin/perl/lib')
82 files changed, 9610 insertions, 4451 deletions
diff --git a/gnu/usr.bin/perl/lib/AutoLoader.pm b/gnu/usr.bin/perl/lib/AutoLoader.pm index 2773a90f10f..5b083a78944 100644 --- a/gnu/usr.bin/perl/lib/AutoLoader.pm +++ b/gnu/usr.bin/perl/lib/AutoLoader.pm @@ -2,31 +2,73 @@ package AutoLoader; use vars qw(@EXPORT @EXPORT_OK); +my $is_dosish; +my $is_vms; + BEGIN { require Exporter; @EXPORT = (); @EXPORT_OK = qw(AUTOLOAD); + $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32'; + $is_vms = $^O eq 'VMS'; } AUTOLOAD { 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; - } + # Try to find the autoloaded file from the package-qualified + # name of the sub. e.g., if the sub needed is + # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is + # something like '/usr/lib/perl5/Getopt/Long.pm', and the + # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'. + # + # However, if @INC is a relative path, this might not work. If, + # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is + # 'lib/Getopt/Long.pm', and we want to require + # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib'). + # In this case, we simple prepend the 'auto/' and let the + # C<require> take care of the searching for us. + + my ($pkg,$func) = $AUTOLOAD =~ /(.*)::([^:]+)$/; + $pkg =~ s#::#/#g; + if (defined($name=$INC{"$pkg.pm"})) { + $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#; + + # if the file exists, then make sure that it is a + # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al', + # or './lib/auto/foo/bar.al'. This avoids C<require> searching + # (and failing) to find the 'lib/auto/foo/bar.al' because it + # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib'). + + if (-r $name) { + unless ($name =~ m|^/|) { + if ($is_dosish) { + unless ($name =~ m{^([a-z]:)?[\\/]}i) { + $name = "./$name"; + } + } + elsif ($is_vms) { + # XXX todo by VMSmiths + $name = "./$name"; + } + else { + $name = "./$name"; + } + } + } + else { + $name = undef; + } + } + unless (defined $name) { + # let C<require> do the searching + $name = "auto/$AUTOLOAD.al"; + $name =~ s#::#/#g; + } } my $save = $@; - eval {local $SIG{__DIE__};require $name}; + eval { local $SIG{__DIE__}; require $name }; if ($@) { if (substr($AUTOLOAD,-9) eq '::DESTROY') { *$AUTOLOAD = sub {}; @@ -73,7 +115,7 @@ sub import { # 'auto/POSIX/autosplit.ix' (without the leading 'lib'). # - (my $calldir = $callpkg) =~ s#::#/#; + (my $calldir = $callpkg) =~ s#::#/#g; my $path = $INC{$calldir . '.pm'}; if (defined($path)) { # Try absolute path name. @@ -136,7 +178,7 @@ 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 +Once this process completes for a given function, it is defined, so future calls to the subroutine will bypass the AUTOLOAD mechanism. =head2 Subroutine Stubs @@ -224,7 +266,7 @@ 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 +should be faster, but requires a mechanism 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. @@ -242,6 +284,10 @@ 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. +AutoLoader may fail to find the autosplit files (or even find the wrong +ones) in cases where C<@INC> contains relative paths, B<and> the program +does C<chdir>. + =head1 SEE ALSO L<SelfLoader> - an autoloader that doesn't use external files. diff --git a/gnu/usr.bin/perl/lib/AutoSplit.pm b/gnu/usr.bin/perl/lib/AutoSplit.pm index 8019df7187b..f8183714d7d 100644 --- a/gnu/usr.bin/perl/lib/AutoSplit.pm +++ b/gnu/usr.bin/perl/lib/AutoSplit.pm @@ -1,12 +1,17 @@ package AutoSplit; -require 5.000; -require Exporter; - -use Config; -use Carp; +use Exporter (); +use Config qw(%Config); +use Carp qw(carp); +use File::Basename (); use File::Path qw(mkpath); +use strict; +use vars qw( + $VERSION @ISA @EXPORT @EXPORT_OK + $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime + ); +$VERSION = "1.0303"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -17,13 +22,9 @@ AutoSplit - split a package for autoloading =head1 SYNOPSIS - perl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... - - use AutoSplit; autosplit($file, $dir, $keep, $check, $modtime); - -for perl versions 5.002 and later: + autosplit($file, $dir, $keep, $check, $modtime); - perl -MAutoSplit -e 'autosplit($ARGV[0], $ARGV[1], $k, $chk, $modtime)' ... + autosplit_lib_modules(@modules); =head1 DESCRIPTION @@ -37,16 +38,36 @@ class hierarchy, and creates the file F<autosplit.ix>. This file acts as both forward declaration of all package routines, and as timestamp for the last update of the hierarchy. -The remaining three arguments to C<autosplit> govern other options to the -autosplitter. If the third argument, I<$keep>, is false, then any pre-existing -C<*.al> files in the autoload directory are removed if they are no longer -part of the module (obsoleted functions). The fourth argument, I<$check>, -instructs C<autosplit> to check the module currently being split to ensure -that it does include a C<use> specification for the AutoLoader module, and -skips the module if AutoLoader is not detected. Lastly, the I<$modtime> -argument specifies that C<autosplit> is to check the modification time of the -module against that of the C<autosplit.ix> file, and only split the module -if it is newer. +The remaining three arguments to C<autosplit> govern other options to +the autosplitter. + +=over 2 + +=item $keep + +If the third argument, I<$keep>, is false, then any +pre-existing C<*.al> files in the autoload directory are removed if +they are no longer part of the module (obsoleted functions). +$keep defaults to 0. + +=item $check + +The +fourth argument, I<$check>, instructs C<autosplit> to check the module +currently being split to ensure that it does include a C<use> +specification for the AutoLoader module, and skips the module if +AutoLoader is not detected. +$check defaults to 1. + +=item $modtime + +Lastly, the I<$modtime> argument specifies +that C<autosplit> is to check the modification time of the module +against that of the C<autosplit.ix> file, and only split the module if +it is newer. +$modtime defaults to 1. + +=back Typical use of AutoSplit in the perl MakeMaker utility is via the command-line with: @@ -65,33 +86,49 @@ B<lib> relative to the current directory. Each file is sent to the autosplitter one at a time, to be split into the directory B<lib/auto>. In both usages of the autosplitter, only subroutines defined following the -perl special marker I<__END__> are split out into separate files. Some +perl I<__END__> token are split out into separate files. Some routines may be placed prior to this marker to force their immediate loading and parsing. -=head1 CAVEATS +=head2 Multiple packages -Currently, C<AutoSplit> cannot handle multiple package specifications -within one file. +As of version 1.01 of the AutoSplit module it is possible to have +multiple packages within a single file. Both of the following cases +are supported: + + package NAME; + __END__ + sub AAA { ... } + package NAME::option1; + sub BBB { ... } + package NAME::option2; + sub BBB { ... } + + package NAME; + __END__ + sub AAA { ... } + sub NAME::option1::BBB { ... } + sub NAME::option2::BBB { ... } =head1 DIAGNOSTICS -C<AutoSplit> will inform the user if it is necessary to create the top-level -directory specified in the invocation. It is preferred that the script or -installation process that invokes C<AutoSplit> have created the full directory -path ahead of time. This warning may indicate that the module is being split -into an incorrect path. +C<AutoSplit> will inform the user if it is necessary to create the +top-level directory specified in the invocation. It is preferred that +the script or installation process that invokes C<AutoSplit> have +created the full directory path ahead of time. This warning may +indicate that the module is being split into an incorrect path. -C<AutoSplit> will warn the user of all subroutines whose name causes potential -file naming conflicts on machines with drastically limited (8 characters or -less) file name length. Since the subroutine name is used as the file name, -these warnings can aid in portability to such systems. +C<AutoSplit> will warn the user of all subroutines whose name causes +potential file naming conflicts on machines with drastically limited +(8 characters or less) file name length. Since the subroutine name is +used as the file name, these warnings can aid in portability to such +systems. -Warnings are issued and the file skipped if C<AutoSplit> cannot locate either -the I<__END__> marker or a "package Name;"-style specification. +Warnings are issued and the file skipped if C<AutoSplit> cannot locate +either the I<__END__> marker or a "package Name;"-style specification. -C<AutoSplit> will also emit general diagnostics for inability to create -directories or files. +C<AutoSplit> will also emit general diagnostics for inability to +create directories or files. =cut @@ -102,18 +139,21 @@ $Keep = 0; $CheckForAutoloader = 1; $CheckModTime = 1; -$IndexFile = "autosplit.ix"; # file also serves as timestamp -$maxflen = 255; +my $IndexFile = "autosplit.ix"; # file also serves as timestamp +my $maxflen = 255; $maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; -$Is_VMS = ($^O eq 'VMS'); +if (defined (&Dos::UseLFN)) { + $maxflen = Dos::UseLFN() ? 255 : 11; +} +my $Is_VMS = ($^O eq 'VMS'); sub autosplit{ - my($file, $autodir, $k, $ckal, $ckmt) = @_; + my($file, $autodir, $keep, $ckal, $ckmt) = @_; # $file - the perl source file to be split (after __END__) # $autodir - the ".../auto" dir below which to write split subs # Handle optional flags: - $keep = $Keep unless defined $k; + $keep = $Keep unless defined $keep; $ckal = $CheckForAutoloader unless defined $ckal; $ckmt = $CheckModTime unless defined $ckmt; autosplit_file($file, $autodir, $keep, $ckal, $ckmt); @@ -136,7 +176,8 @@ sub autosplit_lib_modules{ $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } - autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime); + autosplit_file("lib/$_", "lib/auto", + $Keep, $CheckForAutoloader, $CheckModTime); } 0; } @@ -144,62 +185,66 @@ sub autosplit_lib_modules{ # private functions -sub autosplit_file{ - my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; - my(@names); +sub autosplit_file { + my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) + = @_; + my(@outfiles); local($_); + local($/) = "\n"; # where to write output files - $autodir = "lib/auto" unless $autodir; + $autodir ||= "lib/auto"; if ($Is_VMS) { - ($autodir = VMS::Filespec::unixpath($autodir)) =~ s{/$}{}; + ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/$||; $filename = VMS::Filespec::unixify($filename); # may have dirs } unless (-d $autodir){ mkpath($autodir,0,0755); - # We should never need to create the auto dir here. installperl - # (or similar) should have done it. Expecting it to exist is a valuable - # sanity check against autosplitting into some random directory by mistake. - print "Warning: AutoSplit had to create top-level $autodir unexpectedly.\n"; + # We should never need to create the auto dir + # here. installperl (or similar) should have done + # it. Expecting it to exist is a valuable sanity check against + # autosplitting into some random directory by mistake. + print "Warning: AutoSplit had to create top-level " . + "$autodir unexpectedly.\n"; } # allow just a package name to be used $filename .= ".pm" unless ($filename =~ m/\.pm$/); - open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n"; + open(IN, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; my($pm_mod_time) = (stat($filename))[9]; my($autoloader_seen) = 0; my($in_pod) = 0; + my($def_package,$last_package,$this_package,$fnr); while (<IN>) { # Skip pod text. - $in_pod = 1 if /^=/; + $fnr++; + $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # record last package name seen - $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); + $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; last if /^__END__/; } if ($check_for_autoloader && !$autoloader_seen){ - print "AutoSplit skipped $filename: no AutoLoader used\n" if ($Verbose>=2); - return 0 + print "AutoSplit skipped $filename: no AutoLoader used\n" + if ($Verbose>=2); + return 0; } $_ or die "Can't find __END__ in $filename\n"; - $package or die "Can't find 'package Name;' in $filename\n"; + $def_package or die "Can't find 'package Name;' in $filename\n"; - my($modpname) = $package; - if ($^O eq 'MSWin32') { - $modpname =~ s#::#\\#g; - } else { - $modpname =~ s#::#/#g; - } + my($modpname) = _modpname($def_package); - die "Package $package ($modpname.pm) does not match filename $filename" + # this _has_ to match so we have a reasonable timestamp file + die "Package $def_package ($modpname.pm) does not ". + "match filename $filename" unless ($filename =~ m/\Q$modpname.pm\E$/ or - ($^O eq "msdos") or ($^O eq 'MSWin32') or + ($^O eq 'dos') or ($^O eq 'MSWin32') or $Is_VMS && $filename =~ m/$modpname.pm/i); my($al_idx_file) = "$autodir/$modpname/$IndexFile"; @@ -207,14 +252,13 @@ sub autosplit_file{ if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; if ($al_ts_time >= $pm_mod_time){ - print "AutoSplit skipped ($al_idx_file newer that $filename)\n" + print "AutoSplit skipped ($al_idx_file newer than $filename)\n" if ($Verbose >= 2); return undef; # one undef, not a list } } - my($from) = ($Verbose>=2) ? "$filename => " : ""; - print "AutoSplitting $package ($from$autodir/$modpname)\n" + print "AutoSplitting $filename ($autodir/$modpname)\n" if $Verbose; unless (-d "$autodir/$modpname"){ @@ -228,68 +272,71 @@ sub autosplit_file{ # This is a problem because some systems silently truncate the file # names while others treat long file names as an error. - # We do not yet deal with multiple packages within one file. - # Ideally both of these styles should work. - # - # package NAME; - # __END__ - # sub AAA { ... } - # package NAME::option1; - # sub BBB { ... } - # package NAME::option2; - # sub BBB { ... } - # - # package NAME; - # __END__ - # sub AAA { ... } - # sub NAME::option1::BBB { ... } - # sub NAME::option2::BBB { ... } - # - # For now both of these produce warnings. - - open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning - my(@subnames, %proto); + my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames + + my(@subnames, $subname, %proto, %package); my @cache = (); my $caching = 1; + $last_package = ''; while (<IN>) { - next if /^=\w/ .. /^=cut/; - if (/^package ([\w:]+)\s*;/) { - warn "package $1; in AutoSplit section ignored. Not currently supported."; + $fnr++; + $in_pod = 1 if /^=/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); + # the following (tempting) old coding gives big troubles if a + # cut is forgotten at EOF: + # next if /^=\w/ .. /^=cut/; + if (/^package\s+([\w:]+)\s*;/) { + $this_package = $def_package = $1; } if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) { - print OUT "1;\n"; - my $subname = $1; - $proto{$1} = $2 || ''; - if ($subname =~ m/::/){ - warn "subs with package names not currently supported in AutoSplit section"; + print OUT "# end of $last_package\::$subname\n1;\n" + if $last_package; + $subname = $1; + my $proto = $2 || ''; + if ($subname =~ s/(.*):://){ + $this_package = $1; + } else { + $this_package = $def_package; } - push(@subnames, $subname); + my $fq_subname = "$this_package\::$subname"; + $package{$fq_subname} = $this_package; + $proto{$fq_subname} = $proto; + push(@subnames, $fq_subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); + $modpname = _modpname($this_package); + mkpath("$autodir/$modpname",0,0777); my($lpath) = "$autodir/$modpname/$lname.al"; my($spath) = "$autodir/$modpname/$sname.al"; - unless(open(OUT, ">$lpath")){ + my $path; + if (!$Is83 and open(OUT, ">$lpath")){ + $path=$lpath; + print " writing $lpath\n" if ($Verbose>=2); + } else { open(OUT, ">$spath") or die "Can't create $spath: $!\n"; - push(@names, $sname); + $path=$spath; print " writing $spath (with truncated name)\n" if ($Verbose>=1); - }else{ - push(@names, $lname); - print " writing $lpath\n" if ($Verbose>=2); } - print OUT "# NOTE: Derived from $filename. ", - "Changes made here will be lost.\n"; - print OUT "package $package;\n\n"; + push(@outfiles, $path); + print OUT <<EOT; +# NOTE: Derived from $filename. +# Changes made here will be lost when autosplit again. +# See AutoSplit.pm. +package $this_package; + +#line $fnr "$filename (autosplit into $path)" +EOT print OUT @cache; @cache = (); $caching = 0; } if($caching) { push(@cache, $_) if @cache || /\S/; - } - else { + } else { print OUT $_; } - if(/^}/) { + if(/^\}/) { if($caching) { print OUT @cache; @cache = (); @@ -297,69 +344,118 @@ sub autosplit_file{ print OUT "\n"; $caching = 1; } + $last_package = $this_package if defined $this_package; } - print OUT @cache,"1;\n"; + print OUT @cache,"1;\n# end of $last_package\::$subname\n"; close(OUT); close(IN); - + if (!$keep){ # don't keep any obsolete *.al files in the directory - my(%names); - @names{@names} = @names; - opendir(OUTDIR,"$autodir/$modpname"); - foreach(sort readdir(OUTDIR)){ - next unless /\.al$/; - my($subname) = m/(.*)\.al$/; - next if $names{substr($subname,0,$maxflen-3)}; - my($file) = "$autodir/$modpname/$_"; - print " deleting $file\n" if ($Verbose>=2); - my($deleted,$thistime); # catch all versions on VMS - do { $deleted += ($thistime = unlink $file) } while ($thistime); - carp "Unable to delete $file: $!" unless $deleted; + my(%outfiles); + # @outfiles{@outfiles} = @outfiles; + # perl downcases all filenames on VMS (which upcases all filenames) so + # we'd better downcase the sub name list too, or subs with upper case + # letters in them will get their .al files deleted right after they're + # created. (The mixed case sub name won't match the all-lowercase + # filename, and so be cleaned up as a scrap file) + if ($Is_VMS or $Is83) { + %outfiles = map {lc($_) => lc($_) } @outfiles; + } else { + @outfiles{@outfiles} = @outfiles; + } + my(%outdirs,@outdirs); + for (@outfiles) { + $outdirs{File::Basename::dirname($_)}||=1; + } + for my $dir (keys %outdirs) { + opendir(OUTDIR,$dir); + foreach (sort readdir(OUTDIR)){ + next unless /\.al$/; + my($file) = "$dir/$_"; + $file = lc $file if $Is83 or $Is_VMS; + next if $outfiles{$file}; + print " deleting $file\n" if ($Verbose>=2); + my($deleted,$thistime); # catch all versions on VMS + do { $deleted += ($thistime = unlink $file) } while ($thistime); + carp "Unable to delete $file: $!" unless $deleted; + } + closedir(OUTDIR); } - closedir(OUTDIR); } open(TS,">$al_idx_file") or carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; - print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n"; - print TS "package $package;\n"; - print TS map("sub $_$proto{$_} ;\n", @subnames); + print TS "# Index created by AutoSplit for $filename\n"; + print TS "# (file acts as timestamp)\n"; + $last_package = ''; + for my $fqs (@subnames) { + my($subname) = $fqs; + $subname =~ s/.*:://; + print TS "package $package{$fqs};\n" + unless $last_package eq $package{$fqs}; + print TS "sub $subname $proto{$fqs};\n"; + $last_package = $package{$fqs}; + } print TS "1;\n"; close(TS); - check_unique($package, $Maxlen, 1, @names); + _check_unique($filename, $Maxlen, 1, @outfiles); - @names; + @outfiles; } +sub _modpname ($) { + my($package) = @_; + my $modpname = $package; + if ($^O eq 'MSWin32') { + $modpname =~ s#::#\\#g; + } else { + $modpname =~ s#::#/#g; + } + $modpname; +} -sub check_unique{ - my($module, $maxlen, $warn, @names) = @_; +sub _check_unique { + my($filename, $maxlen, $warn, @outfiles) = @_; my(%notuniq) = (); my(%shorts) = (); - my(@toolong) = grep(length > $maxlen, @names); - - foreach(@toolong){ - my($trunc) = substr($_,0,$maxlen); - $notuniq{$trunc}=1 if $shorts{$trunc}; - $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_; + my(@toolong) = grep( + length(File::Basename::basename($_)) + > $maxlen, + @outfiles + ); + + foreach (@toolong){ + my($dir) = File::Basename::dirname($_); + my($file) = File::Basename::basename($_); + my($trunc) = substr($file,0,$maxlen); + $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; + $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? + "$shorts{$dir}{$trunc}, $file" : $file; } if (%notuniq && $warn){ - print "$module: some names are not unique when truncated to $maxlen characters:\n"; - foreach(keys %notuniq){ - print " $shorts{$_} truncate to $_\n"; + print "$filename: some names are not unique when " . + "truncated to $maxlen characters:\n"; + foreach my $dir (sort keys %notuniq){ + print " directory $dir:\n"; + foreach my $trunc (sort keys %{$notuniq{$dir}}) { + print " $shorts{$dir}{$trunc} truncate to $trunc\n"; + } } } - %notuniq; } 1; __END__ # test functions so AutoSplit.pm can be applied to itself: -sub test1{ "test 1\n"; } -sub test2{ "test 2\n"; } -sub test3{ "test 3\n"; } -sub test4{ "test 4\n"; } - - +sub test1 ($) { "test 1\n"; } +sub test2 ($$) { "test 2\n"; } +sub test3 ($$$) { "test 3\n"; } +sub testtesttesttest4_1 { "test 4\n"; } +sub testtesttesttest4_2 { "duplicate test 4\n"; } +sub Just::Another::test5 { "another test 5\n"; } +sub test6 { return join ":", __FILE__,__LINE__; } +package Yet::Another::AutoSplit; +sub testtesttesttest4_1 ($) { "another test 4\n"; } +sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } diff --git a/gnu/usr.bin/perl/lib/Benchmark.pm b/gnu/usr.bin/perl/lib/Benchmark.pm index 13acf869bc1..ef12d02fcbc 100644 --- a/gnu/usr.bin/perl/lib/Benchmark.pm +++ b/gnu/usr.bin/perl/lib/Benchmark.pm @@ -82,6 +82,30 @@ Results will be printed to STDOUT as TITLE followed by the times. TITLE defaults to "timethis COUNT" if none is provided. STYLE determines the format of the output, as described for timestr() below. +The COUNT can be zero or negative: this means the I<minimum number of +CPU seconds> to run. A zero signifies the default of 3 seconds. For +example to run at least for 10 seconds: + + timethis(-10, $code) + +or to run two pieces of code tests for at least 3 seconds: + + timethese(0, { test1 => '...', test2 => '...'}) + +CPU seconds is, in UNIX terms, the user time plus the system time of +the process itself, as opposed to the real (wallclock) time and the +time spent by the child processes. Less than 0.1 seconds is not +accepted (-0.01 as the count, for example, will cause a fatal runtime +exception). + +Note that the CPU seconds is the B<minimum> time: CPU scheduling and +other operating system factors may complicate the attempt so that a +little bit more time is spent. The benchmark output will, however, +also tell the number of C<$code> runs/second, which should be a more +interesting number than the actually spent seconds. + +Returns a Benchmark object. + =item timethese ( COUNT, CODEHASHREF, [ STYLE ] ) The CODEHASHREF is a reference to a hash containing names as keys @@ -91,12 +115,21 @@ call timethis(COUNT, VALUE, KEY, STYLE) +The routines are called in string comparison order of KEY. + +The COUNT can be zero or negative, see timethis(). + =item timediff ( T1, T2 ) Returns the difference between two Benchmark times as a Benchmark object suitable for passing to timestr(). -=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ]] ) +=item timesum ( T1, T2 ) + +Returns the sum of two Benchmark times as a Benchmark object suitable +for passing to timestr(). + +=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ] ] ) Returns a string that formats the times in the TIMEDIFF object in the requested STYLE. TIMEDIFF is expected to be a Benchmark object @@ -205,8 +238,18 @@ March 28th, 1997; by Hugo van der Sanden: added support for code references and the already documented 'debug' method; revamped documentation. +April 04-07th, 1997: by Jarkko Hietaniemi, added the run-for-some-time +functionality. + =cut +# evaluate something in a clean lexical environment +sub _doeval { eval shift } + +# +# put any lexicals at file scope AFTER here +# + use Carp; use Exporter; @ISA=(Exporter); @@ -237,7 +280,9 @@ sub disablecache { $cache = 0; } # --- Functions to process the 'time' data type -sub new { my @t = (time, times); print "new=@t\n" if $debug; bless \@t; } +sub new { my @t = (time, times, @_ == 2 ? $_[1] : 0); + print "new=@t\n" if $debug; + bless \@t; } sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } @@ -247,29 +292,39 @@ sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } sub timediff { my($a, $b) = @_; my @r; - for ($i=0; $i < @$a; ++$i) { + for (my $i=0; $i < @$a; ++$i) { push(@r, $a->[$i] - $b->[$i]); } bless \@r; } +sub timesum { + my($a, $b) = @_; + my @r; + for (my $i=0; $i < @$a; ++$i) { + push(@r, $a->[$i] + $b->[$i]); + } + bless \@r; +} + sub timestr { my($tr, $style, $f) = @_; my @t = @$tr; - warn "bad time value" unless @t==5; - my($r, $pu, $ps, $cu, $cs) = @t; + warn "bad time value (@t)" unless @t==6; + my($r, $pu, $ps, $cu, $cs, $n) = @t; my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); $f = $defaultfmt unless defined $f; # format a time in the required style, other formats may be added here $style ||= $defaultstyle; $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto'; my $s = "@t $style"; # default for unknown style - $s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)", + $s=sprintf("%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)", @t,$t) if $style eq 'all'; - $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)", + $s=sprintf("%2d wallclock secs (%$f usr + %$f sys = %$f CPU)", $r,$pu,$ps,$pt) if $style eq 'noc'; - $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)", + $s=sprintf("%2d wallclock secs (%$f cusr + %$f csys = %$f CPU)", $r,$cu,$cs,$ct) if $style eq 'nop'; + $s .= sprintf(" @ %$f/s (n=$n)", $n / ( $pu + $ps )) if $n; $s; } @@ -295,16 +350,21 @@ sub runloop { last if $pack ne $curpack; } - 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; + my ($subcode, $subref); + if (ref $c eq 'CODE') { + $subcode = "sub { for (1 .. $n) { local \$_; package $pack; &\$c; } }"; + $subref = eval $subcode; + } + else { + $subcode = "sub { for (1 .. $n) { local \$_; package $pack; $c;} }"; + $subref = _doeval($subcode); + } croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; print STDERR "runloop $n '$subcode'\n" if $debug; - $t0 = &new; + $t0 = Benchmark->new(0); &$subref; - $t1 = &new; + $t1 = Benchmark->new($n); $td = &timediff($t1, $t0); timedebug("runloop:",$td); @@ -336,16 +396,98 @@ sub timeit { $wd; } + +my $default_for = 3; +my $min_for = 0.1; + +sub runfor { + my ($code, $tmax) = @_; + + if ( not defined $tmax or $tmax == 0 ) { + $tmax = $default_for; + } elsif ( $tmax < 0 ) { + $tmax = -$tmax; + } + + die "runfor(..., $tmax): timelimit cannot be less than $min_for.\n" + if $tmax < $min_for; + + my ($n, $td, $tc, $ntot, $rtot, $utot, $stot, $cutot, $cstot ); + + # First find the minimum $n that gives a non-zero timing. + + my $nmin; + + for ($n = 1, $tc = 0; $tc <= 0; $n *= 2 ) { + $td = timeit($n, $code); + $tc = $td->[1] + $td->[2]; + } + + $nmin = $n; + + my $ttot = 0; + my $tpra = 0.05 * $tmax; # Target/time practice. + + # Double $n until we have think we have practiced enough. + for ( $n = 1; $ttot < $tpra; $n *= 2 ) { + $td = timeit($n, $code); + $tc = $td->cpu_p; + $ntot += $n; + $rtot += $td->[0]; + $utot += $td->[1]; + $stot += $td->[2]; + $ttot = $utot + $stot; + $cutot += $td->[3]; + $cstot += $td->[4]; + } + + my $r; + + # Then iterate towards the $tmax. + while ( $ttot < $tmax ) { + $r = $tmax / $ttot - 1; # Linear approximation. + $n = int( $r * $n ); + $n = $nmin if $n < $nmin; + $td = timeit($n, $code); + $ntot += $n; + $rtot += $td->[0]; + $utot += $td->[1]; + $stot += $td->[2]; + $ttot = $utot + $stot; + $cutot += $td->[3]; + $cstot += $td->[4]; + } + + return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ]; +} + # --- Functions implementing high-level time-then-print utilities +sub n_to_for { + my $n = shift; + return $n == 0 ? $default_for : $n < 0 ? -$n : undef; +} + sub timethis{ my($n, $code, $title, $style) = @_; - my $t = timeit($n, $code); + my($t, $for, $forn); + + if ( $n > 0 ) { + croak "non-integer loopcount $n, stopped" if int($n)<$n; + $t = timeit($n, $code); + $title = "timethis $n" unless defined $title; + } else { + $fort = n_to_for( $n ); + $t = runfor($code, $fort); + $title = "timethis for $fort" unless defined $title; + $forn = $t->[-1]; + } local $| = 1; - $title = "timethis $n" unless defined $title; $style = "" unless defined $style; printf("%10s: ", $title); - print timestr($t, $style),"\n"; + print timestr($t, $style, $defaultfmt),"\n"; + + $n = $forn if defined $forn; # A conservative warning to spot very silly tests. # Don't assume that your benchmark is ok simply because @@ -363,11 +505,25 @@ sub timethese{ unless ref $alt eq HASH; my @names = sort keys %$alt; $style = "" unless defined $style; - print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n"; + print "Benchmark: "; + if ( $n > 0 ) { + croak "non-integer loopcount $n, stopped" if int($n)<$n; + print "timing $n iterations of"; + } else { + print "running"; + } + print " ", join(', ',@names); + unless ( $n > 0 ) { + my $for = n_to_for( $n ); + print ", each for at least $for CPU seconds"; + } + print "...\n"; # we could save the results in an array and produce a summary here # sum, min, max, avg etc etc - map timethis($n, $alt->{$_}, $_, $style), @names; + foreach my $name (@names) { + timethis ($n, $alt -> {$name}, $name, $style); + } } 1; diff --git a/gnu/usr.bin/perl/lib/CGI.pm b/gnu/usr.bin/perl/lib/CGI.pm index 9967a42cf67..f94b2dff9a1 100644 --- a/gnu/usr.bin/perl/lib/CGI.pm +++ b/gnu/usr.bin/perl/lib/CGI.pm @@ -1,5 +1,5 @@ package CGI; -require 5.001; +require 5.004; # See the bottom of this file for the POD documentation. Search for the # string '=head'. @@ -8,49 +8,77 @@ require 5.001; # documentation in manual or html file format (these utilities are part of the # Perl 5 distribution). -# Copyright 1995-1997 Lincoln D. Stein. All rights reserved. +# Copyright 1995-1998 Lincoln D. Stein. All rights reserved. # It may be used and modified freely, but I do request that this copyright # notice remain attached to the file. You may modify this module as you # wish, but if you redistribute a modified version, please attach a note # listing the modifications you have made. # The most recent version and complete docs are available at: -# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html -# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ - -# Set this to 1 to enable copious autoloader debugging messages -$AUTOLOAD_DEBUG=0; - -# Set this to 1 to enable NPH scripts -# or: -# 1) use CGI qw(:nph) -# 2) $CGI::nph(1) -# 3) print header(-nph=>1) -$NPH=0; - -# Set this to 1 to make the temporary files created -# during file uploads safe from prying eyes -# or do... -# 1) use CGI qw(:private_tempfiles) -# 2) $CGI::private_tempfiles(1); -$PRIVATE_TEMPFILES=0; - -$CGI::revision = '$Id: CGI.pm,v 1.1 1997/11/30 07:56:38 millert Exp $'; -$CGI::VERSION='2.36'; - -# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG -# $OS = 'UNIX'; -# $OS = 'MACINTOSH'; -# $OS = 'WINDOWS'; -# $OS = 'VMS'; -# $OS = 'OS2'; +# http://stein.cshl.org/WWW/software/CGI/ + +$CGI::revision = '$Id: CGI.pm,v 1.2 1999/04/29 22:51:41 millert Exp $'; +$CGI::VERSION='2.46'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. # $TempFile::TMPDIRECTORY = '/usr/tmp'; +# >>>>> Here are some globals that you might want to adjust <<<<<< +sub initialize_globals { + # Set this to 1 to enable copious autoloader debugging messages + $AUTOLOAD_DEBUG = 0; + + # Change this to the preferred DTD to print in start_html() + # or use default_dtd('text of DTD to use'); + $DEFAULT_DTD = '-//IETF//DTD HTML//EN'; + + # Set this to 1 to enable NPH scripts + # or: + # 1) use CGI qw(-nph) + # 2) $CGI::nph(1) + # 3) print header(-nph=>1) + $NPH = 0; + + # Set this to 1 to disable debugging from the + # command line + $NO_DEBUG = 0; + + # Set this to 1 to make the temporary files created + # during file uploads safe from prying eyes + # or do... + # 1) use CGI qw(:private_tempfiles) + # 2) $CGI::private_tempfiles(1); + $PRIVATE_TEMPFILES = 0; + + # Set this to a positive value to limit the size of a POSTing + # to a certain number of bytes: + $POST_MAX = -1; + + # Change this to 1 to disable uploads entirely: + $DISABLE_UPLOADS = 0; + + # Change this to 1 to suppress redundant HTTP headers + $HEADERS_ONCE = 0; + + # separate the name=value pairs by semicolons rather than ampersands + $USE_PARAM_SEMICOLONS = 0; + + # Other globals that you shouldn't worry about. + undef $Q; + $BEEN_THERE = 0; + undef @QUERY_PARAM; + undef %EXPORT; + + # prevent complaints by mod_perl + 1; +} + # ------------------ START OF THE LIBRARY ------------ +# make mod_perlhappy +initialize_globals(); + # FIGURE OUT THE OS WE'RE RUNNING UNDER # Some systems support the $^O variable. If not # available then require() the Config library @@ -64,7 +92,7 @@ if ($OS=~/Win/i) { $OS = 'WINDOWS'; } elsif ($OS=~/vms/i) { $OS = 'VMS'; -} elsif ($OS=~/Mac/i) { +} elsif ($OS=~/^MacOS$/i) { $OS = 'MACINTOSH'; } elsif ($OS=~/os2/i) { $OS = 'OS2'; @@ -77,77 +105,91 @@ $needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/; # This is the default class for the CGI object to use when all else fails. $DefaultClass = 'CGI' unless defined $CGI::DefaultClass; + # This is where to look for autoloaded routines. $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; # The path separator is a slash, backslash or semicolon, depending # on the paltform. $SL = { - UNIX=>'/', - OS2=>'\\', - WINDOWS=>'\\', - MACINTOSH=>':', - VMS=>'\\' + UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', MACINTOSH=>':', VMS=>'/' }->{$OS}; +# This no longer seems to be necessary # Turn on NPH scripts by default when running under IIS server! -$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for Doug MacEachern's modperl -if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) { - $NPH++; +if (exists $ENV{'GATEWAY_INTERFACE'} + && + ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) +{ $| = 1; - $SEQNO = 1; + require Apache; +} +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning +# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF +# and sometimes CR). The most popular VMS web server +# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't +# use ASCII, so \015\012 means something different. I find this all +# really annoying. +$EBCDIC = "\t" ne "\011"; +if ($OS eq 'VMS') { + $CRLF = "\n"; +} elsif ($EBCDIC) { + $CRLF= "\r\n"; +} else { + $CRLF = "\015\012"; } -# This is really "\r\n", but the meaning of \n is different -# in MacPerl, so we resort to octal here. -$CRLF = "\015\012"; - if ($needs_binmode) { $CGI::DefaultClass->binmode(main::STDOUT); $CGI::DefaultClass->binmode(main::STDIN); $CGI::DefaultClass->binmode(main::STDERR); } -# Cute feature, but it broke when the overload mechanism changed... -# %OVERLOAD = ('""'=>'as_string'); - %EXPORT_TAGS = ( - ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em - tt i b blockquote pre img a address cite samp dfn html head - base body link nextid title meta kbd start_html end_html - input Select option/], - ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont style span/], - ':netscape'=>[qw/blink frameset frame script font fontsize center/], - ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group - submit reset defaults radio_group popup_menu button autoEscape - scrolling_list image_button start_form end_form startform endform - start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], - ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump - raw_cookie request_method query_string accept user_agent remote_host - remote_addr referer server_name server_software server_port server_protocol - virtual_host remote_ident auth_type http use_named_parameters - remote_user user_name header redirect import_names put/], - ':ssl' => [qw/https/], - ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], - ':html' => [qw/:html2 :html3 :netscape/], - ':standard' => [qw/:html2 :form :cgi/], - ':all' => [qw/:html2 :html3 :netscape :form :cgi/] - ); + ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em + tt u i b blockquote pre img a address cite samp dfn html head + base body Link nextid title meta kbd start_html end_html + input Select option comment/], + ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param + embed basefont style span layer ilayer font frameset frame script small big/], + ':netscape'=>[qw/blink fontsize center/], + ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group + submit reset defaults radio_group popup_menu button autoEscape + scrolling_list image_button start_form end_form startform endform + start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], + ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie Dump + raw_cookie request_method query_string Accept user_agent remote_host + remote_addr referer server_name server_software server_port server_protocol + virtual_host remote_ident auth_type http use_named_parameters + save_parameters restore_parameters param_fetch + remote_user user_name header redirect import_names put Delete Delete_all url_param/], + ':ssl' => [qw/https/], + ':imagemap' => [qw/Area Map/], + ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], + ':html' => [qw/:html2 :html3 :netscape/], + ':standard' => [qw/:html2 :html3 :form :cgi/], + ':push' => [qw/multipart_init multipart_start multipart_end/], + ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/] + ); # to import symbols into caller sub import { my $self = shift; + +# This causes modules to clash. +# undef %EXPORT_OK; +# undef %EXPORT; + + $self->_setup_symbols(@_); my ($callpack, $callfile, $callline) = caller; - foreach (@_) { - $NPH++, next if $_ eq ':nph'; - $PRIVATE_TEMPFILES++, next if $_ eq ':private_tempfiles'; - foreach (&expand_tags($_)) { - tr/a-zA-Z0-9_//cd; # don't allow weird function names - $EXPORT{$_}++; - } - } + # To allow overriding, search through the packages # Till we find one in which the correct subroutine is defined. my @packages = ($self,@{"$self\:\:ISA"}); @@ -164,8 +206,14 @@ sub import { } } +sub compile { + my $pack = shift; + $pack->_setup_symbols('-compile',@_); +} + sub expand_tags { my($tag) = @_; + return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; my(@r); return ($tag) unless $EXPORT_TAGS{$tag}; foreach (@{$EXPORT_TAGS{$tag}}) { @@ -182,8 +230,11 @@ sub new { my($class,$initializer) = @_; my $self = {}; bless $self,ref $class || $class || $DefaultClass; - $CGI::DefaultClass->_reset_globals() if $MOD_PERL; - $initializer = to_filehandle($initializer) if $initializer; + if ($MOD_PERL) { + Apache->request->register_cleanup(\&CGI::_reset_globals); + undef $NPH; + } + $self->_reset_globals if $PERLEX; $self->init($initializer); return $self; } @@ -230,98 +281,32 @@ sub param { $name = $p[0]; } - return () unless defined($name) && $self->{$name}; + return unless defined($name) && $self->{$name}; return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; } -#### Method: delete -# Deletes the named parameter entirely. -#### -sub delete { - my($self,$name) = self_or_default(@_); - delete $self->{$name}; - delete $self->{'.fieldnames'}->{$name}; - @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); - return wantarray ? () : undef; -} - sub self_or_default { - return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI'); + return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); unless (defined($_[0]) && - ref($_[0]) && - (ref($_[0]) eq 'CGI' || - eval "\$_[0]->isaCGI()")) { # optimize for the common case - $CGI::DefaultClass->_reset_globals() - if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request(); + (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case + ) { $Q = $CGI::DefaultClass->new unless defined($Q); unshift(@_,$Q); } return @_; } -sub _new_request { - return undef unless (defined(Apache->seqno()) or eval { require Apache }); - if (Apache->seqno() != $SEQNO) { - $SEQNO = Apache->seqno(); - return 1; - } else { - return undef; - } -} - -sub _reset_globals { - undef $Q; - undef @QUERY_PARAM; -} - sub self_or_CGI { local $^W=0; # prevent a warning if (defined($_[0]) && (substr(ref($_[0]),0,3) eq 'CGI' - || eval "\$_[0]->isaCGI()")) { + || UNIVERSAL::isa($_[0],'CGI'))) { return @_; } else { return ($DefaultClass,@_); } } -sub isaCGI { - return 1; -} - -#### Method: import_names -# Import all parameters into the given namespace. -# Assumes namespace 'Q' if not specified -#### -sub import_names { - my($self,$namespace) = self_or_default(@_); - $namespace = 'Q' unless defined($namespace); - die "Can't import names into 'main'\n" - if $namespace eq 'main'; - my($param,@value,$var); - foreach $param ($self->param) { - # protect against silly names - ($var = $param)=~tr/a-zA-Z0-9_/_/c; - $var = "${namespace}::$var"; - @value = $self->param($param); - @{$var} = @value; - ${$var} = $value[0]; - } -} - -#### Method: use_named_parameters -# Force CGI.pm to use named parameter-style method calls -# rather than positional parameters. The same effect -# will happen automatically if the first parameter -# begins with a -. -sub use_named_parameters { - my($self,$use_named) = self_or_default(@_); - return $self->{'.named'} unless defined ($use_named); - - # stupidity to avoid annoying warnings - return $self->{'.named'}=$use_named; -} - ######################################## # THESE METHODS ARE MORE OR LESS PRIVATE # GO TO THE __DATA__ SECTION TO SEE MORE @@ -337,14 +322,13 @@ sub use_named_parameters { sub init { my($self,$initializer) = @_; - my($query_string,@lines); - my($meth) = ''; + my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + local($/) = "\n"; # if we get called more than once, we want to initialize # ourselves from the original query (which may be gone # if it was read from STDIN originally.) if (defined(@QUERY_PARAM) && !defined($initializer)) { - foreach (@QUERY_PARAM) { $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); } @@ -352,12 +336,32 @@ sub init { } $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); + $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; + die "Client attempted to POST $content_length bytes, but POSTs are limited to $POST_MAX" + if ($POST_MAX > 0) && ($content_length > $POST_MAX); + $fh = to_filehandle($initializer) if $initializer; - # If initializer is defined, then read parameters - # from it. METHOD: { - if (defined($initializer)) { + # Process multipart postings, but only if the initializer is + # not defined. + if ($meth eq 'POST' + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| + && !defined($initializer) + ) { + my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; + $self->read_multipart($boundary,$content_length); + last METHOD; + } + + # If initializer is defined, then read parameters + # from it. + if (defined($initializer)) { + if (UNIVERSAL::isa($initializer,'CGI')) { + $query_string = $initializer->query_string; + last METHOD; + } if (ref($initializer) && ref($initializer) eq 'HASH') { foreach (keys %$initializer) { $self->param('-name'=>$_,'-value'=>$initializer->{$_}); @@ -365,9 +369,8 @@ sub init { last METHOD; } - $initializer = $$initializer if ref($initializer); - if (defined(fileno($initializer))) { - while (<$initializer>) { + if (defined($fh) && ($fh ne '')) { + while (<$fh>) { chomp; last if /^=/; push(@lines,$_); @@ -380,49 +383,41 @@ sub init { } last METHOD; } + + # last chance -- treat it as a string + $initializer = $$initializer if ref($initializer) eq 'SCALAR'; $query_string = $initializer; + last METHOD; } - # If method is GET or HEAD, fetch the query from - # the environment. - if ($meth=~/^(GET|HEAD)$/) { - $query_string = $ENV{'QUERY_STRING'}; - last METHOD; - } - - # If the method is POST, fetch the query from standard - # input. - if ($meth eq 'POST') { - if (defined($ENV{'CONTENT_TYPE'}) - && - $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) { - my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/; - $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'}); - - } else { - - $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0) - if $ENV{'CONTENT_LENGTH'} > 0; + # If method is GET or HEAD, fetch the query from + # the environment. + if ($meth=~/^(GET|HEAD)$/) { + $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + last METHOD; + } - } + if ($meth eq 'POST') { + $self->read_from_client(\*STDIN,\$query_string,$content_length,0) + if $content_length > 0; # Some people want to have their cake and eat it too! # Uncomment this line to have the contents of the query string # APPENDED to the POST data. - # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'}; + # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; last METHOD; } - - # If neither is set, assume we're being debugged offline. + + # If $meth is not of GET, POST or HEAD, assume we're being debugged offline. # Check the command line and then the standard input for data. # We use the shellwords package in order to behave the way that # UN*X programmers expect. - $query_string = &read_from_cmdline; + $query_string = read_from_cmdline() unless $NO_DEBUG; } - + # We now have the query string in hand. We do slightly # different things for keyword lists and parameter lists. - if ($query_string) { + if ($query_string ne '') { if ($query_string =~ /=/) { $self->parse_params($query_string); } else { @@ -447,39 +442,23 @@ sub init { $self->delete('.submit'); $self->delete('.cgifields'); $self->save_request unless $initializer; - } - # FUNCTIONS TO OVERRIDE: - # Turn a string into a filehandle sub to_filehandle { - my $string = shift; - if ($string && !ref($string)) { - my($package) = caller(1); - my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string"; - return $tmp if defined(fileno($tmp)); + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } } - return $string; -} - -# Create a new multipart buffer -sub new_MultipartBuffer { - my($self,$boundary,$length,$filehandle) = @_; - return MultipartBuffer->new($self,$boundary,$length,$filehandle); -} - -# Read data from a file handle -sub read_from_client { - my($self, $fh, $buff, $len, $offset) = @_; - local $^W=0; # prevent a warning - return read($fh, $$buff, $len, $offset); -} - -# put a filehandle into binary mode (DOS) -sub binmode { - binmode($_[1]); + return undef; } # send output to the browser @@ -496,7 +475,9 @@ sub print { # unescape URL-encoded data sub unescape { - my($todecode) = @_; + shift() if ref($_[0]); + my $todecode = shift; + return undef unless defined($todecode); $todecode =~ tr/+/ /; # pluses become spaces $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; return $todecode; @@ -504,8 +485,10 @@ sub unescape { # URL-encode data sub escape { - my($toencode) = @_; - $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg; + shift() if ref($_[0]) || $_[0] eq $DefaultClass; + my $toencode = shift; + return undef unless defined($toencode); + $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; return $toencode; } @@ -520,22 +503,14 @@ sub save_request { } } -sub parse_keywordlist { - my($self,$tosplit) = @_; - $tosplit = &unescape($tosplit); # unescape the keywords - $tosplit=~tr/+/ /; # pluses to spaces - my(@keywords) = split(/\s+/,$tosplit); - return @keywords; -} - sub parse_params { my($self,$tosplit) = @_; - my(@pairs) = split('&',$tosplit); + my(@pairs) = split(/[&;]/,$tosplit); my($param,$value); foreach (@pairs) { - ($param,$value) = split('='); - $param = &unescape($param); - $value = &unescape($value); + ($param,$value) = split('=',$_,2); + $param = unescape($param); + $value = unescape($value); $self->add_parameter($param); push (@{$self->{$param}},$value); } @@ -554,46 +529,46 @@ sub all_parameters { return @{$self->{'.parameters'}}; } -#### Method as_string -# -# synonym for "dump" -#### -sub as_string { - &dump(@_); +# put a filehandle into binary mode (DOS) +sub binmode { + CORE::binmode($_[1]); +} + +sub _make_tag_func { + my ($self,$tagname) = @_; + my $func = qq# + sub $tagname { + shift if \$_[0] && + (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || + (ref(\$_[0]) && + (substr(ref(\$_[0]),0,3) eq 'CGI' || + UNIVERSAL::isa(\$_[0],'CGI'))); + + my(\$attr) = ''; + if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') { + my(\@attr) = make_attributes( '',shift() ); + \$attr = " \@attr" if \@attr; + } + #; + if ($tagname=~/start_(\w+)/i) { + $func .= qq! return "<\U$1\E\$attr>";} !; + } elsif ($tagname=~/end_(\w+)/i) { + $func .= qq! return "<\U/$1\E>"; } !; + } else { + $func .= qq# + my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E"); + return \$tag unless \@_; + my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; + return "\@result"; + }#; + } +return $func; } sub AUTOLOAD { print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG; - my($func) = $AUTOLOAD; - my($pack,$func_name) = $func=~/(.+)::([^:]+)$/; - $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass - unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); - - my($sub) = \%{"$pack\:\:SUBS"}; - unless (%$sub) { - my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; - eval "package $pack; $$auto"; - die $@ if $@; - } - my($code) = $sub->{$func_name}; - - $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); - if (!$code) { - if ($EXPORT{':any'} || - $EXPORT{$func_name} || - (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) - && $EXPORT_OK{$func_name}) { - $code = $sub->{'HTML_FUNC'}; - $code=~s/func_name/$func_name/mg; - } - } - die "Undefined subroutine $AUTOLOAD\n" unless $code; - eval "package $pack; $code"; - if ($@) { - $@ =~ s/ at .*\n//; - die $@; - } - goto &{"$pack\:\:$func_name"}; + my $func = &_compile; + goto &$func; } # PRIVATE SUBROUTINE @@ -604,38 +579,112 @@ sub AUTOLOAD { sub rearrange { my($self,$order,@param) = @_; return () unless @param; - - return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-') - || $self->use_named_parameters; - my $i; - for ($i=0;$i<@param;$i+=2) { - $param[$i]=~s/^\-//; # get rid of initial - if present - $param[$i]=~tr/a-z/A-Z/; # parameters are upper case + if (ref($param[0]) eq 'HASH') { + @param = %{$param[0]}; + } else { + return @param + unless (defined($param[0]) && substr($param[0],0,1) eq '-') + || $self->use_named_parameters; } - - my(%param) = @param; # convert into associative array - my(@return_array); - - my($key)=''; - foreach $key (@$order) { - my($value); - # this is an awful hack to fix spurious warnings when the - # -w switch is set. - if (ref($key) && ref($key) eq 'ARRAY') { - foreach (@$key) { - last if defined($value); - $value = $param{$_}; - delete $param{$_}; - } + + # map parameters into positional indices + my ($i,%pos); + $i = 0; + foreach (@$order) { + foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; } + $i++; + } + + my (@result,%leftover); + $#result = $#$order; # preextend + while (@param) { + my $key = uc(shift(@param)); + $key =~ s/^\-//; + if (exists $pos{$key}) { + $result[$pos{$key}] = shift(@param); } else { - $value = $param{$key}; - delete $param{$key}; + $leftover{$key} = shift(@param); } - push(@return_array,$value); } - push (@return_array,$self->make_attributes(\%param)) if %param; - return (@return_array); + + push (@result,$self->make_attributes(\%leftover)) if %leftover; + @result; +} + +sub _compile { + my($func) = $AUTOLOAD; + my($pack,$func_name); + { + local($1,$2); # this fixes an obscure variable suicide problem. + $func=~/(.+)::([^:]+)$/; + ($pack,$func_name) = ($1,$2); + $pack=~s/::SUPER$//; # fix another obscure problem + $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass + unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); + + my($sub) = \%{"$pack\:\:SUBS"}; + unless (%$sub) { + my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; + eval "package $pack; $$auto"; + die $@ if $@; + $$auto = ''; # Free the unneeded storage (but don't undef it!!!) + } + my($code) = $sub->{$func_name}; + + $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); + if (!$code) { + (my $base = $func_name) =~ s/^(start_|end_)//i; + if ($EXPORT{':any'} || + $EXPORT{'-any'} || + $EXPORT{$base} || + (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) + && $EXPORT_OK{$base}) { + $code = $CGI::DefaultClass->_make_tag_func($func_name); + } + } + die "Undefined subroutine $AUTOLOAD\n" unless $code; + eval "package $pack; $code"; + if ($@) { + $@ =~ s/ at .*\n//; + die $@; + } + } + delete($sub->{$func_name}); #free storage + return "$pack\:\:$func_name"; +} + +sub _reset_globals { initialize_globals(); } + +sub _setup_symbols { + my $self = shift; + my $compile = 0; + foreach (@_) { + $HEADERS_ONCE++, next if /^[:-]unique_headers$/; + $NPH++, next if /^[:-]nph$/; + $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; + $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; + $EXPORT{$_}++, next if /^[:-]any$/; + $compile++, next if /^[:-]compile$/; + + # This is probably extremely evil code -- to be deleted some day. + if (/^[-]autoload$/) { + my($pkg) = caller(1); + *{"${pkg}::AUTOLOAD"} = sub { + my($routine) = $AUTOLOAD; + $routine =~ s/^.*::/CGI::/; + &$routine; + }; + next; + } + + foreach (&expand_tags($_)) { + tr/a-zA-Z0-9_//cd; # don't allow weird function names + $EXPORT{$_}++; + } + } + _compile_all(keys %EXPORT) if $compile; } ############################################################################### @@ -654,32 +703,83 @@ END_OF_FUNC sub MULTIPART { 'multipart/form-data'; } END_OF_FUNC -'HTML_FUNC' => <<'END_OF_FUNC', -sub func_name { - - # handle various cases in which we're called - # most of this bizarre stuff is to avoid -w errors - shift if $_[0] && - (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) || - (ref($_[0]) && - (substr(ref($_[0]),0,3) eq 'CGI' || - eval "\$_[0]->isaCGI()")); - - my($attr) = ''; - if (ref($_[0]) && ref($_[0]) eq 'HASH') { - my(@attr) = CGI::make_attributes('',shift); - $attr = " @attr" if @attr; - } - my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E"); - return $tag unless @_; - if (ref($_[0]) eq 'ARRAY') { - my(@r); - foreach (@{$_[0]}) { - push(@r,"$tag$_$untag"); +'SERVER_PUSH' => <<'END_OF_FUNC', +sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; } +END_OF_FUNC + +'use_named_parameters' => <<'END_OF_FUNC', +#### Method: use_named_parameters +# Force CGI.pm to use named parameter-style method calls +# rather than positional parameters. The same effect +# will happen automatically if the first parameter +# begins with a -. +sub use_named_parameters { + my($self,$use_named) = self_or_default(@_); + return $self->{'.named'} unless defined ($use_named); + + # stupidity to avoid annoying warnings + return $self->{'.named'}=$use_named; +} +END_OF_FUNC + +'new_MultipartBuffer' => <<'END_OF_FUNC', +# Create a new multipart buffer +sub new_MultipartBuffer { + my($self,$boundary,$length,$filehandle) = @_; + return MultipartBuffer->new($self,$boundary,$length,$filehandle); +} +END_OF_FUNC + +'read_from_client' => <<'END_OF_FUNC', +# Read data from a file handle +sub read_from_client { + my($self, $fh, $buff, $len, $offset) = @_; + local $^W=0; # prevent a warning + return undef unless defined($fh); + return read($fh, $$buff, $len, $offset); +} +END_OF_FUNC + +'delete' => <<'END_OF_FUNC', +#### Method: delete +# Deletes the named parameter entirely. +#### +sub delete { + my($self,$name) = self_or_default(@_); + delete $self->{$name}; + delete $self->{'.fieldnames'}->{$name}; + @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); + return wantarray ? () : undef; +} +END_OF_FUNC + +#### Method: import_names +# Import all parameters into the given namespace. +# Assumes namespace 'Q' if not specified +#### +'import_names' => <<'END_OF_FUNC', +sub import_names { + my($self,$namespace,$delete) = self_or_default(@_); + $namespace = 'Q' unless defined($namespace); + die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; + if ($delete || $MOD_PERL) { + # can anyone find an easier way to do this? + foreach (keys %{"${namespace}::"}) { + local *symbol = "${namespace}::${_}"; + undef $symbol; + undef @symbol; + undef %symbol; } - return "@r"; - } else { - return "$tag@_$untag"; + } + my($param,@value,$var); + foreach $param ($self->param) { + # protect against silly names + ($var = $param)=~tr/a-zA-Z0-9_/_/c; + $var =~ s/^(?=\d)/_/; + local *symbol = "${namespace}::$var"; + @value = $self->param($param); + @symbol = @value; + $symbol = $value[0]; } } END_OF_FUNC @@ -693,8 +793,8 @@ END_OF_FUNC sub keywords { my($self,@values) = self_or_default(@_); # If values is provided, then we set it. - $self->{'keywords'}=[@values] if @values; - my(@result) = @{$self->{'keywords'}}; + $self->{'keywords'}=[@values] if defined(@values); + my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : (); @result; } END_OF_FUNC @@ -711,6 +811,7 @@ sub ReadParse { *in=*{"${pkg}::in"}; } tie(%in,CGI); + return scalar(keys %in); } END_OF_FUNC @@ -757,7 +858,7 @@ END_OF_FUNC 'TIEHASH' => <<'END_OF_FUNC', sub TIEHASH { - return new CGI; + return $Q || new CGI; } END_OF_FUNC @@ -833,6 +934,20 @@ sub delete_all { } EOF +'Delete' => <<'EOF', +sub Delete { + my($self,@p) = self_or_default(@_); + $self->delete(@p); +} +EOF + +'Delete_all' => <<'EOF', +sub Delete_all { + my($self,@p) = self_or_default(@_); + $self->delete_all(@p); +} +EOF + #### Method: autoescape # If you want to turn off the autoescaping features, # call this method with undef as the argument @@ -861,13 +976,44 @@ sub make_attributes { foreach (keys %{$attr}) { my($key) = $_; $key=~s/^\-//; # get rid of initial - if present - $key=~tr/a-z/A-Z/; # parameters are upper case - push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/); + $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes + push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/); } return @att; } END_OF_FUNC +#### Method: url_param +# Return a parameter in the QUERY_STRING, regardless of +# whether this was a POST or a GET +#### +'url_param' => <<'END_OF_FUNC', +sub url_param { + my ($self,@p) = self_or_default(@_); + my $name = shift(@p); + return undef unless exists($ENV{QUERY_STRING}); + unless (exists($self->{'.url_param'})) { + $self->{'.url_param'}={}; # empty hash + if ($ENV{QUERY_STRING} =~ /=/) { + my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); + my($param,$value); + foreach (@pairs) { + ($param,$value) = split('=',$_,2); + $param = unescape($param); + $value = unescape($value); + push(@{$self->{'.url_param'}->{$param}},$value); + } + } else { + $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})]; + } + } + return keys %{$self->{'.url_param'}} unless defined($name); + return () unless $self->{'.url_param'}->{$name}; + return wantarray ? @{$self->{'.url_param'}->{$name}} + : $self->{'.url_param'}->{$name}->[0]; +} +END_OF_FUNC + #### Method: dump # Returns a string in which all the known parameter/value # pairs are represented as nested lists, mainly for the purposes @@ -894,6 +1040,15 @@ sub dump { } END_OF_FUNC +#### Method as_string +# +# synonym for "dump" +#### +'as_string' => <<'END_OF_FUNC', +sub as_string { + &dump(@_); +} +END_OF_FUNC #### Method: save # Write values out to a filehandle in such a way that they can @@ -902,13 +1057,12 @@ END_OF_FUNC 'save' => <<'END_OF_FUNC', sub save { my($self,$filehandle) = self_or_default(@_); - my($param); - my($package) = caller; -# Check that this still works! -# $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; $filehandle = to_filehandle($filehandle); + my($param); + local($,) = ''; # set print field separator back to a sane value + local($\) = ''; # set output line separator to a sane value foreach $param ($self->param) { - my($escaped_param) = &escape($param); + my($escaped_param) = escape($param); my($value); foreach $value ($self->param($param)) { print $filehandle "$escaped_param=",escape($value),"\n"; @@ -919,6 +1073,83 @@ sub save { END_OF_FUNC +#### Method: save_parameters +# An alias for save() that is a better name for exportation. +# Only intended to be used with the function (non-OO) interface. +#### +'save_parameters' => <<'END_OF_FUNC', +sub save_parameters { + my $fh = shift; + return save(to_filehandle($fh)); +} +END_OF_FUNC + +#### Method: restore_parameters +# A way to restore CGI parameters from an initializer. +# Only intended to be used with the function (non-OO) interface. +#### +'restore_parameters' => <<'END_OF_FUNC', +sub restore_parameters { + $Q = $CGI::DefaultClass->new(@_); +} +END_OF_FUNC + +#### Method: multipart_init +# Return a Content-Type: style header for server-push +# This has to be NPH, and it is advisable to set $| = 1 +# +# Many thanks to Ed Jordan <ed@fidalgo.net> for this +# contribution +#### +'multipart_init' => <<'END_OF_FUNC', +sub multipart_init { + my($self,@p) = self_or_default(@_); + my($boundary,@other) = $self->rearrange([BOUNDARY],@p); + $boundary = $boundary || '------- =_aaaaaaaaaa0'; + $self->{'separator'} = "\n--$boundary\n"; + $type = SERVER_PUSH($boundary); + return $self->header( + -nph => 1, + -type => $type, + (map { split "=", $_, 2 } @other), + ) . $self->multipart_end; +} +END_OF_FUNC + + +#### Method: multipart_start +# Return a Content-Type: style header for server-push, start of section +# +# Many thanks to Ed Jordan <ed@fidalgo.net> for this +# contribution +#### +'multipart_start' => <<'END_OF_FUNC', +sub multipart_start { + my($self,@p) = self_or_default(@_); + my($type,@other) = $self->rearrange([TYPE],@p); + $type = $type || 'text/html'; + return $self->header( + -type => $type, + (map { split "=", $_, 2 } @other), + ); +} +END_OF_FUNC + + +#### Method: multipart_end +# Return a Content-Type: style header for server-push, end of section +# +# Many thanks to Ed Jordan <ed@fidalgo.net> for this +# contribution +#### +'multipart_end' => <<'END_OF_FUNC', +sub multipart_end { + my($self,@p) = self_or_default(@_); + return $self->{'separator'}; +} +END_OF_FUNC + + #### Method: header # Return a Content-Type: style header # @@ -928,42 +1159,53 @@ sub header { my($self,@p) = self_or_default(@_); my(@header); + return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; + my($type,$status,$cookie,$target,$expires,$nph,@other) = - $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + $nph ||= $NPH; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. foreach (@other) { - next unless my($header,$value) = /([^\s=]+)=(.+)/; - substr($header,1,1000)=~tr/A-Z/a-z/; - ($value)=$value=~/^"(.*)"$/; - $_ = "$header: $value"; + next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/; + ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e; } - $type = $type || 'text/html'; + $type ||= 'text/html' unless defined($type); + + # Maybe future compatibility. Maybe not. + my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; + push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; - push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH; push(@header,"Status: $status") if $status; - push(@header,"Window-target: $target") if $target; + push(@header,"Window-Target: $target") if $target; # push all the cookies -- there may be several if ($cookie) { - my(@cookie) = ref($cookie) ? @{$cookie} : $cookie; + my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; foreach (@cookie) { - push(@header,"Set-cookie: $_"); + my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; + push(@header,"Set-Cookie: $cs") if $cs ne ''; } } # if the user indicates an expiration time, then we need # both an Expires and a Date header (so that the browser is # uses OUR clock) - push(@header,"Expires: " . &date(&expire_calc($expires),'http')) + push(@header,"Expires: " . expires($expires,'http')) if $expires; - push(@header,"Date: " . &date(&expire_calc(0),'http')) if $expires || $cookie; + push(@header,"Date: " . expires(0,'http')) if $expires || $cookie; push(@header,"Pragma: no-cache") if $self->cache(); push(@header,@other); - push(@header,"Content-type: $type"); + push(@header,"Content-Type: $type") if $type ne ''; - my $header = join($CRLF,@header); - return $header . "${CRLF}${CRLF}"; + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + if ($MOD_PERL and not $nph) { + my $r = Apache->request; + $r->send_cgi_header($header); + return ''; + } + return $header; } END_OF_FUNC @@ -991,24 +1233,17 @@ END_OF_FUNC 'redirect' => <<'END_OF_FUNC', sub redirect { my($self,@p) = self_or_default(@_); - my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p); + my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p); $url = $url || $self->self_url; my(@o); - foreach (@other) { push(@o,split("=")); } - if($MOD_PERL or exists $self->{'.req'}) { - my $r = $self->{'.req'} || Apache->request; - $r->header_out(Location => $url); - $r->err_header_out(Location => $url); - $r->status(302); - return; - } - push(@o, - '-Status'=>'302 Found', + foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } + unshift(@o, + '-Status'=>'302 Moved', '-Location'=>$url, - '-URI'=>$url, - '-nph'=>($nph||$NPH)); - push(@o,'-Target'=>$target) if $target; - push(@o,'-Cookie'=>$cookie) if $cookie; + '-nph'=>$nph); + unshift(@o,'-Target'=>$target) if $target; + unshift(@o,'-Cookie'=>$cookie) if $cookie; + unshift(@o,'-Type'=>''); return $self->header(@o); } END_OF_FUNC @@ -1036,20 +1271,21 @@ END_OF_FUNC 'start_html' => <<'END_OF_FUNC', sub start_html { my($self,@p) = &self_or_default(@_); - my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,@other) = - $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE],@p); + my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) = + $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p); # strangely enough, the title needs to be escaped as HTML # while the author needs to be escaped as a URL $title = $self->escapeHTML($title || 'Untitled Document'); - $author = $self->escapeHTML($author); + $author = $self->escape($author); my(@result); - push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">'); + $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|; + push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd; push(@result,"<HTML><HEAD><TITLE>$title</TITLE>"); - push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author; + push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author; if ($base || $xbase || $target) { - my $href = $xbase || $self->url(); + my $href = $xbase || $self->url('-path'=>1); my $t = $target ? qq/ TARGET="$target"/ : ''; push(@result,qq/<BASE HREF="$href"$t>/); } @@ -1060,29 +1296,60 @@ sub start_html { push(@result,ref($head) ? @$head : $head) if $head; - # handle various types of -style parameters - if ($style) { - if (ref($style)) { - my($src,$code,@other) = - $self->rearrange([SRC,CODE], - '-foo'=>'bar', # a trick to allow the '-' to be omitted - ref($style) eq 'ARRAY' ? @$style : %$style); - push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src; - push(@result,style($code)) if $code; - } else { - push(@result,style($style)) - } + # handle the infrequently-used -style and -script parameters + push(@result,$self->_style($style)) if defined $style; + push(@result,$self->_script($script)) if defined $script; + + # handle -noscript parameter + push(@result,<<END) if $noscript; +<NOSCRIPT> +$noscript +</NOSCRIPT> +END + ; + my($other) = @other ? " @other" : ''; + push(@result,"</HEAD><BODY$other>"); + return join("\n",@result); +} +END_OF_FUNC + +### Method: _style +# internal method for generating a CSS style section +#### +'_style' => <<'END_OF_FUNC', +sub _style { + my ($self,$style) = @_; + my (@result); + my $type = 'text/css'; + if (ref($style)) { + my($src,$code,$stype,@other) = + $self->rearrange([SRC,CODE,TYPE], + '-foo'=>'bar', # a trick to allow the '-' to be omitted + ref($style) eq 'ARRAY' ? @$style : %$style); + $type = $stype if $stype; + push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src; + push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code; + } else { + push(@result,style({'type'=>$type},"<!--\n$style\n-->")); } + @result; +} +END_OF_FUNC - # handle -script parameter - if ($script) { + +'_script' => <<'END_OF_FUNC', +sub _script { + my ($self,$script) = @_; + my (@result); + my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); + foreach $script (@scripts) { my($src,$code,$language); if (ref($script)) { # script is a hash ($src,$code,$language) = $self->rearrange([SRC,CODE,LANGUAGE], '-foo'=>'bar', # a trick to allow the '-' to be omitted ref($style) eq 'ARRAY' ? @$script : %$script); - + } else { ($src,$code,$language) = ('',$script,'JavaScript'); } @@ -1095,21 +1362,10 @@ sub start_html { if $code && $language=~/perl/i; push(@result,script({@satts},$code)); } - - # handle -noscript parameter - push(@result,<<END) if $noscript; -<NOSCRIPT> -$noscript -</NOSCRIPT> -END - ; - my($other) = @other ? " @other" : ''; - push(@result,"</HEAD><BODY$other>"); - return join("\n",@result); + @result; } END_OF_FUNC - #### Method: end_html # End an HTML document. # Trivial method for completeness. Just returns "</BODY>" @@ -1174,6 +1430,11 @@ sub start_form { } END_OF_FUNC +'end_multipart_form' => <<'END_OF_FUNC', +sub end_multipart_form { + &endform; +} +END_OF_FUNC #### Method: start_multipart_form # synonym for startform @@ -1213,6 +1474,27 @@ sub end_form { END_OF_FUNC +'_textfield' => <<'END_OF_FUNC', +sub _textfield { + my($self,$tag,@p) = self_or_default(@_); + my($name,$default,$size,$maxlength,$override,@other) = + $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); + + my $current = $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $current = defined($current) ? $self->escapeHTML($current) : ''; + $name = defined($name) ? $self->escapeHTML($name) : ''; + my($s) = defined($size) ? qq/ SIZE=$size/ : ''; + my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; + my($other) = @other ? " @other" : ''; + # this entered at cristy's request to fix problems with file upload fields + # and WebTV -- not sure it won't break stuff + my($value) = $current ne '' ? qq(VALUE="$current") : ''; + return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/; +} +END_OF_FUNC + #### Method: textfield # Parameters: # $name -> Name of the text field @@ -1226,18 +1508,7 @@ END_OF_FUNC 'textfield' => <<'END_OF_FUNC', sub textfield { my($self,@p) = self_or_default(@_); - my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); - - my $current = $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $current = defined($current) ? $self->escapeHTML($current) : ''; - $name = defined($name) ? $self->escapeHTML($name) : ''; - my($s) = defined($size) ? qq/ SIZE=$size/ : ''; - my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - my($other) = @other ? " @other" : ''; - return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/; + $self->_textfield('text',@p); } END_OF_FUNC @@ -1253,19 +1524,7 @@ END_OF_FUNC 'filefield' => <<'END_OF_FUNC', sub filefield { my($self,@p) = self_or_default(@_); - - my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); - - $current = $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $name = defined($name) ? $self->escapeHTML($name) : ''; - my($s) = defined($size) ? qq/ SIZE=$size/ : ''; - my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - $current = defined($current) ? $self->escapeHTML($current) : ''; - $other = ' ' . join(" ",@other); - return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/; + $self->_textfield('file',@p); } END_OF_FUNC @@ -1284,23 +1543,10 @@ END_OF_FUNC 'password_field' => <<'END_OF_FUNC', sub password_field { my ($self,@p) = self_or_default(@_); - - my($name,$default,$size,$maxlength,$override,@other) = - $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); - - my($current) = $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $name = defined($name) ? $self->escapeHTML($name) : ''; - $current = defined($current) ? $self->escapeHTML($current) : ''; - my($s) = defined($size) ? qq/ SIZE=$size/ : ''; - my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; - my($other) = @other ? " @other" : ''; - return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/; + $self->_textfield('password',@p); } END_OF_FUNC - #### Method: textarea # Parameters: # $name -> Name of the text field @@ -1383,8 +1629,8 @@ sub submit { $value=$self->escapeHTML($value); my($name) = ' NAME=".submit"'; - $name = qq/ NAME="$label"/ if $label; - $value = $value || $label; + $name = qq/ NAME="$label"/ if defined($label); + $value = defined($value) ? $value : $label; my($val) = ''; $val = qq/ VALUE="$value"/ if defined($value); my($other) = @other ? " @other" : ''; @@ -1438,6 +1684,16 @@ sub defaults { END_OF_FUNC +#### Method: comment +# Create an HTML <!-- comment --> +# Parameters: a string +'comment' => <<'END_OF_FUNC', +sub comment { + my($self,@p) = self_or_CGI(@_); + return "<!-- @p -->"; +} +END_OF_FUNC + #### Method: checkbox # Create a checkbox that is not logically linked to any others. # The field value is "on" when the button is checked. @@ -1457,12 +1713,13 @@ sub checkbox { my($name,$checked,$value,$label,$override,@other) = $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); - if (!$override && defined($self->param($name))) { - $value = $self->param($name) unless defined $value; - $checked = $self->param($name) eq $value ? ' CHECKED' : ''; + $value = defined $value ? $value : 'on'; + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined $self->param($name))) { + $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : ''; } else { $checked = $checked ? ' CHECKED' : ''; - $value = defined $value ? $value : 'on'; } my($the_label) = defined $label ? $label : $name; $name = $self->escapeHTML($name); @@ -1517,33 +1774,37 @@ sub checkbox_group { $name=$self->escapeHTML($name); # Create the elements - my(@elements); - my(@values) = $values ? @$values : $self->param($name); + my(@elements,@values); + + @values = $self->_set_values_and_labels($values,\$labels,$name); + my($other) = @other ? " @other" : ''; foreach (@values) { $checked = $checked{$_} ? ' CHECKED' : ''; $label = ''; unless (defined($nolabels) && $nolabels) { $label = $_; - $label = $labels->{$_} if defined($labels) && $labels->{$_}; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label = $self->escapeHTML($label); } $_ = $self->escapeHTML($_); - push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/); + push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/); } $self->register_parameter($name); - return wantarray ? @elements : join('',@elements) unless $columns; + return wantarray ? @elements : join(' ',@elements) + unless defined($columns) || defined($rows); return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); } END_OF_FUNC - # Escape HTML -- used internally 'escapeHTML' => <<'END_OF_FUNC', sub escapeHTML { my($self,$toencode) = @_; + $toencode = $self unless ref($self); return undef unless defined($toencode); - return $toencode if $self->{'dontescape'}; + return $toencode if ref($self) && $self->{'dontescape'}; + $toencode=~s/&/&/g; $toencode=~s/\"/"/g; $toencode=~s/>/>/g; @@ -1552,6 +1813,25 @@ sub escapeHTML { } END_OF_FUNC +# unescape HTML -- used internally +'unescapeHTML' => <<'END_OF_FUNC', +sub unescapeHTML { + my $string = ref($_[0]) ? $_[1] : $_[0]; + return undef unless defined($string); + # thanks to Randal Schwartz for the correct solution to this one + $string=~ s[&(.*?);]{ + local $_ = $1; + /^amp$/i ? "&" : + /^quot$/i ? '"' : + /^gt$/i ? ">" : + /^lt$/i ? "<" : + /^#(\d+)$/ ? chr($1) : + /^#x([0-9a-f]+)$/i ? chr(hex($1)) : + $_ + }gex; + return $string; +} +END_OF_FUNC # Internal procedure - don't use '_tableize' => <<'END_OF_FUNC', @@ -1559,20 +1839,27 @@ sub _tableize { my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; my($result); - $rows = int(0.99 + @elements/$columns) unless $rows; + if (defined($columns)) { + $rows = int(0.99 + @elements/$columns) unless defined($rows); + } + if (defined($rows)) { + $columns = int(0.99 + @elements/$rows) unless defined($columns); + } + # rearrange into a pretty table $result = "<TABLE>"; my($row,$column); - unshift(@$colheaders,'') if @$colheaders && @$rowheaders; - $result .= "<TR>" if @{$colheaders}; + unshift(@$colheaders,'') if defined(@$colheaders) && defined(@$rowheaders); + $result .= "<TR>" if defined(@{$colheaders}); foreach (@{$colheaders}) { $result .= "<TH>$_</TH>"; } for ($row=0;$row<$rows;$row++) { $result .= "<TR>"; - $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders; + $result .= "<TH>$rowheaders->[$row]</TH>" if defined(@$rowheaders); for ($column=0;$column<$columns;$column++) { - $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"; + $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>" + if defined($elements[$column*$rows + $row]); } $result .= "</TR>"; } @@ -1616,12 +1903,13 @@ sub radio_group { } else { $checked = $default; } + my(@elements,@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + # If no check array is specified, check the first by default - $checked = $values->[0] unless $checked; + $checked = $values[0] unless defined($checked) && $checked ne ''; $name=$self->escapeHTML($name); - my(@elements); - my(@values) = $values ? @$values : $self->param($name); my($other) = @other ? " @other" : ''; foreach (@values) { my($checkit) = $checked eq $_ ? ' CHECKED' : ''; @@ -1629,14 +1917,15 @@ sub radio_group { my($label)=''; unless (defined($nolabels) && $nolabels) { $label = $_; - $label = $labels->{$_} if defined($labels) && $labels->{$_}; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label = $self->escapeHTML($label); } $_=$self->escapeHTML($_); - push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/); + push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/); } $self->register_parameter($name); - return wantarray ? @elements : join('',@elements) unless $columns; + return wantarray ? @elements : join(' ',@elements) + unless defined($columns) || defined($rows); return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); } END_OF_FUNC @@ -1672,12 +1961,14 @@ sub popup_menu { $name=$self->escapeHTML($name); my($other) = @other ? " @other" : ''; - my(@values) = $values ? @$values : $self->param($name); + my(@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + $result = qq/<SELECT NAME="$name"$other>\n/; foreach (@values) { my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : ''; my($label) = $_; - $label = $labels->{$_} if defined($labels) && $labels->{$_}; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); my($value) = $self->escapeHTML($_); $label=$self->escapeHTML($label); $result .= "<OPTION $selectit VALUE=\"$value\">$label\n"; @@ -1716,8 +2007,9 @@ sub scrolling_list { = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); - my($result); - my(@values) = $values ? @$values : $self->param($name); + my($result,@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + $size = $size || scalar(@values); my(%selected) = $self->previous_or_default($name,$defaults,$override); @@ -1730,7 +2022,7 @@ sub scrolling_list { foreach (@values) { my($selectit) = $selected{$_} ? 'SELECTED' : ''; my($label) = $_; - $label = $labels->{$_} if defined($labels) && $labels->{$_}; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label=$self->escapeHTML($label); my($value)=$self->escapeHTML($_); $result .= "<OPTION $selectit VALUE=\"$value\">$label\n"; @@ -1762,7 +2054,7 @@ sub hidden { $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); my $do_override = 0; - if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) { + if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) { @value = ref($default) ? @{$default} : $default; $do_override = $override; } else { @@ -1816,16 +2108,8 @@ END_OF_FUNC #### 'self_url' => <<'END_OF_FUNC', sub self_url { - my($self) = self_or_default(@_); - my($query_string) = $self->query_string; - my $protocol = $self->protocol(); - my $name = "$protocol://" . $self->server_name; - $name .= ":" . $self->server_port - unless $self->server_port == 80; - $name .= $self->script_name; - $name .= $self->path_info if $self->path_info; - return $name unless $query_string; - return "$name?$query_string"; + my($self,@p) = self_or_default(@_); + return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); } END_OF_FUNC @@ -1845,13 +2129,34 @@ END_OF_FUNC #### 'url' => <<'END_OF_FUNC', sub url { - my($self) = self_or_default(@_); - my $protocol = $self->protocol(); - my $name = "$protocol://" . $self->server_name; - $name .= ":" . $self->server_port - unless $self->server_port == 80; - $name .= $self->script_name; - return $name; + my($self,@p) = self_or_default(@_); + my ($relative,$absolute,$full,$path_info,$query) = + $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p); + my $url; + $full++ if !($relative || $absolute); + + if ($full) { + my $protocol = $self->protocol(); + $url = "$protocol://"; + my $vh = http('host'); + if ($vh) { + $url .= $vh; + } else { + $url .= server_name(); + my $port = $self->server_port; + $url .= ":" . $port + unless (lc($protocol) eq 'http' && $port == 80) + || (lc($protocol) eq 'https' && $port == 443); + } + $url .= $self->script_name; + } elsif ($relative) { + ($url) = $self->script_name =~ m!([^/]+)$!; + } elsif ($absolute) { + $url = $self->script_name; + } + $url .= $self->path_info if $path_info and $self->path_info; + $url .= "?" . $self->query_string if $query and $self->query_string; + return $url; } END_OF_FUNC @@ -1869,66 +2174,45 @@ END_OF_FUNC # -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) #### 'cookie' => <<'END_OF_FUNC', -# temporary, for debugging. sub cookie { my($self,@p) = self_or_default(@_); my($name,$value,$path,$domain,$secure,$expires) = $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); + require CGI::Cookie; # if no value is supplied, then we retrieve the # value of the cookie, if any. For efficiency, we cache the parsed - # cookie in our state variables. - unless (defined($value)) { - unless ($self->{'.cookies'}) { - my(@pairs) = split("; ",$self->raw_cookie); - foreach (@pairs) { - my($key,$value) = split("="); - my(@values) = map unescape($_),split('&',$value); - $self->{'.cookies'}->{unescape($key)} = [@values]; - } - } + # cookies in our state variables. + unless ( defined($value) ) { + $self->{'.cookies'} = CGI::Cookie->fetch + unless $self->{'.cookies'}; # If no name is supplied, then retrieve the names of all our cookies. return () unless $self->{'.cookies'}; - return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0] - if defined($name) && $name ne ''; - return keys %{$self->{'.cookies'}}; + return keys %{$self->{'.cookies'}} unless $name; + return () unless $self->{'.cookies'}->{$name}; + return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; } - my(@values); - - # Pull out our parameters. - if (ref($value)) { - if (ref($value) eq 'ARRAY') { - @values = @$value; - } elsif (ref($value) eq 'HASH') { - @values = %$value; - } - } else { - @values = ($value); - } - @values = map escape($_),@values; - # I.E. requires the path to be present. - ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path; + # If we get here, we're creating a new cookie + return undef unless $name; # this is an error - my(@constant_values); - push(@constant_values,"domain=$domain") if $domain; - push(@constant_values,"path=$path") if $path; - push(@constant_values,"expires=".&date(&expire_calc($expires),'cookie')) - if $expires; - push(@constant_values,'secure') if $secure; + my @param; + push(@param,'-name'=>$name); + push(@param,'-value'=>$value); + push(@param,'-domain'=>$domain) if $domain; + push(@param,'-path'=>$path) if $path; + push(@param,'-expires'=>$expires) if $expires; + push(@param,'-secure'=>$secure) if $secure; - my($key) = &escape($name); - my($cookie) = join("=",$key,join("&",@values)); - return join("; ",$cookie,@constant_values); + return new CGI::Cookie(@param); } END_OF_FUNC - # This internal routine creates an expires time exactly some number of # hours from the current time. It incorporates modifications from -# Fisher Mark. +# Mark Fisher. 'expire_calc' => <<'END_OF_FUNC', sub expire_calc { my($time) = @_; @@ -1950,9 +2234,9 @@ sub expire_calc { # If you don't supply one of these forms, we assume you are # specifying the date yourself my($offset); - if (!$time || ($time eq 'now')) { + if (!$time || (lc($time) eq 'now')) { $offset = 0; - } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) { + } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { $offset = ($mult{$2} || 1)*$1; } else { return $time; @@ -1964,16 +2248,17 @@ END_OF_FUNC # This internal routine creates date strings suitable for use in # cookies and HTTP headers. (They differ, unfortunately.) # Thanks to Fisher Mark for this. -'date' => <<'END_OF_FUNC', -sub date { +'expires' => <<'END_OF_FUNC', +sub expires { my($time,$format) = @_; + $format ||= 'http'; + my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; # pass through preformatted dates for the sake of expire_calc() - if ("$time" =~ m/^[^0-9]/o) { - return $time; - } + $time = expire_calc($time); + return $time unless $time =~ /^\d+$/; # make HTTP/cookie date string from GMT'ed time # (cookies use '-' as date separator, HTTP uses ' ') @@ -1986,6 +2271,29 @@ sub date { } END_OF_FUNC +'parse_keywordlist' => <<'END_OF_FUNC', +sub parse_keywordlist { + my($self,$tosplit) = @_; + $tosplit = unescape($tosplit); # unescape the keywords + $tosplit=~tr/+/ /; # pluses to spaces + my(@keywords) = split(/\s+/,$tosplit); + return @keywords; +} +END_OF_FUNC + +'param_fetch' => <<'END_OF_FUNC', +sub param_fetch { + my($self,@p) = self_or_default(@_); + my($name) = $self->rearrange([NAME],@p); + unless (exists($self->{$name})) { + $self->add_parameter($name); + $self->{$name} = []; + } + + return $self->{$name}; +} +END_OF_FUNC + ############################################### # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT ############################################### @@ -1996,7 +2304,19 @@ END_OF_FUNC #### 'path_info' => <<'END_OF_FUNC', sub path_info { - return $ENV{'PATH_INFO'}; + my ($self,$info) = self_or_default(@_); + if (defined($info)) { + $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; + $self->{'.path_info'} = $info; + } elsif (! defined($self->{'.path_info'}) ) { + $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ? + $ENV{'PATH_INFO'} : ''; + + # hack to fix broken path info in IIS + $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS; + + } + return $self->{'.path_info'}; } END_OF_FUNC @@ -2030,13 +2350,13 @@ sub query_string { my($self) = self_or_default(@_); my($param,$value,@pairs); foreach $param ($self->param) { - my($eparam) = &escape($param); + my($eparam) = escape($param); foreach $value ($self->param($param)) { - $value = &escape($value); + $value = escape($value); push(@pairs,"$eparam=$value"); } } - return join("&",@pairs); + return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); } END_OF_FUNC @@ -2052,8 +2372,8 @@ END_OF_FUNC # declares a quantitative score for it. # This handles MIME type globs correctly. #### -'accept' => <<'END_OF_FUNC', -sub accept { +'Accept' => <<'END_OF_FUNC', +sub Accept { my($self,$search) = self_or_CGI(@_); my(%prefs,$type,$pref,$pat); @@ -2102,14 +2422,28 @@ sub user_agent { END_OF_FUNC -#### Method: cookie -# Returns the magic cookie for the session. -# To set the magic cookie for new transations, -# try print $q->header('-Set-cookie'=>'my cookie') +#### Method: raw_cookie +# Returns the magic cookies for the session. +# The cookies are not parsed or altered in any way, i.e. +# cookies are returned exactly as given in the HTTP +# headers. If a cookie name is given, only that cookie's +# value is returned, otherwise the entire raw cookie +# is returned. #### 'raw_cookie' => <<'END_OF_FUNC', sub raw_cookie { - my($self) = self_or_CGI(@_); + my($self,$key) = self_or_CGI(@_); + + require CGI::Cookie; + + if (defined($key)) { + $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch + unless $self->{'.raw_cookies'}; + + return () unless $self->{'.raw_cookies'}; + return () unless $self->{'.raw_cookies'}->{$key}; + return $self->{'.raw_cookies'}->{$key}; + } return $self->http('cookie') || $ENV{'COOKIE'} || ''; } END_OF_FUNC @@ -2120,7 +2454,9 @@ END_OF_FUNC ###### 'virtual_host' => <<'END_OF_FUNC', sub virtual_host { - return http('host') || server_name(); + my $vh = http('host') || server_name(); + $vh =~ s/:\d+$//; # get rid of port number + return $vh; } END_OF_FUNC @@ -2156,7 +2492,7 @@ END_OF_FUNC #### 'script_name' => <<'END_OF_FUNC', sub script_name { - return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'}; + return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'}); # These are for debugging return "/$0" unless $0=~/^\//; return $0; @@ -2254,7 +2590,7 @@ END_OF_FUNC sub protocol { local($^W)=0; my $self = shift; - return 'https' if $self->https() eq 'ON'; + return 'https' if uc($self->https()) eq 'ON'; return 'https' if $self->server_port == 443; my $prot = $self->server_protocol; my($protocol,$version) = split('/',$prot); @@ -2322,11 +2658,22 @@ END_OF_FUNC 'private_tempfiles' => <<'END_OF_FUNC', sub private_tempfiles { my ($self,$param) = self_or_CGI(@_); - $CGI::$PRIVATE_TEMPFILES = $param if defined($param); + $CGI::PRIVATE_TEMPFILES = $param if defined($param); return $CGI::PRIVATE_TEMPFILES; } END_OF_FUNC +#### Method: default_dtd +# Set or return the default_dtd global +#### +'default_dtd' => <<'END_OF_FUNC', +sub default_dtd { + my ($self,$param) = self_or_CGI(@_); + $CGI::DEFAULT_DTD = $param if defined($param); + return $CGI::DEFAULT_DTD; +} +END_OF_FUNC + # -------------- really private subroutines ----------------- 'previous_or_default' => <<'END_OF_FUNC', sub previous_or_default { @@ -2357,30 +2704,30 @@ END_OF_FUNC 'get_fields' => <<'END_OF_FUNC', sub get_fields { my($self) = @_; - return $self->hidden('-name'=>'.cgifields', - '-values'=>[keys %{$self->{'.parametersToAdd'}}], - '-override'=>1); + return $self->CGI::hidden('-name'=>'.cgifields', + '-values'=>[keys %{$self->{'.parametersToAdd'}}], + '-override'=>1); } END_OF_FUNC 'read_from_cmdline' => <<'END_OF_FUNC', sub read_from_cmdline { - require "shellwords.pl"; my($input,@words); my($query_string); if (@ARGV) { - $input = join(" ",@ARGV); + @words = @ARGV; } else { + require "shellwords.pl"; print STDERR "(offline mode: enter name=value pairs on standard input)\n"; - chomp(@lines = <>); # remove newlines + chomp(@lines = <STDIN>); # remove newlines $input = join(" ",@lines); + @words = &shellwords($input); + } + foreach (@words) { + s/\\=/%3D/g; + s/\\&/%26/g; } - # minimal handling of escape characters - $input=~s/\\=/%3D/g; - $input=~s/\\&/%26/g; - - @words = &shellwords($input); if ("@words"=~/=/) { $query_string = join('&',@words); } else { @@ -2400,22 +2747,19 @@ END_OF_FUNC ##### 'read_multipart' => <<'END_OF_FUNC', sub read_multipart { - my($self,$boundary,$length) = @_; - my($buffer) = $self->new_MultipartBuffer($boundary,$length); + my($self,$boundary,$length,$filehandle) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle); return unless $buffer; my(%header,$body); + my $filenumber = 0; while (!$buffer->eof) { %header = $buffer->readHeader; die "Malformed multipart POST\n" unless %header; - # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition" - # Sheesh. - my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition'; - my($param)= $header{$key}=~/ name="([^\"]*)"/; + my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/; - # possible bug: our regular expression expects the filename= part to fall - # at the end of the line. Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{$key}=~/ filename="(.*)"$/; + # Bug: Netscape doesn't escape quotation marks in file names!!! + my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/; # add this parameter to our list $self->add_parameter($param); @@ -2428,60 +2772,44 @@ sub read_multipart { next; } - # If we get here, then we are dealing with a potentially large - # uploaded form. Save the data to a temporary file, then open - # the file for reading. - my($tmpfile) = new TempFile; - my $tmp = $tmpfile->as_string; - - # Now create a new filehandle in the caller's namespace. - # The name of this filehandle just happens to be identical - # to the original filename (NOT the name of the temporary - # file, which is hidden!) - my($filehandle); - if ($filename=~/^[a-zA-Z_]/) { - my($frame,$cp)=(1); - do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()"); - $filehandle = "$cp\:\:$filename"; - } else { - $filehandle = "\:\:$filename"; - } + my ($tmpfile,$tmp,$filehandle); + UPLOADS: { + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + while (defined($data = $buffer->read)) { } + last UPLOADS; + } - # potential security problem -- this type of line can clobber - # tempfile, and can be abused by malicious users. - # open ($filehandle,">$tmp") || die "CGI open of $tmpfile: $!\n"; + $tmpfile = new TempFile; + $tmp = $tmpfile->as_string; + + $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES); - # This technique causes open to fail if file already exists. - unless (defined(&O_RDWR)) { - require Fcntl; - import Fcntl qw/O_RDWR O_CREAT O_EXCL/; - } - sysopen($filehandle,$tmp,&O_RDWR|&O_CREAT|&O_EXCL) || die "CGI open of $tmp: $!\n"; - unlink($tmp) if $PRIVATE_TEMPFILES; - - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; - chmod 0600,$tmp; # only the owner can tamper with it - my $data; - while (defined($data = $buffer->read)) { - print $filehandle $data; - } + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + chmod 0600,$tmp; # only the owner can tamper with it - seek($filehandle,0,0); #rewind file - push(@{$self->{$param}},$filename); - - # Under Unix, it would be safe to let the temporary file - # be deleted immediately. However, I fear that other operating - # systems are not so forgiving. Therefore we save a reference - # to the temporary file in the CGI object so that the file - # isn't unlinked until the CGI object itself goes out of - # scope. This is a bit hacky, but it has the interesting side - # effect that one can access the name of the tmpfile by - # asking for $query->{$query->param('foo')}, where 'foo' - # is the name of the file upload field. - $self->{'.tmpfiles'}->{$filename}= { - name=>($PRIVATE_TEMPFILES ? '' : $tmpfile), - info=>{%header} - } + my ($data); + local($\) = ''; + while (defined($data = $buffer->read)) { + print $filehandle $data; + } + + # back up to beginning of file + seek($filehandle,0,0); + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + $self->{'.tmpfiles'}->{$filename}= { + name => $tmpfile, + info => {%header}, + }; + push(@{$self->{$param}},$filehandle); + } } } END_OF_FUNC @@ -2495,30 +2823,123 @@ sub tmpFileName { } END_OF_FUNC -'uploadInfo' => <<'END_OF_FUNC' +'uploadInfo' => <<'END_OF_FUNC', sub uploadInfo { my($self,$filename) = self_or_default(@_); return $self->{'.tmpfiles'}->{$filename}->{info}; } END_OF_FUNC +# internal routine, don't use +'_set_values_and_labels' => <<'END_OF_FUNC', +sub _set_values_and_labels { + my $self = shift; + my ($v,$l,$n) = @_; + $$l = $v if ref($v) eq 'HASH' && !ref($$l); + return $self->param($n) if !defined($v); + return $v if !ref($v); + return ref($v) eq 'HASH' ? keys %$v : @$v; +} +END_OF_FUNC + +'_compile_all' => <<'END_OF_FUNC', +sub _compile_all { + foreach (@_) { + next if defined(&$_); + $AUTOLOAD = "CGI::$_"; + _compile(); + } +} +END_OF_FUNC + ); END_OF_AUTOLOAD ; -# Globals and stubs for other packages that we use +######################################################### +# Globals and stubs for other packages that we use. +######################################################### + +################### Fh -- lightweight filehandle ############### +package Fh; +use overload + '""' => \&asString, + 'cmp' => \&compare, + 'fallback'=>1; + +$FH='fh00000'; + +*Fh::AUTOLOAD = \&CGI::AUTOLOAD; + +$AUTOLOADED_ROUTINES = ''; # prevent -w error +$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; +%SUBS = ( +'asString' => <<'END_OF_FUNC', +sub asString { + my $self = shift; + # get rid of package name + (my $i = $$self) =~ s/^\*(\w+::)+//; + $i =~ s/\\(.)/$1/g; + return $i; +# BEGIN DEAD CODE +# This was an extremely clever patch that allowed "use strict refs". +# Unfortunately it relied on another bug that caused leaky file descriptors. +# The underlying bug has been fixed, so this no longer works. However +# "strict refs" still works for some reason. +# my $self = shift; +# return ${*{$self}{SCALAR}}; +# END DEAD CODE +} +END_OF_FUNC + +'compare' => <<'END_OF_FUNC', +sub compare { + my $self = shift; + my $value = shift; + return "$self" cmp $value; +} +END_OF_FUNC + +'new' => <<'END_OF_FUNC', +sub new { + my($pack,$name,$file,$delete) = @_; + require Fcntl unless defined &Fcntl::O_RDWR; + ++$FH; + my $ref = \*{'Fh::' . quotemeta($name)}; + sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL()) + || die "CGI open of $file: $!\n"; + unlink($file) if $delete; + delete $Fh::{$FH}; + return bless $ref,$pack; +} +END_OF_FUNC + +'DESTROY' => <<'END_OF_FUNC', +sub DESTROY { + my $self = shift; + close $self; +} +END_OF_FUNC + +); +END_OF_AUTOLOAD + +######################## MultipartBuffer #################### package MultipartBuffer; # how many bytes to read at a time. We use -# a 5K buffer by default. -$FILLUNIT = 1024 * 5; -$TIMEOUT = 10*60; # 10 minute timeout -$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers +# a 4K buffer by default. +$INITIAL_FILLUNIT = 1024 * 4; +$TIMEOUT = 240*60; # 4 hour timeout for big files +$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers $CRLF=$CGI::CRLF; #reuse the autoload function *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD; +# avoid autoloader warnings +sub DESTROY {} + ############################################################################### ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### ############################################################################### @@ -2529,6 +2950,7 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'new' => <<'END_OF_FUNC', sub new { my($package,$interface,$boundary,$length,$filehandle) = @_; + $FILLUNIT = $INITIAL_FILLUNIT; my $IN; if ($filehandle) { my($package) = caller; @@ -2551,10 +2973,11 @@ sub new { # Under the MIME spec, the boundary consists of the # characters "--" PLUS the Boundary string - $boundary = "--$boundary"; - # Read the topmost (boundary) line plus the CRLF - my($null) = ''; - $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0); + + # BUG: IE 3.01 on the Macintosh uses just the boundary -- not + # the two extra hyphens. We do a special case here on the user-agent!!!! + $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; ?Mac'); + } else { # otherwise we find it ourselves my($old); ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line @@ -2574,7 +2997,13 @@ sub new { $FILLUNIT = length($boundary) if length($boundary) > $FILLUNIT; - return bless $self,ref $package || $package; + my $retval = bless $self,ref $package || $package; + + # Read the preamble and the topmost (boundary) line plus the CRLF. + while ($self->read(0)) { } + die "Malformed multipart POST\n" if $self->eof; + + return $retval; } END_OF_FUNC @@ -2584,20 +3013,36 @@ sub readHeader { my($end); my($ok) = 0; my($bad) = 0; + + if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert! + local($CRLF) = "\015\012"; + } + do { $self->fillBuffer($FILLUNIT); $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; $ok++ if $self->{BUFFER} eq ''; $bad++ if !$ok && $self->{LENGTH} <= 0; - $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; + # this was a bad idea + # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; } until $ok || $bad; return () if $bad; my($header) = substr($self->{BUFFER},0,$end+2); substr($self->{BUFFER},0,$end+4) = ''; my %return; - while ($header=~/^([\w-]+): (.*)$CRLF/mog) { - $return{$1}=$2; + + + # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 + # (Folding Long Header Fields), 3.4.3 (Comments) + # and 3.4.5 (Quoted-Strings). + + my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; + $header=~s/$CRLF\s+/ /og; # merge continuation lines + while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { + my ($field_name,$field_value) = ($1,$2); # avoid taintedness + $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize + $return{$field_name}=$field_value; } return %return; } @@ -2688,6 +3133,7 @@ sub fillBuffer { \$self->{BUFFER}, $bytesToRead, $bufferLength); + $self->{BUFFER} = '' unless defined $self->{BUFFER}; # An apparent bug in the Apache server causes the read() # to return zero bytes repeatedly without blocking if the @@ -2725,15 +3171,20 @@ END_OF_AUTOLOAD package TempFile; $SL = $CGI::SL; +$MAC = $CGI::OS eq 'MACINTOSH'; +my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; unless ($TMPDIRECTORY) { - @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items"); + @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", + "C:${SL}temp","${SL}tmp","${SL}temp","${vol}${SL}Temporary Items", + "${SL}WWW_ROOT"); foreach (@TEMP) { do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; } } -$TMPDIRECTORY = "." unless $TMPDIRECTORY; -$SEQUENCE="CGItemp${$}0000"; +$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; +$SEQUENCE=0; +$MAXTRIES = 5000; # cute feature, but overload implementation broke it # %OVERLOAD = ('""'=>'as_string'); @@ -2749,8 +3200,12 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'new' => <<'END_OF_FUNC', sub new { my($package) = @_; - $SEQUENCE++; - my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}"; + my $directory; + my $i; + for ($i = 0; $i < $MAXTRIES; $i++) { + $directory = sprintf("${TMPDIRECTORY}${SL}CGItemp%d%04d",${$},++$SEQUENCE); + last if ! -f $directory; + } return bless \$directory; } END_OF_FUNC @@ -2784,13 +3239,13 @@ if ($^W) { $MultipartBuffer::SPIN_LOOP_MAX; $MultipartBuffer::CRLF; $MultipartBuffer::TIMEOUT; - $MultipartBuffer::FILLUNIT; + $MultipartBuffer::INITIAL_FILLUNIT; $TempFile::SEQUENCE; EOF ; } -$revision; +1; __END__ @@ -2800,72 +3255,218 @@ CGI - Simple Common Gateway Interface Class =head1 SYNOPSIS - use CGI; - # the rest is too complicated for a synopsis; keep reading + # CGI script that creates a fill-out form + # and echoes back its values. + + use CGI qw/:standard/; + print header, + start_html('A Simple Example'), + h1('A Simple Example'), + start_form, + "What's your name? ",textfield('name'),p, + "What's the combination?", p, + checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','minie']), p, + "What's your favorite color? ", + popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']),p, + submit, + end_form, + hr; + + if (param()) { + print "Your name is",em(param('name')),p, + "The keywords are: ",em(join(", ",param('words'))),p, + "Your favorite color is ",em(param('color')), + hr; + } =head1 ABSTRACT -This perl library uses perl5 objects to make it easy to create -Web fill-out forms and parse their contents. This package -defines CGI objects, entities that contain the values of the -current query string and other state variables. -Using a CGI object's methods, you can examine keywords and parameters -passed to your script, and create forms whose initial values -are taken from the current query (thereby preserving state -information). +This perl library uses perl5 objects to make it easy to create Web +fill-out forms and parse their contents. This package defines CGI +objects, entities that contain the values of the current query string +and other state variables. Using a CGI object's methods, you can +examine keywords and parameters passed to your script, and create +forms whose initial values are taken from the current query (thereby +preserving state information). The module provides shortcut functions +that produce boilerplate HTML, reducing typing and coding errors. It +also provides functionality for some of the more advanced features of +CGI scripting, including support for file uploads, cookies, cascading +style sheets, server push, and frames. + +CGI.pm also provides a simple function-oriented programming style for +those who don't need its object-oriented features. The current version of CGI.pm is available at http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ -=head1 INSTALLATION +=head1 DESCRIPTION -CGI is a part of the base Perl installation. However, you may need -to install a newer version someday. Therefore: +=head2 PROGRAMMING STYLE + +There are two styles of programming with CGI.pm, an object-oriented +style and a function-oriented style. In the object-oriented style you +create one or more CGI objects and then use object methods to create +the various elements of the page. Each CGI object starts out with the +list of named parameters that were passed to your CGI script by the +server. You can modify the objects, save them to a file or database +and recreate them. Because each object corresponds to the "state" of +the CGI script, and because each object's parameter list is +independent of the others, this allows you to save the state of the +script and restore it later. + +For example, using the object oriented style, here is how you create +a simple "Hello World" HTML page: + + #!/usr/local/bin/perl + use CGI; # load CGI routines + $q = new CGI; # create new CGI object + print $q->header, # create the HTTP header + $q->start_html('hello world'), # start the HTML + $q->h1('hello world'), # level 1 header + $q->end_html; # end the HTML + +In the function-oriented style, there is one default CGI object that +you rarely deal with directly. Instead you just call functions to +retrieve CGI parameters, create HTML tags, manage cookies, and so +on. This provides you with a cleaner programming interface, but +limits you to using one CGI object at a time. The following example +prints the same page, but uses the function-oriented interface. +The main differences are that we now need to import a set of functions +into our name space (usually the "standard" functions), and we don't +need to create the CGI object. + + #!/usr/local/bin/perl + use CGI qw/:standard/; # load standard CGI routines + print header, # create the HTTP header + start_html('hello world'), # start the HTML + h1('hello world'), # level 1 header + end_html; # end the HTML + +The examples in this document mainly use the object-oriented style. +See HOW TO IMPORT FUNCTIONS for important information on +function-oriented programming in CGI.pm + +=head2 CALLING CGI.PM ROUTINES + +Most CGI.pm routines accept several arguments, sometimes as many as 20 +optional ones! To simplify this interface, all routines use a named +argument calling style that looks like this: + + print $q->header(-type=>'image/gif',-expires=>'+3d'); + +Each argument name is preceded by a dash. Neither case nor order +matters in the argument list. -type, -Type, and -TYPE are all +acceptable. In fact, only the first argument needs to begin with a +dash. If a dash is present in the first argument, CGI.pm assumes +dashes for the subsequent ones. + +You don't have to use the hyphen at all if you don't want to. After +creating a CGI object, call the B<use_named_parameters()> method with +a nonzero value. This will tell CGI.pm that you intend to use named +parameters exclusively: -To install this package, just change to the directory in which this -file is found and type the following: + $query = new CGI; + $query->use_named_parameters(1); + $field = $query->radio_group('name'=>'OS', + 'values'=>['Unix','Windows','Macintosh'], + 'default'=>'Unix'); - perl Makefile.PL - make - make install +Several routines are commonly called with just one argument. In the +case of these routines you can provide the single argument without an +argument name. header() happens to be one of these routines. In this +case, the single argument is the document type. + + print $q->header('text/html'); + +Other such routines are documented below. + +Sometimes named arguments expect a scalar, sometimes a reference to an +array, and sometimes a reference to a hash. Often, you can pass any +type of argument and the routine will do whatever is most appropriate. +For example, the param() routine is used to set a CGI parameter to a +single or a multi-valued value. The two cases are shown below: + + $q->param(-name=>'veggie',-value=>'tomato'); + $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']); + +A large number of routines in CGI.pm actually aren't specifically +defined in the module, but are generated automatically as needed. +These are the "HTML shortcuts," routines that generate HTML tags for +use in dynamically-generated pages. HTML tags have both attributes +(the attribute="value" pairs within the tag itself) and contents (the +part between the opening and closing pairs.) To distinguish between +attributes and contents, CGI.pm uses the convention of passing HTML +attributes as a hash reference as the first argument, and the +contents, if any, as any subsequent arguments. It works out like +this: + + Code Generated HTML + ---- -------------- + h1() <H1> + h1('some','contents'); <H1>some contents</H1> + h1({-align=>left}); <H1 ALIGN="LEFT"> + h1({-align=>left},'contents'); <H1 ALIGN="LEFT">contents</H1> + +HTML tags are described in more detail later. + +Many newcomers to CGI.pm are puzzled by the difference between the +calling conventions for the HTML shortcuts, which require curly braces +around the HTML tag attributes, and the calling conventions for other +routines, which manage to generate attributes without the curly +brackets. Don't be confused. As a convenience the curly braces are +optional in all but the HTML shortcuts. If you like, you can use +curly braces when calling any routine that takes named arguments. For +example: + + print $q->header( {-type=>'image/gif',-expires=>'+3d'} ); + +If you use the B<-w> switch, you will be warned that some CGI.pm argument +names conflict with built-in Perl functions. The most frequent of +these is the -values argument, used to create multi-valued menus, +radio button clusters and the like. To get around this warning, you +have several choices: -This will copy CGI.pm to your perl library directory for use by all -perl scripts. You probably must be root to do this. Now you can -load the CGI routines in your Perl scripts with the line: +=over 4 - use CGI; +=item 1. Use another name for the argument, if one is available. For +example, -value is an alias for -values. -If you don't have sufficient privileges to install CGI.pm in the Perl -library directory, you can put CGI.pm into some convenient spot, such -as your home directory, or in cgi-bin itself and prefix all Perl -scripts that call it with something along the lines of the following -preamble: +=item 2. Change the capitalization, e.g. -Values - use lib '/home/davis/lib'; - use CGI; +=item 3. Put quotes around the argument name, e.g. '-values' -If you are using a version of perl earlier than 5.002 (such as NT perl), use -this instead: +=back - BEGIN { - unshift(@INC,'/home/davis/lib'); - } - use CGI; +Many routines will do something useful with a named argument that it +doesn't recognize. For example, you can produce non-standard HTTP +header fields by providing them as named arguments: -The CGI distribution also comes with a cute module called L<CGI::Carp>. -It redefines the die(), warn(), confess() and croak() error routines -so that they write nicely formatted error messages into the server's -error log (or to the output stream of your choice). This avoids long -hours of groping through the error and access logs, trying to figure -out which CGI script is generating error messages. If you choose, -you can even have fatal error messages echoed to the browser to avoid -the annoying and uninformative "Server Error" message. + print $q->header(-type => 'text/html', + -cost => 'Three smackers', + -annoyance_level => 'high', + -complaints_to => 'bit bucket'); -=head1 DESCRIPTION +This will produce the following nonstandard HTTP header: + + HTTP/1.0 200 OK + Cost: Three smackers + Annoyance-level: high + Complaints-to: bit bucket + Content-type: text/html + +Notice the way that underscores are translated automatically into +hyphens. HTML-generating routines perform a different type of +translation. -=head2 CREATING A NEW QUERY OBJECT: +This feature allows you to keep up with the rapidly changing HTTP and +HTML "standards". + +=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE): $query = new CGI; @@ -2876,12 +3477,12 @@ it into a perl5 object called $query. $query = new CGI(INPUTFILE); -If you provide a file handle to the new() method, it -will read parameters from the file (or STDIN, or whatever). The -file can be in any of the forms describing below under debugging -(i.e. a series of newline delimited TAG=VALUE pairs will work). -Conveniently, this type of file is created by the save() method -(see below). Multiple records can be saved and restored. +If you provide a file handle to the new() method, it will read +parameters from the file (or STDIN, or whatever). The file can be in +any of the forms describing below under debugging (i.e. a series of +newline delimited TAG=VALUE pairs will work). Conveniently, this type +of file is created by the save() method (see below). Multiple records +can be saved and restored. Perl purists will be pleased to know that this syntax accepts references to file handles, or even references to filehandle globs, @@ -2889,6 +3490,18 @@ which is the "official" way to pass a filehandle: $query = new CGI(\*STDIN); +You can also initialize the CGI object with a FileHandle or IO::File +object. + +If you are using the function-oriented interface and want to +initialize CGI state from a file handle, the way to do this is with +B<restore_parameters()>. This will (re)initialize the +default CGI object from the indicated file handle. + + open (IN,"test.in") || die; + restore_parameters(IN); + close IN; + You can also initialize the query object from an associative array reference: @@ -2901,11 +3514,20 @@ or from a properly formatted, URL-escaped query string: $query = new CGI('dinosaur=barney&color=purple'); +or from a previously existing CGI object (currently this clones the +parameter list, but none of the other object-specific fields, such as +autoescaping): + + $old_query = new CGI; + $new_query = new CGI($old_query); + To create an empty query, initialize it from an empty string or hash: - $empty_query = new CGI(""); - -or- - $empty_query = new CGI({}); + $empty_query = new CGI(""); + + -or- + + $empty_query = new CGI({}); =head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY: @@ -2964,7 +3586,7 @@ in more detail later: =head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER: - $query->append(-name=>;'foo',-values=>['yet','more','values']); + $query->append(-name=>'foo',-values=>['yet','more','values']); This adds a value or list of values to the named parameter. The values are appended to the end of the parameter if it already exists. @@ -2993,14 +3615,32 @@ This completely clears a parameter. It sometimes useful for resetting parameters that you don't want passed down between script invocations. +If you are using the function call interface, use "Delete()" instead +to avoid conflicts with Perl's built-in delete operator. + =head2 DELETING ALL PARAMETERS: -$query->delete_all(); + $query->delete_all(); This clears the CGI object completely. It might be useful to ensure that all the defaults are taken when you create a fill-out form. -=head2 SAVING THE STATE OF THE FORM TO A FILE: +Use Delete_all() instead if you are using the function call interface. + +=head2 DIRECT ACCESS TO THE PARAMETER LIST: + + $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; + unshift @{$q->param_fetch(-name=>'address')},'George Munster'; + +If you need access to the parameter list in a way that isn't covered +by the methods above, you can obtain a direct reference to it by +calling the B<param_fetch()> method with the name of the . This +will return an array reference to the named parameters, which you then +can manipulate in any way you like. + +You can also use a named argument style using the B<-name> argument. + +=head2 SAVING THE STATE OF THE SCRIPT TO A FILE: $query->save(FILEHANDLE) @@ -3051,115 +3691,298 @@ manipulated and even databased using Boulderio utilities. See for further details. -=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION: +If you wish to use this method from the function-oriented (non-OO) +interface, the exported name for this method is B<save_parameters()>. - $myself = $query->self_url; - print "<A HREF=$myself>I'm talking to myself.</A>"; +=head2 USING THE FUNCTION-ORIENTED INTERFACE -self_url() will return a URL, that, when selected, will reinvoke -this script with all its state information intact. This is most -useful when you want to jump around within the document using -internal anchors but you don't want to disrupt the current contents -of the form(s). Something like this will do the trick. +To use the function-oriented interface, you must specify which CGI.pm +routines or sets of routines to import into your script's namespace. +There is a small overhead associated with this importation, but it +isn't much. - $myself = $query->self_url; - print "<A HREF=$myself#table1>See table 1</A>"; - print "<A HREF=$myself#table2>See table 2</A>"; - print "<A HREF=$myself#yourself>See for yourself</A>"; + use CGI <list of methods>; -If you don't want to get the whole query string, call -the method url() to return just the URL for the script: +The listed methods will be imported into the current package; you can +call them directly without creating a CGI object first. This example +shows how to import the B<param()> and B<header()> +methods, and then use them directly: - $myself = $query->url; - print "<A HREF=$myself>No query string in this baby!</A>\n"; + use CGI 'param','header'; + print header('text/plain'); + $zipcode = param('zipcode'); -You can also retrieve the unprocessed query string with query_string(): +More frequently, you'll import common sets of functions by referring +to the groups by name. All function sets are preceded with a ":" +character as in ":html3" (for tags defined in the HTML 3 standard). - $the_string = $query->query_string; +Here is a list of the function sets you can import: -=head2 COMPATIBILITY WITH CGI-LIB.PL +=over 4 -To make it easier to port existing programs that use cgi-lib.pl -the compatibility routine "ReadParse" is provided. Porting is -simple: +=item B<:cgi> -OLD VERSION - require "cgi-lib.pl"; - &ReadParse; - print "The value of the antique is $in{antique}.\n"; +Import all CGI-handling methods, such as B<param()>, B<path_info()> +and the like. -NEW VERSION - use CGI; - CGI::ReadParse - print "The value of the antique is $in{antique}.\n"; +=item B<:form> -CGI.pm's ReadParse() routine creates a tied variable named %in, -which can be accessed to obtain the query variables. Like -ReadParse, you can also provide your own variable. Infrequently -used features of ReadParse, such as the creation of @in and $in -variables, are not supported. +Import all fill-out form generating methods, such as B<textfield()>. -Once you use ReadParse, you can retrieve the query object itself -this way: +=item B<:html2> - $q = $in{CGI}; - print $q->textfield(-name=>'wow', - -value=>'does this really work?'); +Import all methods that generate HTML 2.0 standard elements. -This allows you to start using the more interesting features -of CGI.pm without rewriting your old scripts from scratch. +=item B<:html3> -=head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS +Import all methods that generate HTML 3.0 proposed elements (such as +<table>, <super> and <sub>). -In versions of CGI.pm prior to 2.0, it could get difficult to remember -the proper order of arguments in CGI function calls that accepted five -or six different arguments. As of 2.0, there's a better way to pass -arguments to the various CGI functions. In this style, you pass a -series of name=>argument pairs, like this: +=item B<:netscape> - $field = $query->radio_group(-name=>'OS', - -values=>[Unix,Windows,Macintosh], - -default=>'Unix'); +Import all methods that generate Netscape-specific HTML extensions. -The advantages of this style are that you don't have to remember the -exact order of the arguments, and if you leave out a parameter, in -most cases it will default to some reasonable value. If you provide -a parameter that the method doesn't recognize, it will usually do -something useful with it, such as incorporating it into the HTML form -tag. For example if Netscape decides next week to add a new -JUSTIFICATION parameter to the text field tags, you can start using -the feature without waiting for a new version of CGI.pm: +=item B<:html> - $field = $query->textfield(-name=>'State', - -default=>'gaseous', - -justification=>'RIGHT'); +Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + +'netscape')... -This will result in an HTML tag that looks like this: +=item B<:standard> - <INPUT TYPE="textfield" NAME="State" VALUE="gaseous" - JUSTIFICATION="RIGHT"> +Import "standard" features, 'html2', 'html3', 'form' and 'cgi'. -Parameter names are case insensitive: you can use -name, or -Name or --NAME. You don't have to use the hyphen if you don't want to. After -creating a CGI object, call the B<use_named_parameters()> method with -a nonzero value. This will tell CGI.pm that you intend to use named -parameters exclusively: +=item B<:all> - $query = new CGI; - $query->use_named_parameters(1); - $field = $query->radio_group('name'=>'OS', - 'values'=>['Unix','Windows','Macintosh'], - 'default'=>'Unix'); +Import all the available methods. For the full list, see the CGI.pm +code, where the variable %TAGS is defined. + +=back + +If you import a function name that is not part of CGI.pm, the module +will treat it as a new HTML tag and generate the appropriate +subroutine. You can then use it like any other HTML tag. This is to +provide for the rapidly-evolving HTML "standard." For example, say +Microsoft comes out with a new tag called <GRADIENT> (which causes the +user's desktop to be flooded with a rotating gradient fill until his +machine reboots). You don't need to wait for a new version of CGI.pm +to start using it immediately: -Actually, CGI.pm only looks for a hyphen in the first parameter. So -you can leave it off subsequent parameters if you like. Something to -be wary of is the potential that a string constant like "values" will -collide with a keyword (and in fact it does!) While Perl usually -figures out when you're referring to a function and when you're -referring to a string, you probably should put quotation marks around -all string constants just to play it safe. + use CGI qw/:standard :html3 gradient/; + print gradient({-start=>'red',-end=>'blue'}); -=head2 CREATING THE HTTP HEADER: +Note that in the interests of execution speed CGI.pm does B<not> use +the standard L<Exporter> syntax for specifying load symbols. This may +change in the future. + +If you import any of the state-maintaining CGI or form-generating +methods, a default CGI object will be created and initialized +automatically the first time you use any of the methods that require +one to be present. This includes B<param()>, B<textfield()>, +B<submit()> and the like. (If you need direct access to the CGI +object, you can find it in the global variable B<$CGI::Q>). By +importing CGI.pm methods, you can create visually elegant scripts: + + use CGI qw/:standard/; + print + header, + start_html('Simple Script'), + h1('Simple Script'), + start_form, + "What's your name? ",textfield('name'),p, + "What's the combination?", + checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','moe']),p, + "What's your favorite color?", + popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']),p, + submit, + end_form, + hr,"\n"; + + if (param) { + print + "Your name is ",em(param('name')),p, + "The keywords are: ",em(join(", ",param('words'))),p, + "Your favorite color is ",em(param('color')),".\n"; + } + print end_html; + +=head2 PRAGMAS + +In addition to the function sets, there are a number of pragmas that +you can import. Pragmas, which are always preceded by a hyphen, +change the way that CGI.pm functions in various ways. Pragmas, +function sets, and individual functions can all be imported in the +same use() line. For example, the following use statement imports the +standard set of functions and disables debugging mode (pragma +-no_debug): + + use CGI qw/:standard -no_debug/; + +The current list of pragmas is as follows: + +=over 4 + +=item -any + +When you I<use CGI -any>, then any method that the query object +doesn't recognize will be interpreted as a new HTML tag. This allows +you to support the next I<ad hoc> Netscape or Microsoft HTML +extension. This lets you go wild with new and unsupported tags: + + use CGI qw(-any); + $q=new CGI; + print $q->gradient({speed=>'fast',start=>'red',end=>'blue'}); + +Since using <cite>any</cite> causes any mistyped method name +to be interpreted as an HTML tag, use it with care or not at +all. + +=item -compile + +This causes the indicated autoloaded methods to be compiled up front, +rather than deferred to later. This is useful for scripts that run +for an extended period of time under FastCGI or mod_perl, and for +those destined to be crunched by Malcom Beattie's Perl compiler. Use +it in conjunction with the methods or method families you plan to use. + + use CGI qw(-compile :standard :html3); + +or even + + use CGI qw(-compile :all); + +Note that using the -compile pragma in this way will always have +the effect of importing the compiled functions into the current +namespace. If you want to compile without importing use the +compile() method instead (see below). + +=item -nph + +This makes CGI.pm produce a header appropriate for an NPH (no +parsed header) script. You may need to do other things as well +to tell the server that the script is NPH. See the discussion +of NPH scripts below. + +=item -newstyle_urls + +Separate the name=value pairs in CGI parameter query strings with +semicolons rather than ampersands. For example: + + ?name=fred;age=24;favorite_color=3 + +Semicolon-delimited query strings are always accepted, but will not be +emitted by self_url() and query_string() unless the -newstyle_urls +pragma is specified. + +=item -autoload + +This overrides the autoloader so that any function in your program +that is not recognized is referred to CGI.pm for possible evaluation. +This allows you to use all the CGI.pm functions without adding them to +your symbol table, which is of concern for mod_perl users who are +worried about memory consumption. I<Warning:> when +I<-autoload> is in effect, you cannot use "poetry mode" +(functions without the parenthesis). Use I<hr()> rather +than I<hr>, or add something like I<use subs qw/hr p header/> +to the top of your script. + +=item -no_debug + +This turns off the command-line processing features. If you want to +run a CGI.pm script from the command line to produce HTML, and you +don't want it pausing to request CGI parameters from standard input or +the command line, then use this pragma: + + use CGI qw(-no_debug :standard); + +If you'd like to process the command-line parameters but not standard +input, this should work: + + use CGI qw(-no_debug :standard); + restore_parameters(join('&',@ARGV)); + +See the section on debugging for more details. + +=item -private_tempfiles + +CGI.pm can process uploaded file. Ordinarily it spools the +uploaded file to a temporary directory, then deletes the file +when done. However, this opens the risk of eavesdropping as +described in the file upload section. +Another CGI script author could peek at this data during the +upload, even if it is confidential information. On Unix systems, +the -private_tempfiles pragma will cause the temporary file to be unlinked as soon +as it is opened and before any data is written into it, +eliminating the risk of eavesdropping. + +=back + +=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS + +Many of the methods generate HTML tags. As described below, tag +functions automatically generate both the opening and closing tags. +For example: + + print h1('Level 1 Header'); + +produces + + <H1>Level 1 Header</H1> + +There will be some times when you want to produce the start and end +tags yourself. In this case, you can use the form start_I<tag_name> +and end_I<tag_name>, as in: + + print start_h1,'Level 1 Header',end_h1; + +With a few exceptions (described below), start_I<tag_name> and +end_I<tag_name> functions are not generated automatically when you +I<use CGI>. However, you can specify the tags you want to generate +I<start/end> functions for by putting an asterisk in front of their +name, or, alternatively, requesting either "start_I<tag_name>" or +"end_I<tag_name>" in the import list. + +Example: + + use CGI qw/:standard *table start_ul/; + +In this example, the following functions are generated in addition to +the standard ones: + +=over 4 + +=item 1. start_table() (generates a <TABLE> tag) + +=item 2. end_table() (generates a </TABLE> tag) + +=item 3. start_ul() (generates a <UL> tag) + +=item 4. end_ul() (generates a </UL> tag) + +=back + +=head1 GENERATING DYNAMIC DOCUMENTS + +Most of CGI.pm's functions deal with creating documents on the fly. +Generally you will produce the HTTP header first, followed by the +document itself. CGI.pm provides functions for generating HTTP +headers of various types as well as for generating HTML. For creating +GIF images, see the GD.pm module. + +Each of these functions produces a fragment of HTML or HTTP which you +can print out directly so that it displays in the browser window, +append to a string, or save to a file for later use. + +=head2 CREATING A STANDARD HTTP HEADER: + +Normally the first thing you will do in any CGI script is print out an +HTTP header. This tells the browser what type of document to expect, +and gives other optional information, such as the language, expiration +date, and whether to cache the document. The header can also be +manipulated for special purposes, such as server push and pay per view +pages. print $query->header; @@ -3184,16 +4007,16 @@ header() returns the Content-type: header. You can provide your own MIME type if you choose, otherwise it defaults to text/html. An optional second parameter specifies the status code and a human-readable message. For example, you can specify 204, "No response" to create a -script that tells the browser to do nothing at all. If you want to -add additional fields to the header, just tack them on to the end: - - print $query->header('text/html','200 OK','Content-Length: 3002'); +script that tells the browser to do nothing at all. The last example shows the named argument style for passing arguments to the CGI methods using named parameters. Recognized parameters are -B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other +B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named parameters will be stripped of their initial hyphens and turned into header fields, allowing you to specify any HTTP header you desire. +Internal underscores will be turned into hyphens: + + print $query->header(-Content_length=>3002); Most browsers will not cache the output from CGI scripts. Every time the browser reloads the page, the script is invoked anew. You can @@ -3210,11 +4033,7 @@ indicated expiration date. The following forms are all valid for the now immediately +3M in three months +10y in ten years time - Thursday, 25-Apr-96 00:40:33 GMT at the indicated time & date - -(CGI::expires() is the static function call used internally that turns -relative time intervals into HTTP dates. You can call it directly if -you wish.) + Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date The B<-cookie> parameter generates a header that tells the browser to provide a "magic cookie" during all subsequent transactions with your script. @@ -3227,14 +4046,19 @@ headers to work with a NPH (no-parse-header) script. This is important to use with certain servers, such as Microsoft Internet Explorer, which expect all their scripts to be NPH. -=head2 GENERATING A REDIRECTION INSTRUCTION +=head2 GENERATING A REDIRECTION HEADER print $query->redirect('http://somewhere.else/in/movie/land'); -redirects the browser elsewhere. If you use redirection like this, -you should B<not> print out a header as well. As of version 2.0, we -produce both the unofficial Location: header and the official URI: -header. This should satisfy most servers and browsers. +Sometimes you don't want to produce a document yourself, but simply +redirect the browser elsewhere, perhaps choosing a URL based on the +time of day or the identity of the user. + +The redirect() function redirects the browser to a different URL. If +you use redirection like this, you should B<not> print out a header as +well. As of version 2.0, we produce both the unofficial Location: +header and the official URI: header. This should satisfy most servers +and browsers. One hint I can offer is that relative links may not work correctly when you generate a redirection to another document on your site. @@ -3242,7 +4066,7 @@ This is due to a well-intentioned optimization that some servers use. The solution to this is to use the full URL (including the http: part) of the document you are redirecting to. -You can use named parameters: +You can also use named arguments: print $query->redirect(-uri=>'http://somewhere.else/in/movie/land', -nph=>1); @@ -3252,8 +4076,7 @@ headers to work with a NPH (no-parse-header) script. This is important to use with certain servers, such as Microsoft Internet Explorer, which expect all their scripts to be NPH. - -=head2 CREATING THE HTML HEADER: +=head2 CREATING THE HTML DOCUMENT HEADER print $query->start_html(-title=>'Secrets of the Pyramids', -author=>'fred@capricorn.org', @@ -3264,17 +4087,17 @@ expect all their scripts to be NPH. -style=>{'src'=>'/styles/style1.css'}, -BGCOLOR=>'blue'); - -or- - - print $query->start_html('Secrets of the Pyramids', - 'fred@capricorn.org','true', - 'BGCOLOR="blue"'); +After creating the HTTP header, most CGI scripts will start writing +out an HTML document. The start_html() routine creates the top of the +page, along with a lot of optional information that controls the +page's appearance and behavior. -This will return a canned HTML header and the opening <BODY> tag. -All parameters are optional. In the named parameter form, recognized -parameters are -title, -author, -base, -xbase and -target (see below for the -explanation). Any additional parameters you provide, such as the -Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag. +This method returns a canned HTML header and the opening <BODY> tag. +All parameters are optional. In the named parameter form, recognized +parameters are -title, -author, -base, -xbase and -target (see below +for the explanation). Any additional parameters you provide, such as +the Netscape unofficial BGCOLOR attribute, are added to the <BODY> +tag. Additional parameters must be proceeded by a hyphen. The argument B<-xbase> allows you to provide an HREF for the <BASE> tag different from the current location, as in @@ -3312,31 +4135,32 @@ You can place other arbitrary HTML elements to the <HEAD> section with the B<-head> tag. For example, to place the rarely-used <LINK> element in the head section, use this: - print $q->header(-head=>link({-rel=>'next', + print $q->start_html(-head=>Link({-rel=>'next', -href=>'http://www.capricorn.com/s2.html'})); To incorporate multiple HTML elements into the <HEAD> section, just pass an array reference: - print $q->header(-head=>[ link({-rel=>'next', + print $q->start_html(-head=>[ + Link({-rel=>'next', -href=>'http://www.capricorn.com/s2.html'}), - link({-rel=>'previous', + Link({-rel=>'previous', -href=>'http://www.capricorn.com/s1.html'}) ] ); - -JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad> and B<-onUnload> parameters -are used to add Netscape JavaScript calls to your pages. B<-script> -should point to a block of text containing JavaScript function -definitions. This block will be placed within a <SCRIPT> block inside -the HTML (not HTTP) header. The block is placed in the header in -order to give your page a fighting chance of having all its JavaScript -functions in place even if the user presses the stop button before the -page has loaded completely. CGI.pm attempts to format the script in -such a way that JavaScript-naive browsers will not choke on the code: -unfortunately there are some browsers, such as Chimera for Unix, that -get confused by it nevertheless. +JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, +B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used +to add Netscape JavaScript calls to your pages. B<-script> should +point to a block of text containing JavaScript function definitions. +This block will be placed within a <SCRIPT> block inside the HTML (not +HTTP) header. The block is placed in the header in order to give your +page a fighting chance of having all its JavaScript functions in place +even if the user presses the stop button before the page has loaded +completely. CGI.pm attempts to format the script in such a way that +JavaScript-naive browsers will not choke on the code: unfortunately +there are some browsers, such as Chimera for Unix, that get confused +by it nevertheless. The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript code to execute when the page is respectively opened and closed by the @@ -3386,6 +4210,31 @@ one or more of -language, -src, or -code: ); +A final feature allows you to incorporate multiple <SCRIPT> sections into the +header. Just pass the list of script sections as an array reference. +this allows you to specify different source files for different dialects +of JavaScript. Example: + + print $q->start_html(-title=>'The Riddle of the Sphinx', + -script=>[ + { -language => 'JavaScript1.0', + -src => '/javascript/utilities10.js' + }, + { -language => 'JavaScript1.1', + -src => '/javascript/utilities11.js' + }, + { -language => 'JavaScript1.2', + -src => '/javascript/utilities12.js' + }, + { -language => 'JavaScript28.2', + -src => '/javascript/utilities219.js' + } + ] + ); + </pre> + +If this looks a bit extreme, take my advice and stick with straight CGI scripting. + See http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/ @@ -3425,7 +4274,278 @@ place to put Netscape extensions, such as colors and wallpaper patterns. This ends an HTML document by printing the </BODY></HTML> tags. -=head1 CREATING FORMS +=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION: + + $myself = $query->self_url; + print "<A HREF=$myself>I'm talking to myself.</A>"; + +self_url() will return a URL, that, when selected, will reinvoke +this script with all its state information intact. This is most +useful when you want to jump around within the document using +internal anchors but you don't want to disrupt the current contents +of the form(s). Something like this will do the trick. + + $myself = $query->self_url; + print "<A HREF=$myself#table1>See table 1</A>"; + print "<A HREF=$myself#table2>See table 2</A>"; + print "<A HREF=$myself#yourself>See for yourself</A>"; + +If you want more control over what's returned, using the B<url()> +method instead. + +You can also retrieve the unprocessed query string with query_string(): + + $the_string = $query->query_string; + +=head2 OBTAINING THE SCRIPT'S URL + + $full_url = $query->url(); + $full_url = $query->url(-full=>1); #alternative syntax + $relative_url = $query->url(-relative=>1); + $absolute_url = $query->url(-absolute=>1); + $url_with_path = $query->url(-path_info=>1); + $url_with_path_and_query = $query->url(-path_info=>1,-query=>1); + +B<url()> returns the script's URL in a variety of formats. Called +without any arguments, it returns the full form of the URL, including +host name and port number + + http://your.host.com/path/to/script.cgi + +You can modify this format with the following named arguments: + +=over 4 + +=item B<-absolute> + +If true, produce an absolute URL, e.g. + + /path/to/script.cgi + +=item B<-relative> + +Produce a relative URL. This is useful if you want to reinvoke your +script with different parameters. For example: + + script.cgi + +=item B<-full> + +Produce the full URL, exactly as if called without any arguments. +This overrides the -relative and -absolute arguments. + +=item B<-path> (B<-path_info>) + +Append the additional path information to the URL. This can be +combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info> +is provided as a synonym. + +=item B<-query> (B<-query_string>) + +Append the query string to the URL. This can be combined with +B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided +as a synonym. + +=back + +=head2 MIXING POST AND URL PARAMETERS + + $color = $query->url_param('color'); + +It is possible for a script to receive CGI parameters in the URL as +well as in the fill-out form by creating a form that POSTs to a URL +containing a query string (a "?" mark followed by arguments). The +B<param()> method will always return the contents of the POSTed +fill-out form, ignoring the URL's query string. To retrieve URL +parameters, call the B<url_param()> method. Use it in the same way as +B<param()>. The main difference is that it allows you to read the +parameters, but not set them. + + +Under no circumstances will the contents of the URL query string +interfere with similarly-named CGI parameters in POSTed forms. If you +try to mix a URL query string with a form submitted with the GET +method, the results will not be what you expect. + +=head1 CREATING STANDARD HTML ELEMENTS: + +CGI.pm defines general HTML shortcut methods for most, if not all of +the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single +HTML element and return a fragment of HTML text that you can then +print or manipulate as you like. Each shortcut returns a fragment of +HTML code that you can append to a string, save to a file, or, most +commonly, print out so that it displays in the browser window. + +This example shows how to use the HTML methods: + + $q = new CGI; + print $q->blockquote( + "Many years ago on the island of", + $q->a({href=>"http://crete.org/"},"Crete"), + "there lived a minotaur named", + $q->strong("Fred."), + ), + $q->hr; + +This results in the following HTML code (extra newlines have been +added for readability): + + <blockquote> + Many years ago on the island of + <a HREF="http://crete.org/">Crete</a> there lived + a minotaur named <strong>Fred.</strong> + </blockquote> + <hr> + +If you find the syntax for calling the HTML shortcuts awkward, you can +import them into your namespace and dispense with the object syntax +completely (see the next section for more details): + + use CGI ':standard'; + print blockquote( + "Many years ago on the island of", + a({href=>"http://crete.org/"},"Crete"), + "there lived a minotaur named", + strong("Fred."), + ), + hr; + +=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS + +The HTML methods will accept zero, one or multiple arguments. If you +provide no arguments, you get a single tag: + + print hr; # <HR> + +If you provide one or more string arguments, they are concatenated +together with spaces and placed between opening and closing tags: + + print h1("Chapter","1"); # <H1>Chapter 1</H1>" + +If the first argument is an associative array reference, then the keys +and values of the associative array become the HTML tag's attributes: + + print a({-href=>'fred.html',-target=>'_new'}, + "Open a new frame"); + + <A HREF="fred.html",TARGET="_new">Open a new frame</A> + +You may dispense with the dashes in front of the attribute names if +you prefer: + + print img {src=>'fred.gif',align=>'LEFT'}; + + <IMG ALIGN="LEFT" SRC="fred.gif"> + +Sometimes an HTML tag attribute has no argument. For example, ordered +lists can be marked as COMPACT. The syntax for this is an argument that +that points to an undef string: + + print ol({compact=>undef},li('one'),li('two'),li('three')); + +Prior to CGI.pm version 2.41, providing an empty ('') string as an +attribute argument was the same as providing undef. However, this has +changed in order to accommodate those who want to create tags of the form +<IMG ALT="">. The difference is shown in these two pieces of code: + + CODE RESULT + img({alt=>undef}) <IMG ALT> + img({alt=>''}) <IMT ALT=""> + +=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS + +One of the cool features of the HTML shortcuts is that they are +distributive. If you give them an argument consisting of a +B<reference> to a list, the tag will be distributed across each +element of the list. For example, here's one way to make an ordered +list: + + print ul( + li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']); + ); + +This example will result in HTML output that looks like this: + + <UL> + <LI TYPE="disc">Sneezy</LI> + <LI TYPE="disc">Doc</LI> + <LI TYPE="disc">Sleepy</LI> + <LI TYPE="disc">Happy</LI> + </UL> + +This is extremely useful for creating tables. For example: + + print table({-border=>undef}, + caption('When Should You Eat Your Vegetables?'), + Tr({-align=>CENTER,-valign=>TOP}, + [ + th(['Vegetable', 'Breakfast','Lunch','Dinner']), + td(['Tomatoes' , 'no', 'yes', 'yes']), + td(['Broccoli' , 'no', 'no', 'yes']), + td(['Onions' , 'yes','yes', 'yes']) + ] + ) + ); + +=head2 HTML SHORTCUTS AND LIST INTERPOLATION + +Consider this bit of code: + + print blockquote(em('Hi'),'mom!')); + +It will ordinarily return the string that you probably expect, namely: + + <BLOCKQUOTE><EM>Hi</EM> mom!</BLOCKQUOTE> + +Note the space between the element "Hi" and the element "mom!". +CGI.pm puts the extra space there using array interpolation, which is +controlled by the magic $" variable. Sometimes this extra space is +not what you want, for example, when you are trying to align a series +of images. In this case, you can simply change the value of $" to an +empty string. + + { + local($") = ''; + print blockquote(em('Hi'),'mom!')); + } + +I suggest you put the code in a block as shown here. Otherwise the +change to $" will affect all subsequent code until you explicitly +reset it. + +=head2 NON-STANDARD HTML SHORTCUTS + +A few HTML tags don't follow the standard pattern for various +reasons. + +B<comment()> generates an HTML comment (<!-- comment -->). Call it +like + + print comment('here is my comment'); + +Because of conflicts with built-in Perl functions, the following functions +begin with initial caps: + + Select + Tr + Link + Delete + Accept + Sub + +In addition, start_html(), end_html(), start_form(), end_form(), +start_multipart_form() and all the fill-out form tags are special. +See their respective sections. + +=head2 PRETTY-PRINTING HTML + +By default, all the HTML produced by these functions comes out as one +long line without carriage returns or indentation. This is yuck, but +it does reduce the size of the documents by 10-20%. To get +pretty-printed output, please use L<CGI::Pretty>, a subclass +contributed by Brian Paulsen. + +=head1 CREATING FILL-OUT FORMS: I<General note> The various form-creating methods all return strings to the caller, containing the tag or tags that will create the requested @@ -3479,7 +4599,7 @@ default is to process the query with the current script. print $query->startform(-method=>$method, -action=>$action, - -encoding=>$encoding); + -enctype=>$encoding); <... various form stuff ...> print $query->endform; @@ -3494,11 +4614,11 @@ action and form encoding that you specify. The defaults are: method: POST action: this script - encoding: application/x-www-form-urlencoded + enctype: application/x-www-form-urlencoded endform() returns the closing </FORM> tag. -Startform()'s encoding method tells the browser how to package the various +Startform()'s enctype argument tells the browser how to package the various fields of the form before sending the form to the server. Two values are possible: @@ -3519,7 +4639,7 @@ It is suitable for forms that contain very large fields or that are intended for transferring binary data. Most importantly, it enables the "file upload" feature of Netscape 2.0 forms. For your convenience, CGI.pm stores the name of this encoding type -in B<$CGI::MULTIPART> +in B<&CGI::MULTIPART> Forms that use this type of encoding are not easily interpreted by CGI scripts unless they use CGI.pm or another library designed @@ -3605,13 +4725,14 @@ parameter: -size=>50, -maxlength=>80); -JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur> -and B<-onSelect> parameters to register JavaScript event handlers. -The onChange handler will be called whenever the user changes the -contents of the text field. You can do text validation if you like. -onFocus and onBlur are called respectively when the insertion point -moves into and out of the text field. onSelect is called when the -user changes the portion of the text that is selected. +JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, +B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> +parameters to register JavaScript event handlers. The onChange +handler will be called whenever the user changes the contents of the +text field. You can do text validation if you like. onFocus and +onBlur are called respectively when the insertion point moves into and +out of the text field. onSelect is called when the user changes the +portion of the text that is selected. =head2 CREATING A BIG TEXT FIELD @@ -3629,8 +4750,9 @@ rows and columns for a multiline text entry box. You can provide a starting value for the field, which can be long and contain multiple lines. -JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> -and B<-onSelect> parameters are recognized. See textfield(). +JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> , +B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are +recognized. See textfield(). =head2 CREATING A PASSWORD FIELD @@ -3645,8 +4767,9 @@ and B<-onSelect> parameters are recognized. See textfield(). password_field() is identical to textfield(), except that its contents will be starred out on the web page. -JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> -and B<-onSelect> parameters are recognized. See textfield(). +JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>, +B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are +recognized. See textfield(). =head2 CREATING A FILE UPLOAD FIELD @@ -3678,12 +4801,11 @@ The first parameter is the required name for the field (-name). The optional second parameter is the starting value for the field contents to be used as the default file name (-default). -The beta2 version of Netscape 2.0 currently doesn't pay any attention -to this field, and so the starting value will always be blank. Worse, -the field loses its "sticky" behavior and forgets its previous -contents. The starting value field is called for in the HTML -specification, however, and possibly later versions of Netscape will -honor it. +For security reasons, browsers don't pay any attention to this field, +and so the starting value will always be blank. Worse, the field +loses its "sticky" behavior and forgets its previous contents. The +starting value field is called for in the HTML specification, however, +and possibly some browser will eventually provide support for it. =item 3. @@ -3702,9 +4824,9 @@ by calling param(). $filename = $query->param('uploaded_file'); -In Netscape Gold, the filename that gets returned is the full local filename -on the B<remote user's> machine. If the remote user is on a Unix -machine, the filename will follow Unix conventions: +In Netscape Navigator 2.0, the filename that gets returned is the full +local filename on the B<remote user's> machine. If the remote user is +on a Unix machine, the filename will follow Unix conventions: /path/to/the/file @@ -3747,9 +4869,9 @@ If you are using a machine that recognizes "text" and "binary" data modes, be sure to understand when and how to use them (see the Camel book). Otherwise you may find that binary files are corrupted during file uploads. -JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> -and B<-onSelect> parameters are recognized. See textfield() -for details. +JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>, +B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are +recognized. See textfield() for details. =head2 CREATING A POPUP MENU @@ -3811,8 +4933,9 @@ be retrieved using: $popup_menu_value = $query->param('menu_name'); JAVASCRIPTING: popup_menu() recognizes the following event handlers: -B<-onChange>, B<-onFocus>, and B<-onBlur>. See the textfield() -section for details on when these handlers are called. +B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and +B<-onBlur>. See the textfield() section for details on when these +handlers are called. =head2 CREATING A SCROLLING LIST @@ -3880,9 +5003,10 @@ selected items can be retrieved with: =back -JAVASCRIPTING: scrolling_list() recognizes the following event handlers: -B<-onChange>, B<-onFocus>, and B<-onBlur>. See textfield() for -the description of when these handlers are called. +JAVASCRIPTING: scrolling_list() recognizes the following event +handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut> +and B<-onBlur>. See textfield() for the description of when these +handlers are called. =head2 CREATING A GROUP OF RELATED CHECKBOXES @@ -3940,17 +5064,15 @@ be used as the default. =item 5. -B<HTML3-compatible browsers> (such as Netscape) can take advantage -of the optional -parameters B<-rows>, and B<-columns>. These parameters cause -checkbox_group() to return an HTML3 compatible table containing -the checkbox group formatted with the specified number of rows -and columns. You can provide just the -columns parameter if you -wish; checkbox_group will calculate the correct number of rows -for you. +B<HTML3-compatible browsers> (such as Netscape) can take advantage of +the optional parameters B<-rows>, and B<-columns>. These parameters +cause checkbox_group() to return an HTML3 compatible table containing +the checkbox group formatted with the specified number of rows and +columns. You can provide just the -columns parameter if you wish; +checkbox_group will calculate the correct number of rows for you. To include row and column headings in the returned table, you -can use the B<-rowheader> and B<-colheader> parameters. Both +can use the B<-rowheaders> and B<-colheaders> parameters. Both of these accept a pointer to an array of headings to use. The headings are just decorative. They don't reorganize the interpretation of the checkboxes -- they're still a single named @@ -4100,7 +5222,7 @@ To include row and column headings in the returned table, you can use the B<-rowheader> and B<-colheader> parameters. Both of these accept a pointer to an array of headings to use. The headings are just decorative. They don't reorganize the -interpetation of the radio buttons -- they're still a single named +interpretation of the radio buttons -- they're still a single named unit. =back @@ -4164,6 +5286,9 @@ reset() creates the "reset" button. Note that it restores the form to its value from the last time the script was called, NOT necessarily to the defaults. +Note that this conflicts with the Perl reset() built-in. Use +CORE::reset() to get the original reset function. + =head2 CREATING A DEFAULT BUTTON print $query->defaults('button_label') @@ -4270,11 +5395,12 @@ pointed to by the B<-onClick> parameter will be executed. On non-Netscape browsers this form element will probably not even display. -=head1 NETSCAPE COOKIES +=head1 HTTP COOKIES -Netscape browsers versions 1.1 and higher support a so-called -"cookie" designed to help maintain state within a browser session. -CGI.pm has several methods that support cookies. +Netscape browsers versions 1.1 and higher, and all versions of +Internet Explorer, support a so-called "cookie" designed to help +maintain state within a browser session. CGI.pm has several methods +that support cookies. A cookie is a name=value pair much like the named parameters in a CGI query string. CGI scripts create one or more cookies and send @@ -4292,15 +5418,15 @@ optional attributes: This is a time/date string (in a special GMT format) that indicates when a cookie expires. The cookie will be saved and returned to your script until this expiration date is reached if the user exits -Netscape and restarts it. If an expiration date isn't specified, the cookie -will remain active until the user quits Netscape. +the browser and restarts it. If an expiration date isn't specified, the cookie +will remain active until the user quits the browser. =item 2. a domain This is a partial or complete domain name for which the cookie is valid. The browser will return the cookie to any host that matches the partial domain name. For example, if you specify a domain name -of ".capricorn.com", then Netscape will return the cookie to +of ".capricorn.com", then the browser will return the cookie to Web servers running on any of the machines "www.capricorn.com", "www2.capricorn.com", "feckless.capricorn.com", etc. Domain names must contain at least two periods to prevent attempts to match @@ -4325,7 +5451,7 @@ script if the CGI request is occurring on a secure channel, such as SSL. =back -The interface to Netscape cookies is the B<cookie()> method: +The interface to HTTP cookies is the B<cookie()> method: $cookie = $query->cookie(-name=>'sessionID', -value=>'xyzzy', @@ -4342,7 +5468,7 @@ B<cookie()> creates a new cookie. Its parameters include: =item B<-name> The name of the cookie (required). This can be any string at all. -Although Netscape limits its cookie names to non-whitespace +Although browsers limit their cookie names to non-whitespace alphanumeric characters, CGI.pm removes this restriction by escaping and unescaping cookies behind the scenes. @@ -4413,19 +5539,11 @@ simple to turn a CGI parameter into a cookie, and vice-versa: See the B<cookie.cgi> example script for some ideas on how to use cookies effectively. -B<NOTE:> There appear to be some (undocumented) restrictions on -Netscape cookies. In Netscape 2.01, at least, I haven't been able to -set more than three cookies at a time. There may also be limits on -the length of cookies. If you need to store a lot of information, -it's probably better to create a unique session ID, store it in a -cookie, and use the session ID to locate an external file/database -saved on the server's side of the connection. +=head1 WORKING WITH FRAMES -=head1 WORKING WITH NETSCAPE FRAMES - -It's possible for CGI.pm scripts to write into several browser -panels and windows using Netscape's frame mechanism. -There are three techniques for defining new frames programmatically: +It's possible for CGI.pm scripts to write into several browser panels +and windows using the HTML 4 frame mechanism. There are three +techniques for defining new frames programmatically: =over 4 @@ -4448,12 +5566,12 @@ You may provide a B<-target> parameter to the header() method: print $q->header(-target=>'ResultsWindow'); -This will tell Netscape to load the output of your script into the -frame named "ResultsWindow". If a frame of that name doesn't -already exist, Netscape will pop up a new window and load your -script's document into that. There are a number of magic names -that you can use for targets. See the frame documents on Netscape's -home pages for details. +This will tell the browser to load the output of your script into the +frame named "ResultsWindow". If a frame of that name doesn't already +exist, the browser will pop up a new window and load your script's +document into that. There are a number of magic names that you can +use for targets. See the frame documents on Netscape's home pages for +details. =item 3. Specify the destination for the document in the <FORM> tag @@ -4485,6 +5603,10 @@ stylesheet can be found. B<-code> points to a scalar value to be incorporated into a <STYLE> section. Style definitions in B<-code> override similarly-named ones in B<-src>, hence the name "cascading." +You may also specify the type of the stylesheet by adding the optional +B<-type> parameter to the hash pointed to by B<-style>. If not +specified, the style defaults to 'text/css'. + To refer to a style within the body of your document, add the B<-class> parameter to any HTML element: @@ -4594,13 +5716,8 @@ Produces something that looks like: </UL> </UL> -You can pass a value of 'true' to dump() in order to get it to -print the results out as plain text, suitable for incorporating -into a <PRE> section. - -As a shortcut, as of version 1.56 you can interpolate the entire CGI -object into a string and it will be replaced with the a nice HTML dump -shown above: +As a shortcut, you can interpolate the entire CGI object into a string +and it will be replaced with the a nice HTML dump shown above: $query=new CGI; print "<H2>Current Values</H2> $query\n"; @@ -4612,25 +5729,32 @@ through this interface. The methods are as follows: =over 4 -=item B<accept()> +=item B<Accept()> + +Return a list of MIME types that the remote browser accepts. If you +give this method a single argument corresponding to a MIME type, as in +$query->Accept('text/html'), it will return a floating point value +corresponding to the browser's preference for this type from 0.0 +(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept +list are handled correctly. -Return a list of MIME types that the remote browser -accepts. If you give this method a single argument -corresponding to a MIME type, as in -$query->accept('text/html'), it will return a -floating point value corresponding to the browser's -preference for this type from 0.0 (don't want) to 1.0. -Glob types (e.g. text/*) in the browser's accept list -are handled correctly. +Note that the capitalization changed between version 2.43 and 2.44 in +order to avoid conflict with Perl's accept() function. =item B<raw_cookie()> -Returns the HTTP_COOKIE variable, an HTTP extension -implemented by Netscape browsers version 1.1 -and higher. Cookies have a special format, and this -method call just returns the raw form (?cookie dough). -See cookie() for ways of setting and retrieving -cooked cookies. +Returns the HTTP_COOKIE variable, an HTTP extension implemented by +Netscape browsers version 1.1 and higher, and all versions of Internet +Explorer. Cookies have a special format, and this method call just +returns the raw form (?cookie dough). See cookie() for ways of +setting and retrieving cooked cookies. + +Called with no parameters, raw_cookie() returns the packed cookie +structure. You can separate it into individual cookies by splitting +on the character sequence "; ". Called with the name of a cookie, +retrieves the B<unescaped> form of the cookie. You can use the +regular cookie() method to get the names, or use the raw_fetch() +method from the CGI::Cookie module. =item B<user_agent()> @@ -4705,10 +5829,9 @@ verification, if this script is protected. =item B<user_name ()> -Attempt to obtain the remote user's name, using a variety -of different techniques. This only works with older browsers -such as Mosaic. Netscape does not reliably report the user -name! +Attempt to obtain the remote user's name, using a variety of different +techniques. This only works with older browsers such as Mosaic. +Newer browsers do not report the user name for privacy reasons! =item B<request_method()> @@ -4717,242 +5840,232 @@ one of 'POST', 'GET' or 'HEAD'. =back -=head1 CREATING HTML ELEMENTS - -In addition to its shortcuts for creating form elements, CGI.pm -defines general HTML shortcut methods as well. HTML shortcuts are -named after a single HTML element and return a fragment of HTML text -that you can then print or manipulate as you like. - -This example shows how to use the HTML methods: - - $q = new CGI; - print $q->blockquote( - "Many years ago on the island of", - $q->a({href=>"http://crete.org/"},"Crete"), - "there lived a minotaur named", - $q->strong("Fred."), - ), - $q->hr; - -This results in the following HTML code (extra newlines have been -added for readability): +=head1 USING NPH SCRIPTS - <blockquote> - Many years ago on the island of - <a HREF="http://crete.org/">Crete</a> there lived - a minotaur named <strong>Fred.</strong> - </blockquote> - <hr> +NPH, or "no-parsed-header", scripts bypass the server completely by +sending the complete HTTP header directly to the browser. This has +slight performance benefits, but is of most use for taking advantage +of HTTP extensions that are not directly supported by your server, +such as server push and PICS headers. -If you find the syntax for calling the HTML shortcuts awkward, you can -import them into your namespace and dispense with the object syntax -completely (see the next section for more details): +Servers use a variety of conventions for designating CGI scripts as +NPH. Many Unix servers look at the beginning of the script's name for +the prefix "nph-". The Macintosh WebSTAR server and Microsoft's +Internet Information Server, in contrast, try to decide whether a +program is an NPH script by examining the first line of script output. - use CGI shortcuts; # IMPORT HTML SHORTCUTS - print blockquote( - "Many years ago on the island of", - a({href=>"http://crete.org/"},"Crete"), - "there lived a minotaur named", - strong("Fred."), - ), - hr; -=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS +CGI.pm supports NPH scripts with a special NPH mode. When in this +mode, CGI.pm will output the necessary extra header information when +the header() and redirect() methods are +called. -The HTML methods will accept zero, one or multiple arguments. If you -provide no arguments, you get a single tag: +The Microsoft Internet Information Server requires NPH mode. As of version +2.30, CGI.pm will automatically detect when the script is running under IIS +and put itself into this mode. You do not need to do this manually, although +it won't hurt anything if you do. - print hr; - # gives "<hr>" +There are a number of ways to put CGI.pm into NPH mode: -If you provide one or more string arguments, they are concatenated -together with spaces and placed between opening and closing tags: +=over 4 - print h1("Chapter","1"); - # gives "<h1>Chapter 1</h1>" +=item In the B<use> statement -If the first argument is an associative array reference, then the keys -and values of the associative array become the HTML tag's attributes: +Simply add the "-nph" pragmato the list of symbols to be imported into +your script: - print a({href=>'fred.html',target=>'_new'}, - "Open a new frame"); - # gives <a href="fred.html",target="_new">Open a new frame</a> + use CGI qw(:standard -nph) -You are free to use CGI.pm-style dashes in front of the attribute -names if you prefer: +=item By calling the B<nph()> method: - print img {-src=>'fred.gif',-align=>'LEFT'}; - # gives <img ALIGN="LEFT" SRC="fred.gif"> +Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program. -=head2 Generating new HTML tags + CGI->nph(1) -Since no mere mortal can keep up with Netscape and Microsoft as they -battle it out for control of HTML, the code that generates HTML tags -is general and extensible. You can create new HTML tags freely just -by referring to them on the import line: +=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements: - use CGI shortcuts,winkin,blinkin,nod; + print $q->header(-nph=>1); -Now, in addition to the standard CGI shortcuts, you've created HTML -tags named "winkin", "blinkin" and "nod". You can use them like this: +=back - print blinkin {color=>'blue',rate=>'fast'},"Yahoo!"; - # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin> +=head1 Server Push + +CGI.pm provides three simple functions for producing multipart +documents of the type needed to implement server push. These +functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To +import these into your namespace, you must import the ":push" set. +You are also advised to put the script into NPH mode and to set $| to +1 to avoid buffering problems. + +Here is a simple script that demonstrates server push: + + #!/usr/local/bin/perl + use CGI qw/:push -nph/; + $| = 1; + print multipart_init(-boundary=>'----------------here we go!'); + while (1) { + print multipart_start(-type=>'text/plain'), + "The current time is ",scalar(localtime),"\n", + multipart_end; + sleep 1; + } -=head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE +This script initializes server push by calling B<multipart_init()>. +It then enters an infinite loop in which it begins a new multipart +section by calling B<multipart_start()>, prints the current local time, +and ends a multipart section with B<multipart_end()>. It then sleeps +a second, and begins again. -As a convenience, you can import most of the CGI method calls directly -into your name space. The syntax for doing this is: +=over 4 - use CGI <list of methods>; +=item multipart_init() + + multipart_init(-boundary=>$boundary); -The listed methods will be imported into the current package; you can -call them directly without creating a CGI object first. This example -shows how to import the B<param()> and B<header()> -methods, and then use them directly: +Initialize the multipart system. The -boundary argument specifies +what MIME boundary string to use to separate parts of the document. +If not provided, CGI.pm chooses a reasonable boundary for you. - use CGI param,header; - print header('text/plain'); - $zipcode = param('zipcode'); +=item multipart_start() -You can import groups of methods by referring to a number of special -names: + multipart_start(-type=>$type) -=over 4 +Start a new part of the multipart document using the specified MIME +type. If not specified, text/html is assumed. -=item B<cgi> +=item multipart_end() -Import all CGI-handling methods, such as B<param()>, B<path_info()> -and the like. + multipart_end() -=item B<form> +End a part. You must remember to call multipart_end() once for each +multipart_start(). -Import all fill-out form generating methods, such as B<textfield()>. +=back -=item B<html2> +Users interested in server push applications should also have a look +at the CGI::Push module. -Import all methods that generate HTML 2.0 standard elements. +=head1 Avoiding Denial of Service Attacks -=item B<html3> +A potential problem with CGI.pm is that, by default, it attempts to +process form POSTings no matter how large they are. A wily hacker +could attack your site by sending a CGI script a huge POST of many +megabytes. CGI.pm will attempt to read the entire POST into a +variable, growing hugely in size until it runs out of memory. While +the script attempts to allocate the memory the system may slow down +dramatically. This is a form of denial of service attack. -Import all methods that generate HTML 3.0 proposed elements (such as -<table>, <super> and <sub>). +Another possible attack is for the remote user to force CGI.pm to +accept a huge file upload. CGI.pm will accept the upload and store it +in a temporary directory even if your script doesn't expect to receive +an uploaded file. CGI.pm will delete the file automatically when it +terminates, but in the meantime the remote user may have filled up the +server's disk space, causing problems for other programs. -=item B<netscape> +The best way to avoid denial of service attacks is to limit the amount +of memory, CPU time and disk space that CGI scripts can use. Some Web +servers come with built-in facilities to accomplish this. In other +cases, you can use the shell I<limit> or I<ulimit> +commands to put ceilings on CGI resource usage. -Import all methods that generate Netscape-specific HTML extensions. -=item B<shortcuts> +CGI.pm also has some simple built-in protections against denial of +service attacks, but you must activate them before you can use them. +These take the form of two global variables in the CGI name space: -Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + -'netscape')... +=over 4 -=item B<standard> +=item B<$CGI::POST_MAX> -Import "standard" features, 'html2', 'form' and 'cgi'. +If set to a non-negative integer, this variable puts a ceiling +on the size of POSTings, in bytes. If CGI.pm detects a POST +that is greater than the ceiling, it will immediately exit with an error +message. This value will affect both ordinary POSTs and +multipart POSTs, meaning that it limits the maximum size of file +uploads as well. You should set this to a reasonably high +value, such as 1 megabyte. -=item B<all> +=item B<$CGI::DISABLE_UPLOADS> -Import all the available methods. For the full list, see the CGI.pm -code, where the variable %TAGS is defined. +If set to a non-zero value, this will disable file uploads +completely. Other fill-out form values will work as usual. =back -Note that in the interests of execution speed CGI.pm does B<not> use -the standard L<Exporter> syntax for specifying load symbols. This may -change in the future. - -If you import any of the state-maintaining CGI or form-generating -methods, a default CGI object will be created and initialized -automatically the first time you use any of the methods that require -one to be present. This includes B<param()>, B<textfield()>, -B<submit()> and the like. (If you need direct access to the CGI -object, you can find it in the global variable B<$CGI::Q>). By -importing CGI.pm methods, you can create visually elegant scripts: - - use CGI standard,html2; - print - header, - start_html('Simple Script'), - h1('Simple Script'), - start_form, - "What's your name? ",textfield('name'),p, - "What's the combination?", - checkbox_group(-name=>'words', - -values=>['eenie','meenie','minie','moe'], - -defaults=>['eenie','moe']),p, - "What's your favorite color?", - popup_menu(-name=>'color', - -values=>['red','green','blue','chartreuse']),p, - submit, - end_form, - hr,"\n"; +You can use these variables in either of two ways. - if (param) { - print - "Your name is ",em(param('name')),p, - "The keywords are: ",em(join(", ",param('words'))),p, - "Your favorite color is ",em(param('color')),".\n"; - } - print end_html; +=over 4 -=head1 USING NPH SCRIPTS +=item B<1. On a script-by-script basis> -NPH, or "no-parsed-header", scripts bypass the server completely by -sending the complete HTTP header directly to the browser. This has -slight performance benefits, but is of most use for taking advantage -of HTTP extensions that are not directly supported by your server, -such as server push and PICS headers. +Set the variable at the top of the script, right after the "use" statement: -Servers use a variety of conventions for designating CGI scripts as -NPH. Many Unix servers look at the beginning of the script's name for -the prefix "nph-". The Macintosh WebSTAR server and Microsoft's -Internet Information Server, in contrast, try to decide whether a -program is an NPH script by examining the first line of script output. + use CGI qw/:standard/; + use CGI::Carp 'fatalsToBrowser'; + $CGI::POST_MAX=1024 * 100; # max 100K posts + $CGI::DISABLE_UPLOADS = 1; # no uploads +=item B<2. Globally for all scripts> -CGI.pm supports NPH scripts with a special NPH mode. When in this -mode, CGI.pm will output the necessary extra header information when -the header() and redirect() methods are -called. +Open up CGI.pm, find the definitions for $POST_MAX and +$DISABLE_UPLOADS, and set them to the desired values. You'll +find them towards the top of the file in a subroutine named +initialize_globals(). -The Microsoft Internet Information Server requires NPH mode. As of version -2.30, CGI.pm will automatically detect when the script is running under IIS -and put itself into this mode. You do not need to do this manually, although -it won't hurt anything if you do. - -There are a number of ways to put CGI.pm into NPH mode: +=back -=over 4 +Since an attempt to send a POST larger than $POST_MAX bytes +will cause a fatal error, you might want to use CGI::Carp to echo the +fatal error message to the browser window as shown in the example +above. Otherwise the remote user will see only a generic "Internal +Server" error message. See the L<CGI::Carp> manual page for more +details. -=item In the B<use> statement -Simply add ":nph" to the list of symbols to be imported into your script: +=head1 COMPATIBILITY WITH CGI-LIB.PL - use CGI qw(:standard :nph) +To make it easier to port existing programs that use cgi-lib.pl +the compatibility routine "ReadParse" is provided. Porting is +simple: -=item By calling the B<nph()> method: +OLD VERSION + require "cgi-lib.pl"; + &ReadParse; + print "The value of the antique is $in{antique}.\n"; -Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program. +NEW VERSION + use CGI; + CGI::ReadParse + print "The value of the antique is $in{antique}.\n"; - CGI->nph(1) +CGI.pm's ReadParse() routine creates a tied variable named %in, +which can be accessed to obtain the query variables. Like +ReadParse, you can also provide your own variable. Infrequently +used features of ReadParse, such as the creation of @in and $in +variables, are not supported. -=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements: +Once you use ReadParse, you can retrieve the query object itself +this way: - print $q->header(-nph=>1); + $q = $in{CGI}; + print $q->textfield(-name=>'wow', + -value=>'does this really work?'); -=back +This allows you to start using the more interesting features +of CGI.pm without rewriting your old scripts from scratch. =head1 AUTHOR INFORMATION -Copyright 1995,1996, Lincoln D. Stein. All rights reserved. It may -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Address bug reports and comments to: lstein@cshl.org. When sending +bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and +version of the operating system you are using. If the problem is even +remotely browser dependent, please provide information about the +affected browers as well. =head1 CREDITS @@ -4972,7 +6085,7 @@ Thanks very much to: =item Joergen Haegg (jh@axis.se) -=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu) +=item Laurent Delfosse (delfosse@delfosse.com) =item Richard Resnick (applepi1@aol.com) @@ -4996,6 +6109,10 @@ Thanks very much to: =item David Alan Pisoni (david@cnation.com) +=item Doug MacEachern (dougm@opengroup.org) + +=item Robin Houston (robin@oneworld.org) + =item ...and many many more... for suggestions and bug fixes. @@ -5060,7 +6177,7 @@ for suggestions and bug fixes. -rows=>10, -columns=>50); - print "<P>",$query->reset; + print "<P>",$query->Reset; print $query->submit('Action','Shout'); print $query->submit('Action','Scream'); print $query->endform; @@ -5101,8 +6218,8 @@ warnings when programs are run with the B<-w> switch. =head1 SEE ALSO L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>, -L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>, -L<CGI::Push>, L<CGI::Fast> +L<CGI::Base>, L<CGI::Form>, L<CGI::Push>, L<CGI::Fast>, +L<CGI::Pretty> =cut diff --git a/gnu/usr.bin/perl/lib/CGI/Apache.pm b/gnu/usr.bin/perl/lib/CGI/Apache.pm index 6ea7523c571..d155f69439c 100644 --- a/gnu/usr.bin/perl/lib/CGI/Apache.pm +++ b/gnu/usr.bin/perl/lib/CGI/Apache.pm @@ -4,7 +4,7 @@ use vars qw(@ISA $VERSION); require CGI; @ISA = qw(CGI); -$VERSION = (qw$Revision: 1.1 $)[1]; +$VERSION = (qw$Revision: 1.2 $)[1]; $CGI::DefaultClass = 'CGI::Apache'; $CGI::Apache::AutoloadClass = 'CGI'; @@ -78,7 +78,7 @@ CGI::Apache - Make things work with CGI.pm against Perl-Apache API =head1 DESCRIPTION When using the Perl-Apache API, your applications are faster, but the -enviroment is different than CGI. +environment is different than CGI. This module attempts to set-up that environment as best it can. =head1 NOTE 1 @@ -98,6 +98,6 @@ perl(1), Apache(3), CGI(3) =head1 AUTHOR -Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas König E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt> +Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt> =cut diff --git a/gnu/usr.bin/perl/lib/CGI/Carp.pm b/gnu/usr.bin/perl/lib/CGI/Carp.pm index 4cd79467fd8..dfae1a61b73 100644 --- a/gnu/usr.bin/perl/lib/CGI/Carp.pm +++ b/gnu/usr.bin/perl/lib/CGI/Carp.pm @@ -14,6 +14,12 @@ B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log warn "I'm confused"; die "I'm dying.\n"; + use CGI::Carp qw(cluck); + cluck "I wouldn't do that if I were you"; + + use CGI::Carp qw(fatalsToBrowser); + die "Fatal error messages are now sent to browser"; + =head1 DESCRIPTION CGI scripts have a nasty habit of leaving warning messages in the error @@ -87,6 +93,8 @@ accepted as well: ... and so on +FileHandle and other objects work as well. + Use of carpout() is not great for performance, so it is recommended for debugging purposes or for moderate-use applications. A future version of this module may delay redirecting STDERR until one of the @@ -106,6 +114,34 @@ occur in the early compile phase will be seen. Nonfatal errors will still be directed to the log file only (unless redirected with carpout). +=head2 Changing the default message + +By default, the software error message is followed by a note to +contact the Webmaster by e-mail with the time and date of the error. +If this message is not to your liking, you can change it using the +set_message() routine. This is not imported by default; you should +import it on the use() line: + + use CGI::Carp qw(fatalsToBrowser set_message); + set_message("It's not a bug, it's a feature!"); + +You may also pass in a code reference in order to create a custom +error message. At run time, your code will be called with the text +of the error message that caused the script to die. Example: + + use CGI::Carp qw(fatalsToBrowser set_message); + BEGIN { + sub handle_errors { + my $msg = shift; + print "<h1>Oh gosh</h1>"; + print "Got an error: $msg"; + } + set_message(\&handle_errors); + } + +In order to correctly intercept compile-time errors, you should call +set_message() from within a BEGIN{} block. + =head1 CHANGE LOG 1.05 carpout() added and minor corrections by Marc Hedlund @@ -114,11 +150,32 @@ with carpout). 1.06 fatalsToBrowser() no longer aborts for fatal errors within eval() statements. +1.08 set_message() added and carpout() expanded to allow for FileHandle + objects. + +1.09 set_message() now allows users to pass a code REFERENCE for + really custom error messages. croak and carp are now + exported by default. Thanks to Gunther Birznieks for the + patches. + +1.10 Patch from Chris Dean (ctdean@cogit.com) to allow + module to run correctly under mod_perl. + +1.11 Changed order of > and < escapes. + +1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. + +1.13 Added cluck() to make the module orthogonal with Carp. + More mod_perl related fixes. + =head1 AUTHORS -Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute -this under the Perl Artistic License. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. +Address bug reports and comments to: lstein@cshl.org =head1 SEE ALSO @@ -133,18 +190,19 @@ use Carp; @ISA = qw(Exporter); @EXPORT = qw(confess croak carp); -@EXPORT_OK = qw(carpout fatalsToBrowser); +@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck); $main::SIG{__WARN__}=\&CGI::Carp::warn; $main::SIG{__DIE__}=\&CGI::Carp::die; -$CGI::Carp::VERSION = '1.06'; +$CGI::Carp::VERSION = '1.13'; +$CGI::Carp::CUSTOM_MSG = undef; # fancy import routine detects and handles 'errorWrap' specially. sub import { my $pkg = shift; my(%routines); - grep($routines{$_}++,@_); - $WRAP++ if $routines{'fatalsToBrowser'}; + grep($routines{$_}++,@_,@EXPORT); + $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; my($oldlevel) = $Exporter::ExportLevel; $Exporter::ExportLevel = 1; Exporter::import($pkg,keys %routines); @@ -152,8 +210,8 @@ sub import { } # These are the originals -sub realwarn { warn(@_); } -sub realdie { die(@_); } +sub realwarn { CORE::warn(@_); } +sub realdie { CORE::die(@_); } sub id { my $level = shift; @@ -183,26 +241,40 @@ sub warn { realwarn $message; } +# The mod_perl package Apache::Registry loads CGI programs by calling +# eval. These evals don't count when looking at the stack backtrace. +sub _longmess { + my $message = Carp::longmess(); + my $mod_perl = exists $ENV{MOD_PERL}; + $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl; + return( $message ); +} + sub die { my $message = shift; my $time = scalar(localtime); my($file,$line,$id) = id(1); - return undef if $file=~/^\(eval/; - $message .= " at $file line $line.\n" unless $message=~/\n$/; - &fatalsToBrowser($message) if $WRAP; + $message .= " at $file line $line." unless $message=~/\n$/; + &fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m; my $stamp = stamp; $message=~s/^/$stamp/gm; realdie $message; } +sub set_message { + $CGI::Carp::CUSTOM_MSG = shift; + return $CGI::Carp::CUSTOM_MSG; +} + # Avoid generating "subroutine redefined" warnings with the following # hack: { local $^W=0; eval <<EOF; sub confess { CGI::Carp::die Carp::longmess \@_; } -sub croak { CGI::Carp::die Carp::shortmess \@_; } -sub carp { CGI::Carp::warn Carp::shortmess \@_; } +sub croak { CGI::Carp::die Carp::shortmess \@_; } +sub carp { CGI::Carp::warn Carp::shortmess \@_; } +sub cluck { CGI::Carp::warn Carp::longmess \@_; } EOF ; } @@ -211,14 +283,8 @@ EOF # or a string. sub carpout { my($in) = @_; - $in = $$in if ref($in); # compatability with Marc's method; - my($no) = fileno($in); - unless (defined($no)) { - my($package) = caller; - my($handle) = $in=~/[':]/ ? $in : "$package\:\:$in"; - $no = fileno($handle); - } - die "Invalid filehandle $in\n" unless $no; + my($no) = fileno(to_filehandle($in)); + realdie("Invalid filehandle $in\n") unless defined $no; open(SAVEERR, ">&STDERR"); open(STDERR, ">&$no") or @@ -228,15 +294,72 @@ sub carpout { # headers sub fatalsToBrowser { my($msg) = @_; + $msg=~s/&/&/g; $msg=~s/>/>/g; $msg=~s/</</g; - print STDOUT "Content-type: text/html\n\n"; - print STDOUT <<END; + $msg=~s/\"/"/g; + my($wm) = $ENV{SERVER_ADMIN} ? + qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : + "this site's webmaster"; + my ($outer_message) = <<END; +For help, please send mail to $wm, giving this error message +and the time and date of the error. +END + ; + my $mod_perl = exists $ENV{MOD_PERL}; + print STDOUT "Content-type: text/html\n\n" + unless $mod_perl; + + if ($CUSTOM_MSG) { + if (ref($CUSTOM_MSG) eq 'CODE') { + &$CUSTOM_MSG($msg); # nicer to perl 5.003 users + return; + } else { + $outer_message = $CUSTOM_MSG; + } + } + + my $mess = <<END; <H1>Software error:</H1> <CODE>$msg</CODE> <P> -Please send mail to this site's webmaster for help. +$outer_message END + ; + + if ($mod_perl) { + my $r = Apache->request; + # If bytes have already been sent, then + # we print the message out directly. + # Otherwise we make a custom error + # handler to produce the doc for us. + if ($r->bytes_sent) { + $r->print($mess); + $r->exit; + } else { + $r->status(500); + $r->custom_response(500,$mess); + } + } else { + print STDOUT $mess; + } +} + +# Cut and paste from CGI.pm so that we don't have the overhead of +# always loading the entire CGI module. +sub to_filehandle { + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } + } + return undef; } 1; diff --git a/gnu/usr.bin/perl/lib/CGI/Fast.pm b/gnu/usr.bin/perl/lib/CGI/Fast.pm index 03b54072c96..a39fe052e86 100644 --- a/gnu/usr.bin/perl/lib/CGI/Fast.pm +++ b/gnu/usr.bin/perl/lib/CGI/Fast.pm @@ -16,7 +16,7 @@ package CGI::Fast; # The most recent version and complete docs are available at: # http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html # ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ -$CGI::Fast::VERSION='1.00a'; +$CGI::Fast::VERSION='1.01'; use CGI; use FCGI; @@ -34,9 +34,11 @@ sub save_request { # New is slightly different in that it calls FCGI's # accept() method. sub new { - return undef unless FCGI::accept() >= 0; - my($self,@param) = @_; - return $CGI::Q = $self->SUPER::new(@param); + my ($self, $initializer, @param) = @_; + unless (defined $initializer) { + return undef unless FCGI::accept() >= 0; + } + return $CGI::Q = $self->SUPER::new($initializer, @param); } 1; @@ -154,13 +156,12 @@ I haven't tested this very much. =head1 AUTHOR INFORMATION -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1996-1998, Lincoln D. Stein. All rights reserved. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Address bug reports and comments to: lstein@cshl.org =head1 BUGS diff --git a/gnu/usr.bin/perl/lib/CGI/Push.pm b/gnu/usr.bin/perl/lib/CGI/Push.pm index 4390d0383e6..e4a66aee72d 100644 --- a/gnu/usr.bin/perl/lib/CGI/Push.pm +++ b/gnu/usr.bin/perl/lib/CGI/Push.pm @@ -14,23 +14,25 @@ package CGI::Push; # listing the modifications you have made. # The most recent version and complete docs are available at: -# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html -# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ +# http://stein.cshl.org/WWW/software/CGI/ -$CGI::Push::VERSION='1.00'; +$CGI::Push::VERSION='1.01'; use CGI; @ISA = ('CGI'); -# add do_push() to exported tags -push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push'); +$CGI::DefaultClass = 'CGI::Push'; +$CGI::Push::AutoloadClass = 'CGI'; + +# add do_push() and push_delay() to exported tags +push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay'); sub do_push { - my ($self,@p) = CGI::self_or_CGI(@_); + my ($self,@p) = CGI::self_or_default(@_); # unbuffer output $| = 1; srand; - my ($random) = rand()*1E16; + my ($random) = sprintf("%16.0f",rand()*1E16); my ($boundary) = "----------------------------------$random"; my (@header); @@ -39,6 +41,7 @@ sub do_push { $type = 'text/html' unless $type; $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE'; $delay = 1 unless defined($delay); + $self->push_delay($delay); my(@o); foreach (@other) { push(@o,split("=")); } @@ -55,15 +58,18 @@ sub do_push { my @contents; while (1) { last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]); - print "Content-type: ${type}$CGI::CRLF$CGI::CRLF"; + print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" + unless $type eq 'dynamic'; print @contents,"$CGI::CRLF"; print "${boundary}$CGI::CRLF"; - do_sleep($delay) if $delay; + do_sleep($self->push_delay()) if $self->push_delay(); + } + + # Optional last page + if ($last_page && ref($last_page) eq 'CODE') { + print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i; + print &$last_page($self,$COUNTER),"$CGI::CRLF${boundary}$CGI::CRLF"; } - print "Content-type: ${type}$CGI::CRLF$CGI::CRLF", - &$last_page($self,++$COUNTER), - "$CGI::CRLF${boundary}$CGI::CRLF" - if $last_page && ref($last_page) eq 'CODE'; } sub simple_counter { @@ -87,6 +93,12 @@ sub do_sleep { } } +sub push_delay { + my ($self,$delay) = CGI::self_or_default(@_); + return defined($delay) ? $self->{'.delay'} = + $delay : $self->{'.delay'}; +} + 1; =head1 NAME @@ -176,6 +188,9 @@ redrawing loop and print out the final page (if any) "This page called $counter times"; } +You are of course free to refer to create and use global variables +within your draw routine in order to achieve special effects. + =item -last_page This optional parameter points to a reference to the subroutine @@ -187,8 +202,12 @@ itself should have exactly the same calling conventions as the =item -type This optional parameter indicates the content type of each page. It -defaults to "text/html". Currently, server push of heterogeneous -document types is not supported. +defaults to "text/html". Normally the module assumes that each page +is of a homogenous MIME type. However if you provide either of the +magic values "heterogeneous" or "dynamic" (the latter provided for the +convenience of those who hate long parameter names), you can specify +the MIME type -- and other header fields -- on a per-page basis. See +"heterogeneous pages" for more details. =item -delay @@ -204,6 +223,60 @@ CGI::header(). =back +=head2 Heterogeneous Pages + +Ordinarily all pages displayed by CGI::Push share a common MIME type. +However by providing a value of "heterogeneous" or "dynamic" in the +do_push() -type parameter, you can specify the MIME type of each page +on a case-by-case basis. + +If you use this option, you will be responsible for producing the +HTTP header for each page. Simply modify your draw routine to +look like this: + + sub my_draw_routine { + my($q,$counter) = @_; + return header('text/html'), # note we're producing the header here + start_html('testing'), + h1('testing'), + "This page called $counter times"; + } + +You can add any header fields that you like, but some (cookies and +status fields included) may not be interpreted by the browser. One +interesting effect is to display a series of pages, then, after the +last page, to redirect the browser to a new URL. Because redirect() +does b<not> work, the easiest way is with a -refresh header field, +as shown below: + + sub my_draw_routine { + my($q,$counter) = @_; + return undef if $counter > 10; + return header('text/html'), # note we're producing the header here + start_html('testing'), + h1('testing'), + "This page called $counter times"; + } + + sub my_last_page { + header(-refresh=>'5; URL=http://somewhere.else/finished.html', + -type=>'text/html'), + start_html('Moved'), + h1('This is the last page'), + 'Goodbye!' + hr, + end_html; + } + +=head2 Changing the Page Delay on the Fly + +If you would like to control the delay between pages on a page-by-page +basis, call push_delay() from within your draw routine. push_delay() +takes a single numeric argument representing the number of seconds you +wish to delay after the current page is displayed and before +displaying the next one. The delay may be fractional. Without +parameters, push_delay() just returns the current delay. + =head1 INSTALLING CGI::Push SCRIPTS Server push scripts B<must> be installed as no-parsed-header (NPH) @@ -213,19 +286,14 @@ Recognition of NPH scripts happens automatically with WebSTAR and Microsoft IIS. Users of other servers should see their documentation for help. -=head1 CAVEATS - -This is a new module. It hasn't been extensively tested. - =head1 AUTHOR INFORMATION -be used and modified freely, but I do request that this copyright -notice remain attached to the file. You may modify this module as you -wish, but if you redistribute a modified version, please attach a note -listing the modifications you have made. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. -Address bug reports and comments to: -lstein@genome.wi.mit.edu +Address bug reports and comments to: lstein@cshl.org =head1 BUGS diff --git a/gnu/usr.bin/perl/lib/CGI/Switch.pm b/gnu/usr.bin/perl/lib/CGI/Switch.pm index 420fff7643c..8afc6a6cb34 100644 --- a/gnu/usr.bin/perl/lib/CGI/Switch.pm +++ b/gnu/usr.bin/perl/lib/CGI/Switch.pm @@ -2,7 +2,7 @@ package CGI::Switch; use Carp; use strict; use vars qw($VERSION @Pref); -$VERSION = '0.05'; +$VERSION = '0.06'; @Pref = qw(CGI::Apache CGI); #default sub import { @@ -33,13 +33,6 @@ sub new { Carp::croak "Couldn't load+construct any of @Pref\n"; } -# there's a trick in Lincoln's package that determines the calling -# package. The reason is to have a filehandle with the same name as -# the filename. To tell this trick that we are not the calling -# package we have to follow this dirty convention. It's a questionable -# trick imho, but for now I want to have something working -sub isaCGI { 1 } - 1; __END__ @@ -73,6 +66,6 @@ perl(1), Apache(3), CGI(3), CGI::XA(3) =head1 AUTHOR -Andreas König E<lt>a.koenig@mind.deE<gt> +Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt> =cut diff --git a/gnu/usr.bin/perl/lib/CPAN.pm b/gnu/usr.bin/perl/lib/CPAN.pm index 2b0f6cce5dd..5e2126912b2 100644 --- a/gnu/usr.bin/perl/lib/CPAN.pm +++ b/gnu/usr.bin/perl/lib/CPAN.pm @@ -1,24 +1,25 @@ package CPAN; -use vars qw{$Try_autoload $Revision +use vars qw{$Try_autoload + $Revision $META $Signal $Cwd $End $Suppress_readline %Dontload - $Frontend - }; + $Frontend $Defaultsite + }; #}; -$VERSION = '1.3102'; +$VERSION = '1.48'; -# $Id: CPAN.pm,v 1.1 1997/11/30 07:56:39 millert Exp $ +# $Id: CPAN.pm,v 1.2 1999/04/29 22:51:43 millert Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.1 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.2 $, 10)."]"; use Carp (); use Config (); use Cwd (); use DirHandle; use Exporter (); -use ExtUtils::MakeMaker (); +use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1; use File::Basename (); use File::Copy (); use File::Find; @@ -27,10 +28,11 @@ use FileHandle (); use Safe (); use Text::ParseWords (); use Text::Wrap; +use File::Spec; END { $End++; &cleanup; } -%CPAN::DEBUG = qw( +%CPAN::DEBUG = qw[ CPAN 1 Index 2 InfoObj 4 @@ -44,23 +46,19 @@ END { $End++; &cleanup; } Shell 1024 Eval 2048 Config 4096 - ); + Tarzip 8192 +]; $CPAN::DEBUG ||= 0; $CPAN::Signal ||= 0; $CPAN::Frontend ||= "CPAN::Shell"; +$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN"; package CPAN; use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term); use strict qw(vars); -@CPAN::ISA = qw(CPAN::Debug Exporter MM); # MM will go away - # soonish. Already version - # 1.29 doesn't rely on - # catfile and catdir being - # available via - # inheritance. Anything else - # in danger? +@CPAN::ISA = qw(CPAN::Debug Exporter); @EXPORT = qw( autobundle bundle expand force get @@ -73,6 +71,7 @@ sub AUTOLOAD { $l =~ s/.*:://; my(%EXPORT); @EXPORT{@EXPORT} = ''; + CPAN::Config->load unless $CPAN::Config_loaded++; if (exists $EXPORT{$l}){ CPAN::Shell->$l(@_); } else { @@ -90,7 +89,9 @@ sub AUTOLOAD { #-> sub CPAN::shell ; sub shell { + my($self) = @_; $Suppress_readline ||= ! -t STDIN; + CPAN::Config->load unless $CPAN::Config_loaded++; my $prompt = "cpan> "; local($^W) = 1; @@ -98,8 +99,20 @@ sub shell { require Term::ReadLine; # import Term::ReadLine; $term = Term::ReadLine->new('CPAN Monitor'); - $readline::rl_completion_function = - $readline::rl_completion_function = 'CPAN::Complete::cpl'; + if ($term->ReadLine eq "Term::ReadLine::Gnu") { + my $attribs = $term->Attribs; +# $attribs->{completion_entry_function} = +# $attribs->{'list_completion_function'}; + $attribs->{attempted_completion_function} = sub { + &CPAN::Complete::gnu_cpl; + } +# $attribs->{completion_word} = +# [qw(help me somebody to find out how +# to use completion with GNU)]; + } else { + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } } no strict; @@ -107,6 +120,7 @@ sub shell { my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my $cwd = CPAN->$getcwd(); + my $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub"; my $rl_avail = $Suppress_readline ? "suppressed" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (try ``install Bundle::CPAN'')"; @@ -129,8 +143,8 @@ ReadLine support $rl_avail $_ = "$continuation$_" if $continuation; s/^\s+//; next if /^$/; - $_ = 'h' if $_ eq '?'; - if (/^q(?:uit)?$/i) { + $_ = 'h' if /^\s*\?/; + if (/^(?:q(?:uit)?|bye|exit)$/i) { last; } elsif (s/\\$//s) { chomp; @@ -165,12 +179,25 @@ ReadLine support $rl_avail $prompt = "cpan> "; } } continue { - &cleanup, $CPAN::Frontend->mydie("Goodbye\n") if $Signal; + $Signal=0; + CPAN::Queue->nullify_queue; + if ($try_detect_readline) { + if ($CPAN::META->has_inst("Term::ReadLine::Gnu") + || + $CPAN::META->has_inst("Term::ReadLine::Perl") + ) { + delete $INC{"Term/ReadLine.pm"}; + my $redef; + local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef); + require Term::ReadLine; + $CPAN::Frontend->myprint("\n$redef subroutines in Term::ReadLine redefined\n"); + goto &shell; + } + } } } package CPAN::CacheMgr; -use vars qw($Du); @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); use File::Find; @@ -220,6 +247,7 @@ use vars qw($AUTOLOAD $redef @ISA); sub AUTOLOAD { my($autoload) = $AUTOLOAD; my $class = shift(@_); + # warn "autoload[$autoload] class[$class]"; $autoload =~ s/.*:://; if ($autoload =~ /^w/) { if ($CPAN::META->has_inst('CPAN::WAIT')) { @@ -228,7 +256,7 @@ sub AUTOLOAD { $CPAN::Frontend->mywarn(qq{ Commands starting with "w" require CPAN::WAIT to be installed. Please consider installing CPAN::WAIT to use the fulltext index. -For this you just need to type +For this you just need to type install CPAN::WAIT }); } @@ -258,7 +286,7 @@ sub try_dot_al { if (defined($name=$INC{"$pkg.pm"})) { $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|; - $name = undef unless (-r $name); + $name = undef unless (-r $name); } unless (defined $name) { @@ -273,7 +301,7 @@ sub try_dot_al { *$autoload = sub {}; $ok = 1; } else { - if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){ eval {local $SIG{__DIE__};require $name}; } if ($@){ @@ -284,7 +312,9 @@ sub try_dot_al { } } } else { - $ok = 1; + + $ok = 1; + } $@ = $save; # my $lm = Carp::longmess(); @@ -301,7 +331,7 @@ sub try_dot_al { # $Try_autoload = 1; if ($CPAN::Try_autoload) { - my $p; + my $p; for $p (qw( CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP @@ -311,14 +341,132 @@ if ($CPAN::Try_autoload) { } } +package CPAN::Tarzip; +use vars qw($AUTOLOAD @ISA); +@CPAN::Tarzip::ISA = qw(CPAN::Debug); + +package CPAN::Queue; + +# One use of the queue is to determine if we should or shouldn't +# announce the availability of a new CPAN module + +# Now we try to use it for dependency tracking. For that to happen +# we need to draw a dependency tree and do the leaves first. This can +# easily be reached by running CPAN.pm recursively, but we don't want +# to waste memory and run into deep recursion. So what we can do is +# this: + +# CPAN::Queue is the package where the queue is maintained. Dependencies +# often have high priority and must be brought to the head of the queue, +# possibly by jumping the queue if they are already there. My first code +# attempt tried to be extremely correct. Whenever a module needed +# immediate treatment, I either unshifted it to the front of the queue, +# or, if it was already in the queue, I spliced and let it bypass the +# others. This became a too correct model that made it impossible to put +# an item more than once into the queue. Why would you need that? Well, +# you need temporary duplicates as the manager of the queue is a loop +# that +# +# (1) looks at the first item in the queue without shifting it off +# +# (2) cares for the item +# +# (3) removes the item from the queue, *even if its agenda failed and +# even if the item isn't the first in the queue anymore* (that way +# protecting against never ending queues) +# +# So if an item has prerequisites, the installation fails now, but we +# want to retry later. That's easy if we have it twice in the queue. +# +# I also expect insane dependency situations where an item gets more +# than two lives in the queue. Simplest example is triggered by 'install +# Foo Foo Foo'. People make this kind of mistakes and I don't want to +# get in the way. I wanted the queue manager to be a dumb servant, not +# one that knows everything. +# +# Who would I tell in this model that the user wants to be asked before +# processing? I can't attach that information to the module object, +# because not modules are installed but distributions. So I'd have to +# tell the distribution object that it should ask the user before +# processing. Where would the question be triggered then? Most probably +# in CPAN::Distribution::rematein. +# Hope that makes sense, my head is a bit off:-) -- AK + +use vars qw{ @All }; -package CPAN; +sub new { + my($class,$mod) = @_; + my $self = bless {mod => $mod}, $class; + push @All, $self; + # my @all = map { $_->{mod} } @All; + # warn "Adding Queue object for mod[$mod] all[@all]"; + return $self; +} -$META ||= CPAN->new; # In case we reeval ourselves we - # need a || +sub first { + my $obj = $All[0]; + $obj->{mod}; +} + +sub delete_first { + my($class,$what) = @_; + my $i; + for my $i (0..$#All) { + if ( $All[$i]->{mod} eq $what ) { + splice @All, $i, 1; + return; + } + } +} + +sub jumpqueue { + my $class = shift; + my @what = @_; + my $obj; + WHAT: for my $what (reverse @what) { + my $jumped = 0; + for (my $i=0; $i<$#All;$i++) { #prevent deep recursion + if ($All[$i]->{mod} eq $what){ + $jumped++; + if ($jumped > 100) { # one's OK if e.g. just processing now; + # more are OK if user typed it several + # times + $CPAN::Frontend->mywarn( +qq{Object [$what] queued more than 100 times, ignoring} + ); + next WHAT; + } + } + } + my $obj = bless { mod => $what }, $class; + unshift @All, $obj; + } +} -# Do this after you have set up the whole inheritance -CPAN::Config->load unless defined $CPAN::No_Config_is_ok; +sub exists { + my($self,$what) = @_; + my @all = map { $_->{mod} } @All; + my $exists = grep { $_->{mod} eq $what } @All; + # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]"; + $exists; +} + +sub delete { + my($self,$mod) = @_; + @All = grep { $_->{mod} ne $mod } @All; + # my @all = map { $_->{mod} } @All; + # warn "Deleting Queue object for mod[$mod] all[@all]"; +} + +sub nullify_queue { + @All = (); +} + + + +package CPAN; + +$META ||= CPAN->new; # In case we re-eval ourselves we need the || 1; @@ -342,12 +490,14 @@ sub clean; sub test; #-> sub CPAN::all ; -sub all { +sub all_objects { my($mgr,$class) = @_; + CPAN::Config->load unless $CPAN::Config_loaded++; CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; CPAN::Index->reload; values %{ $META->{$class} }; } +*all = \&all_objects; # Called by shell, not in batch mode. Not clean XXX #-> sub CPAN::checklock ; @@ -420,13 +570,15 @@ or $self->{LOCK} = $lockfile; $fh->close; $SIG{'TERM'} = sub { - &cleanup; - $CPAN::Frontend->mydie("Got SIGTERM, leaving"); + &cleanup; + $CPAN::Frontend->mydie("Got SIGTERM, leaving"); }; $SIG{'INT'} = sub { - my $s = $Signal == 2 ? "a second" : "another"; - &cleanup, $CPAN::Frontend->mydie("Got $s SIGINT") if $Signal; - $Signal = 1; + # no blocks!!! + &cleanup if $Signal; + $CPAN::Frontend->mydie("Got another SIGINT") if $Signal; + print "Caught SIGINT\n"; + $Signal++; }; $SIG{'__DIE__'} = \&cleanup; $self->debug("Signal handler set.") if $CPAN::DEBUG; @@ -452,6 +604,12 @@ sub exists { exists $META->{$class}{$id}; } +#-> sub CPAN::delete ; +sub delete { + my($mgr,$class,$id) = @_; + delete $META->{$class}{$id}; +} + #-> sub CPAN::has_inst sub has_inst { my($self,$mod,$message) = @_; @@ -469,13 +627,18 @@ sub has_inst { $file =~ s|/|\\|g if $^O eq 'MSWin32'; $file .= ".pm"; if ($INC{$file}) { -# warn "$file in %INC"; #debug + # checking %INC is wrong, because $INC{LWP} may be true + # although $INC{"URI/URL.pm"} may have failed. But as + # I really want to say "bla loaded OK", I have to somehow + # cache results. + ### warn "$file in %INC"; #debug return 1; } elsif (eval { require $file }) { # eval is good: if we haven't yet read the database it's # perfect and if we have installed the module in the meantime, # it tries again. The second require is only a NOOP returning # 1 if we had success, otherwise it's retrying + $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n"); if ($mod eq "CPAN::WAIT") { push @CPAN::Shell::ISA, CPAN::WAIT; @@ -496,6 +659,8 @@ sub has_inst { }); sleep 2; + } else { + delete $INC{$file}; # if it inc'd LWP but failed during, say, URI } return 0; } @@ -515,16 +680,30 @@ sub new { #-> sub CPAN::cleanup ; sub cleanup { - local $SIG{__DIE__} = ''; - my $i = 0; my $ineval = 0; my $sub; - while ((undef,undef,undef,$sub) = caller(++$i)) { - $ineval = 1, last if $sub eq '(eval)'; + # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]"; + local $SIG{__DIE__} = ''; + my($message) = @_; + my $i = 0; + my $ineval = 0; + if ( + 0 && # disabled, try reload cpan with it + $] > 5.004_60 # thereabouts + ) { + $ineval = $^S; + } else { + my($subroutine); + while ((undef,undef,undef,$subroutine) = caller(++$i)) { + $ineval = 1, last if + $subroutine eq '(eval)'; } - return if $ineval && !$End; - return unless defined $META->{'LOCK'}; - return unless -f $META->{'LOCK'}; - unlink $META->{'LOCK'}; - $CPAN::Frontend->mywarn("Lockfile removed.\n"); + } + return if $ineval && !$End; + return unless defined $META->{'LOCK'}; + return unless -f $META->{'LOCK'}; + unlink $META->{'LOCK'}; + # require Carp; + # Carp::cluck("DEBUGGING"); + $CPAN::Frontend->mywarn("Lockfile removed.\n"); } package CPAN::CacheMgr; @@ -544,25 +723,21 @@ sub cachesize { shift->{DU}; } -# sub check { -# my($self,@dirs) = @_; -# return unless -d $self->{ID}; -# my $dir; -# @dirs = $self->dirs unless @dirs; -# for $dir (@dirs) { -# $self->disk_usage($dir); -# } -# } - -#-> sub CPAN::CacheMgr::clean_cache ; -#=# sub clean_cache { -#=# my $self = shift; -#=# my $dir; -#=# while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) { -#=# $self->force_clean_cache($dir); -#=# } -#=# $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG; -#=# } +sub tidyup { + my($self) = @_; + return unless -d $self->{ID}; + while ($self->{DU} > $self->{'MAX'} ) { + my($toremove) = shift @{$self->{FIFO}}; + $CPAN::Frontend->myprint(sprintf( + "Deleting from cache". + ": $toremove (%.1f>%.1f MB)\n", + $self->{DU}, $self->{'MAX'}) + ); + return if $CPAN::Signal; + $self->force_clean_cache($toremove); + return if $CPAN::Signal; + } +} #-> sub CPAN::CacheMgr::dir ; sub dir { @@ -579,7 +754,8 @@ sub entries { $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my($cwd) = CPAN->$getcwd(); chdir $dir or Carp::croak("Can't chdir to $dir: $!"); - my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir $dir: $!"); my(@entries); for ($dh->read) { next if $_ eq "." || $_ eq ".."; @@ -598,39 +774,35 @@ sub entries { #-> sub CPAN::CacheMgr::disk_usage ; sub disk_usage { my($self,$dir) = @_; -# if (! defined $dir or $dir eq "") { -# $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG; -# return; -# } - return if $self->{SIZE}{$dir}; - local($Du) = 0; + return if exists $self->{SIZE}{$dir}; + return if $CPAN::Signal; + my($Du) = 0; find( sub { - return if -l $_; - $Du += -s _; + $File::Find::prune++ if $CPAN::Signal; + return if -l $_; + if ($^O eq 'MacOS') { + require Mac::Files; + my $cat = Mac::Files::FSpGetCatInfo($_); + $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen(); + } else { + $Du += (-s _); + } }, $dir ); + return if $CPAN::Signal; $self->{SIZE}{$dir} = $Du/1024/1024; push @{$self->{FIFO}}, $dir; $self->debug("measured $dir is $Du") if $CPAN::DEBUG; $self->{DU} += $Du/1024/1024; - if ($self->{DU} > $self->{'MAX'} ) { - my($toremove) = shift @{$self->{FIFO}}; - $CPAN::Frontend->myprint(sprintf( - "...Hold on a sec... ". - "cleaning from cache ". - "(%.1f>%.1f MB): $toremove\n", - $self->{DU}, $self->{'MAX'}) - ); - $self->force_clean_cache($toremove); - } $self->{DU}; } #-> sub CPAN::CacheMgr::force_clean_cache ; sub force_clean_cache { my($self,$dir) = @_; + return unless -e $dir; $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") if $CPAN::DEBUG; File::Path::rmtree($dir); @@ -647,17 +819,13 @@ sub new { my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, + SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', DU => 0 }; File::Path::mkpath($self->{ID}); my $dh = DirHandle->new($self->{ID}); bless $self, $class; - $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG; - my $e; - for $e ($self->entries) { - next if $e eq ".." || $e eq "."; - $self->disk_usage($e); - } + $self->scan_cache; $t2 = time; $debug .= "timing of CacheMgr->new: ".($t2 - $time); $time = $t2; @@ -665,6 +833,24 @@ sub new { $self; } +#-> sub CPAN::CacheMgr::scan_cache ; +sub scan_cache { + my $self = shift; + return if $self->{SCAN} eq 'never'; + $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") + unless $self->{SCAN} eq 'atstart'; + $CPAN::Frontend->myprint( + sprintf("Scanning cache %s for sizes\n", + $self->{ID})); + my $e; + for $e ($self->entries($self->{ID})) { + next if $e eq ".." || $e eq "."; + $self->disk_usage($e); + return if $CPAN::Signal; + } + $self->tidyup; +} + package CPAN::Debug; #-> sub CPAN::Debug::debug ; @@ -743,7 +929,7 @@ sub commit { unless (defined $configpm){ $configpm ||= $INC{"CPAN/MyConfig.pm"}; $configpm ||= $INC{"CPAN/Config.pm"}; - $configpm || Carp::confess(qq{ + $configpm || Carp::confess(q{ CPAN::Config::commit called without an argument. Please specify a filename where to save the configuration or try "o conf init" to have an interactive course through configing. @@ -759,7 +945,7 @@ Please specify a filename where to save the configuration or try my $msg = <<EOF unless $configpm =~ /MyConfig/; -# This is CPAN.pm's systemwide configuration file. This file provides +# This is CPAN.pm's systemwide configuration file. This file provides # defaults for users, and the values can be changed in a per-user # configuration file. The user-config file is being looked for as # ~/.cpan/CPAN/MyConfig.pm. @@ -767,6 +953,7 @@ Please specify a filename where to save the configuration or try EOF $msg ||= "\n"; my($fh) = FileHandle->new; + rename $configpm, "$configpm~" if -f $configpm; open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; $fh->print(qq[$msg\$CPAN::Config = \{\n]); foreach (sort keys %$CPAN::Config) { @@ -811,11 +998,15 @@ sub init { sub load { my($self) = shift; my(@miss); + use Carp; eval {require CPAN::Config;}; # We eval because of some # MakeMaker problems - unshift @INC, MM->catdir($ENV{HOME},".cpan") unless $dot_cpan++; - eval {require CPAN::MyConfig;}; # where you can override + unless ($dot_cpan++){ + unshift @INC, MM->catdir($ENV{HOME},".cpan"); + eval {require CPAN::MyConfig;}; # where you can override # system wide settings + shift @INC; + } return unless @miss = $self->not_loaded; # XXX better check for arrayrefs too require CPAN::FirstTime; @@ -872,11 +1063,11 @@ sub load { } } local($") = ", "; - $CPAN::Frontend->myprint(qq{ + $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled; We have to reconfigure CPAN.pm due to following uninitialized parameters: @miss -}) if $redo && ! $theycalled; +END $CPAN::Frontend->myprint(qq{ $configpm initialized. }); @@ -888,9 +1079,10 @@ $configpm initialized. sub not_loaded { my(@miss); for (qw( - cpan_home keep_source_where build_dir build_cache index_expire - gzip tar unzip make pager makepl_arg make_arg make_install_arg - urllist inhibit_startup_message ftp_proxy http_proxy no_proxy + cpan_home keep_source_where build_dir build_cache scan_cache + index_expire gzip tar unzip make pager makepl_arg make_arg + make_install_arg urllist inhibit_startup_message + ftp_proxy http_proxy no_proxy prerequisites_policy )) { push @miss, $_ unless defined $CPAN::Config->{$_}; } @@ -903,10 +1095,9 @@ sub unload { delete $INC{'CPAN/Config.pm'}; } -*h = \&help; #-> sub CPAN::Config::help ; sub help { - $CPAN::Frontend->myprint(qq{ + $CPAN::Frontend->myprint(q[ Known options: defaults reload default config values from disk commit commit session changes to disk @@ -922,7 +1113,7 @@ You may edit key values in the follow fashion: o conf urllist unshift ftp://ftp.foo.bar/ -}); +]); undef; #don't reprint CPAN::Config } @@ -933,9 +1124,13 @@ sub cpl { CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; my(@words) = split " ", substr($line,0,$pos+1); if ( - $words[2] =~ /list$/ && @words == 3 - || - $words[2] =~ /list$/ && @words == 4 && length($word) + defined($words[2]) + and + ( + $words[2] =~ /list$/ && @words == 3 + || + $words[2] =~ /list$/ && @words == 4 && length($word) + ) ) { return grep /^\Q$word\E/, qw(splice shift unshift pop push); } elsif (@words >= 4) { @@ -980,6 +1175,8 @@ q quit the shell subroutine } } +*help = \&h; + #-> sub CPAN::Shell::a ; sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));} #-> sub CPAN::Shell::b ; @@ -1003,7 +1200,9 @@ sub b { #-> sub CPAN::Shell::d ; sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} #-> sub CPAN::Shell::m ; -sub m { $CPAN::Frontend->myprint(shift->format_result('Module',@_));} +sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here + $CPAN::Frontend->myprint(shift->format_result('Module',@_)); +} #-> sub CPAN::Shell::i ; sub i { @@ -1032,7 +1231,14 @@ sub o { shift @o_what if @o_what && $o_what[0] eq 'help'; if (!@o_what) { my($k,$v); - $CPAN::Frontend->myprint("CPAN::Config options:\n"); + $CPAN::Frontend->myprint("CPAN::Config options"); + if (exists $INC{'CPAN/Config.pm'}) { + $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}"); + } + if (exists $INC{'CPAN/MyConfig.pm'}) { + $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}"); + } + $CPAN::Frontend->myprint(":\n"); for $k (sort keys %CPAN::Config::can) { $v = $CPAN::Config::can{$k}; $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); @@ -1111,6 +1317,21 @@ Known options: } } +sub dotdot_onreload { + my($ref) = shift; + sub { + if ( $_[0] =~ /Subroutine (\w+) redefined/ ) { + my($subr) = $1; + ++$$ref; + local($|) = 1; + # $CPAN::Frontend->myprint(".($subr)"); + $CPAN::Frontend->myprint("."); + return; + } + warn @_; + }; +} + #-> sub CPAN::Shell::reload ; sub reload { my($self,$command,@arg) = @_; @@ -1120,27 +1341,16 @@ sub reload { CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; my $fh = FileHandle->new($INC{'CPAN.pm'}); local($/); - undef $/; $redef = 0; - local($SIG{__WARN__}) - = sub { - if ( $_[0] =~ /Subroutine \w+ redefined/ ) { - ++$redef; - local($|) = 1; - $CPAN::Frontend->myprint("."); - return; - } - warn @_; - }; + local($SIG{__WARN__}) = dotdot_onreload(\$redef); eval <$fh>; warn $@ if $@; $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); } elsif ($command =~ /index/) { - CPAN::Index->force_reload; + CPAN::Index->force_reload; } else { - $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file -index re-reads the index files -}); + $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file +index re-reads the index files\n}); } } @@ -1205,6 +1415,7 @@ sub _u_r_common { my($latest) = $module->cpan_version; my($inst_file) = $module->inst_file; my($have); + return if $CPAN::Signal; if ($inst_file){ if ($what eq "a") { $have = $module->inst_version; @@ -1294,6 +1505,7 @@ sub u { #-> sub CPAN::Shell::autobundle ; sub autobundle { my($self) = shift; + CPAN::Config->load unless $CPAN::Config_loaded++; my(@bundle) = $self->_u_r_common("a",@_); my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle"); File::Path::mkpath($todir); @@ -1350,7 +1562,7 @@ sub expand { my $class = "CPAN::$type"; my $obj; if (defined $regex) { - for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) { + for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class)) { push @m, $obj if $obj->id =~ /$regex/i @@ -1412,7 +1624,8 @@ sub print_ornamented { *color = sub { return "" }; } } - for my $line (split /\n/, $what) { + my $line; + for $line (split /\n/, $what) { $longest = length($line) if length($line) > $longest; } my $sprintf = "%-" . $longest . "s"; @@ -1458,6 +1671,7 @@ sub mydie { } #-> sub CPAN::Shell::rematein ; +# RE-adme||MA-ke||TE-st||IN-stall sub rematein { shift; my($meth,@some) = @_; @@ -1469,6 +1683,9 @@ sub rematein { CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; my($s,@s); foreach $s (@some) { + CPAN::Queue->new($s); + } + while ($s = CPAN::Queue->first) { my $obj; if (ref $s) { $obj = $s; @@ -1482,7 +1699,7 @@ sub rematein { } if (ref $obj) { CPAN->debug( - qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}. + qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}. $obj->as_string. qq{\]} ) if $CPAN::DEBUG; @@ -1490,8 +1707,16 @@ sub rematein { if $pragma && - ($] < 5.00303 || $obj->can($pragma)); ### compatibility with 5.003 - $obj->$meth(); + ($] < 5.00303 || $obj->can($pragma)); ### + ### compatibility + ### with + ### 5.003 + if ($]>=5.00303 && $obj->can('called_for')) { + $obj->called_for($s); + } + CPAN::Queue->delete($s) if $obj->$meth(); # if it is more + # than once in + # the queue } elsif ($CPAN::META->exists('CPAN::Author',$s)) { $obj = $CPAN::META->instance('CPAN::Author',$s); $CPAN::Frontend->myprint( @@ -1501,7 +1726,9 @@ sub rematein { " ;-)\n" ); } else { - $CPAN::Frontend->myprint(qq{Warning: Cannot $meth $s, don\'t know what it is. + $CPAN::Frontend + ->myprint(qq{Warning: Cannot $meth $s, }. + qq{don\'t know what it is. Try the command i /$s/ @@ -1509,6 +1736,7 @@ Try the command to find objects with similar identifiers. }); } + CPAN::Queue->delete_first($s); } } @@ -1533,47 +1761,85 @@ package CPAN::FTP; #-> sub CPAN::FTP::ftp_get ; sub ftp_get { - my($class,$host,$dir,$file,$target) = @_; - $class->debug( - qq[Going to fetch file [$file] from dir [$dir] + my($class,$host,$dir,$file,$target) = @_; + $class->debug( + qq[Going to fetch file [$file] from dir [$dir] on host [$host] as local [$target]\n] ) if $CPAN::DEBUG; - my $ftp = Net::FTP->new($host); - return 0 unless defined $ftp; - $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; - $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); - unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ - warn "Couldn't login on $host"; - return; - } - unless ( $ftp->cwd($dir) ){ - warn "Couldn't cwd $dir"; - return; - } - $ftp->binary; - $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; - unless ( $ftp->get($file,$target) ){ - warn "Couldn't fetch $file from $host\n"; - return; - } - $ftp->quit; # it's ok if this fails - return 1; + my $ftp = Net::FTP->new($host); + return 0 unless defined $ftp; + $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; + $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); + unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ + warn "Couldn't login on $host"; + return; + } + unless ( $ftp->cwd($dir) ){ + warn "Couldn't cwd $dir"; + return; + } + $ftp->binary; + $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; + unless ( $ftp->get($file,$target) ){ + warn "Couldn't fetch $file from $host\n"; + return; + } + $ftp->quit; # it's ok if this fails + return 1; } +# If more accuracy is wanted/needed, Chris Leach sent me this patch... + + # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 + # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997 + # leach,> *************** + # leach,> *** 1562,1567 **** + # leach,> --- 1562,1580 ---- + # leach,> return 1 if substr($url,0,4) eq "file"; + # leach,> return 1 unless $url =~ m|://([^/]+)|; + # leach,> my $host = $1; + # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; + # leach,> + if ($proxy) { + # leach,> + $proxy =~ m|://([^/:]+)|; + # leach,> + $proxy = $1; + # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; + # leach,> + if ($noproxy) { + # leach,> + if ($host !~ /$noproxy$/) { + # leach,> + $host = $proxy; + # leach,> + } + # leach,> + } else { + # leach,> + $host = $proxy; + # leach,> + } + # leach,> + } + # leach,> require Net::Ping; + # leach,> return 1 unless $Net::Ping::VERSION >= 2; + # leach,> my $p; + + +# this is quite optimistic and returns one on several occasions where +# inappropriate. But this does no harm. It would do harm if we were +# too pessimistic (as I was before the http_proxy sub is_reachable { my($self,$url) = @_; return 1; # we can't simply roll our own, firewalls may break ping return 0 unless $url; return 1 if substr($url,0,4) eq "file"; - return 1 unless $url =~ m|://([^/]+)|; - my $host = $1; + return 1 unless $url =~ m|^(\w+)://([^/]+)|; + my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy + my $host = $2; + return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype}; require Net::Ping; return 1 unless $Net::Ping::VERSION >= 2; my $p; + # 1.3101 had it different: only if the first eval raised an + # exception we tried it with TCP. Now we are happy if icmp wins + # the order and return, we don't even check for $@. Thanks to + # thayer@uis.edu for the suggestion. eval {$p = Net::Ping->new("icmp");}; - eval {$p = Net::Ping->new("tcp");} if $@; + return 1 if $p && ref($p) && $p->ping($host, 10); + eval {$p = Net::Ping->new("tcp");}; $CPAN::Frontend->mydie($@) if $@; - return $p->ping($host, 3); + return $p->ping($host, 10); } #-> sub CPAN::FTP::localize ; @@ -1587,6 +1853,20 @@ sub localize { $self->debug("file[$file] aslocal[$aslocal] force[$force]") if $CPAN::DEBUG; + if ($^O eq 'MacOS') { + my($name, $path) = File::Basename::fileparse($aslocal, ''); + if (length($name) > 31) { + $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//; + my $suf = $1; + my $size = 31 - length($suf); + while (length($name) > $size) { + chop $name; + } + $name .= $suf; + $aslocal = File::Spec->catfile($path, $name); + } + } + return $aslocal if -f $aslocal && -r _ && !($force & 1); my($restore) = 0; if (-f $aslocal){ @@ -1602,7 +1882,7 @@ sub localize { to insufficient permissions.\n}) unless -w $aslocal_dir; # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->has_inst('LWP')) { + if ($CPAN::META->has_inst('LWP::UserAgent')) { require LWP::UserAgent; unless ($Ua) { $Ua = LWP::UserAgent->new; @@ -1619,7 +1899,7 @@ sub localize { # Try the list of urls for each single object. We keep a record # where we did get a file from my(@reordered,$last); -#line 1621 + $CPAN::Config->{urllist} ||= []; $last = $#{$CPAN::Config->{urllist}}; if ($force & 2) { # local cpans probably out of date, don't reorder @reordered = (0..$last); @@ -1627,7 +1907,7 @@ sub localize { @reordered = sort { (substr($CPAN::Config->{urllist}[$b],0,4) eq "file") - <=> + <=> (substr($CPAN::Config->{urllist}[$a],0,4) eq "file") or defined($Thesite) @@ -1636,11 +1916,6 @@ sub localize { <=> ($a == $Thesite) } 0..$last; - -# ((grep { substr($CPAN::Config->{urllist}[$_],0,4) -# eq "file" } 0..$last), -# (grep { substr($CPAN::Config->{urllist}[$_],0,4) -# ne "file" } 0..$last)); } my($level,@levels); if ($Themethod) { @@ -1648,15 +1923,19 @@ sub localize { } else { @levels = qw/easy hard hardest/; } + @levels = qw/easy/ if $^O eq 'MacOS'; for $level (@levels) { my $method = "host$level"; my @host_seq = $level eq "easy" ? @reordered : 0..$last; # reordered has CDROM up front + @host_seq = (0) unless @host_seq; my $ret = $self->$method(\@host_seq,$file,$aslocal); if ($ret) { - $Themethod = $level; - $self->debug("level[$level]") if $CPAN::DEBUG; - return $ret; + $Themethod = $level; + $self->debug("level[$level]") if $CPAN::DEBUG; + return $ret; + } else { + unlink $aslocal; } } my(@mess); @@ -1681,7 +1960,7 @@ sub hosteasy { my($self,$host_seq,$file,$aslocal) = @_; my($i); HOSTEASY: for $i (@$host_seq) { - my $url = $CPAN::Config->{urllist}[$i]; + my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; unless ($self->is_reachable($url)) { $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n"); sleep 2; @@ -1702,8 +1981,11 @@ sub hosteasy { # fileurl = "file://" [ host | "localhost" ] "/" fpath # Thanks to "Mark D. Baushke" <mdb@cisco.com> for # the code - ($l = $url) =~ s,^file://[^/]+,,; # discard the host part - $l =~ s/^file://; # assume they meant file://localhost + ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part + $l =~ s|^file:||; # assume they + # meant + # file://localhost + $l =~ s|^/|| unless -f $l; # e.g. /P: } if ( -f $l && -r _) { $Thesite = $i; @@ -1712,37 +1994,47 @@ sub hosteasy { # Maybe mirror has compressed it? if (-f "$l.gz") { $self->debug("found compressed $l.gz") if $CPAN::DEBUG; - system("$CPAN::Config->{gzip} -dc $l.gz > $aslocal"); + CPAN::Tarzip->gunzip("$l.gz", $aslocal); if ( -f $aslocal) { $Thesite = $i; return $aslocal; } } } - if ($CPAN::META->has_inst('LWP')) { - $CPAN::Frontend->myprint("Fetching with LWP: + if ($CPAN::META->has_inst('LWP')) { + $CPAN::Frontend->myprint("Fetching with LWP: $url "); - my $res = $Ua->mirror($url, $aslocal); - if ($res->is_success) { - $Thesite = $i; - return $aslocal; - } elsif ($url !~ /\.gz$/) { - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint("Fetching with LWP: + unless ($Ua) { + require LWP::UserAgent; + $Ua = LWP::UserAgent->new; + } + my $res = $Ua->mirror($url, $aslocal); + if ($res->is_success) { + $Thesite = $i; + return $aslocal; + } elsif ($url !~ /\.gz$/) { + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint("Fetching with LWP: $gzurl "); - $res = $Ua->mirror($gzurl, "$aslocal.gz"); - if ($res->is_success && - system("$CPAN::Config->{gzip} -d $aslocal.gz")==0) { - $Thesite = $i; - return $aslocal; - } else { - next HOSTEASY ; - } + $res = $Ua->mirror($gzurl, "$aslocal.gz"); + if ($res->is_success && + CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal) + ) { + $Thesite = $i; + return $aslocal; } else { - next HOSTEASY ; + # next HOSTEASY ; } + } else { + # Alan Burlison informed me that in firewall envs Net::FTP + # can still succeed where LWP fails. So we do not skip + # Net::FTP anymore when LWP is available. + # next HOSTEASY ; + } + } else { + $self->debug("LWP not installed") if $CPAN::DEBUG; } if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { # that's the nice and easy way thanks to Graham @@ -1750,7 +2042,7 @@ sub hosteasy { if ($CPAN::META->has_inst('Net::FTP')) { $dir =~ s|/+|/|g; $CPAN::Frontend->myprint("Fetching with Net::FTP: - $aslocal + $url "); $self->debug("getfile[$getfile]dir[$dir]host[$host]" . "aslocal[$aslocal]") if $CPAN::DEBUG; @@ -1761,50 +2053,58 @@ sub hosteasy { if ($aslocal !~ /\.gz$/) { my $gz = "$aslocal.gz"; $CPAN::Frontend->myprint("Fetching with Net::FTP - $gz + $url.gz "); - if (CPAN::FTP->ftp_get($host, - $dir, - "$getfile.gz", - $gz) && - system("$CPAN::Config->{gzip} -d $gz")==0 ){ + if (CPAN::FTP->ftp_get($host, + $dir, + "$getfile.gz", + $gz) && + CPAN::Tarzip->gunzip($gz,$aslocal) + ){ $Thesite = $i; return $aslocal; } } - next HOSTEASY; + # next HOSTEASY; } } } } sub hosthard { - my($self,$host_seq,$file,$aslocal) = @_; + my($self,$host_seq,$file,$aslocal) = @_; - # Came back if Net::FTP couldn't establish connection (or - # failed otherwise) Maybe they are behind a firewall, but they - # gave us a socksified (or other) ftp program... + # Came back if Net::FTP couldn't establish connection (or + # failed otherwise) Maybe they are behind a firewall, but they + # gave us a socksified (or other) ftp program... - my($i); - my($aslocal_dir) = File::Basename::dirname($aslocal); - File::Path::mkpath($aslocal_dir); + my($i); + my($devnull) = $CPAN::Config->{devnull} || ""; + # < /dev/null "; + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); HOSTHARD: for $i (@$host_seq) { - my $url = $CPAN::Config->{urllist}[$i]; + my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; unless ($self->is_reachable($url)) { $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); next; } $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; - my($host,$dir,$getfile); - if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { - ($host,$dir,$getfile) = ($1,$2,$3); + my($proto,$host,$dir,$getfile); + + # Courtesy Mark Conty mark_conty@cargill.com change from + # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + # to + if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) { + # proto not yet used + ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); } else { next HOSTHARD; # who said, we could ftp anything except ftp? } $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; my($f,$funkyftp); - for $f ('lynx','ncftp') { + for $f ('lynx','ncftpget','ncftp') { next unless exists $CPAN::Config->{$f}; $funkyftp = $CPAN::Config->{$f}; next unless defined $funkyftp; @@ -1813,14 +2113,14 @@ sub hosthard { my $aslocal_uncompressed; ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; my($source_switch) = ""; - $source_switch = "-source" if $funkyftp =~ /\blynx$/; - $source_switch = "-c" if $funkyftp =~ /\bncftp$/; + $source_switch = " -source" if $funkyftp =~ /\blynx$/; + $source_switch = " -c" if $funkyftp =~ /\bncftp$/; $CPAN::Frontend->myprint( - qq{ -Trying with "$funkyftp $source_switch" to get + qq[ +Trying with "$funkyftp$source_switch" to get $url -}); - my($system) = "$funkyftp $source_switch '$url' > ". +]); + my($system) = "$funkyftp$source_switch '$url' $devnull > ". "$aslocal_uncompressed"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); @@ -1830,51 +2130,49 @@ Trying with "$funkyftp $source_switch" to get # system even if it fails ) { if ($aslocal_uncompressed ne $aslocal) { - # test gzip integrity - $system = - "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed"; - if (system($system) == 0) { - rename $aslocal_uncompressed, $aslocal; - } else { - $system = - "$CPAN::Config->{'gzip'} $aslocal_uncompressed"; - system($system); - } - $Thesite = $i; - return $aslocal; + # test gzip integrity + if ( + CPAN::Tarzip->gtest($aslocal_uncompressed) + ) { + rename $aslocal_uncompressed, $aslocal; + } else { + CPAN::Tarzip->gzip($aslocal_uncompressed, + "$aslocal_uncompressed.gz"); + } } + $Thesite = $i; + return $aslocal; } elsif ($url !~ /\.gz$/) { - my $gz = "$aslocal.gz"; - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint( - qq{ -Trying with "$funkyftp $source_switch" to get + unlink $aslocal_uncompressed if + -f $aslocal_uncompressed && -s _ == 0; + my $gz = "$aslocal.gz"; + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint( + qq[ +Trying with "$funkyftp$source_switch" to get $url.gz -}); - my($system) = "$funkyftp $source_switch '$url.gz' > ". - "$aslocal_uncompressed.gz"; - $self->debug("system[$system]") if $CPAN::DEBUG; - my($wstatus); - if (($wstatus = system($system)) == 0 - && - -s "$aslocal_uncompressed.gz" - ) { - # test gzip integrity - $system = - "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed.gz"; - $CPAN::Frontend->mywarn("system[$system]"); - if (system($system) == 0) { - $system = "$CPAN::Config->{'gzip'} -dc ". - "$aslocal_uncompressed.gz > $aslocal"; - $CPAN::Frontend->mywarn("system[$system]"); - system($system); - } else { - rename $aslocal_uncompressed, $aslocal; - } -#line 1739 - $Thesite = $i; - return $aslocal; +]); + my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". + "$aslocal_uncompressed.gz"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + -s "$aslocal_uncompressed.gz" + ) { + # test gzip integrity + if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { + CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", + $aslocal); + } else { + rename $aslocal_uncompressed, $aslocal; } + $Thesite = $i; + return $aslocal; + } else { + unlink "$aslocal_uncompressed.gz" if + -f "$aslocal_uncompressed.gz"; + } } else { my $estatus = $wstatus >> 8; my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; @@ -1898,7 +2196,7 @@ sub hosthardest { $CPAN::Frontend->myprint("No external ftp command available\n\n"); last HOSTHARDEST; } - my $url = $CPAN::Config->{urllist}[$i]; + my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; unless ($self->is_reachable($url)) { $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); next; @@ -1963,7 +2261,7 @@ sub hosthardest { $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host nor does it have a default entry\n"); } - + # OK, they don't have a valid ~/.netrc. Use 'ftp -n' # then and login manually to host, using e-mail as # password. @@ -2001,11 +2299,11 @@ sub talk_ftp { Subprocess "|$command" returned status $estatus (wstat $wstatus) }) if $wstatus; - } # find2perl needs modularization, too, all the following is stolen # from there +# CPAN::FTP::ls sub ls { my($self,$name) = @_; my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, @@ -2127,6 +2425,27 @@ sub contains { package CPAN::Complete; +sub gnu_cpl { + my($text, $line, $start, $end) = @_; + my(@perlret) = cpl($text, $line, $start); + # find longest common match. Can anybody show me how to peruse + # T::R::Gnu to have this done automatically? Seems expensive. + return () unless @perlret; + my($newtext) = $text; + for (my $i = length($text)+1;;$i++) { + last unless length($perlret[0]) && length($perlret[0]) >= $i; + my $try = substr($perlret[0],0,$i); + my @tries = grep {substr($_,0,$i) eq $try} @perlret; + # warn "try[$try]tries[@tries]"; + if (@tries == @perlret) { + $newtext = $try; + } else { + last; + } + } + ($newtext,@perlret); +} + #-> sub CPAN::Complete::cpl ; sub cpl { my($word,$line,$pos) = @_; @@ -2172,7 +2491,7 @@ sub cpl { #-> sub CPAN::Complete::cplx ; sub cplx { my($class, $word) = @_; - grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); + grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); } #-> sub CPAN::Complete::cpl_any ; @@ -2242,26 +2561,35 @@ sub reload { my $needshort = $^O eq "dos"; - $cl->rd_authindex($cl->reload_x( - "authors/01mailrc.txt.gz", - $needshort ? "01mailrc.gz" : "", - $force)); + $cl->rd_authindex($cl + ->reload_x( + "authors/01mailrc.txt.gz", + $needshort ? + File::Spec->catfile('authors', '01mailrc.gz') : + File::Spec->catfile('authors', '01mailrc.txt.gz'), + $force)); $t2 = time; $debug = "timing reading 01[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->rd_modpacks($cl->reload_x( - "modules/02packages.details.txt.gz", - $needshort ? "02packag.gz" : "", - $force)); + $cl->rd_modpacks($cl + ->reload_x( + "modules/02packages.details.txt.gz", + $needshort ? + File::Spec->catfile('modules', '02packag.gz') : + File::Spec->catfile('modules', '02packages.details.txt.gz'), + $force)); $t2 = time; $debug .= "02[".($t2 - $time)."]"; $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->rd_modlist($cl->reload_x( - "modules/03modlist.data.gz", - $needshort ? "03mlist.gz" : "", - $force)); + $cl->rd_modlist($cl + ->reload_x( + "modules/03modlist.data.gz", + $needshort ? + File::Spec->catfile('modules', '03mlist.gz') : + File::Spec->catfile('modules', '03modlist.data.gz'), + $force)); $t2 = time; $debug .= "03[".($t2 - $time)."]"; $time = $t2; @@ -2294,15 +2622,20 @@ sub reload_x { #-> sub CPAN::Index::rd_authindex ; sub rd_authindex { - my($cl,$index_target) = @_; + my($cl, $index_target) = @_; + my @lines; return unless defined $index_target; - my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; $CPAN::Frontend->myprint("Going to read $index_target\n"); - my $fh = FileHandle->new("$pipe|"); - while (<$fh>) { - chomp; +# my $fh = CPAN::Tarzip->TIEHANDLE($index_target); +# while ($_ = $fh->READLINE) { + # no strict 'refs'; + local(*FH); + tie *FH, CPAN::Tarzip, $index_target; + local($/) = "\n"; + push @lines, split /\012/ while <FH>; + foreach (@lines) { my($userid,$fullname,$email) = - /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; + m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/; next unless $userid && $fullname && $email; # instantiate an author object @@ -2310,35 +2643,53 @@ sub rd_authindex { $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); return if $CPAN::Signal; } - $fh->close; - $? and Carp::croak "FAILED $pipe: exit status [$?]"; +} + +sub userid { + my($self,$dist) = @_; + $dist = $self->{'id'} unless defined $dist; + my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|; + $ret; } #-> sub CPAN::Index::rd_modpacks ; sub rd_modpacks { - my($cl,$index_target) = @_; + my($cl, $index_target) = @_; + my @lines; return unless defined $index_target; - my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; $CPAN::Frontend->myprint("Going to read $index_target\n"); - my $fh = FileHandle->new("$pipe|"); - while (<$fh>) { - last if /^\s*$/; + my $fh = CPAN::Tarzip->TIEHANDLE($index_target); + local($/) = "\n"; + while ($_ = $fh->READLINE) { + s/\012/\n/g; + my @ls = map {"$_\n"} split /\n/, $_; + unshift @ls, "\n" x length($1) if /^(\n+)/; + push @lines, @ls; } - while (<$fh>) { + while (@lines) { + my $shift = shift(@lines); + last if $shift =~ /^\s*$/; + } + foreach (@lines) { chomp; my($mod,$version,$dist) = split; ### $version =~ s/^\+//; - # if it as a bundle, instatiate a bundle object + # if it is a bundle, instatiate a bundle object my($bundle,$id,$userid); - - if ($mod eq 'CPAN') { + + if ($mod eq 'CPAN' && + ! ( + CPAN::Queue->exists('Bundle::CPAN') || + CPAN::Queue->exists('CPAN') + ) + ) { local($^W)= 0; if ($version > $CPAN::VERSION){ $CPAN::Frontend->myprint(qq{ There\'s a new CPAN.pm version (v$version) available! You might want to try - install CPAN + install Bundle::CPAN reload cpan without quitting the current session. It should be a seamless upgrade while we are running... @@ -2353,9 +2704,11 @@ sub rd_modpacks { if ($bundle){ $id = $CPAN::META->instance('CPAN::Bundle',$mod); + # warn "made mod[$mod]a bundle"; # Let's make it a module too, because bundles have so much # in common with modules $CPAN::META->instance('CPAN::Module',$mod); + # warn "made mod[$mod]a module"; # This "next" makes us faster but if the job is running long, we ignore # rereads which is bad. So we have to be a bit slower again. @@ -2369,8 +2722,7 @@ sub rd_modpacks { } if ($id->cpan_file ne $dist){ - # determine the author - ($userid) = $dist =~ /([^\/]+)/; + $userid = $cl->userid($dist); $id->set( 'CPAN_USERID' => $userid, 'CPAN_VERSION' => $version, @@ -2389,31 +2741,36 @@ sub rd_modpacks { return if $CPAN::Signal; } - $fh->close; - $? and Carp::croak "FAILED $pipe: exit status [$?]"; + undef $fh; } #-> sub CPAN::Index::rd_modlist ; sub rd_modlist { my($cl,$index_target) = @_; return unless defined $index_target; - my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; $CPAN::Frontend->myprint("Going to read $index_target\n"); - my $fh = FileHandle->new("$pipe|"); - my $eval; - while (<$fh>) { - if (/^Date:\s+(.*)/){ + my $fh = CPAN::Tarzip->TIEHANDLE($index_target); + my @eval; + local($/) = "\n"; + while ($_ = $fh->READLINE) { + s/\012/\n/g; + my @ls = map {"$_\n"} split /\n/, $_; + unshift @ls, "\n" x length($1) if /^(\n+)/; + push @eval, @ls; + } + while (@eval) { + my $shift = shift(@eval); + if ($shift =~ /^Date:\s+(.*)/){ return if $date_of_03 eq $1; ($date_of_03) = $1; } - last if /^\s*$/; + last if $shift =~ /^\s*$/; } - local($/) = undef; - $eval = <$fh>; - $fh->close; - $eval .= q{CPAN::Modulelist->data;}; + undef $fh; + push @eval, q{CPAN::Modulelist->data;}; local($^W) = 0; my($comp) = Safe->new("CPAN::Safe1"); + my($eval) = join("", @eval); my $ret = $comp->reval($eval); Carp::confess($@) if $@; return if $CPAN::Signal; @@ -2459,8 +2816,19 @@ sub as_string { for (sort keys %$self) { next if $_ eq 'ID'; my $extra = ""; - $_ eq "CPAN_USERID" and $extra = " (".$self->author.")"; - if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX + if ($_ eq "CPAN_USERID") { + $extra .= " (".$self->author; + my $email; # old perls! + if ($email = $CPAN::META->instance(CPAN::Author, + $self->{$_} + )->email) { + $extra .= " <$email>"; + } else { + $extra .= " <no email>"; + } + $extra .= ")"; + } + if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; } else { push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; @@ -2496,6 +2864,7 @@ sub as_glimpse { #-> sub CPAN::Author::fullname ; sub fullname { shift->{'FULLNAME'} } *name = \&fullname; + #-> sub CPAN::Author::email ; sub email { shift->{'EMAIL'} } @@ -2559,11 +2928,12 @@ sub get { } else { $self->{archived} = "NO"; } - chdir ".."; + chdir File::Spec->updir; if ($self->{archived} ne 'NO') { - chdir "tmp"; + chdir File::Spec->catdir(File::Spec->curdir, "tmp"); # Let's check if the package has its own directory. - my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!"); + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir .: $!"); my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC?? $dh->close; my ($distdir,$packagedir); @@ -2586,7 +2956,7 @@ sub get { } } $self->{'build_dir'} = $packagedir; - chdir ".."; + chdir File::Spec->updir; $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG; @@ -2597,25 +2967,32 @@ sub get { } my($makefilepl) = MM->catfile($packagedir,"Makefile.PL"); unless (-f $makefilepl) { - my($configure) = MM->catfile($packagedir,"Configure"); - if (-f $configure) { - # do we have anything to do? - $self->{'configure'} = $configure; - } else { - my $fh = FileHandle->new(">$makefilepl") - or Carp::croak("Could not open >$makefilepl"); - my $cf = $self->called_for || "unknown"; - $fh->print( + my($configure) = MM->catfile($packagedir,"Configure"); + if (-f $configure) { + # do we have anything to do? + $self->{'configure'} = $configure; + } elsif (-f MM->catfile($packagedir,"Makefile")) { + $CPAN::Frontend->myprint(qq{ +Package comes with a Makefile and without a Makefile.PL. +We\'ll try to build it with that Makefile then. +}); + $self->{writemakefile} = "YES"; + sleep 2; + } else { + my $fh = FileHandle->new(">$makefilepl") + or Carp::croak("Could not open >$makefilepl"); + my $cf = $self->called_for || "unknown"; + $fh->print( qq{# This Makefile.PL has been autogenerated by the module CPAN.pm # because there was no Makefile.PL supplied. # Autogenerated on: }.scalar localtime().qq{ - use ExtUtils::MakeMaker; - WriteMakefile(NAME => q[$cf]); +use ExtUtils::MakeMaker; +WriteMakefile(NAME => q[$cf]); }); - $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.\n}. - qq{ Writing one on our own (calling it $cf)\n}); + $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL. + Writing one on our own (calling it $cf)\n}); } } } @@ -2625,9 +3002,7 @@ qq{# This Makefile.PL has been autogenerated by the module CPAN.pm sub untar_me { my($self,$local_file) = @_; $self->{archived} = "tar"; - my $system = "$CPAN::Config->{gzip} --decompress --stdout " . - "$local_file | $CPAN::Config->{tar} xvf -"; - if (system($system)== 0) { + if (CPAN::Tarzip->untar($local_file)) { $self->{unwrapped} = "YES"; } else { $self->{unwrapped} = "NO"; @@ -2650,9 +3025,7 @@ sub pm2dir_me { $self->{archived} = "pm"; my $to = File::Basename::basename($local_file); $to =~ s/\.(gz|Z)$//; - my $system = "$CPAN::Config->{gzip} --decompress --stdout ". - "$local_file > $to"; - if (system($system) == 0) { + if (CPAN::Tarzip->gunzip($local_file,$to)) { $self->{unwrapped} = "YES"; } else { $self->{unwrapped} = "NO"; @@ -2672,6 +3045,12 @@ sub new { #-> sub CPAN::Distribution::look ; sub look { my($self) = @_; + + if ($^O eq 'MacOS') { + $self->ExtUtils::MM_MacOS::look; + return; + } + if ( $CPAN::Config->{'shell'} ) { $CPAN::Frontend->myprint(qq{ Trying to open a subshell in the build directory... @@ -2714,6 +3093,12 @@ sub readme { $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted) or $CPAN::Frontend->mydie(qq{No $sans.readme found});; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::launch_file($local_file); + return; + } + my $fh_pager = FileHandle->new; local($SIG{PIPE}) = "IGNORE"; $fh_pager->open("|$CPAN::Config->{'pager'}") @@ -2761,9 +3146,8 @@ sub verifyMD5 { $lc_file = CPAN::FTP->localize("authors/id/@local", "$lc_want.gz",1); if ($lc_file) { - my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file); - system(@system) == 0 or die "Could not uncompress $lc_file"; $lc_file =~ s/\.gz$//; + CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file); } else { return; } @@ -2781,6 +3165,7 @@ sub MD5_check_file { if (open $fh, $chk_file){ local($/); my $eval = <$fh>; + $eval =~ s/\015?\012/\n/g; close $fh; my($comp) = Safe->new(); $cksum = $comp->reval($eval); @@ -2791,22 +3176,33 @@ sub MD5_check_file { } else { Carp::carp "Could not open $chk_file for reading"; } - if ($cksum->{$basename}->{md5}) { + + if (exists $cksum->{$basename}{md5}) { $self->debug("Found checksum for $basename:" . - "$cksum->{$basename}->{md5}\n") if $CPAN::DEBUG; - my $pipe = "$CPAN::Config->{gzip} --decompress ". - "--stdout $file|"; - if ( - open($fh, $file) && - binmode $fh && - $self->eq_MD5($fh,$cksum->{$basename}->{md5}) - or - open($fh, $pipe) && - binmode $fh && - $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) - ){ - $CPAN::Frontend->myprint("Checksum for $file ok\n"); - return $self->{MD5_STATUS} = "OK"; + "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG; + + open($fh, $file); + binmode $fh; + my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'}); + $fh->close; + $fh = CPAN::Tarzip->TIEHANDLE($file); + + unless ($eq) { + # had to inline it, when I tied it, the tiedness got lost on + # the call to eq_MD5. (Jan 1998) + my $md5 = MD5->new; + my($data,$ref); + $ref = \$data; + while ($fh->READ($ref, 4096)){ + $md5->add($data); + } + my $hexdigest = $md5->hexdigest; + $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'}; + } + + if ($eq) { + $CPAN::Frontend->myprint("Checksum for $file ok\n"); + return $self->{MD5_STATUS} = "OK"; } else { $CPAN::Frontend->myprint(qq{Checksum mismatch for }. qq{distribution file. }. @@ -2817,15 +3213,15 @@ sub MD5_check_file { $self->{CPAN_USERID} )->as_string); my $wrap = qq{I\'d recommend removing $file. It seems to -be a bogus file. Maybe you have configured your \`urllist\' with a -bad URL. Please check this array with \`o conf urllist\', and +be a bogus file. Maybe you have configured your \`urllist\' with a +bad URL. Please check this array with \`o conf urllist\', and retry.}; $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap)); $CPAN::Frontend->myprint("\n\n"); sleep 3; return; } - close $fh if fileno($fh); + # close $fh if fileno($fh); } else { $self->{MD5_STATUS} ||= ""; if ($self->{MD5_STATUS} eq "NIL") { @@ -2845,23 +3241,39 @@ Removing $chk_file sub eq_MD5 { my($self,$fh,$expectMD5) = @_; my $md5 = MD5->new; - $md5->addfile($fh); + my($data); + while (read($fh, $data, 4096)){ + $md5->add($data); + } + # $md5->addfile($fh); my $hexdigest = $md5->hexdigest; + # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]"; $hexdigest eq $expectMD5; } #-> sub CPAN::Distribution::force ; sub force { - my($self) = @_; - $self->{'force_update'}++; - delete $self->{'MD5_STATUS'}; - delete $self->{'archived'}; - delete $self->{'build_dir'}; - delete $self->{'localfile'}; - delete $self->{'make'}; - delete $self->{'install'}; - delete $self->{'unwrapped'}; - delete $self->{'writemakefile'}; + my($self) = @_; + $self->{'force_update'}++; + for my $att (qw( + MD5_STATUS archived build_dir localfile make install unwrapped + writemakefile have_sponsored + )) { + delete $self->{$att}; + } +} + +sub isa_perl { + my($self) = @_; + my $file = File::Basename::basename($self->id); + return unless $file =~ m{ ^ perl + (5) + ([._-]) + (\d{3}(_[0-4][0-9])?) + \.tar[._-]gz + $ + }x; + "$1.$3"; } #-> sub CPAN::Distribution::perl ; @@ -2893,6 +3305,29 @@ sub perl { sub make { my($self) = @_; $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id); + # Emergency brake if they said install Pippi and get newest perl + if ($self->isa_perl) { + if ( + $self->called_for ne $self->id && ! $self->{'force_update'} + ) { + $CPAN::Frontend->mydie(sprintf qq{ +The most recent version "%s" of the module "%s" +comes with the current version of perl (%s). +I\'ll build that only if you ask for something like + force install %s +or + install %s +}, + $CPAN::META->instance( + 'CPAN::Module', + $self->called_for + )->cpan_version, + $self->called_for, + $self->isa_perl, + $self->called_for, + $self->id); + } + } $self->get; EXCUSE: { my @e; @@ -2916,9 +3351,14 @@ sub make { chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make($self); + return; + } + my $system; if ($self->{'configure'}) { - $system = $self->{'configure'}; + $system = $self->{'configure'}; } else { my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; my $switch = ""; @@ -2928,19 +3368,23 @@ sub make { # if $] > 5.00310; $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}"; } - { + unless (exists $self->{writemakefile}) { local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; my($ret,$pid); $@ = ""; if ($CPAN::Config->{inactivity_timeout}) { eval { alarm $CPAN::Config->{inactivity_timeout}; - local $SIG{CHLD} = sub { wait }; + local $SIG{CHLD}; # = sub { wait }; if (defined($pid = fork)) { if ($pid) { #parent - wait; + # wait; + waitpid $pid, 0; } else { #child - exec $system; + # note, this exec isn't necessary if + # inactivity_timeout is 0. On the Mac I'd + # suggest, we set it always to 0. + exec $system; } } else { $CPAN::Frontend->myprint("Cannot fork: $!"); @@ -2957,15 +3401,41 @@ sub make { return; } } else { - $ret = system($system); - if ($ret != 0) { - $self->{writemakefile} = "NO"; - return; - } + $ret = system($system); + if ($ret != 0) { + $self->{writemakefile} = "NO"; + return; + } } + $self->{writemakefile} = "YES"; } - $self->{writemakefile} = "YES"; return if $CPAN::Signal; + if (my @prereq = $self->needs_prereq){ + my $id = $self->id; + $CPAN::Frontend->myprint("---- Dependencies detected ". + "during [$id] -----\n"); + + for my $p (@prereq) { + $CPAN::Frontend->myprint(" $p\n"); + } + my $follow = 0; + if ($CPAN::Config->{prerequisites_policy} eq "follow") { + $follow = 1; + } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { + require ExtUtils::MakeMaker; + my $answer = ExtUtils::MakeMaker::prompt( +"Shall I follow them and prepend them to the queue +of modules we are processing right now?", "yes"); + $follow = $answer =~ /^\s*y/i; + } else { + local($") = ", "; + $CPAN::Frontend->myprint(" Ignoring dependencies on modules @prereq\n"); + } + if ($follow) { + CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself + return; + } + } $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -2977,6 +3447,44 @@ sub make { } } +#-> sub CPAN::Distribution::needs_prereq ; +sub needs_prereq { + my($self) = @_; + return unless -f "Makefile"; # we cannot say much + my $fh = FileHandle->new("<Makefile") or + $CPAN::Frontend->mydie("Couldn't open Makefile: $!"); + local($/) = "\n"; + + my(@p,@need); + while (<$fh>) { + last if /MakeMaker post_initialize section/; + my($p) = m{^[\#] + \s+PREREQ_PM\s+=>\s+(.+) + }x; + next unless $p; + # warn "Found prereq expr[$p]"; + + while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){ + push @p, $1; + } + last; + } + for my $p (@p) { + my $mo = $CPAN::META->instance("CPAN::Module",$p); + next if $mo->uptodate; + # it's not needed, so don't push it. We cannot omit this step, because + # if 'force' is in effect, nobody else will check. + if ($self->{'have_sponsored'}{$p}++){ + # We have already sponsored it and for some reason it's still + # not available. So we do nothing. Or what should we do? + # if we push it again, we have a potential infinite loop + next; + } + push @need, $p; + } + return @need; +} + #-> sub CPAN::Distribution::test ; sub test { my($self) = @_; @@ -2999,6 +3507,12 @@ sub test { Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_test($self); + return; + } + my $system = join " ", $CPAN::Config->{'make'}, "test"; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3021,6 +3535,12 @@ sub clean { chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_clean($self); + return; + } + my $system = join " ", $CPAN::Config->{'make'}, "clean"; if (system($system) == 0) { $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3063,9 +3583,16 @@ sub install { Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + ExtUtils::MM_MacOS::make_install($self); + return; + } + my $system = join(" ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg}); - my($pipe) = FileHandle->new("$system 2>&1 |"); + my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 "; + my($pipe) = FileHandle->new("$system $stderr |"); my($makeout) = ""; while (<$pipe>){ $CPAN::Frontend->myprint($_); @@ -3074,7 +3601,7 @@ sub install { $pipe->close; if ($?==0) { $CPAN::Frontend->myprint(" $system -- OK\n"); - $self->{'install'} = "YES"; + return $self->{'install'} = "YES"; } else { $self->{'install'} = "NO"; $CPAN::Frontend->myprint(" $system -- NOT OK\n"); @@ -3102,58 +3629,67 @@ sub as_string { #-> sub CPAN::Bundle::contains ; sub contains { - my($self) = @_; - my($parsefile) = $self->inst_file; - my($id) = $self->id; - $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; - unless ($parsefile) { - # Try to get at it in the cpan directory - $self->debug("no parsefile") if $CPAN::DEBUG; - Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; - my $dist = $CPAN::META->instance('CPAN::Distribution', - $self->{CPAN_FILE}); - $dist->get; - $self->debug($dist->as_string) if $CPAN::DEBUG; - my($todir) = $CPAN::Config->{'cpan_home'}; - my(@me,$from,$to,$me); - @me = split /::/, $self->id; - $me[-1] .= ".pm"; - $me = MM->catfile(@me); - $from = $self->find_bundle_file($dist->{'build_dir'},$me); - $to = MM->catfile($todir,$me); - File::Path::mkpath(File::Basename::dirname($to)); - File::Copy::copy($from, $to) - or Carp::confess("Couldn't copy $from to $to: $!"); - $parsefile = $to; - } - my @result; - my $fh = FileHandle->new; - local $/ = "\n"; - open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $inpod = 0; - $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; - while (<$fh>) { - $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : - /^=head1\s+CONTENTS/ ? 1 : $inpod; - next unless $inpod; - next if /^=/; - next if /^\s+$/; - chomp; - push @result, (split " ", $_, 2)[0]; - } - close $fh; - delete $self->{STATUS}; - $self->{CONTAINS} = join ", ", @result; - $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; - @result; + my($self) = @_; + my($parsefile) = $self->inst_file; + my($id) = $self->id; + $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; + unless ($parsefile) { + # Try to get at it in the cpan directory + $self->debug("no parsefile") if $CPAN::DEBUG; + Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->{CPAN_FILE}); + $dist->get; + $self->debug($dist->as_string) if $CPAN::DEBUG; + my($todir) = $CPAN::Config->{'cpan_home'}; + my(@me,$from,$to,$me); + @me = split /::/, $self->id; + $me[-1] .= ".pm"; + $me = MM->catfile(@me); + $from = $self->find_bundle_file($dist->{'build_dir'},$me); + $to = MM->catfile($todir,$me); + File::Path::mkpath(File::Basename::dirname($to)); + File::Copy::copy($from, $to) + or Carp::confess("Couldn't copy $from to $to: $!"); + $parsefile = $to; + } + my @result; + my $fh = FileHandle->new; + local $/ = "\n"; + open($fh,$parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; + while (<$fh>) { + $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 : + m/^=head1\s+CONTENTS/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, (split " ", $_, 2)[0]; + } + close $fh; + delete $self->{STATUS}; + $self->{CONTAINS} = join ", ", @result; + $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; + unless (@result) { + $CPAN::Frontend->mywarn(qq{ +The bundle file "$parsefile" may be a broken +bundlefile. It seems not to contain any bundle definition. +Please check the file and if it is bogus, please delete it. +Sorry for the inconvenience. +}); + } + @result; } #-> sub CPAN::Bundle::find_bundle_file sub find_bundle_file { my($self,$where,$what) = @_; $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; - my $bu = MM->catfile($where,$what); - return $bu if -f $bu; +### The following two lines let CPAN.pm become Bundle/CPAN.pm :-( +### my $bu = MM->catfile($where,$what); +### return $bu if -f $bu; my $manifest = MM->catfile($where,"MANIFEST"); unless (-f $manifest) { require ExtUtils::Manifest; @@ -3166,20 +3702,30 @@ sub find_bundle_file { my $fh = FileHandle->new($manifest) or Carp::croak("Couldn't open $manifest: $!"); local($/) = "\n"; + my $what2 = $what; + if ($^O eq 'MacOS') { + $what =~ s/^://; + $what2 =~ tr|:|/|; + $what2 =~ s/:Bundle://; + $what2 =~ tr|:|/|; + } else { + $what2 =~ s|Bundle/||; + } + my $bu; while (<$fh>) { next if /^\s*\#/; my($file) = /(\S+)/; if ($file =~ m|\Q$what\E$|) { $bu = $file; - return MM->catfile($where,$bu); - } elsif ($what =~ s|Bundle/||) { # retry if she managed to - # have no Bundle directory - if ($file =~ m|\Q$what\E$|) { - $bu = $file; - return MM->catfile($where,$bu); - } + # return MM->catfile($where,$bu); # bad + last; } + # retry if she managed to + # have no Bundle directory + $bu = $file if $file =~ m|\Q$what2\E$|; } + $bu =~ tr|/|:| if $^O eq 'MacOS'; + return MM->catfile($where, $bu) if $bu; Carp::croak("Couldn't find a Bundle file in $where"); } @@ -3208,7 +3754,7 @@ sub rematein { my($id) = $self->id; Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" unless $self->inst_file || $self->{CPAN_FILE}; - my($s); + my($s,%fail); for $s ($self->contains) { my($type) = $s =~ m|/| ? 'CPAN::Distribution' : $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; @@ -3219,7 +3765,26 @@ explicitly a file $s. }); sleep 3; } - $CPAN::META->instance($type,$s)->$meth(); + # possibly noisy action: + my $obj = $CPAN::META->instance($type,$s); + $obj->$meth(); + my $success = $obj->can("uptodate") ? $obj->uptodate : 0; + $success ||= $obj->{'install'} && $obj->{'install'} eq "YES"; + $fail{$s} = 1 unless $success; + } + # recap with less noise + if ( $meth eq "install") { + if (%fail) { + $CPAN::Frontend->myprint(qq{\nBundle summary: }. + qq{The following items seem to }. + qq{have had installation problems:\n}); + for $s ($self->contains) { + $CPAN::Frontend->myprint( "$s " ) if $fail{$s}; + } + $CPAN::Frontend->myprint(qq{\n}); + } else { + $self->{'install'} = 'YES'; + } } } @@ -3239,7 +3804,10 @@ sub make { shift->rematein('make',@_); } #-> sub CPAN::Bundle::test ; sub test { shift->rematein('test',@_); } #-> sub CPAN::Bundle::install ; -sub install { shift->rematein('install',@_); } +sub install { + my $self = shift; + $self->rematein('install',@_); +} #-> sub CPAN::Bundle::clean ; sub clean { shift->rematein('clean',@_); } @@ -3282,12 +3850,17 @@ sub as_string { if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){ my $author; if ($author = CPAN::Shell->expand('Author',$userid)) { - push @m, sprintf( - $sprintf2, - 'CPAN_USERID', - $userid, - $author->fullname - ); + my $email = ""; + my $m; # old perls + if ($m = $author->email) { + $email = " <$m>"; + } + push @m, sprintf( + $sprintf2, + 'CPAN_USERID', + $userid, + $author->fullname . $email + ); } } push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) @@ -3300,9 +3873,9 @@ sub as_string { pre-alpha alpha beta released mature standard,; @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,; - @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; - @stati{qw,? f r O,} = qw,unknown functions - references+ties object-oriented,; + @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,; + @stati{qw,? f r O h,} = qw,unknown functions + references+ties object-oriented hybrid,; $statd{' '} = 'unknown'; $stats{' '} = 'unknown'; $statl{' '} = 'unknown'; @@ -3320,23 +3893,8 @@ sub as_string { $stati{$self->{stati}} ) if $self->{statd}; my $local_file = $self->inst_file; - if ($local_file && ! exists $self->{MANPAGE}) { - my $fh = FileHandle->new($local_file) - or Carp::croak("Couldn't open $local_file: $!"); - my $inpod = 0; - my(@result); - local $/ = "\n"; - while (<$fh>) { - $inpod = /^=(?!head1\s+NAME)/ ? 0 : - /^=head1\s+NAME/ ? 1 : $inpod; - next unless $inpod; - next if /^=/; - next if /^\s+$/; - chomp; - push @result, $_; - } - close $fh; - $self->{MANPAGE} = join " ", @result; + if ($local_file) { + $self->{MANPAGE} ||= $self->manpage_headline($local_file); } my($item); for $item (qw/MANPAGE CONTAINS/) { @@ -3350,6 +3908,33 @@ sub as_string { join "", @m, "\n"; } +sub manpage_headline { + my($self,$local_file) = @_; + my(@local_file) = $local_file; + $local_file =~ s/\.pm$/.pod/; + push @local_file, $local_file; + my(@result,$locf); + for $locf (@local_file) { + next unless -f $locf; + my $fh = FileHandle->new($locf) + or $Carp::Frontend->mydie("Couldn't open $locf: $!"); + my $inpod = 0; + local $/ = "\n"; + while (<$fh>) { + $inpod = m/^=(?!head1\s+NAME)/ ? 0 : + m/^=head1\s+NAME/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, $_; + } + close $fh; + last if @result; + } + join " ", @result; +} + #-> sub CPAN::Module::cpan_file ; sub cpan_file { my $self = shift; @@ -3362,12 +3947,12 @@ sub cpan_file { } elsif (exists $self->{'userid'} && defined $self->{'userid'}) { my $fullname = $CPAN::META->instance(CPAN::Author, $self->{'userid'})->fullname; - unless (defined $fullname) { - $CPAN::Frontend->mywarn(qq{Full name of author }. - qq{$self->{userid} not known}); - return "Contact Author $self->{userid}"; + my $email = $CPAN::META->instance(CPAN::Author, + $self->{'userid'})->email; + unless (defined $fullname && defined $email) { + return "Contact Author $self->{userid} (Try ``a $self->{userid}'')"; } - return "Contact Author $self->{userid} ($fullname)" + return "Contact Author $fullname <$email>"; } else { return "N/A"; } @@ -3378,7 +3963,7 @@ sub cpan_file { #-> sub CPAN::Module::cpan_version ; sub cpan_version { my $self = shift; - $self->{'CPAN_VERSION'} = 'undef' + $self->{'CPAN_VERSION'} = 'undef' unless defined $self->{'CPAN_VERSION'}; # I believe this is # always a bug in the # index and should be @@ -3402,8 +3987,19 @@ sub rematein { my($self,$meth) = @_; $self->debug($self->id) if $CPAN::DEBUG; my $cpan_file = $self->cpan_file; - return if $cpan_file eq "N/A"; - return if $cpan_file =~ /^Contact Author/; + if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){ + $CPAN::Frontend->mywarn(sprintf qq{ + The module %s isn\'t available on CPAN. + + Either the module has not yet been uploaded to CPAN, or it is + temporary unavailable. Please contact the author to find out + more about the status. Try ``i %s''. +}, + $self->id, + $self->id, + ); + return; + } my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); $pack->called_for($self->id); $pack->force if exists $self->{'force_update'}; @@ -3421,10 +4017,9 @@ sub get { shift->rematein('get',@_); } sub make { shift->rematein('make') } #-> sub CPAN::Module::test ; sub test { shift->rematein('test') } -#-> sub CPAN::Module::install ; -sub install { +#-> sub CPAN::Module::uptodate ; +sub uptodate { my($self) = @_; - my($doit) = 0; my($latest) = $self->cpan_version; $latest ||= 0; my($inst_file) = $self->inst_file; @@ -3432,19 +4027,26 @@ sub install { if (defined $inst_file) { $have = $self->inst_version; } - if (1){ # A block for scoping $^W, the if is just for the visual - # appeal - local($^W)=0; - if ($inst_file - && - $have >= $latest - && - not exists $self->{'force_update'} - ) { - $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); - } else { - $doit = 1; - } + local($^W)=0; + if ($inst_file + && + $have >= $latest + ) { + return 1; + } + return; +} +#-> sub CPAN::Module::install ; +sub install { + my($self) = @_; + my($doit) = 0; + if ($self->uptodate + && + not exists $self->{'force_update'} + ) { + $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); + } else { + $doit = 1; } $self->rematein('install') if $doit; } @@ -3487,11 +4089,174 @@ sub inst_version { my($self) = @_; my $parsefile = $self->inst_file or return; local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; + # warn "HERE"; my $have = MM->parse_version($parsefile) || "undef"; $have =~ s/\s+//g; $have; } +package CPAN::Tarzip; + +sub gzip { + my($class,$read,$write) = @_; + if ($CPAN::META->has_inst("Compress::Zlib")) { + my($buffer,$fhw); + $fhw = FileHandle->new($read) + or $CPAN::Frontend->mydie("Could not open $read: $!"); + my $gz = Compress::Zlib::gzopen($write, "wb") + or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n"); + $gz->gzwrite($buffer) + while read($fhw,$buffer,4096) > 0 ; + $gz->gzclose() ; + $fhw->close; + return 1; + } else { + system("$CPAN::Config->{'gzip'} -c $read > $write")==0; + } +} + +sub gunzip { + my($class,$read,$write) = @_; + if ($CPAN::META->has_inst("Compress::Zlib")) { + my($buffer,$fhw); + $fhw = FileHandle->new(">$write") + or $CPAN::Frontend->mydie("Could not open >$write: $!"); + my $gz = Compress::Zlib::gzopen($read, "rb") + or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n"); + $fhw->print($buffer) + while $gz->gzread($buffer) > 0 ; + $CPAN::Frontend->mydie("Error reading from $read: $!\n") + if $gz->gzerror != Compress::Zlib::Z_STREAM_END(); + $gz->gzclose() ; + $fhw->close; + return 1; + } else { + system("$CPAN::Config->{'gzip'} -dc $read > $write")==0; + } +} + +sub gtest { + my($class,$read) = @_; + if ($CPAN::META->has_inst("Compress::Zlib")) { + my($buffer); + my $gz = Compress::Zlib::gzopen($read, "rb") + or $CPAN::Frontend->mydie("Cannot open $read: $!\n"); + 1 while $gz->gzread($buffer) > 0 ; + $CPAN::Frontend->mydie("Error reading from $read: $!\n") + if $gz->gzerror != Compress::Zlib::Z_STREAM_END(); + $gz->gzclose() ; + return 1; + } else { + return system("$CPAN::Config->{'gzip'} -dt $read")==0; + } +} + +sub TIEHANDLE { + my($class,$file) = @_; + my $ret; + $class->debug("file[$file]"); + if ($CPAN::META->has_inst("Compress::Zlib")) { + my $gz = Compress::Zlib::gzopen($file,"rb") or + die "Could not gzopen $file"; + $ret = bless {GZ => $gz}, $class; + } else { + my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |"; + my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!"; + binmode $fh; + $ret = bless {FH => $fh}, $class; + } + $ret; +} + +sub READLINE { + my($self) = @_; + if (exists $self->{GZ}) { + my $gz = $self->{GZ}; + my($line,$bytesread); + $bytesread = $gz->gzreadline($line); + return undef if $bytesread == 0; + return $line; + } else { + my $fh = $self->{FH}; + return scalar <$fh>; + } +} + +sub READ { + my($self,$ref,$length,$offset) = @_; + die "read with offset not implemented" if defined $offset; + if (exists $self->{GZ}) { + my $gz = $self->{GZ}; + my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8 + return $byteread; + } else { + my $fh = $self->{FH}; + return read($fh,$$ref,$length); + } +} + +sub DESTROY { + my($self) = @_; + if (exists $self->{GZ}) { + my $gz = $self->{GZ}; + $gz->gzclose(); + } else { + my $fh = $self->{FH}; + $fh->close; + } + undef $self; +} + +sub untar { + my($class,$file) = @_; + # had to disable, because version 0.07 seems to be buggy + if (MM->maybe_command($CPAN::Config->{'gzip'}) + && + MM->maybe_command($CPAN::Config->{'tar'})) { + if ($^O =~ /win/i) { # irgggh + # people find the most curious tar binaries that cannot handle + # pipes + my $system = "$CPAN::Config->{'gzip'} --decompress $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); + } else { + $CPAN::Frontend->mydie( + qq{Couldn\'t uncompress $file\n} + ); + } + $file =~ s/\.gz$//; + $system = "$CPAN::Config->{tar} xvf $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); + } else { + $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); + } + return 1; + } else { + my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . + "< $file | $CPAN::Config->{tar} xvf -"; + return system($system) == 0; + } + } elsif ($CPAN::META->has_inst("Archive::Tar") + && + $CPAN::META->has_inst("Compress::Zlib") ) { + my $tar = Archive::Tar->new($file,1); + $tar->extract($tar->list_files); # I'm pretty sure we have nothing + # that isn't compressed + + ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1) + if ($^O eq 'MacOS'); + + return 1; + } else { + $CPAN::Frontend->mydie(qq{ +CPAN.pm needs either both external programs tar and gzip installed or +both the modules Archive::Tar and Compress::Zlib. Neither prerequisite +is available. Can\'t continue. +}); + } +} + package CPAN; 1; @@ -3536,7 +4301,15 @@ session. The cache manager keeps track of the disk space occupied by the make processes and deletes excess space according to a simple FIFO mechanism. -All methods provided are accessible in a programmer style and in an +For extended searching capabilities there's a plugin for CPAN available, +L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes +all documents available in CPAN authors directories. If C<CPAN::WAIT> +is installed on your system, the interactive shell of <CPAN.pm> will +enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send +queries to the WAIT server that has been configured for your +installation. + +All other methods provided are accessible in a programmer style and in an interactive shell style. =head2 Interactive Mode @@ -3545,9 +4318,9 @@ The interactive mode is entered by running perl -MCPAN -e shell -which puts you into a readline interface. You will have most fun if +which puts you into a readline interface. You will have the most fun if you install Term::ReadKey and Term::ReadLine to enjoy both history and -completion. +command completion. Once you are on the command line, type 'h' and the rest should be self-explanatory. @@ -3563,15 +4336,15 @@ for each of the four categories and another, C<i> for any of the mentioned four. Each of the four entities is implemented as a class with slightly differing methods for displaying an object. -Arguments you pass to these commands are either strings matching exact +Arguments you pass to these commands are either strings exactly matching the identification string of an object or regular expressions that are then matched case-insensitively against various attributes of the -objects. The parser recognizes a regualar expression only if you +objects. The parser recognizes a regular expression only if you enclose it between two slashes. The principle is that the number of found objects influences how an -item is displayed. If the search finds one item, we display the result -of object-E<gt>as_string, but if we find more than one, we display +item is displayed. If the search finds one item, the result is displayed +as object-E<gt>as_string, but if we find more than one, we display each as object-E<gt>as_glimpse. E.g. cpan> a ANDK @@ -3592,27 +4365,30 @@ each as object-E<gt>as_glimpse. E.g. =item make, test, install, clean modules or distributions -These commands do indeed exist just as written above. Each of them -takes any number of arguments and investigates for each what it might -be. Is it a distribution file (recognized by embedded slashes), this -file is being processed. Is it a module, CPAN determines the -distribution file where this module is included and processes that. +These commands take any number of arguments and investigates what is +necessary to perform the action. If the argument is a distribution +file name (recognized by embedded slashes), it is processed. If it is +a module, CPAN determines the distribution file in which this module +is included and processes that, following any dependencies named in +the module's Makefile.PL (this behavior is controlled by +I<prerequisites_policy>.) -Any C<make>, C<test>, and C<readme> are run unconditionally. A +Any C<make> or C<test> are run unconditionally. An install <distribution_file> -also is run unconditionally. But for +also is run unconditionally. But for install <module> CPAN checks if an install is actually needed for it and prints -I<Foo up to date> in case the module doesnE<39>t need to be updated. +I<module up to date> in the case that the distribution file containing +the module doesnE<39>t need to be updated. CPAN also keeps track of what it has done within the current session and doesnE<39>t try to build a package a second time regardless if it -succeeded or not. The C<force > command takes as first argument the -method to invoke (currently: make, test, or install) and executes the +succeeded or not. The C<force> command takes as a first argument the +method to invoke (currently: C<make>, C<test>, or C<install>) and executes the command from scratch. Example: @@ -3625,13 +4401,31 @@ Example: OpenGL-0.4/COPYRIGHT [...] +A C<clean> command results in a + + make clean + +being executed within the distribution file's working directory. + =item readme, look module or distribution These two commands take only one argument, be it a module or a -distribution file. C<readme> displays the README of the associated -distribution file. C<Look> gets and untars (if not yet done) the -distribution file, changes to the appropriate directory and opens a -subshell process in that directory. +distribution file. C<readme> unconditionally runs, displaying the +README of the associated distribution file. C<Look> gets and +untars (if not yet done) the distribution file, changes to the +appropriate directory and opens a subshell process in that directory. + +=item Signals + +CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are +in the cpan-shell it is intended that you can press C<^C> anytime and +return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell +to clean up and leave the shell loop. You can emulate the effect of a +SIGTERM by sending two consecutive SIGINTs, which usually means by +pressing C<^C> twice. + +CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a +SIGALRM is used during the run of the C<perl Makefile.PL> subprocess. =back @@ -3658,15 +4452,14 @@ current date and a counter. recompile() is a very special command in that it takes no argument and runs the make/test/install cycle with brute force over all installed dynamically loadable extensions (aka XS modules) with 'force' in -effect. Primary purpose of this command is to finish a network +effect. The primary purpose of this command is to finish a network installation. Imagine, you have a common source tree for two different architectures. You decide to do a completely independent fresh installation. You start on one architecture with the help of a Bundle file produced earlier. CPAN installs the whole Bundle for you, but when you try to repeat the job on the second architecture, CPAN responds with a C<"Foo up to date"> message for all modules. So you -will be glad to run recompile in the second architecture and -youE<39>re done. +invoke CPAN's recompile on the second architecture and youE<39>re done. Another popular use for C<recompile> is to act as a rescue in case your perl breaks binary compatibility. If one of the modules that CPAN uses @@ -3675,13 +4468,13 @@ commands), then you should try the CPAN::Nox module for recovery. =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution -Although it may be considered internal, the class hierarchie does -matter for both users and programmer. CPAN.pm deals with above -mentioned four classes, and all those classes share a set of -methods. It is a classical single polymorphism that is in effect. A -metaclass object registers all objects of all kinds and indexes them -with a string. The strings referencing objects have a separated -namespace (well, not completely separated): +Although it may be considered internal, the class hierarchy does matter +for both users and programmer. CPAN.pm deals with above mentioned four +classes, and all those classes share a set of methods. A classical +single polymorphism is in effect. A metaclass object registers all +objects of all kinds and indexes them with a string. The strings +referencing objects have a separated namespace (well, not completely +separated): Namespace Class @@ -3690,20 +4483,20 @@ namespace (well, not completely separated): everything else Module or Author Modules know their associated Distribution objects. They always refer -to the most recent official release. Developers may mark their -releases as unstable development versions (by inserting an underbar -into the visible version number), so not always is the default -distribution for a given module the really hottest and newest. If a -module Foo circulates on CPAN in both version 1.23 and 1.23_90, -CPAN.pm offers a convenient way to install version 1.23 by saying +to the most recent official release. Developers may mark their releases +as unstable development versions (by inserting an underbar into the +visible version number), so the really hottest and newest distribution +file is not always the default. If a module Foo circulates on CPAN in +both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to +install version 1.23 by saying install Foo This would install the complete distribution file (say -BAR/Foo-1.23.tar.gz) with all accompanying material in there. But if -you would like to install version 1.23_90, you need to know where the +BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would +like to install version 1.23_90, you need to know where the distribution file resides on CPAN relative to the authors/id/ -directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz, +directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz; so you would have to say install BAR/Foo-1.23_90.tar.gz @@ -3717,7 +4510,7 @@ If you do not enter the shell, the available shell commands are both available as methods (C<CPAN::Shell-E<gt>install(...)>) and as functions in the calling package (C<install(...)>). -There's currently only one class that has a stable interface, +There's currently only one class that has a stable interface - CPAN::Shell. All commands that are available in the CPAN shell are methods of the class CPAN::Shell. Each of the commands that produce listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the @@ -3758,7 +4551,7 @@ functionalities that are available in the shell. =back -=head2 Methods in the four +=head2 Methods in the four Classes =head2 Cache Manager @@ -3785,7 +4578,7 @@ define any functions or methods. It usually only contains documentation. It starts like a perl module with a package declaration and a $VERSION variable. After that the pod section looks like any other pod with the -only difference, that I<one special pod section> exists starting with +only difference being that I<one special pod section> exists starting with (verbatim): =head1 CONTENTS @@ -3795,7 +4588,7 @@ In this pod section each line obeys the format Module_Name [Version_String] [- optional text] The only required part is the first field, the name of a module -(eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest +(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest of the line is optional. The comment part is delimited by a dash just as in the man page header. @@ -3804,7 +4597,7 @@ other distributions. Bundles are treated specially in the CPAN package. If you say 'install Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all -the modules in the CONTENTS section of the pod. You can install your +the modules in the CONTENTS section of the pod. You can install your own Bundles locally by placing a conformant Bundle file somewhere into your @INC path. The autobundle() command which is available in the shell interface does that for you by including all currently installed @@ -3822,6 +4615,8 @@ If you have neither Net::FTP nor LWP, there is a fallback mechanism implemented for an external ftp command or for an external lynx command. +=head2 Finding packages and VERSION + This module presumes that all packages on CPAN =over 2 @@ -3829,13 +4624,13 @@ This module presumes that all packages on CPAN =item * declare their $VERSION variable in an easy to parse manner. This -prerequisite can hardly be relaxed because it consumes by far too much +prerequisite can hardly be relaxed because it consumes far too much memory to load all packages into the running program just to determine -the $VERSION variable . Currently all programs that are dealing with +the $VERSION variable. Currently all programs that are dealing with version use something like this perl -MExtUtils::MakeMaker -le \ - 'print MM->parse_version($ARGV[0])' filename + 'print MM->parse_version(shift)' filename If you are author of a package and wonder if your $VERSION can be parsed, please try the above method. @@ -3843,7 +4638,7 @@ parsed, please try the above method. =item * come as compressed or gzipped tarfiles or as zip files and contain a -Makefile.PL (well we try to handle a bit more, but without much +Makefile.PL (well, we try to handle a bit more, but without much enthusiasm). =back @@ -3857,12 +4652,12 @@ synchronicity, and of bugs within CPAN.pm. In interactive mode you can try "o debug" which will list options for debugging the various parts of the package. The output may not be very -useful for you as it's just a byproduct of my own testing, but if you +useful for you as it's just a by-product of my own testing, but if you have an idea which part of the package may have a bug, it's sometimes worth to give it a try and send me more specific output. You should know that "o debug" has built-in completion support. -=head2 Floppy, Zip, and all that Jazz +=head2 Floppy, Zip, Offline Mode CPAN.pm works nicely without network too. If you maintain machines that are not networked at all, you should consider working with file: @@ -3875,7 +4670,7 @@ with this floppy. =head1 CONFIGURATION -When the CPAN module is installed a site wide configuration file is +When the CPAN module is installed, a site wide configuration file is created as CPAN/Config.pm. The default values defined there can be overridden in another configuration file: CPAN/MyConfig.pm. You can store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because @@ -3887,23 +4682,31 @@ defined: build_cache size of cache for directories to build modules build_dir locally accessible directory to build modules - index_expire after how many days refetch index files + index_expire after this many days refetch index files cpan_home local directory reserved for this package gzip location of external program gzip - inactivity_timeout breaks interactive Makefile.PLs after that + inactivity_timeout breaks interactive Makefile.PLs after this many seconds inactivity. Set to 0 to never break. inhibit_startup_message if true, does not print the startup message keep_source keep the source in a local directory? - keep_source_where where keep the source (if we do) - make location of external program make + keep_source_where directory in which to keep the source (if we do) + make location of external make program make_arg arguments that should always be passed to 'make' make_install_arg same as make_arg for 'make install' makepl_arg arguments passed to 'perl Makefile.PL' pager location of external program more (or any pager) + prerequisites_policy + what to do if you are missing module prerequisites + ('follow' automatically, 'ask' me, or 'ignore') + scan_cache controls scanning of cache ('atstart' or 'never') tar location of external program tar unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) + wait_list arrayref to a wait server to try (See CPAN::WAIT) + ftp_proxy, } the three usual variables for configuring + http_proxy, } proxy requests. Both as CPAN::Config variables + no_proxy } and as environment variables configurable. You can set and query each of these options interactively in the cpan shell with the command set defined within the C<o conf> command: @@ -3933,7 +4736,7 @@ works like the corresponding perl commands. =back -=head2 CD-ROM support +=head2 urllist parameter has CD-ROM support The C<urllist> parameter of the configuration table contains a list of URLs that are to be used for downloading. If the list contains any @@ -3948,6 +4751,14 @@ CPAN.pm will then fetch the index files from one of the CPAN sites that come at the beginning of urllist. It will later check for each module if there is a local copy of the most recent version. +Another peculiarity of urllist is that the site that we could +successfully fetch the last file from automatically gets a preference +token and is tried as the first site for the next request. So if you +add a new site at runtime it may happen that the previously preferred +site will be tried another time. This means that if you want to disallow +a site for the next transfer, it must be explicitly removed from +urllist. + =head1 SECURITY There's no strong security layer in CPAN.pm. CPAN.pm helps you to @@ -3955,7 +4766,7 @@ install foreign, unmasked, unsigned code on your machine. We compare to a checksum that comes from the net just as the distribution file itself. If somebody has managed to tamper with the distribution file, they may have as well tampered with the CHECKSUMS file. Future -development will go towards strong authentification. +development will go towards strong authentication. =head1 EXPORT @@ -3963,19 +4774,108 @@ Most functions in package CPAN are exported per default. The reason for this is that the primary use is intended for the cpan shell or for oneliners. +=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES + +To populate a freshly installed perl with my favorite modules is pretty +easiest by maintaining a private bundle definition file. To get a useful +blueprint of a bundle definition file, the command autobundle can be used +on the CPAN shell command line. This command writes a bundle definition +file for all modules that re installed for the currently running perl +interpreter. It's recommended to run this command only once and from then +on maintain the file manually under a private name, say +Bundle/my_bundle.pm. With a clever bundle file you can then simply say + + cpan> install Bundle::my_bundle + +then answer a few questions and then go out. + +Maintaining a bundle definition file means to keep track of two things: +dependencies and interactivity. CPAN.pm (currently) does not take into +account dependencies between distributions, so a bundle definition file +should specify distributions that depend on others B<after> the others. +On the other hand, it's a bit annoying that many distributions need some +interactive configuring. So what I try to accomplish in my private bundle +file is to have the packages that need to be configured early in the file +and the gentle ones later, so I can go out after a few minutes and leave +CPAN.pm unattained. + +=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS + +Thanks to Graham Barr for contributing the firewall following howto. + +Firewalls can be categorized into three basic types. + +=over + +=item http firewall + +This is where the firewall machine runs a web server and to access the +outside world you must do it via the web server. If you set environment +variables like http_proxy or ftp_proxy to a values beginning with http:// +or in your web browser you have to set proxy information then you know +you are running a http firewall. + +To access servers outside these types of firewalls with perl (even for +ftp) you will need to use LWP. + +=item ftp firewall + +This where the firewall machine runs a ftp server. This kind of firewall will +only let you access ftp serves outside the firewall. This is usually done by +connecting to the firewall with ftp, then entering a username like +"user@outside.host.com" + +To access servers outside these type of firewalls with perl you +will need to use Net::FTP. + +=item One way visibility + +I say one way visibility as these firewalls try to make themselve look +invisible to the users inside the firewall. An FTP data connection is +normally created by sending the remote server your IP address and then +listening for the connection. But the remote server will not be able to +connect to you because of the firewall. So for these types of firewall +FTP connections need to be done in a passive mode. + +There are two that I can think off. + +=over + +=item SOCKS + +If you are using a SOCKS firewall you will need to compile perl and link +it with the SOCKS library, this is what is normally called a ``socksified'' +perl. With this executable you will be able to connect to servers outside +the firewall as if it is not there. + +=item IP Masquerade + +This is the firewall implemented in the Linux kernel, it allows you to +hide a complete network behind one IP address. With this firewall no +special compiling is need as you can access hosts directly. + +=back + +=back + =head1 BUGS -we should give coverage for _all_ of the CPAN and not just the -PAUSE part, right? In this discussion CPAN and PAUSE have become -equal -- but they are not. PAUSE is authors/ and modules/. CPAN is -PAUSE plus the clpa/, doc/, misc/, ports/, src/, scripts/. +We should give coverage for _all_ of the CPAN and not just the PAUSE +part, right? In this discussion CPAN and PAUSE have become equal -- +but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus +the clpa/, doc/, misc/, ports/, src/, scripts/. Future development should be directed towards a better integration of the other parts. +If a Makefile.PL requires special customization of libraries, prompts +the user for special input, etc. then you may find CPAN is not able to +build the distribution. In that case, you should attempt the +traditional method of building a Perl module package from a shell. + =head1 AUTHOR -Andreas König E<lt>a.koenig@mind.deE<gt> +Andreas König E<lt>a.koenig@kulturbox.deE<gt> =head1 SEE ALSO diff --git a/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm b/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm index ae09240c0f3..801304aa19a 100644 --- a/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm +++ b/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm @@ -13,9 +13,10 @@ package CPAN::FirstTime; use strict; use ExtUtils::MakeMaker qw(prompt); use FileHandle (); +use File::Basename (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.1 $, 10; +$VERSION = substr q$Revision: 1.2 $, 10; =head1 NAME @@ -36,22 +37,61 @@ file. Nothing special. sub init { my($configpm) = @_; use Config; - require CPAN::Nox; + unless ($CPAN::VERSION) { + require CPAN::Nox; + } eval {require CPAN::Config;}; $CPAN::Config ||= {}; local($/) = "\n"; local($\) = ""; + local($|) = 1; my($ans,$default,$local,$cont,$url,$expected_size); - + # # Files, directories # + print qq[ + +CPAN is the world-wide archive of perl resources. It consists of about +100 sites that all replicate the same contents all around the globe. +Many countries have at least one CPAN site already. The resources +found on CPAN are easily accessible with the CPAN.pm module. If you +want to use CPAN.pm, you have to configure it properly. + +If you do not want to enter a dialog now, you can answer 'no' to this +question and I\'ll try to autoconfigure. (Note: you can revisit this +dialog anytime later by typing 'o conf init' at the cpan prompt.) + +]; + + my $manual_conf = + ExtUtils::MakeMaker::prompt("Are you ready for manual configuration?", + "yes"); + my $fastread; + { + local $^W; + if ($manual_conf =~ /^\s*y/i) { + $fastread = 0; + *prompt = \&ExtUtils::MakeMaker::prompt; + } else { + $fastread = 1; + *prompt = sub { + my($q,$a) = @_; + my($ret) = defined $a ? $a : ""; + printf qq{%s [%s]\n\n}, $q, $ret; + $ret; + }; + } + } print qq{ -The CPAN module needs a directory of its own to cache important -index files and maybe keep a temporary mirror of CPAN files. This may -be a site-wide directory or a personal directory. + +The following questions are intended to help you with the +configuration. The CPAN module needs a directory of its own to cache +important index files and maybe keep a temporary mirror of CPAN files. +This may be a site-wide directory or a personal directory. + }; my $cpan_home = $CPAN::Config->{cpan_home} || MM->catdir($ENV{HOME}, ".cpan"); @@ -73,16 +113,21 @@ First of all, I\'d like to create this directory. Where? $default = $cpan_home; while ($ans = prompt("CPAN build and cache directory?",$default)) { - File::Path::mkpath($ans); # dies if it can't - if (-d $ans && -w _) { - last; - } else { - warn "Couldn't find directory $ans + eval { File::Path::mkpath($ans); }; # dies if it can't + if ($@) { + warn "Couldn't create directory $ans. +Please retry.\n"; + next; + } + if (-d $ans && -w _) { + last; + } else { + warn "Couldn't find directory $ans or directory is not writable. Please retry.\n"; - } + } } $CPAN::Config->{cpan_home} = $ans; - + print qq{ If you want, I can keep the source files after a build in the cpan @@ -113,6 +158,42 @@ with all the intermediate files? # XXX This the time when we refetch the index files (in days) $CPAN::Config->{'index_expire'} = 1; + print qq{ + +By default, each time the CPAN module is started, cache scanning +is performed to keep the cache size in sync. To prevent from this, +disable the cache scanning with 'never'. + +}; + + $default = $CPAN::Config->{scan_cache} || 'atstart'; + do { + $ans = prompt("Perform cache scanning (atstart or never)?", $default); + } while ($ans ne 'atstart' && $ans ne 'never'); + $CPAN::Config->{scan_cache} = $ans; + + # + # prerequisites_policy + # Do we follow PREREQ_PM? + # + print qq{ + +The CPAN module can detect when a module that which you are trying to +build depends on prerequisites. If this happens, it can build the +prerequisites for you automatically ('follow'), ask you for +confirmation ('ask'), or just ignore them ('ignore'). Please set your +policy to one of the three values. + +}; + + $default = $CPAN::Config->{prerequisites_policy} || 'follow'; + do { + $ans = + prompt("Policy on building prerequisites (follow, ask or ignore)?", + $default); + } while ($ans ne 'follow' && $ans ne 'ask' && $ans ne 'ignore'); + $CPAN::Config->{prerequisites_policy} = $ans; + # # External programs # @@ -126,24 +207,46 @@ those. }; + my $old_warn = $^W; + local $^W if $^O eq 'MacOS'; my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; - my $prog; - for $prog (qw/gzip tar unzip make lynx ncftp ftp/){ - my $path = $CPAN::Config->{$prog} || ""; - if (MM->file_name_is_absolute($path)) { - warn "Warning: configured $path does not exist\n" unless -e $path; - $path = ""; - } else { - $path = ''; - } - $path ||= find_exe($prog,[@path]); - warn "Warning: $prog not found in PATH\n" unless -e $path; - $ans = prompt("Where is your $prog program?",$path) || $path; - $CPAN::Config->{$prog} = $ans; + local $^W = $old_warn; + my $progname; + for $progname (qw/gzip tar unzip make lynx ncftpget ncftp ftp/){ + if ($^O eq 'MacOS') { + $CPAN::Config->{$progname} = 'not_here'; + next; + } + my $progcall = $progname; + # we don't need ncftp if we have ncftpget + next if $progname eq "ncftp" && $CPAN::Config->{ncftpget} gt " "; + my $path = $CPAN::Config->{$progname} + || $Config::Config{$progname} + || ""; + if (MM->file_name_is_absolute($path)) { + # testing existence is not good enough, some have these exe + # extensions + + # warn "Warning: configured $path does not exist\n" unless -e $path; + # $path = ""; + } else { + $path = ''; + } + unless ($path) { + # e.g. make -> nmake + $progcall = $Config::Config{$progname} if $Config::Config{$progname}; + } + + $path ||= find_exe($progcall,[@path]); + warn "Warning: $progcall not found in PATH\n" unless + $path; # not -e $path, because find_exe already checked that + $ans = prompt("Where is your $progname program?",$path) || $path; + $CPAN::Config->{$progname} = $ans; } my $path = $CPAN::Config->{'pager'} || $ENV{PAGER} || find_exe("less",[@path]) || - find_exe("more",[@path]) || "more"; + find_exe("more",[@path]) || ($^O eq 'MacOS' ? $ENV{EDITOR} : 0 ) + || "more"; $ans = prompt("What is your favorite pager program?",$path); $CPAN::Config->{'pager'} = $ans; $path = $CPAN::Config->{'shell'}; @@ -152,8 +255,13 @@ those. $path = ""; } $path ||= $ENV{SHELL}; - $ans = prompt("What is your favorite shell?",$path); - $CPAN::Config->{'shell'} = $ans; + if ($^O eq 'MacOS') { + $CPAN::Config->{'shell'} = 'not_here'; + } else { + $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only + $ans = prompt("What is your favorite shell?",$path); + $CPAN::Config->{'shell'} = $ans; + } # # Arguments to make etc. @@ -198,53 +306,29 @@ the default and recommended setting. $default = $CPAN::Config->{inactivity_timeout} || 0; $CPAN::Config->{inactivity_timeout} = - prompt("Timeout for inacivity during Makefile.PL?",$default); + prompt("Timeout for inactivity during Makefile.PL?",$default); + # Proxies - # - # MIRRORED.BY - # + print qq{ - $local = 'MIRRORED.BY'; - $local = MM->catfile($CPAN::Config->{keep_source_where},"MIRRORED.BY") unless -f $local; - if (@{$CPAN::Config->{urllist}||[]}) { - print qq{ -I found a list of URLs in CPAN::Config and will use this. -You can change it later with the 'o conf urllist' command. +If you\'re accessing the net via proxies, you can specify them in the +CPAN configuration or via environment variables. The variable in +the \$CPAN::Config takes precedence. -} - } elsif ( - -s $local - && - -M $local < 30 - ) { - read_mirrored_by($local); - } else { - $CPAN::Config->{urllist} ||= []; - while (! @{$CPAN::Config->{urllist}}) { - my($input) = prompt(qq{ -We need to know the URL of your favorite CPAN site. -Please enter it here:}); - $input =~ s/\s//g; - next unless $input; - my($wanted) = "MIRRORED.BY"; - print qq{ -Testing "$input" ... -}; - push @{$CPAN::Config->{urllist}}, $input; - CPAN::FTP->localize($wanted,$local,"force"); - if (-s $local) { - print qq{ -"$input" seems to work }; - } else { - my $ans = prompt(qq{$input doesn\'t seem to work. Keep it in the list?},"n"); - last unless $ans =~ /^n/i; - pop @{$CPAN::Config->{urllist}}; - } - } + + for (qw/ftp_proxy http_proxy no_proxy/) { + $default = $CPAN::Config->{$_} || $ENV{$_}; + $CPAN::Config->{$_} = prompt("Your $_?",$default); } + # + # MIRRORED.BY + # + + conf_sites() unless $fastread; + unless (@{$CPAN::Config->{'wait_list'}||[]}) { print qq{ @@ -258,19 +342,6 @@ you don\'t know a WAIT server near you, just press ENTER. push @{$CPAN::Config->{'wait_list'}}, $ans; } - print qq{ - -If you\'re accessing the net via proxies, you can specify them in the -CPAN configuration or via environment variables. The variable in -the \$CPAN::Config takes precedence. - -}; - - for (qw/ftp_proxy http_proxy no_proxy/) { - $default = $CPAN::Config->{$_} || $ENV{$_}; - $CPAN::Config->{$_} = prompt("Your $_?",$default); - } - # We don't ask that now, it will be noticed in time, won't it? $CPAN::Config->{'inhibit_startup_message'} = 0; $CPAN::Config->{'getcwd'} = 'cwd'; @@ -279,23 +350,72 @@ the \$CPAN::Config takes precedence. CPAN::Config->commit($configpm); } +sub conf_sites { + my $m = 'MIRRORED.BY'; + my $mby = MM->catfile($CPAN::Config->{keep_source_where},$m); + File::Path::mkpath(File::Basename::dirname($mby)); + if (-f $mby && -f $m && -M $m < -M $mby) { + require File::Copy; + File::Copy::copy($m,$mby) or die "Could not update $mby: $!"; + } + if ( ! -f $mby ){ + print qq{You have no $mby + I\'m trying to fetch one +}; + $mby = CPAN::FTP->localize($m,$mby,3); + } elsif (-M $mby > 30 ) { + print qq{Your $mby is older than 30 days, + I\'m trying to fetch one +}; + $mby = CPAN::FTP->localize($m,$mby,3); + } + read_mirrored_by($mby); +} + sub find_exe { my($exe,$path) = @_; my($dir); #warn "in find_exe exe[$exe] path[@$path]"; for $dir (@$path) { my $abs = MM->catfile($dir,$exe); - if (MM->maybe_command($abs)) { + if (($abs = MM->maybe_command($abs))) { return $abs; } } } +sub picklist { + my($items,$prompt,$default,$require_nonempty,$empty_warning)=@_; + $default ||= ''; + + my ($item, $i); + for $item (@$items) { + printf "(%d) %s\n", ++$i, $item; + } + + my @nums; + while (1) { + my $num = prompt($prompt,$default); + @nums = split (' ', $num); + (warn "invalid items entered, try again\n"), next + if grep (/\D/ || $_ < 1 || $_ > $i, @nums); + if ($require_nonempty) { + (warn "$empty_warning\n"), next + unless @nums; + } + last; + } + print "\n"; + for (@nums) { $_-- } + @{$items}[@nums]; +} + sub read_mirrored_by { my($local) = @_; my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location); my $fh = FileHandle->new; $fh->open($local) or die "Couldn't open $local: $!"; + local $/ = "\012"; while (<$fh>) { ($host) = /^([\w\.\-]+)/ unless defined $host; next unless defined $host; @@ -303,6 +423,7 @@ sub read_mirrored_by { /location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and ($continent, $country) = @location[-1,-2]; $continent =~ s/\s\(.*//; + $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude /dst_dst\s+=\s+\"([^\"]+)/ and $dst = $1; next unless $host && $dst && $continent && $country; $all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst); @@ -311,92 +432,97 @@ sub read_mirrored_by { } $fh->close; $CPAN::Config->{urllist} ||= []; - if ($expected_size = @{$CPAN::Config->{urllist}}) { - for $url (@{$CPAN::Config->{urllist}}) { - # sanity check, scheme+colon, not "q" there: - next unless $url =~ /^\w+:\/./; - $all{"[From previous setup]"}{"found URL"}{$url}=CPAN::Mirrored::By->new('[From previous setup]','found URL',$url); - } + my(@previous_urls); + if (@previous_urls = @{$CPAN::Config->{urllist}}) { $CPAN::Config->{urllist} = []; - } else { - $expected_size = 6; } - + print qq{ -Now we need to know, where your favorite CPAN sites are located. Push +Now we need to know where your favorite CPAN sites are located. Push a few sites onto the array (just in case the first on the array won\'t work). If you are mirroring CPAN to your local workstation, specify a file: URL. -You can enter the number in front of the URL on the next screen, a -file:, ftp: or http: URL, or "q" to finish selecting. +First, pick a nearby continent and country (you can pick several of +each, separated by spaces, or none if you just want to keep your +existing selections). Then, you will be presented with a list of URLs +of CPAN mirrors in the countries you selected, along with previously +selected URLs. Select some of those URLs, or just keep the old list. +Finally, you will be prompted for any extra URLs -- file:, ftp:, or +http: -- that host a CPAN mirror. }; - $ans = prompt("Press RETURN to continue"); - my $other; - $ans = $other = ""; - my(%seen); - - my $pipe = -t *STDIN ? "| $CPAN::Config->{'pager'}" : ">/dev/null"; - while () { - my(@valid,$previous_best); - my $fh = FileHandle->new; - $fh->open($pipe); - { - my($cont,$country,$url,$item); - my(@cont) = sort keys %all; - for $cont (@cont) { - $fh->print(" $cont\n"); - for $country (sort {lc $a cmp lc $b} keys %{$all{$cont}}) { - for $url (sort {lc $a cmp lc $b} keys %{$all{$cont}{$country}}) { - my $t = sprintf( - " %-18s (%2d) %s\n", - $country, - ++$item, - $url - ); - if ($cont =~ /^\[/) { - $previous_best ||= $item; - } - push @valid, $all{$cont}{$country}{$url}; - $fh->print($t); - } - } - } - } - $fh->close; - $previous_best ||= 1; - $default = - @{$CPAN::Config->{urllist}} >= $expected_size ? "q" : $previous_best; - $ans = prompt( - "\nSelect an$other ftp or file URL or a number (q to finish)", - $default - ); - my $sel; - if ($ans =~ /^\d/) { - my $this = $valid[$ans-1]; - my($con,$cou,$url) = ($this->continent,$this->country,$this->url); - push @{$CPAN::Config->{urllist}}, $url unless $seen{$url}++; - delete $all{$con}{$cou}{$url}; - # print "Was a number [$ans] con[$con] cou[$cou] url[$url]\n"; - } elsif (@{$CPAN::Config->{urllist}} && $ans =~ /^q/i) { - last; - } else { - $ans =~ s|/?$|/|; # has to end with one slash - $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: - if ($ans =~ /^\w+:\/./) { - push @{$CPAN::Config->{urllist}}, $ans unless $seen{$ans}++; - } else { - print qq{"$ans" doesn\'t look like an URL at first sight. -I\'ll ignore it for now. You can add it to lib/CPAN/Config.pm -later and report a bug in my Makefile.PL to me (andreas koenig). -Thanks.\n}; - } - } - $other ||= "other"; + my (@cont, $cont, %cont, @countries, @urls, %seen); + my $no_previous_warn = + "Sorry! since you don't have any existing picks, you must make a\n" . + "geographic selection."; + @cont = picklist([sort keys %all], + "Select your continent (or several nearby continents)", + '', + ! @previous_urls, + $no_previous_warn); + + + foreach $cont (@cont) { + my @c = sort keys %{$all{$cont}}; + @cont{@c} = map ($cont, 0..$#c); + @c = map ("$_ ($cont)", @c) if @cont > 1; + push (@countries, @c); } + + if (@countries) { + @countries = picklist (\@countries, + "Select your country (or several nearby countries)", + '', + ! @previous_urls, + $no_previous_warn); + %seen = map (($_ => 1), @previous_urls); + # hmmm, should take list of defaults from CPAN::Config->{'urllist'}... + foreach $country (@countries) { + (my $bare_country = $country) =~ s/ \(.*\)//; + my @u = sort keys %{$all{$cont{$bare_country}}{$bare_country}}; + @u = grep (! $seen{$_}, @u); + @u = map ("$_ ($bare_country)", @u) + if @countries > 1; + push (@urls, @u); + } + } + push (@urls, map ("$_ (previous pick)", @previous_urls)); + my $prompt = "Select as many URLs as you like"; + if (@previous_urls) { + $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) .. + (scalar @urls)); + $prompt .= "\n(or just hit RETURN to keep your previous picks)"; + } + + @urls = picklist (\@urls, $prompt, $default); + foreach (@urls) { s/ \(.*\)//; } + %seen = map (($_ => 1), @urls); + + do { + $ans = prompt ("Enter another URL or RETURN to quit:", ""); + + if ($ans) { + $ans =~ s|/?$|/|; # has to end with one slash + $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: + if ($ans =~ /^\w+:\/./) { + push @urls, $ans + unless $seen{$ans}; + } + else { + print qq{"$ans" doesn\'t look like an URL at first sight. +I\'ll ignore it for now. You can add it to $INC{'CPAN/MyConfig.pm'} +later if you\'re sure it\'s right.\n}; + } + } + } while $ans; + + push @{$CPAN::Config->{urllist}}, @urls; + # xxx delete or comment these out when you're happy that it works + print "New set of picks:\n"; + map { print " $_\n" } @{$CPAN::Config->{urllist}}; } 1; diff --git a/gnu/usr.bin/perl/lib/CPAN/Nox.pm b/gnu/usr.bin/perl/lib/CPAN/Nox.pm index 23ad760b87b..e9cb189f297 100644 --- a/gnu/usr.bin/perl/lib/CPAN/Nox.pm +++ b/gnu/usr.bin/perl/lib/CPAN/Nox.pm @@ -1,9 +1,13 @@ +package CPAN::Nox; + BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;} use CPAN; +$VERSION = "1.00"; $CPAN::META->has_inst('MD5','no'); $CPAN::META->has_inst('LWP','no'); +$CPAN::META->has_inst('Compress::Zlib','no'); @EXPORT = @CPAN::EXPORT; *AUTOLOAD = \&CPAN::AUTOLOAD; diff --git a/gnu/usr.bin/perl/lib/Carp.pm b/gnu/usr.bin/perl/lib/Carp.pm index 685a7933d05..f8f750a5d71 100644 --- a/gnu/usr.bin/perl/lib/Carp.pm +++ b/gnu/usr.bin/perl/lib/Carp.pm @@ -35,7 +35,7 @@ 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 +This feature is enabled by 'importing' the non-existent symbol 'verbose'. You would typically enable it by saying perl -MCarp=verbose script.pl @@ -43,14 +43,30 @@ This feature is enabled by 'importing' the non-existant symbol or by including the string C<MCarp=verbose> in the L<PERL5OPT> environment variable. +=head1 BUGS + +The Carp routines don't handle exception objects currently. +If called with a first argument that is a reference, they simply +call die() or warn(), as appropriate. + =cut # This package is heavily used. Be small. Be fast. Be good. +# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an +# _almost_ complete understanding of the package. Corrections and +# comments are welcome. + +# The $CarpLevel variable can be set to "strip off" extra caller levels for +# those times when Carp calls are buried inside other functions. The +# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval +# text and function arguments should be formatted when printed. + $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. +$Verbose = 0; # If true then make shortmess call longmess instead require Exporter; @ISA = ('Exporter'); @@ -58,30 +74,59 @@ require Exporter; @EXPORT_OK = qw(cluck verbose); @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") +# then the following method will be called by the Exporter which knows +# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word +# 'verbose'. + sub export_fail { shift; - if ($_[0] eq 'verbose') { - local $^W = 0; - *shortmess = \&longmess; - shift; - } + $Verbose = shift if $_[0] eq 'verbose'; return @_; } +# longmess() crawls all the way up the stack reporting on all the function +# calls made. The error string, $error, is originally constructed from the +# arguments passed into longmess() via confess(), cluck() or shortmess(). +# This gets appended with the stack trace messages which are generated for +# each function call on the stack. + sub longmess { + return @_ if ref $_[0]; my $error = join '', @_; my $mess = ""; my $i = 1 + $CarpLevel; my ($pack,$file,$line,$sub,$hargs,$eval,$require); my (@a); + # + # crawl up the stack.... + # while (do { { package DB; @a = caller($i++) } } ) { - ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # get copies of the variables returned from caller() + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # + # if the $error error string is newline terminated then it + # is copied into $mess. Otherwise, $mess gets set (at the end of + # the 'else {' section below) to one of two things. The first time + # through, it is set to the "$error at $file line $line" message. + # $error is then set to 'called' which triggers subsequent loop + # iterations to append $sub to $mess before appending the "$error + # at $file line $line" which now actually reads "called at $file line + # $line". Thus, the stack trace message is constructed: + # + # first time: $mess = $error at $file line $line + # subsequent times: $mess .= $sub $error at $file line $line + # ^^^^^^ + # "called" if ($error =~ m/\n$/) { $mess .= $error; } else { + # Build a string, $sub, which names the sub-routine called. + # This may also be "require ...", "eval '...' or "eval {...}" if (defined $eval) { - if ($require) { + if ($require) { $sub = "require $eval"; } else { $eval =~ s/([\\\'])/\\$1/g; @@ -93,32 +138,48 @@ sub longmess { } elsif ($sub eq '(eval)') { $sub = 'eval {...}'; } + # if there are any arguments in the sub-routine call, format + # them according to the format variables defined earlier in + # this file and join them onto the $sub sub-routine string if ($hargs) { - @a = @DB::args; # must get local copy of args - if ($MaxArgNums and @a > $MaxArgNums) { - $#a = $MaxArgNums; - $a[$#a] = "..."; - } - for (@a) { - $_ = "undef", next unless defined $_; - if (ref $_) { - $_ .= ''; - s/'/\\'/g; + # we may trash some of the args so we take a copy + @a = @DB::args; # must get local copy of args + # don't print any more than $MaxArgNums + if ($MaxArgNums and @a > $MaxArgNums) { + # cap the length of $#a and set the last element to '...' + $#a = $MaxArgNums; + $a[$#a] = "..."; } - else { - s/'/\\'/g; - substr($_,$MaxArgLen) = '...' - if $MaxArgLen and $MaxArgLen < length; + for (@a) { + # set args to the string "undef" if undefined + $_ = "undef", next unless defined $_; + if (ref $_) { + # dunno what this is for... + $_ .= ''; + s/'/\\'/g; + } + else { + s/'/\\'/g; + # terminate the string early with '...' if too long + substr($_,$MaxArgLen) = '...' + if $MaxArgLen and $MaxArgLen < length; + } + # 'quote' arg unless it looks like a number + $_ = "'$_'" unless /^-?[\d.]+$/; + # print high-end chars as 'M-<char>' or '^<char>' + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } - $_ = "'$_'" unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - $sub .= '(' . join(', ', @a) . ')'; + # append ('all', 'the', 'arguments') to the $sub string + $sub .= '(' . join(', ', @a) . ')'; } + # here's where the error message, $mess, gets constructed $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; } + # we don't need to print the actual error message again so we can + # change this to "called" so that the string "$error at $file line + # $line" makes sense as "called at $file line $line". $error = "called"; } # this kludge circumvents die's incorrect handling of NUL @@ -127,36 +188,72 @@ sub longmess { $$msg; } + +# shortmess() is called by carp() and croak() to skip all the way up to +# the top-level caller's package and report the error from there. confess() +# and cluck() generate a full stack trace so they call longmess() to +# generate that. In verbose mode shortmess() calls longmess() so +# you always get a stack trace + sub shortmess { # Short-circuit &longmess if called via multiple packages + goto &longmess if $Verbose; + return @_ if ref $_[0]; my $error = join '', @_; my ($prevpack) = caller(1); my $extra = $CarpLevel; my $i = 2; my ($pack,$file,$line); + # when reporting an error, we want to report it from the context of the + # calling package. So what is the calling package? Within a module, + # there may be many calls between methods and perhaps between sub-classes + # and super-classes, but the user isn't interested in what happens + # inside the package. We start by building a hash array which keeps + # track of all the packages to which the calling package belongs. We + # do this by examining its @ISA variable. Any call from a base class + # method (one of our caller's @ISA packages) can be ignored my %isa = ($prevpack,1); + # merge all the caller's @ISA packages into %isa. @isa{@{"${prevpack}::ISA"}} = () if(defined @{"${prevpack}::ISA"}); + # now we crawl up the calling stack and look at all the packages in + # there. For each package, we look to see if it has an @ISA and then + # we see if our caller features in that list. That would imply that + # our caller is a derived class of that package and its calls can also + # be ignored while (($pack,$file,$line) = caller($i++)) { if(defined @{$pack . "::ISA"}) { my @i = @{$pack . "::ISA"}; my %i; @i{@i} = (); + # merge any relevant packages into %isa @isa{@i,$pack} = () if(exists $i{$prevpack} || exists $isa{$pack}); } + # and here's where we do the ignoring... if the package in + # question is one of our caller's base or derived packages then + # we can ignore it (skip it) and go onto the next (but note that + # the continue { } block below gets called every time) next if(exists $isa{$pack}); + # Hey! We've found a package that isn't one of our caller's + # clan....but wait, $extra refers to the number of 'extra' levels + # we should skip up. If $extra > 0 then this is a false alarm. + # We must merge the package into the %isa hash (so we can ignore it + # if it pops up again), decrement $extra, and continue. if ($extra-- > 0) { %isa = ($pack,1); @isa{@{$pack . "::ISA"}} = () if(defined @{$pack . "::ISA"}); } else { - # this kludge circumvents die's incorrect handling of NUL + # OK! We've got a candidate package. Time to construct the + # relevant error message and return it. die() doesn't like + # to be given NUL characters (which $msg may contain) so we + # remove them first. (my $msg = "$error at $file line $line\n") =~ tr/\0//d; return $msg; } @@ -165,12 +262,23 @@ sub shortmess { # Short-circuit &longmess if called via multiple packages $prevpack = $pack; } + # uh-oh! It looks like we crawled all the way up the stack and + # never found a candidate package. Oh well, let's call longmess + # to generate a full stack trace. We use the magical form of 'goto' + # so that this shortmess() function doesn't appear on the stack + # to further confuse longmess() about it's calling package. goto &longmess; } -sub confess { die longmess @_; } -sub croak { die shortmess @_; } -sub carp { warn shortmess @_; } -sub cluck { warn longmess @_; } + +# the following four functions call longmess() or shortmess() depending on +# whether they should generate a full stack trace (confess() and cluck()) +# or simply report the caller's package (croak() and carp()), respectively. +# confess() and croak() die, carp() and cluck() warn. + +sub croak { die shortmess @_ } +sub confess { die longmess @_ } +sub carp { warn shortmess @_ } +sub cluck { warn longmess @_ } 1; diff --git a/gnu/usr.bin/perl/lib/Class/Struct.pm b/gnu/usr.bin/perl/lib/Class/Struct.pm index 09ab196254e..8fddfbf68ef 100644 --- a/gnu/usr.bin/perl/lib/Class/Struct.pm +++ b/gnu/usr.bin/perl/lib/Class/Struct.pm @@ -40,6 +40,11 @@ sub printem { $self->[$index]; } + sub FETCHSIZE { + my $self = shift; + return scalar(@$self); + } + sub DESTROY { } } @@ -180,7 +185,7 @@ sub struct { } elsif( defined $classes{$name} ){ if ( $CHECK_CLASS_MEMBERSHIP ) { - $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$type');\n"; + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; } } $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; diff --git a/gnu/usr.bin/perl/lib/Cwd.pm b/gnu/usr.bin/perl/lib/Cwd.pm index 3bd0085c730..5c10e8e1686 100644 --- a/gnu/usr.bin/perl/lib/Cwd.pm +++ b/gnu/usr.bin/perl/lib/Cwd.pm @@ -20,11 +20,21 @@ getcwd - get pathname of current working directory chdir "/tmp"; print $ENV{'PWD'}; + use Cwd 'abs_path'; + print abs_path($ENV{'PWD'}); + + use Cwd 'fast_abs_path'; + print fast_abs_path($ENV{'PWD'}); + =head1 DESCRIPTION The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. +The abs_path() function takes a single argument and returns the +absolute pathname for that argument. It uses the same algorithm as +getcwd(). (actually getcwd() is abs_path(".")) + The fastcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because it might conceivably chdir() you out of a directory that it can't chdir() you back into. If fastcwd @@ -35,6 +45,9 @@ that it leaves you in the same directory that it started in. If it has changed it will C<die> with the message "Unstable directory path, current directory changed unexpectedly". That should never happen. +The fast_abs_path() function looks the same as abs_path(), but runs faster. +And like fastcwd() is more dangerous. + The cwd() function looks the same as getcwd and fastgetcwd but is implemented using the most natural and safe form for the current architecture. For most systems it is identical to `pwd` (but without @@ -54,7 +67,7 @@ kept up to date if all packages which use chdir import it from Cwd. use Carp; -$VERSION = '2.00'; +$VERSION = '2.01'; require Exporter; @ISA = qw(Exporter); @@ -82,66 +95,9 @@ sub _backtick_pwd { sub getcwd { - my($dotdots, $cwd, @pst, @cst, $dir, @tst); - - unless (@cst = stat('.')) - { - warn "stat(.): $!"; - return ''; - } - $cwd = ''; - $dotdots = ''; - do - { - $dotdots .= '/' if $dotdots; - $dotdots .= '..'; - @pst = @cst; - unless (opendir(PARENT, $dotdots)) - { - warn "opendir($dotdots): $!"; - return ''; - } - unless (@cst = stat($dotdots)) - { - warn "stat($dotdots): $!"; - closedir(PARENT); - return ''; - } - if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) - { - $dir = undef; - } - else - { - do - { - unless (defined ($dir = readdir(PARENT))) - { - warn "readdir($dotdots): $!"; - closedir(PARENT); - return ''; - } - unless (@tst = 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); - # return ''; - } - } - while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || - $tst[1] != $pst[1]); - } - $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; - closedir(PARENT); - } while (defined $dir); - chop($cwd) unless $cwd eq '/'; # drop the trailing / - $cwd; + abs_path('.'); } - - # By John Bazik # # Usage: $cwd = &fastcwd; @@ -162,7 +118,7 @@ sub fastcwd { for (;;) { my $direntry; ($odev, $oino) = ($cdev, $cino); - chdir('..') || return undef; + CORE::chdir('..') || return undef; ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; opendir(DIR, '.') || return undef; @@ -183,7 +139,7 @@ sub fastcwd { # 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; + CORE::chdir($path) || return undef; ($cdev, $cino) = stat('.'); die "Unstable directory path, current directory changed unexpectedly" if $cdev != $orig_cdev || $cino != $orig_cino; @@ -199,7 +155,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -249,7 +205,7 @@ sub chdir { sub abs_path { - my $start = shift || '.'; + my $start = @_ ? shift : '.'; my($dotdots, $cwd, @pst, @cst, $dir, @tst); unless (@cst = stat( $start )) @@ -276,7 +232,7 @@ sub abs_path } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { - $dir = ''; + $dir = undef; } else { @@ -293,19 +249,19 @@ sub abs_path 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; } sub fast_abs_path { my $cwd = getcwd(); my $path = shift || '.'; - chdir($path) || croak "Cannot chdir to $path:$!"; + CORE::chdir($path) || croak "Cannot chdir to $path:$!"; my $realpath = getcwd(); - chdir($cwd) || croak "Cannot chdir back to $cwd:$!"; + CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!"; $realpath; } @@ -313,7 +269,7 @@ sub fast_abs_path { # --- PORTING SECTION --- # VMS: $ENV{'DEFAULT'} points to default directory at all times -# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu +# 06-Mar-1996 Charles Bailey bailey@newman.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 @@ -339,23 +295,40 @@ sub _os2_cwd { } sub _win32_cwd { - $ENV{'PWD'} = Win32::GetCurrentDirectory(); + $ENV{'PWD'} = Win32::GetCwd(); $ENV{'PWD'} =~ s:\\:/:g ; return $ENV{'PWD'}; } *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && - defined &Win32::GetCurrentDirectory); + defined &Win32::GetCwd); *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd; -sub _msdos_cwd { - $ENV{'PWD'} = `command /c cd`; +sub _dos_cwd { + if (!defined &Dos::GetCwd) { + $ENV{'PWD'} = `command /c cd`; + chop $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + } else { + $ENV{'PWD'} = Dos::GetCwd(); + } + return $ENV{'PWD'}; +} + +sub _qnx_cwd { + $ENV{'PWD'} = `/usr/bin/fullpath -t`; chop $ENV{'PWD'}; - $ENV{'PWD'} =~ s:\\:/:g ; return $ENV{'PWD'}; } +sub _qnx_abs_path { + my $path = shift || '.'; + my $realpath=`/usr/bin/fullpath -t $path`; + chop $realpath; + return $realpath; +} + { local $^W = 0; # assignments trigger 'subroutine redefined' warning @@ -383,13 +356,21 @@ sub _msdos_cwd { *fastcwd = \&cwd; *abs_path = \&fast_abs_path; } - elsif ($^O eq 'msdos') { - *cwd = \&_msdos_cwd; - *getcwd = \&_msdos_cwd; - *fastgetcwd = \&_msdos_cwd; - *fastcwd = \&_msdos_cwd; + elsif ($^O eq 'dos') { + *cwd = \&_dos_cwd; + *getcwd = \&_dos_cwd; + *fastgetcwd = \&_dos_cwd; + *fastcwd = \&_dos_cwd; *abs_path = \&fast_abs_path; } + elsif ($^O eq 'qnx') { + *cwd = \&_qnx_cwd; + *getcwd = \&_qnx_cwd; + *fastgetcwd = \&_qnx_cwd; + *fastcwd = \&_qnx_cwd; + *abs_path = \&_qnx_abs_path; + *fast_abs_path = \&_qnx_abs_path; + } } # package main; eval join('',<DATA>) || die $@; # quick test diff --git a/gnu/usr.bin/perl/lib/English.pm b/gnu/usr.bin/perl/lib/English.pm index bbb6bd7b280..9f29a487dc7 100644 --- a/gnu/usr.bin/perl/lib/English.pm +++ b/gnu/usr.bin/perl/lib/English.pm @@ -15,6 +15,14 @@ English - use nice English (or awk) names for ugly punctuation variables =head1 DESCRIPTION +You should I<not> use this module in programs intended to be portable +among Perl versions, programs that must perform regular expression +matching operations efficiently, or libraries intended for use with +such programs. In a sense, this module is deprecated. The reasons +for this have to do with implementation details of the Perl +interpreter which are too thorny to go into here. Perhaps someday +they will be fixed to make "C<use English>" more practical. + This module provides aliases for the built-in variables whose names no one seems to like to read. Variables with side-effects which get triggered just by accessing them (like $0) will still @@ -160,6 +168,7 @@ sub import { *PERL_VERSION = *] ; *ACCUMULATOR = *^A ; + *COMPILING = *^C ; *DEBUGGING = *^D ; *SYSTEM_FD_MAX = *^F ; *INPLACE_EDIT = *^I ; diff --git a/gnu/usr.bin/perl/lib/Env.pm b/gnu/usr.bin/perl/lib/Env.pm index f2fe4af422e..b0afc3b2dbf 100644 --- a/gnu/usr.bin/perl/lib/Env.pm +++ b/gnu/usr.bin/perl/lib/Env.pm @@ -45,14 +45,14 @@ Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt> sub import { my ($callpack) = caller(0); my $pack = shift; - my @vars = @_ ? @_ : keys(%ENV); + my @vars = grep /^[A-Za-z_]\w*$/, (@_ ? @_ : 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*$/; + tie ${"${callpack}::$_"}, Env, $_; } } diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Command.pm b/gnu/usr.bin/perl/lib/ExtUtils/Command.pm index d37d0f3c25e..e900e51ffa4 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Command.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Command.pm @@ -31,8 +31,8 @@ ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. =head1 DESCRIPTION -The module is used in Win32 port to replace common UNIX commands. -Most commands are wrapers on generic modules File::Path and File::Basename. +The module is used in the Win32 port to replace common UNIX commands. +Most commands are wrappers on generic modules File::Path and File::Basename. =over 4 @@ -107,11 +107,13 @@ Makes files exist, with current timestamp sub touch { expand_wildcards(); + my $t = time; while (@ARGV) { my $file = shift(@ARGV); open(FILE,">>$file") || die "Cannot write $file:$!"; close(FILE); + utime($t,$t,$file); } } @@ -187,6 +189,7 @@ sub test_f exit !-f shift(@ARGV); } + 1; __END__ diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm b/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm index 04ce1763da7..4b56e88b260 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm @@ -43,10 +43,15 @@ sub my_return { } } +sub is_perl_object { + $Config{ccflags} =~ /-DPERL_OBJECT/; +} + sub xsinit { my($file, $std, $mods) = @_; my($fh,@mods,%seen); $file ||= "perlxsi.c"; + my $xsinit_proto = is_perl_object() ? "CPERLarg" : "void"; if (@_) { @mods = @$mods if $mods; @@ -70,10 +75,10 @@ sub xsinit { @mods = grep(!$seen{$_}++, @mods); print $fh &xsi_header(); - print $fh "EXTERN_C void xs_init _((void));\n\n"; + print $fh "EXTERN_C void xs_init _(($xsinit_proto));\n\n"; print $fh &xsi_protos(@mods); - print $fh "\nEXTERN_C void\nxs_init()\n{\n"; + print $fh "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n"; print $fh &xsi_body(@mods); print $fh "}\n"; @@ -81,14 +86,24 @@ sub xsinit { sub xsi_header { return <<EOF; -#ifdef __cplusplus +#if defined(__cplusplus) && !defined(PERL_OBJECT) +#define is_cplusplus +#endif + +#ifdef is_cplusplus extern "C" { #endif #include <EXTERN.h> #include <perl.h> - -#ifdef __cplusplus +#ifdef PERL_OBJECT +#define NO_XSLOCKS +#include <XSUB.h> +#include "win32iop.h" +#include <fcntl.h> +#include <perlhost.h> +#endif +#ifdef is_cplusplus } # ifndef EXTERN_C # define EXTERN_C extern "C" @@ -105,13 +120,14 @@ EOF sub xsi_protos { my(@exts) = @_; my(@retval,%seen); - + my $boot_proto = is_perl_object() ? + "CV* cv _CPERLarg" : "CV* cv"; foreach $_ (@exts){ my($pname) = canon('/', $_); my($mname, $cname); ($mname = $pname) =~ s!/!::!g; ($cname = $pname) =~ s!/!__!g; - my($ccode) = "EXTERN_C void boot_${cname} _((CV* cv));\n"; + my($ccode) = "EXTERN_C void boot_${cname} _(($boot_proto));\n"; next if $seen{$ccode}++; push(@retval, $ccode); } @@ -185,7 +201,7 @@ sub ldopts { my($mod,@ns,$root,$sub,$extra,$archive,@archives); print STDERR "Searching (@path) for archives\n" if $Verbose; foreach $mod (@mods) { - @ns = split('::', $mod); + @ns = split(/::|\/|\\/, $mod); $sub = $ns[-1]; $root = $MM->catdir(@ns); @@ -400,7 +416,7 @@ This will print arguments for linking with B<libperl.a>, B<DynaLoader> and extensions found in B<$Config{static_ext}>. This includes libraries found in B<$Config{libs}> and the first ModuleName.a library for each extension that is found by searching B<@INC> or the path -specifed by the B<-I> option. +specified by the B<-I> option. In addition, when ModuleName.a is found, additional linker arguments are picked up from the B<extralibs.ld> file in the same directory. diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Install.pm b/gnu/usr.bin/perl/lib/ExtUtils/Install.pm index 2c1dd8ae341..a11c445ad73 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Install.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Install.pm @@ -1,7 +1,7 @@ package ExtUtils::Install; -$VERSION = substr q$Revision: 1.2 $, 10; -# $Date: 1997/11/30 07:57:24 $ +$VERSION = substr q$Revision: 1.3 $, 10; +# $Date: 1999/04/29 22:51:50 $ use Exporter; use Carp (); @@ -11,7 +11,7 @@ use vars qw(@ISA @EXPORT $VERSION); @EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); $Is_VMS = $^O eq 'VMS'; -my $splitchar = $^O eq 'VMS' ? '|' : $^O eq 'os2' ? ';' : ':'; +my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':'; my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; my $Inc_uninstall_warn_handler; @@ -30,6 +30,7 @@ sub install { use Cwd qw(cwd); use ExtUtils::MakeMaker; # to implement a MY class + use ExtUtils::Packlist; use File::Basename qw(dirname); use File::Copy qw(copy); use File::Find qw(find); @@ -37,10 +38,11 @@ sub install { use File::Compare qw(compare); my(%hash) = %$hash; - my(%pack, %write, $dir, $warn_permissions); + my(%pack, $dir, $warn_permissions); + my($packlist) = ExtUtils::Packlist->new(); # -w doesn't work reliably on FAT dirs $warn_permissions++ if $^O eq 'MSWin32'; - local(*DIR, *P); + local(*DIR); for (qw/read write/) { $pack{$_}=$hash{$_}; delete $hash{$_}; @@ -52,32 +54,21 @@ sub install { opendir DIR, $source_dir_or_file or next; for (readdir DIR) { next if $_ eq "." || $_ eq ".." || $_ eq ".exists"; - if (-w $hash{$source_dir_or_file} || mkpath($hash{$source_dir_or_file})) { + if (-w $hash{$source_dir_or_file} || + mkpath($hash{$source_dir_or_file})) { last; } else { - warn "Warning: 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; } - if (-f $pack{"read"}) { - open P, $pack{"read"} or Carp::croak("Couldn't read $pack{'read'}"); - # Remember what you found - while (<P>) { - chomp; - $write{$_}++; - } - close P; - } + $packlist->read($pack{"read"}) if (-f $pack{"read"}); my $cwd = cwd(); my $umask = umask 0 unless $Is_VMS; - # This silly reference is just here to be able to call MY->catdir - # without a warning (Waiting for a proper path/directory module, - # Charles!) - my $MY = {}; - bless $MY, 'MY'; my($source); MOD_INSTALL: foreach $source (sort keys %hash) { #copy the tree to the target directory without altering @@ -85,14 +76,27 @@ sub install { #file. The packlist file contains the absolute paths of the #install locations. AFS users may call this a bug. We'll have #to reconsider how to add the means to satisfy AFS users also. + + #October 1997: we want to install .pm files into archlib if + #there are any files in arch. So we depend on having ./blib/arch + #hardcoded here. + my $targetroot = $hash{$source}; + if ($source eq "blib/lib" and + exists $hash{"blib/arch"} and + directory_not_empty("blib/arch")) { + $targetroot = $hash{"blib/arch"}; + print "Files found in blib/arch --> Installing files in " + . "blib/lib into architecture dependend library tree!\n" + ; #if $verbose>1; + } chdir($source) or next; find(sub { my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat; return unless -f _; return if $_ eq ".exists"; - my $targetdir = $MY->catdir($hash{$source},$File::Find::dir); - my $targetfile = $MY->catfile($targetdir,$_); + my $targetdir = MY->catdir($targetroot,$File::Find::dir); + my $targetfile = MY->catfile($targetdir,$_); my $diff = 0; if ( -f $targetfile && -s _ == $size) { @@ -127,7 +131,7 @@ sub install { } else { inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0 } - $write{$targetfile}++; + $packlist->{$targetfile}++; }, "."); chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!"); @@ -137,14 +141,23 @@ sub install { $dir = dirname($pack{'write'}); mkpath($dir,0,0755); print "Writing $pack{'write'}\n"; - open P, ">$pack{'write'}" or Carp::croak("Couldn't write $pack{'write'}: $!"); - for (sort keys %write) { - print P "$_\n"; - } - close P; + $packlist->write($pack{'write'}); } } +sub directory_not_empty ($) { + my($dir) = @_; + my $files = 0; + find(sub { + return if $_ eq ".exists"; + if (-f) { + $File::Find::prune++; + $files = 1; + } + }, $dir); + return $files; +} + sub install_default { @_ < 2 or die "install_default should be called with 0 or 1 argument"; my $FULLEXT = @_ ? shift : $ARGV[0]; @@ -158,7 +171,9 @@ sub install_default { install({ read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", - $INST_LIB => $Config{installsitelib}, + $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ? + $Config{installsitearch} : + $Config{installsitelib}, $INST_ARCHLIB => $Config{installsitearch}, $INST_BIN => $Config{installbin} , $INST_SCRIPT => $Config{installscript}, @@ -168,31 +183,33 @@ sub install_default { } sub uninstall { + use ExtUtils::Packlist; my($fil,$verbose,$nonono) = @_; die "no packlist file found: $fil" unless -f $fil; # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first - local *P; - open P, $fil or Carp::croak("uninstall: Could not read packlist file $fil: $!"); - while (<P>) { + my ($packlist) = ExtUtils::Packlist->new($fil); + foreach (sort(keys(%$packlist))) { chomp; print "unlink $_\n" if $verbose; forceunlink($_) unless $nonono; } print "unlink $fil\n" if $verbose; + close P; forceunlink($fil) unless $nonono; } sub inc_uninstall { my($file,$libdir,$verbose,$nonono) = @_; my($dir); - my $MY = {}; - bless $MY, 'MY'; my %seen_dir = (); - foreach $dir (@INC, @PERL_ENV_LIB, @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); + my($targetfile) = MY->catfile($dir,$libdir,$file); next unless -f $targetfile; # The reason why we compare file's contents is, that we cannot @@ -337,7 +354,7 @@ 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 +The argument-less form is convenient for install scripts like perl -MExtUtils::Install -e install_default Tk/Canvas diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm b/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm index 5b4d6abecb4..be7aed7b9bb 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm @@ -2,7 +2,7 @@ package ExtUtils::Liblist; use vars qw($VERSION); # Broken out of MakeMaker from version 4.11 -$VERSION = substr q$Revision: 1.2 $, 10; +$VERSION = substr q$Revision: 1.3 $, 10; use Config; use Cwd 'cwd'; @@ -182,16 +182,23 @@ sub _unix_os2_ext { } sub _win32_ext { + + require Text::ParseWords; + 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"; + my $cc = $Config{cc}; + my $VC = 1 if $cc =~ /^cl/i; + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + 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 @@ -203,55 +210,120 @@ sub _win32_ext { } warn "Potential libraries are '$potential_libs':\n" if $verbose; + # normalize to forward slashes + $libpth =~ s,\\,/,g; + $potential_libs =~ s,\\,/,g; + # compute $extralibs from $potential_libs - my(@searchpath); # from "-L/path" entries in $potential_libs - my(@libpath) = split " ", $libpth; - my(@extralibs); + my @searchpath; # from "-L/path" in $potential_libs + my @libpath = Text::ParseWords::quotewords('\s+', 0, $libpth); + my @extralibs; + my $pwd = cwd(); # from Cwd.pm + my $lib = ''; + my $found = 0; + my $search = 1; my($fullname, $thislib, $thispth); - my($pwd) = cwd(); # from Cwd.pm - my($lib) = ''; - my($found) = 0; - foreach $thislib (split ' ', $potential_libs){ + # add "$Config{installarchlib}/CORE" to default search path + push @libpath, "$Config{installarchlib}/CORE"; - # Handle possible linker path arguments. - if ($thislib =~ s/^-L// and not -d $thislib) { - warn "-L$thislib ignored, directory does not exist\n" + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ + + $thislib = $_; + + # see if entry is a flag + if (/^:\w+$/) { + $search = 0 if lc eq ':nosearch'; + $search = 1 if lc eq ':search'; + warn "Ignoring unknown flag '$thislib'\n" + if $verbose and !/^:(no)?(search|default)$/i; + next; + } + + # if searching is disabled, do compiler-specific translations + unless ($search) { + s/^-l(.+)$/$1.lib/ unless $GC; + s/^-L/-libpath:/ if $VC; + push(@extralibs, $_); + $found++; + next; + } + + # handle possible linker path arguments + if (s/^-L// and not -d) { + warn "$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); + elsif (-d) { + unless ($self->file_name_is_absolute($_)) { + warn "Warning: '$thislib' changed to '-L$pwd/$_'\n"; + $_ = $self->catdir($pwd,$_); } - push(@searchpath, $thislib); + push(@searchpath, $_); next; } - # Handle possible library arguments. - $thislib =~ s/^-l//; - $thislib .= $libext if $thislib !~ /\Q$libext\E$/i; + # handle possible library arguments + if (s/^-l// and $GC and !/^lib/i) { + $_ = "lib$_"; + } + $_ .= $libext if !/\Q$libext\E$/i; - my($found_lib)=0; + my $secondpass = 0; + LOOKAGAIN: + + # look for the file itself + if (-f) { + warn "'$thislib' found as '$_'\n" if $verbose; + $found++; + push(@extralibs, $_); + next; + } + + my $found_lib = 0; foreach $thispth (@searchpath, @libpath){ - unless (-f ($fullname="$thispth\\$thislib")) { - warn "$thislib not found in $thispth\n" if $verbose; + unless (-f ($fullname="$thispth\\$_")) { + warn "'$thislib' not found as '$fullname'\n" if $verbose; next; } - warn "'$thislib' found at $fullname\n" if $verbose; + warn "'$thislib' found as '$fullname'\n" if $verbose; $found++; $found_lib++; push(@extralibs, $fullname); last; } + + # do another pass with (or without) leading 'lib' if they used -l + if (!$found_lib and $thislib =~ /^-l/ and !$secondpass++) { + if ($GC) { + goto LOOKAGAIN if s/^lib//i; + } + elsif (!/^lib/i) { + $_ = "lib$_"; + goto LOOKAGAIN; + } + } + + # give up warn "Note (probably harmless): " ."No library found for '$thislib'\n" unless $found_lib>0; + } + return ('','','','') unless $found; + + # make sure paths with spaces are properly quoted + @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs; $lib = join(' ',@extralibs); + + # normalize back to backward slashes (to help braindead tools) + # XXX this may break equally braindead GNU tools that don't understand + # backslashes, either. Seems like one can't win here. Cursed be CP/M. + $lib =~ s,/,\\,g; + warn "Result: $lib\n" if $verbose; wantarray ? ($lib, '', $lib, '') : $lib; } @@ -259,9 +331,38 @@ sub _win32_ext { sub _vms_ext { my($self, $potential_libs,$verbose) = @_; - return ('', '', '', '') unless $potential_libs; + my(@crtls,$crtlstr); + my($dbgqual) = $self->{OPTIMIZE} || $Config{'optimize'} || + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and + # a library spec could be resolved via a logical name, we go to some trouble + # to insure that the copy in the local tree is used, rather than one to + # which a system-wide logical may point. + if ($self->{PERL_SRC}) { + my($lib,$locspec,$type); + foreach $lib (@crtls) { + if (($locspec,$type) = $lib =~ m-^([\w$\-]+)(/\w+)?- and $locspec =~ /perl/i) { + if (lc $type eq '/share') { $locspec .= $Config{'exe_ext'}; } + elsif (lc $type eq '/library') { $locspec .= $Config{'lib_ext'}; } + else { $locspec .= $Config{'obj_ext'}; } + $locspec = $self->catfile($self->{PERL_SRC},$locspec); + $lib = "$locspec$type" if -e $locspec; + } + } + } + $crtlstr = @crtls ? join(' ',@crtls) : ''; - my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj); + unless ($potential_libs) { + warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; + return ('', '', $crtlstr, ''); + } + + my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj,$ldlib); 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 @@ -386,8 +487,10 @@ sub _vms_ext { 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; + + $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; + warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; + wantarray ? ($lib, '', $ldlib, '') : $lib; } 1; @@ -475,7 +578,7 @@ Unix-OS/2 version in several respects: =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 +C<-l> and C<-L> prefixes 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 @@ -486,7 +589,7 @@ prefixes, since the Unix-OS/2 version of ext() requires them. 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 +it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions used in some ported software. =item * @@ -497,8 +600,10 @@ 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. +LDLOADLIBS contains both the libraries found based on C<$potential_libs> and +the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those +libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH +are always empty. =back @@ -520,16 +625,39 @@ Unix-OS/2 version in several respects: =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>, +C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +For each library that is found, a space-separated list of fully qualified +library pathnames is generated. + +=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 +C<-l> and C<-L> prefixes used by Unix linkers. + +An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look +for the libraries that follow. + +An entry of the form C<-lfoo> specifies the library C<foo>, which may be +spelled differently depending on what kind of compiler you are using. If +you are using GCC, it gets translated to C<libfoo.a>, but for other win32 +compilers, it becomes C<foo.lib>. If no files are found by those translated +names, one more attempt is made to find them using either C<foo.a> or +C<libfoo.lib>, depending on whether GCC or some other win32 compiler is +being used, respectively. + +If neither the C<-L> or C<-l> prefix is present in an entry, the entry 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. +be appended to any entries that are not directories and don't already have +the suffix. + +Note that the C<-L> and C<-l> prefixes are B<not required>, but authors +who wish their extensions to be portable to Unix or OS/2 should use the +prefixes, since the Unix-OS/2 version of ext() requires them. =item * @@ -538,15 +666,21 @@ 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). +Entries in C<$potential_libs> beginning with a colon and followed by +alphanumeric characters are treated as flags. Unknown flags will be ignored. + +An entry that matches C</:nodefault/i> disables the appending of default +libraries found in C<$Config{libs}> (this should be only needed very rarely). + +An entry that matches C</:nosearch/i> disables all searching for +the libraries specified after it. Translation of C<-Lfoo> and +C<-lfoo> still happens as appropriate (depending on compiler being used, +as reflected by C<$Config{cc}>), but the entries are not verified to be +valid files or directories. + +An entry that matches C</:search/i> reenables searching for +the libraries specified after it. You can put it at the end to +enable searching for default libraries specified by C<$Config{libs}>. =item * @@ -560,6 +694,55 @@ distinguish between them. LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS and LD_RUN_PATH are always empty (this may change in future). +=item * + +You must make sure that any paths and path components are properly +surrounded with double-quotes if they contain spaces. For example, +C<$potential_libs> could be (literally): + + "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib" + +Note how the first and last entries are protected by quotes in order +to protect the spaces. + +=item * + +Since this module is most often used only indirectly from extension +C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add +a library to the build process for an extension: + + LIBS => ['-lgl'] + +When using GCC, that entry specifies that MakeMaker should first look +for C<libgl.a> (followed by C<gl.a>) in all the locations specified by +C<$Config{libpth}>. + +When using a compiler other than GCC, the above entry will search for +C<gl.lib> (followed by C<libgl.lib>). + +If the library happens to be in a location not in C<$Config{libpth}>, +you need: + + LIBS => ['-Lc:\gllibs -lgl'] + +Here is a less often used example: + + LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32'] + +This specifies a search for library C<gl> as before. If that search +fails to find the library, it looks at the next item in the list. The +C<:nosearch> flag will prevent searching for the libraries that follow, +so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>, +since GCC can use that value as is with its linker. + +When using the Visual C compiler, the second item is returned as +C<-libpath:d:\mesalibs mesa.lib user32.lib>. + +When using the Borland compiler, the second item is returned as +C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of +moving the C<-Ld:\mesalibs> to the correct place in the linker +command line. + =back diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm index 65abfc2d99c..5d6034ce349 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm @@ -8,7 +8,6 @@ require Exporter; Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); -$ENV{EMXSHELL} = 'sh'; # to run `commands` unshift @MM::ISA, 'ExtUtils::MM_OS2'; sub dlsyms { @@ -16,6 +15,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; my(@m); (my $boot = $self->{NAME}) =~ s/:/_/g; @@ -28,13 +28,46 @@ $self->{BASEEXT}.def: Makefile.PL Mksymlists("NAME" => "', $self->{NAME}, '", "DLBASE" => "',$self->{DLBASE}, '", "DL_FUNCS" => ',neatvalue($funcs), + ', "FUNCLIST" => ',neatvalue($funclist), ', "IMPORTS" => ',neatvalue($imports), - ', "DL_VARS" => ', neatvalue($vars), ');\' + ', "VERSION" => "',$self->{VERSION}, + '", "DL_VARS" => ', neatvalue($vars), ');\' '); } + if (%{$self->{IMPORTS}}) { + # Make import files (needed for static build) + -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; + open IMP, '>tmpimp.imp' or die "Can't open tmpimp.imp"; + my ($name, $exp); + while (($name, $exp)= each %{$self->{IMPORTS}}) { + my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'"; + print IMP "$name $lib $id ?\n"; + } + close IMP or die "Can't close tmpimp.imp"; + # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n"; + system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" + and die "Cannot make import library: $!, \$?=$?"; + unlink <tmp_imp/*>; + system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}" + and die "Cannot extract import objects: $!, \$?=$?"; + } join('',@m); } +sub static_lib { + my($self) = @_; + my $old = $self->ExtUtils::MM_Unix::static_lib(); + return $old unless %{$self->{IMPORTS}}; + + my @chunks = split /\n{2,}/, $old; + shift @chunks unless length $chunks[0]; # Empty lines at the start + $chunks[0] .= <<'EOC'; + + $(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@ +EOC + return join "\n\n". '', @chunks; +} + sub replace_manpage_separator { my($self,$man) = @_; $man =~ s,/+,.,g; @@ -43,6 +76,7 @@ sub replace_manpage_separator { sub maybe_command { my($self,$file) = @_; + $file =~ s,[/\\]+,/,g; return $file if -x $file && ! -d _; return "$file.exe" if -x "$file.exe" && ! -d _; return "$file.cmd" if -x "$file.cmd" && ! -d _; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm index b308c4aad6f..35346577202 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm @@ -5,11 +5,11 @@ 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 +use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT $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 $ +$VERSION = substr q$Revision: 1.4 $, 10; +# $Id: MM_Unix.pm,v 1.4 1999/04/29 22:51:51 millert Exp $ Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); @@ -17,6 +17,9 @@ Exporter::import('ExtUtils::MakeMaker', $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; +$Is_Dos = $^O eq 'dos'; + +$Is_PERL_OBJECT = $Config{'ccflags'} =~ /-DPERL_OBJECT/; if ($Is_VMS = $^O eq 'VMS') { require VMS::Filespec; @@ -77,11 +80,15 @@ path. On UNIX eliminated successive slashes and successive "/.". sub canonpath { my($self,$path) = @_; - $path =~ s|/+|/|g ; # xx////xx -> xx/xx + my $node = ''; + if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/| ) { + $node = $1; + } + $path =~ s|(?<=[^/])/+|/|g ; # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx - $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx - $path; + $path =~ s|(?<=[^/])/$|| ; # xx/ -> xx + "$node$path"; } =item catdir @@ -97,17 +104,13 @@ trailing slash :-) # '; sub catdir { - shift; + my $self = shift @_; my @args = @_; for (@args) { # append a slash to each argument unless it has one there $_ .= "/" if $_ eq '' or substr($_,-1) ne "/"; } - my $result = join('', @args); - # remove a trailing slash unless we are root - substr($result,-1) = "" - if length($result) > 1 && substr($result,-1) eq "/"; - $result; + $self->canonpath(join('', @args)); } =item catfile @@ -120,12 +123,12 @@ complete path ending with a filename sub catfile { my $self = shift @_; my $file = pop @_; - return $file unless @_; + return $self->canonpath($file) unless @_; my $dir = $self->catdir(@_); for ($dir) { $_ .= "/" unless substr($_,length($_)-1,1) eq "/"; } - return $dir.$file; + return $self->canonpath($dir.$file); } =item curdir @@ -211,6 +214,7 @@ sub ExtUtils::MM_Unix::pm_to_blib ; sub ExtUtils::MM_Unix::post_constants ; sub ExtUtils::MM_Unix::post_initialize ; sub ExtUtils::MM_Unix::postamble ; +sub ExtUtils::MM_Unix::ppd ; sub ExtUtils::MM_Unix::prefixify ; sub ExtUtils::MM_Unix::processPL ; sub ExtUtils::MM_Unix::realclean ; @@ -229,6 +233,7 @@ sub ExtUtils::MM_Unix::tools_other ; sub ExtUtils::MM_Unix::top_targets ; sub ExtUtils::MM_Unix::writedoc ; sub ExtUtils::MM_Unix::xs_c ; +sub ExtUtils::MM_Unix::xs_cpp ; sub ExtUtils::MM_Unix::xs_o ; sub ExtUtils::MM_Unix::xsubpp_version ; @@ -266,7 +271,7 @@ sub c_o { push @m, ' .C$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C -' if $^O ne 'os2' and $^O ne 'MSWin32'; # Case-specific +' if $^O ne 'os2' and $^O ne 'MSWin32' and $^O ne 'dos'; #Case-specific push @m, ' .cpp$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cpp @@ -370,6 +375,15 @@ sub cflags { $self->{uc $_} ||= $cflags{$_} } + if ($self->{CAPI} && $Is_PERL_OBJECT) { + $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\s|$)//; + $self->{CCFLAGS} .= ' -DPERL_CAPI '; + if ($Is_Win32 && $Config{'cc'} =~ /^cl.exe/i) { + # Turn off C++ mode of the MSC compiler + $self->{CCFLAGS} =~ s/-TP(\s|$)//; + $self->{OPTIMIZE} =~ s/-TP(\s|$)//; + } + } return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} @@ -557,6 +571,15 @@ MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})." push @m, "$tmp = $self->{$tmp}\n"; } + for $tmp (qw( + PERM_RW PERM_RWX + ) + ) { + my $method = lc($tmp); + # warn "self[$self] method[$method]"; + push @m, "$tmp = ", $self->$method(), "\n"; + } + push @m, q{ .NO_CONFIG_REC: Makefile } if $ENV{CLEARCASE_ROOT}; @@ -681,8 +704,8 @@ $targ :: $src $self->{NOECHO}\$(MKPATH) $targdir $self->{NOECHO}\$(EQUALIZE_TIMESTAMP) $src $targ }; - push(@m,qq{ - -$self->{NOECHO}\$(CHMOD) 755 $targdir + push(@m, qq{ + -$self->{NOECHO}\$(CHMOD) \$(PERM_RWX) $targdir }) unless $Is_VMS; } join "", @m; @@ -705,8 +728,8 @@ sub dist { my($tarflags) = $attribs{TARFLAGS} || 'cvf'; my($zip) = $attribs{ZIP} || 'zip'; # eg pkzip Yuck! my($zipflags) = $attribs{ZIPFLAGS} || '-r'; - my($compress) = $attribs{COMPRESS} || 'compress'; # eg gzip - my($suffix) = $attribs{SUFFIX} || '.Z'; # eg .gz + my($compress) = $attribs{COMPRESS} || 'gzip --best'; + my($suffix) = $attribs{SUFFIX} || '.gz'; # eg .gz my($shar) = $attribs{SHAR} || 'shar'; # eg "shar --gzip" my($preop) = $attribs{PREOP} || "$self->{NOECHO}\$(NOOP)"; # eg update MANIFEST my($postop) = $attribs{POSTOP} || "$self->{NOECHO}\$(NOOP)"; # eg remove the distdir @@ -796,7 +819,7 @@ ci : =item dist_core (o) -Defeines the targets dist, tardist, zipdist, uutardist, shdist +Defines the targets dist, tardist, zipdist, uutardist, shdist =cut @@ -893,6 +916,7 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my(@m); push(@m," @@ -909,7 +933,8 @@ static :: $self->{BASEEXT}.exp $self->{BASEEXT}.exp: Makefile.PL ",' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\ Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ', - neatvalue($funcs),', "DL_VARS" => ', neatvalue($vars), ');\' + neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist), + ', "DL_VARS" => ', neatvalue($vars), ');\' '); join('',@m); @@ -958,12 +983,12 @@ $(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)/.exis -MExtUtils::Mkbootstrap \ -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP) - $(CHMOD) 644 $@ + $(CHMOD) $(PERM_RW) $@ $(INST_BOOT): $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists '."$self->{NOECHO}$self->{RM_RF}".' $(INST_BOOT) -'.$self->{CP}.' $(BOOTSTRAP) $(INST_BOOT) - $(CHMOD) 644 $@ + $(CHMOD) $(PERM_RW) $@ '; } @@ -1007,10 +1032,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} if ($^O eq 'solaris'); + # The IRIX linker also doesn't use LD_RUN_PATH + $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"} + if ($^O eq 'irix' && $self->{LD_RUN_PATH}); + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' - $(CHMOD) 755 $@ + $(CHMOD) $(PERM_RWX) $@ '; push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); @@ -1049,7 +1078,12 @@ Takes as argument a path and returns true, if it is an absolute path. sub file_name_is_absolute { my($self,$file) = @_; - $file =~ m:^/: ; + if ($Is_Dos){ + $file =~ m{^([a-z]:)?[\\/]}i ; + } + else { + $file =~ m:^/: ; + } } =item find_perl @@ -1149,6 +1183,7 @@ sub fixin { # stolen from the pink Camel book, more or less my($shb) = ""; if ($interpreter) { print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose; + # this is probably value-free on DOSISH platforms if ($does_shbang) { $shb .= "$Config{'sharpbang'}$interpreter"; $shb .= ' ' . $arg if defined $arg; @@ -1157,23 +1192,22 @@ sub fixin { # stolen from the pink Camel book, more or less $shb .= qq{ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' if 0; # not running under some shell -}; +} unless $Is_Win32; # this won't work on win32, so don't } 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") ) { + unless ( open(FIXOUT,">$file.new") ) { warn "Can't create new $file: $!\n"; next; } my($dev,$ino,$mode) = stat FIXIN; - $mode = 0755 unless $dev; + # If they override perm_rwx, we won't notice it during fixin, + # because fixin is run through a new instance of MakeMaker. + # That is why we must run another CHMOD later. + $mode = oct($self->perm_rwx) unless $dev; chmod $mode, $file; # Print out the new #! line (or equivalent). @@ -1182,9 +1216,23 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' print FIXOUT $shb, <FIXIN>; close FIXIN; close FIXOUT; + # can't rename open files on some DOSISH platforms + unless ( rename($file, "$file.bak") ) { + warn "Can't rename $file to $file.bak: $!"; + next; + } + unless ( rename("$file.new", $file) ) { + warn "Can't rename $file.new to $file: $!"; + unless ( rename("$file.bak", $file) ) { + warn "Can't rename $file.bak back to $file either: $!"; + warn "Leaving $file renamed as $file.bak\n"; + } + next; + } unlink "$file.bak"; } continue { - chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; + chmod oct($self->perm_rwx), $file or + die "Can't reset permissions for $file: $!\n"; system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; } } @@ -1252,7 +1300,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my($self) = @_; my($name, %dir, %xs, %c, %h, %ignore, %pl_files, %manifypods); local(%pm); #the sub in find() has to see this hash - $ignore{'test.pl'} = 1; + @ignore{qw(Makefile.PL test.pl)} = (1,1); $ignore{'makefile.pl'} = 1 if $Is_VMS; foreach $name ($self->lsdir($self->curdir)){ next if $name =~ /\#/; @@ -1270,13 +1318,16 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) unless $name =~ m/perlmain\.c/; # See MAP_TARGET } elsif ($name =~ /\.h$/i){ $h{$name} = 1; + } elsif ($name =~ /\.PL$/) { + ($pl_files{$name} = $name) =~ s/\.PL$// ; + } elsif ($Is_VMS && $name =~ /\.pl$/) { # case-insensitive filesystem + local($/); open(PL,$name); my $txt = <PL>; close PL; + if ($txt =~ /Extracting \S+ \(with variable substitutions/) { + ($pl_files{$name} = $name) =~ s/\.pl$// ; + } + else { $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); } } elsif ($name =~ /\.(p[ml]|pod)$/){ $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); - } elsif ($name =~ /\.PL$/ && $name ne "Makefile.PL") { - ($pl_files{$name} = $name) =~ s/\.PL$// ; - } elsif ($Is_VMS && $name =~ /\.pl$/ && $name ne 'makefile.pl' && - $name ne 'test.pl') { # case-insensitive filesystem - ($pl_files{$name} = $name) =~ s/\.pl$// ; } } @@ -1480,7 +1531,7 @@ sub init_main { $modfname = &DynaLoader::mod2fname(\@modparts); } - ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!([\w:]+::)?(\w+)$! ; + ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)$! ; if (defined &DynaLoader::mod2fname) { # As of 5.001m, dl_os2 appends '_' @@ -1934,7 +1985,7 @@ pure_site_install :: }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{ doc_perl_install :: - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLPRIVLIB)" \ LINKTYPE "$(LINKTYPE)" \ @@ -1943,7 +1994,7 @@ doc_perl_install :: >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ doc_site_install :: - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ @@ -1970,7 +2021,7 @@ uninstall_from_sitedirs :: =item installbin (o) -Defines targets to install EXE_FILES. +Defines targets to make and to install EXE_FILES. =cut @@ -1991,10 +2042,13 @@ sub installbin { push(@m, qq{ EXE_FILES = @{$self->{EXE_FILES}} -FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker \\ +} . ($Is_Win32 + ? q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ + -e "system qq[pl2bat.bat ].shift" +} : q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::MakeMaker \ -e "MY->fixin(shift)" - -all :: @to +}).qq{ +pure_all :: @to $self->{NOECHO}\$(NOOP) realclean :: @@ -2009,6 +2063,7 @@ $to: $from $self->{MAKEFILE} " . $self->catdir($todir,'.exists') . " $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to \$(FIXIN) $to + -$self->{NOECHO}\$(CHMOD) \$(PERM_RWX) $to "; } join "", @m; @@ -2281,7 +2336,7 @@ MAP_LIBPERL = $libperl push @m, " \$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all - \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom $llibperl \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) + \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom \$(MAP_STATIC) $llibperl `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' @@ -2295,14 +2350,17 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\ - -e "writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)" > $@t && $(MV) $@t $@ + -e "writemain(grep s#.*/auto/##, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@ }; + push @m, "\t",$self->{NOECHO}.q{$(PERL) $(INSTALLSCRIPT)/fixpmain +} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0); + push @m, q{ doc_inst_perl: }.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod - }.$self->{NOECHO}.q{$(DOC_INSTALL) \ + -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Perl binary" "$(MAP_TARGET)" \ MAP_STATIC "$(MAP_STATIC)" \ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ @@ -2348,6 +2406,7 @@ $(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{$(RM_F) }."$self->{MAKEFILE}.old".q{ -}.$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{ @@ -2373,7 +2432,8 @@ put them into the INST_* directories. sub manifypods { my($self, %attribs) = @_; - return "\nmanifypods :\n\t$self->{NOECHO}\$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}}; + return "\nmanifypods : pure_all\n\t$self->{NOECHO}\$(NOOP)\n" unless + %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}}; my($dist); my($pod2man_exe); if (defined $self->{PERL_SRC}) { @@ -2394,13 +2454,14 @@ END my(@m); push @m, qq[POD2MAN_EXE = $pod2man_exe\n], -q[POD2MAN = $(PERL) -we '%m=@ARGV;for (keys %m){' \\ --e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "].$self->{MAKEFILE}.q[";' \\ +qq[POD2MAN = \$(PERL) -we '%m=\@ARGV;for (keys %m){' \\\n], +q[-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "], + $self->{MAKEFILE}, q[";' \\ -e 'print "Manifying $$m{$$_}\n";' \\ -e 'system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2MAN_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\ --e 'chmod 0644, $$m{$$_} or warn "chmod 644 $$m{$$_}: $$!\n";}' +-e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}' ]; - push @m, "\nmanifypods : "; + push @m, "\nmanifypods : pure_all "; push @m, join " \\\n\t", keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}}; push(@m,"\n"); @@ -2543,6 +2604,32 @@ sub parse_version { return $result; } +=item parse_abstract + +parse a file and return what you think is the ABSTRACT + +=cut + +sub parse_abstract { + my($self,$parsefile) = @_; + my $result; + local *FH; + local $/ = "\n"; + open(FH,$parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + my $package = $self->{DISTNAME}; + $package =~ s/-/::/; + while (<FH>) { + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if !$inpod; + chop; + next unless /^($package\s-\s)(.*)/; + $result = $2; + last; + } + close FH; + return $result; +} =item pasthru (o) @@ -2575,7 +2662,7 @@ Takes no argument, returns the environment variable PATH as an array. sub path { my($self) = @_; - my $path_sep = $Is_OS2 ? ";" : ":"; + my $path_sep = ($Is_OS2 || $Is_Dos) ? ";" : ":"; my $path = $ENV{PATH}; $path =~ s:\\:/:g if $Is_OS2; my @path = split $path_sep, $path; @@ -2631,7 +2718,7 @@ $(PERL_INC)/config.h $(PERL_INC)/mg.h $(PERL_INC)/scope.h \ $(PERL_INC)/cop.h $(PERL_INC)/op.h $(PERL_INC)/sv.h \ $(PERL_INC)/cv.h $(PERL_INC)/opcode.h $(PERL_INC)/unixish.h \ $(PERL_INC)/dosish.h $(PERL_INC)/patchlevel.h $(PERL_INC)/util.h \ -$(PERL_INC)/embed.h $(PERL_INC)/perl.h \ +$(PERL_INC)/embed.h $(PERL_INC)/perl.h $(PERL_INC)/iperlsys.h \ $(PERL_INC)/form.h $(PERL_INC)/perly.h $(OBJECT) : $(PERL_HDRS) @@ -2642,6 +2729,91 @@ $(OBJECT) : $(PERL_HDRS) join "\n", @m; } +=item ppd + +Defines target that creates a PPD (Perl Package Description) file +for a binary distribution. + +=cut + +sub ppd { + my($self) = @_; + my(@m); + if ($self->{ABSTRACT_FROM}){ + $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or + Carp::carp "WARNING: Setting ABSTRACT via file '$self->{ABSTRACT_FROM}' failed\n"; + } + my ($pack_ver) = join ",", (split (/\./, $self->{VERSION}), (0) x 4) [0 .. 3]; + push(@m, "# Creates a PPD (Perl Package Description) for a binary distribution.\n"); + push(@m, "ppd:\n"); + push(@m, "\t\@\$(PERL) -e \"print qq{<SOFTPKG NAME=\\\"$self->{DISTNAME}\\\" VERSION=\\\"$pack_ver\\\">\\n}"); + push(@m, ". qq{\\t<TITLE>$self->{DISTNAME}</TITLE>\\n}"); + my $abstract = $self->{ABSTRACT}; + $abstract =~ s/\n/\\n/sg; + $abstract =~ s/</</g; + $abstract =~ s/>/>/g; + push(@m, ". qq{\\t<ABSTRACT>$abstract</ABSTRACT>\\n}"); + my ($author) = $self->{AUTHOR}; + $author =~ s/</</g; + $author =~ s/>/>/g; + $author =~ s/@/\\@/g; + push(@m, ". qq{\\t<AUTHOR>$author</AUTHOR>\\n}"); + push(@m, ". qq{\\t<IMPLEMENTATION>\\n}"); + my ($prereq); + foreach $prereq (sort keys %{$self->{PREREQ_PM}}) { + my $pre_req = $prereq; + $pre_req =~ s/::/-/g; + my ($dep_ver) = join ",", (split (/\./, $self->{PREREQ_PM}{$prereq}), (0) x 4) [0 .. 3]; + push(@m, ". qq{\\t\\t<DEPENDENCY NAME=\\\"$pre_req\\\" VERSION=\\\"$dep_ver\\\" />\\n}"); + } + push(@m, ". qq{\\t\\t<OS NAME=\\\"\$(OSNAME)\\\" />\\n}"); + push(@m, ". qq{\\t\\t<ARCHITECTURE NAME=\\\"$Config{'archname'}\\\" />\\n}"); + my ($bin_location) = $self->{BINARY_LOCATION}; + $bin_location =~ s/\\/\\\\/g; + if ($self->{PPM_INSTALL_SCRIPT}) { + if ($self->{PPM_INSTALL_EXEC}) { + push(@m, " . qq{\\t\\t<INSTALL EXEC=\\\"$self->{PPM_INSTALL_EXEC}\\\">$self->{PPM_INSTALL_SCRIPT}</INSTALL>\\n}"); + } + else { + push(@m, " . qq{\\t\\t<INSTALL>$self->{PPM_INSTALL_SCRIPT}</INSTALL>\\n}"); + } + } + push(@m, ". qq{\\t\\t<CODEBASE HREF=\\\"$bin_location\\\" />\\n}"); + push(@m, ". qq{\\t</IMPLEMENTATION>\\n}"); + push(@m, ". qq{</SOFTPKG>\\n}\" > $self->{DISTNAME}.ppd"); + + join("", @m); +} + +=item perm_rw (o) + +Returns the attribute C<PERM_RW> or the string C<644>. +Used as the string that is passed +to the C<chmod> command to set the permissions for read/writeable files. +MakeMaker chooses C<644> because it has turned out in the past that +relying on the umask provokes hard-to-track bug reports. +When the return value is used by the perl function C<chmod>, it is +interpreted as an octal value. + +=cut + +sub perm_rw { + shift->{PERM_RW} || "644"; +} + +=item perm_rwx (o) + +Returns the attribute C<PERM_RWX> or the string C<755>, +i.e. the string that is passed +to the C<chmod> command to set the permissions for executable files. +See also perl_rw. + +=cut + +sub perm_rwx { + shift->{PERM_RWX} || "755"; +} + =item pm_to_blib Defines target that copies all files in the hash PM to their @@ -2725,13 +2897,18 @@ sub processPL { return "" unless $self->{PL_FILES}; my(@m, $plfile); foreach $plfile (sort keys %{$self->{PL_FILES}}) { + my $list = ref($self->{PL_FILES}->{$plfile}) + ? $self->{PL_FILES}->{$plfile} + : [$self->{PL_FILES}->{$plfile}]; + foreach $target (@$list) { push @m, " -all :: $self->{PL_FILES}->{$plfile} +all :: $target $self->{NOECHO}\$(NOOP) -$self->{PL_FILES}->{$plfile} :: $plfile - \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile +$target :: $plfile + \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile $target "; + } } join "", @m; } @@ -2760,7 +2937,8 @@ realclean purge :: clean push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n"); push(@m, " $self->{RM_F} \$(INST_STATIC)\n"); } - push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n"); + push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n") + if keys %{$self->{PM}}; my(@otherfiles) = ($self->{MAKEFILE}, "$self->{MAKEFILE}.old"); # Makefiles last push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; @@ -2778,7 +2956,11 @@ form Foo/Bar and replaces the slash with C<::>. Returns the replacement. sub replace_manpage_separator { my($self,$man) = @_; - $man =~ s,/+,::,g; + if ($^O eq 'uwin') { + $man =~ s,/+,.,g; + } else { + $man =~ s,/+,::,g; + } $man; } @@ -2825,7 +3007,7 @@ END push @m, q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@ - $(CHMOD) 755 $@ + $(CHMOD) $(PERM_RWX) $@ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld }; # Old mechanism - still available: @@ -3139,9 +3321,11 @@ sub tool_xsubpp { } } + my $xsubpp = $self->{CAPI} ? "xsubpp -object_capi" : "xsubpp"; + return qq{ XSUBPPDIR = $xsdir -XSUBPP = \$(XSUBPPDIR)/xsubpp +XSUBPP = \$(XSUBPPDIR)/$xsubpp XSPROTOARG = $self->{XSPROTOARG} XSUBPPDEPS = @tmdeps XSUBPPARGS = @tmargs @@ -3287,7 +3471,7 @@ Version_check: =item writedoc -Obsolete, depecated method. Not used since Version 5.21. +Obsolete, deprecated method. Not used since Version 5.21. =cut @@ -3311,7 +3495,22 @@ 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 >xstmp.c && $(MV) xstmp.c $*.c +'; +} + +=item xs_cpp (o) + +Defines the suffix rules to compile XS files to C++. + +=cut + +sub xs_cpp { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.cpp: + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.cpp '; } @@ -3342,6 +3541,7 @@ and Win32 do. sub perl_archive { + return '$(PERL_INC)' . "/$Config{libperl}" if $^O eq "beos"; return ""; } diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm index dc3b4ceca64..8f8ac1787c4 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm @@ -3,7 +3,7 @@ # This package is inserted into @ISA of MakeMaker's MM before the # built-in ExtUtils::MM_Unix methods if MakeMaker.pm is run under VMS. # -# Author: Charles Bailey bailey@genetics.upenn.edu +# Author: Charles Bailey bailey@newman.upenn.edu package ExtUtils::MM_VMS; @@ -14,7 +14,7 @@ use VMS::Filespec; use File::Basename; use vars qw($Revision); -$Revision = '5.3901 (6-Mar-1997)'; +$Revision = '5.52 (12-Sep-1998)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; @@ -61,15 +61,22 @@ sub eliminate_macros { if ($self->{$2}) { ($head,$macro,$tail) = ($1,$2,$3); if (ref $self->{$macro}) { - carp "Can't expand macro containing " . ref $self->{$macro}; - $npath = "$head\cB$macro\cB$tail"; - $complex = 1; + if (ref $self->{$macro} eq 'ARRAY') { + print "Note: expanded array macro \$($macro) in $path\n" if $Verbose; + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } } else { ($macro = unixify($self->{$macro})) =~ s#/$##; } $npath = "$head$macro$tail"; } } - if ($complex) { $npath =~ s#\cB(.*?)\cB#\$($1)#g; } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; } print "eliminate_macros($path) = |$npath|\n" if $Verbose >= 3; $npath; } @@ -83,8 +90,10 @@ are all macro, so that we can tell how long the expansion is, and avoid overrunning DCL's command buffer when MM[KS] is running. If optional second argument has a TRUE value, then the return string is -a VMS-syntax directory specification, otherwise it is a VMS-syntax file -specification. +a VMS-syntax directory specification, if it is FALSE, the return string +is a VMS-syntax file specification, and if it is not specified, fixpath() +checks to see whether it matches the name of a directory in the current +default directory, and returns a directory or file specification accordingly. =cut @@ -115,8 +124,10 @@ sub fixpath { $fixedpath = $path; $fixedpath = vmspath($fixedpath) if $force_path; } - # Convert names without directory or type to paths - if (!$force_path and $fixedpath !~ /[:>(.\]]/) { $fixedpath = vmspath($fixedpath); } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } # Trim off root dirname if it's had other dirs inserted in front of it. $fixedpath =~ s/\.000000([\]>])/$1/; print "fixpath($path) = |$fixedpath|\n" if $Verbose >= 3; @@ -193,7 +204,7 @@ sub wraplist { # traversing array (scalar(@array) doesn't show them, but # foreach(@array) does) (5.00307) next unless $word =~ /\w/; - $line .= ', ' if length($line); + $line .= ' ' if length($line); if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } $line .= $word; $hlen += length($word) + 2; @@ -429,7 +440,7 @@ sub find_perl { } foreach $name (@snames){ if ($name !~ m![/:>\]]!) { push(@cand,$self->catfile($dir,$name)); } - else { push(@cand,$self->fixpath($name)); } + else { push(@cand,$self->fixpath($name,0)); } } } foreach $name (@cand) { @@ -632,9 +643,9 @@ sub constants { if ($self->{OBJECT} =~ /\s/) { $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g; - $self->{OBJECT} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT}))); + $self->{OBJECT} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{OBJECT}))); } - $self->{LDFROM} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM}))); + $self->{LDFROM} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{LDFROM}))); # Fix up directory specs @@ -657,7 +668,7 @@ sub constants { # Fix up file specs foreach $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKE_APERL_FILE MYEXTLIB] ) { next unless defined $self->{$macro}; - $self->{$macro} = $self->fixpath($self->{$macro}); + $self->{$macro} = $self->fixpath($self->{$macro},0); } foreach $macro (qw/ @@ -695,7 +706,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision FULLEXT VERSION_FROM OBJECT LDFROM / ) { next unless defined $self->{$tmp}; - push @m, "$tmp = ",$self->fixpath($self->{$tmp}),"\n"; + push @m, "$tmp = ",$self->fixpath($self->{$tmp},0),"\n"; } for $tmp (qw/ @@ -709,7 +720,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision next unless defined $self->{$tmp}; my(%tmp,$key); for $key (keys %{$self->{$tmp}}) { - $tmp{$self->fixpath($key)} = $self->fixpath($self->{$tmp}{$key}); + $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$tmp}{$key},0); } $self->{$tmp} = \%tmp; } @@ -718,7 +729,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision next unless defined $self->{$tmp}; my(@tmp,$val); for $val (@{$self->{$tmp}}) { - push(@tmp,$self->fixpath($val)); + push(@tmp,$self->fixpath($val,0)); } $self->{$tmp} = \@tmp; } @@ -726,12 +737,12 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision push @m,' # Handy lists of source code files: -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}}),' +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}}),' '; @@ -764,21 +775,22 @@ INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT) INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs '; } else { + my $shr = $Config{'dbgprefix'} . 'PERLSHR'; push @m,' INST_STATIC = INST_DYNAMIC = INST_BOOT = EXPORT_LIST = $(BASEEXT).opt -PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : "Sys\$Share:PerlShr.$Config{'dlext'}"),' +PERL_ARCHIVE = ',($ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"),' '; } $self->{TO_INST_PM} = [ sort keys %{$self->{PM}} ]; $self->{PM_TO_BLIB} = [ %{$self->{PM}} ]; push @m,' -TO_INST_PM = ',$self->wraplist(', ',@{$self->{TO_INST_PM}}),' +TO_INST_PM = ',$self->wraplist(@{$self->{TO_INST_PM}}),' -PM_TO_BLIB = ',$self->wraplist(', ',@{$self->{PM_TO_BLIB}}),' +PM_TO_BLIB = ',$self->wraplist(@{$self->{PM_TO_BLIB}}),' '; join('',@m); @@ -795,18 +807,41 @@ instance of this qualifier on the command line. sub cflags { my($self,$libperl) = @_; - my($quals) = $Config{'ccflags'}; + my($quals) = $self->{CCFLAGS} || $Config{'ccflags'}; + my($definestr,$undefstr,$flagoptstr) = ('','',''); + my($incstr) = '/Include=($(PERL_INC)'; my($name,$sys,@m); - my($optimize) = '/Optimize'; ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}. " required to modify CC command for $self->{'BASEEXT'}\n" if ($Config{$name}); + if ($quals =~ / -[DIUOg]/) { + while ($quals =~ / -([Og])(\d*)\b/) { + my($type,$lvl) = ($1,$2); + $quals =~ s/ -$type$lvl\b\s*//; + if ($type eq 'g') { $flagoptstr = '/NoOptimize'; } + else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); } + } + while ($quals =~ / -([DIU])(\S+)/) { + my($type,$def) = ($1,$2); + $quals =~ s/ -$type$def\s*//; + $def =~ s/"/""/g; + if ($type eq 'D') { $definestr .= qq["$def",]; } + elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); } + else { $undefstr .= qq["$def",]; } + } + } + if (length $quals and $quals !~ m!/!) { + warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n"; + $quals = ''; + } + if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; } + if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; } # Deal with $self->{DEFINE} here since some C compilers pay attention # to only one /Define clause on command line, so we have to - # conflate the ones from $Config{'cc'} and $self->{DEFINE} + # conflate the ones from $Config{'ccflags'} and $self->{DEFINE} if ($quals =~ m:(.*)/define=\(?([^\(\/\)\s]+)\)?(.*)?:i) { $quals = "$1/Define=($2," . ($self->{DEFINE} ? "$self->{DEFINE}," : '') . "\$(DEFINE_VERSION),\$(XS_DEFINE_VERSION))$3"; @@ -817,32 +852,45 @@ sub cflags { } $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb"; - if ($libperl =~ /libperl(\w+)\./i) { - my($type) = uc $1; - my(%map) = ( 'D' => 'DEBUGGING', 'E' => 'EMBED', 'M' => 'MULTIPLICITY', - 'DE' => 'DEBUGGING,EMBED', 'DM' => 'DEBUGGING,MULTIPLICITY', - 'EM' => 'EMBED,MULTIPLICITY', 'DEM' => 'DEBUGGING,EMBED,MULTIPLICITY' ); - $quals =~ s:/define=\(([^\)]+)\):/Define=($1,$map{$type}):i - } +# This whole section is commented out, since I don't think it's necessary (or applicable) +# if ($libperl =~ s/^$Config{'dbgprefix'}//) { $libperl =~ s/perl([^Dd]*)\./perld$1./; } +# if ($libperl =~ /libperl(\w+)\./i) { +# my($type) = uc $1; +# my(%map) = ( 'D' => 'DEBUGGING', 'E' => 'EMBED', 'M' => 'MULTIPLICITY', +# 'DE' => 'DEBUGGING,EMBED', 'DM' => 'DEBUGGING,MULTIPLICITY', +# 'EM' => 'EMBED,MULTIPLICITY', 'DEM' => 'DEBUGGING,EMBED,MULTIPLICITY' ); +# my($add) = join(',', grep { $quals !~ /\b$_\b/ } split(/,/,$map{$type})); +# $quals =~ s:/define=\(([^\)]+)\):/Define=($1,$add):i if $add; +# $self->{PERLTYPE} ||= $type; +# } # Likewise with $self->{INC} and /Include - my($incstr) = '/Include=($(PERL_INC)'; if ($self->{'INC'}) { my(@includes) = split(/\s+/,$self->{INC}); foreach (@includes) { s/^-I//; - $incstr .= ', '.$self->fixpath($_,1); + $incstr .= ','.$self->fixpath($_,1); } } $quals .= "$incstr)"; + $self->{CCFLAGS} = $quals; - $optimize = '/Debug/NoOptimize' - if ($self->{OPTIMIZE} =~ /-g/ or $self->{OPTIMIZE} =~ m!/Debug!i); + $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'}; + if ($self->{OPTIMIZE} !~ m!/!) { + if ($self->{OPTIMIZE} =~ m!\b-g\b!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' } + elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) { + $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : ''); + } + else { + warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE}; + $self->{OPTIMIZE} = '/Optimize'; + } + } return $self->{CFLAGS} = qq{ -CCFLAGS = $quals -OPTIMIZE = $optimize -PERLTYPE = +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} SPLIT = LARGE = }; @@ -968,7 +1016,7 @@ sub tool_xsubpp { warn "Typemap $typemap not found.\n"; } else{ - push(@tmdeps, $self->fixpath($typemap)); + push(@tmdeps, $self->fixpath($typemap,0)); } } } @@ -1274,30 +1322,14 @@ sub dlsyms { my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; - my($srcdir)= $attribs{PERL_SRC} || $self->{PERL_SRC} || ''; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my(@m); unless ($self->{SKIPHASH}{'dynamic'}) { push(@m,' -dynamic :: rtls.opt $(INST_ARCHAUTODIR)$(BASEEXT).opt +dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt $(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 -rtls.opt : $popt $lopt \$(BASEEXT).opt - Copy/Log $popt Sys\$Disk:[]rtls.opt - Append/Log $lopt Sys\$Disk:[]rtls.opt -"); - } - else { - push(@m,' -# rtls.opt is built in the same step as $(BASEEXT).opt -rtls.opt : $(BASEEXT).opt - $(TOUCH) $(MMS$TARGET) -'); - } } push(@m,' @@ -1312,7 +1344,8 @@ $(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt $(BASEEXT).opt : Makefile.PL $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Mksymlists;" - ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ], - neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),')" + neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars), + q[, 'FUNCLIST' => ],neatvalue($funclist),')" $(PERL) -e "print ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET) '); @@ -1347,6 +1380,7 @@ sub dynamic_lib { my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my $shr = $Config{'dbgprefix'} . 'PerlShr'; my(@m); push @m," @@ -1355,10 +1389,10 @@ 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) +$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) $(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 + If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",' + Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option '; push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); @@ -1409,7 +1443,7 @@ $(INST_STATIC) : $(NOECHO) $(NOOP) ' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}); - my(@m); + my(@m,$lib); push @m,' # Rely on suffix rule for update action $(OBJECT) : $(INST_ARCHAUTODIR).exists @@ -1418,43 +1452,28 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) '; # If this extension has it's own library (eg SDBM_File) # then copy that to $(INST_STATIC) and add $(OBJECT) into it. - push(@m, ' $(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB}; + push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB}; - push(@m,' - If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) - Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST) - $(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq{$(EXTRALIBS)\n};close F;" -'); + push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n"); + + # if there was a library to copy, then we can't use MMS$SOURCE_LIST, + # 'cause it's a library and you can't stick them in other libraries. + # In that case, we use $OBJECT instead and hope for the best + if ($self->{MYEXTLIB}) { + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n"); + } else { + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); + } + + foreach $lib (split $self->{EXTRALIBS}) { + $lib = '""' if $lib eq '"'; + push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); + } push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('',@m); } -# sub installpm_x { # called by installpm perl file -# my($self, $dist, $inst, $splitlib) = @_; -# if ($inst =~ m!#!) { -# warn "Warning: MM[SK] would have problems processing this file: $inst, SKIPPED\n"; -# return ''; -# } -# $inst = $self->fixpath($inst); -# $dist = $self->fixpath($dist); -# my($instdir) = $inst =~ /([^\)]+\))[^\)]*$/ ? $1 : dirname($inst); -# my(@m); -# -# push(@m, " -# $inst : $dist \$(MAKEFILE) ${instdir}.exists \$(INST_ARCHAUTODIR).exists -# ",' $(NOECHO) $(RM_F) $(MMS$TARGET) -# $(NOECHO) $(CP) ',"$dist $inst",' -# $(CHMOD) 644 $(MMS$TARGET) -# '); -# push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ', -# $self->catdir($splitlib,'auto')."\n\n") -# if ($splitlib and $inst =~ /\.pm$/); -# push(@m,$self->dir_target($instdir)); -# -# join('',@m); -# } - =item manifypods (override) Use VMS-style quoting on command line, and VMS logical name @@ -1516,15 +1535,20 @@ 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, " + my $list = ref($self->{PL_FILES}->{$plfile}) + ? $self->{PL_FILES}->{$plfile} + : [$self->{PL_FILES}->{$plfile}]; + foreach $target (@$list) { + my $vmsplfile = vmsify($plfile); + my $vmsfile = vmsify($target); + push @m, " all :: $vmsfile \$(NOECHO) \$(NOOP) $vmsfile :: $vmsplfile -",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile +",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile $vmsfile "; + } } join "", @m; } @@ -1640,13 +1664,16 @@ clean :: if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { push(@otherfiles, @{$self->{$key}}); } - else { push(@otherfiles, $attribs{FILES}); } + else { push(@otherfiles, $word); } } } push(@otherfiles, qw[ blib $(MAKE_APERL_FILE) extralibs.ld perlmain.c pm_to_blib.ts ]); push(@otherfiles,$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); my($file,$line); $line = ''; #avoid unitialized var warning + # Occasionally files are repeated several times from different sources + { my(%of) = map { ($_,1) } @otherfiles; @otherfiles = keys %of; } + foreach $file (@otherfiles) { $file = $self->fixpath($file); if (length($line) + length($file) > 80) { @@ -1691,6 +1718,8 @@ realclean :: clean } push(@files, values %{$self->{PM}}); $line = ''; #avoid unitialized var warning + # Occasionally files are repeated several times from different sources + { my(%f) = map { ($_,1) } @files; @files = keys %f; } foreach $file (@files) { $file = $self->fixpath($file); if (length($line) + length($file) > 80 || ++$fcnt >= 2) { @@ -1709,9 +1738,11 @@ realclean :: clean if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { push(@allfiles, @{$self->{$key}}); } - else { push(@allfiles, $attribs{FILES}); } + else { push(@allfiles, $word); } } $line = ''; + # Occasionally files are repeated several times from different sources + { my(%af) = map { ($_,1) } @allfiles; @allfiles = keys %af; } foreach $file (@allfiles) { $file = $self->fixpath($file); if (length($line) + length($file) > 80) { @@ -1950,9 +1981,7 @@ uninstall_from_sitedirs :: =item perldepend (override) Use VMS-style syntax for files; it's cheaper to just do it directly here -than to have the MM_Unix method call C<catfile> repeatedly. Also use -config.vms as source of original config data if the Perl distribution -is available; config.sh is an ancillary file under VMS. Finally, if +than to have the MM_Unix method call C<catfile> repeatedly. Also, if we have to rebuild Config.pm, use MM[SK] to do it. =cut @@ -1969,6 +1998,7 @@ $(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)op.h, $(PERL_INC)opcode.h, $(PERL_INC)pa $(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)proto.h $(OBJECT) : $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h $(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h +$(OBJECT) : $(PERL_INC)iperlsys.h ' if $self->{OBJECT}; @@ -1985,18 +2015,15 @@ $(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h # Check for unpropagated config.sh changes. Should never happen. # We do NOT just update config.h because that is not sufficient. # 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 - $(NOECHO) Write Sys$Error "Warning: $(PERL_INC)config.h out of date with $(PERL_VMS)config.vms" +$(PERL_INC)config.h : $(PERL_SRC)config.sh -#$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh -$(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl - $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.vms or genconfig.pl" +$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh + $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl" olddef = F$Environment("Default") Set Default $(PERL_SRC) $(MMS)],$mmsquals,); if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { - my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm')); + my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0)); $target =~ s/\Q$prefix/[/; push(@m," $target"); } @@ -2006,7 +2033,7 @@ $(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl ]); } - push(@m, join(" ", map($self->fixpath($_),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") + push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") if %{$self->{XS}}; join('',@m); @@ -2171,7 +2198,8 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) } - my($linkcmd,@staticopts,@staticpkgs,$extralist,$targdir,$libperldir); + my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen); + local($_); # The front matter of the linkcommand... $linkcmd = join ' ', $Config{'ld'}, @@ -2234,28 +2262,46 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) # (e.g. Intuit::DWIM will precede Intuit, so unresolved # references from [.intuit.dwim]dwim.obj can be found # in [.intuit]intuit.olb). - for (sort keys %olbs) { + for (sort { length($a) <=> length($b) } keys %olbs) { next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/; my($dir) = $self->fixpath($_,1); my($extralibs) = $dir . "extralibs.ld"; my($extopt) = $dir . $olbs{$_}; $extopt =~ s/$self->{LIB_EXT}$/.opt/; + push @optlibs, "$dir$olbs{$_}"; + # Get external libraries this extension will need if (-f $extralibs ) { + my %seenthis; open LIST,$extralibs or warn $!,next; - push @$extra, <LIST>; + while (<LIST>) { + chomp; + # Include a library in the link only once, unless it's mentioned + # multiple times within a single extension's options file, in which + # case we assume the builder needed to search it again later in the + # link. + my $skip = exists($libseen{$_}) && !exists($seenthis{$_}); + $libseen{$_}++; $seenthis{$_}++; + next if $skip; + push @$extra,$_; + } close LIST; } + # Get full name of extension for ExtUtils::Miniperl if (-f $extopt) { open OPT,$extopt or die $!; while (<OPT>) { next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/; - # ExtUtils::Miniperl expects Unix paths - (my($pkg) = "$1_$1$self->{LIB_EXT}") =~ s#_*#/#g; + my $pkg = $1; + $pkg =~ s#__*#::#g; push @staticpkgs,$pkg; } - push @staticopts, $extopt; } } + # Place all of the external libraries after all of the Perl extension + # libraries in the final link, in order to maximize the opportunity + # for XS code from multiple extensions to resolve symbols against the + # same external library while only including that library once. + push @optlibs, @$extra; $target = "Perl$Config{'exe_ext'}" unless $target; ($shrtarget,$targdir) = fileparse($target); @@ -2264,11 +2310,11 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $target = "Perlshr.$Config{'dlext'}" unless $target; $tmp = "[]" unless $tmp; $tmp = $self->fixpath($tmp,1); - if (@$extra) { - $extralist = join(' ',@$extra); - $extralist =~ s/[,\s\n]+/, /g; - } - else { $extralist = ''; } + if (@optlibs) { $extralist = join(' ',@optlibs); } + else { $extralist = ''; } + # Let ExtUtils::Liblist find the necessary for us (but skip PerlShr; + # that's what we're building here). + push @optlibs, grep { !/PerlShr/i } split +($self->ext())[2]; if ($libperl) { unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { print STDOUT "Warning: $libperl not found\n"; @@ -2289,22 +2335,25 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) push @m, ' # Fill in the target you want to produce if it\'s not perl -MAP_TARGET = ',$self->fixpath($target),' -MAP_SHRTARGET = ',$self->fixpath($shrtarget)," +MAP_TARGET = ',$self->fixpath($target,0),' +MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," MAP_LINKCMD = $linkcmd -MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',' -# We use the linker options files created with each extension, rather than -#specifying the object files directly on the command line. -MAP_STATIC = ',@staticopts ? join(' ', @staticopts) : '',' -MAP_OPTS = ',@staticopts ? ','.join(',', map($_.'/Option', @staticopts)) : ''," +MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : ''," MAP_EXTRA = $extralist -MAP_LIBPERL = ",$self->fixpath($libperl),' +MAP_LIBPERL = ",$self->fixpath($libperl,0),' '; - push @m,' -$(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",' + push @m,"\n${tmp}Makeaperl.Opt : \$(MAP_EXTRA)\n"; + foreach (@optlibs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n"; + } + push @m,"\n${tmp}PerlShr.Opt :\n\t"; + push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n"; + +push @m,' +$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",' + $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",' $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt",' $(MAP_LINKCMD) ',"${tmp}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option $(NOECHO) $(SAY) "To install the new ""$(MAP_TARGET)"" binary, say" @@ -2312,13 +2361,17 @@ $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt" $(NOECHO) $(SAY) "To remove the intermediate files, say $(NOECHO) $(SAY) " $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKEFILE) map_clean" '; - push @m,' -',"${tmp}perlmain.c",' : $(MAKEFILE) - $(NOECHO) $(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET) -'; + push @m,"\n${tmp}perlmain.c : \$(MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmp}Writemain.tmp\n"; + push @m, "# More from the 255-char line length limit\n"; + foreach (@staticpkgs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmp}Writemain.tmp\n]; + } + push @m,' + $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" ',$tmp,'Writemain.tmp >$(MMS$TARGET) + $(NOECHO) $(RM_F) ',"${tmp}Writemain.tmp\n"; push @m, q[ -# More from the 255-char line length limit +# Still more from the 255-char line length limit doc_inst_perl : $(NOECHO) $(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp $(NOECHO) $(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp @@ -2341,7 +2394,7 @@ clean :: map_clean map_clean : \$(RM_F) ${tmp}perlmain\$(OBJ_EXT) ${tmp}perlmain.c \$(MAKEFILE) - \$(RM_F) ${tmp}PerlShr.Opt \$(MAP_TARGET) + \$(RM_F) ${tmp}Makeaperl.Opt ${tmp}PerlShr.Opt \$(MAP_TARGET) "; join '', @m; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm index 3545f2c5a4e..4070b2e10b0 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm @@ -30,14 +30,18 @@ $ENV{EMXSHELL} = 'sh'; # to run `commands` unshift @MM::ISA, 'ExtUtils::MM_Win32'; $BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; +$GCC = 1 if $Config{'cc'} =~ /^gcc/i; $DMAKE = 1 if $Config{'make'} =~ /^dmake/i; $NMAKE = 1 if $Config{'make'} =~ /^nmake/i; +$PERLMAKE = 1 if $Config{'make'} =~ /^pmake/i; +$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; sub dlsyms { my($self,%attribs) = @_; my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; my(@m); (my $boot = $self->{NAME}) =~ s/:/_/g; @@ -50,6 +54,7 @@ $self->{BASEEXT}.def: Makefile.PL -e "Mksymlists('NAME' => '!, $self->{NAME}, q!', 'DLBASE' => '!,$self->{DLBASE}, q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'FUNCLIST' => !,neatvalue($funclist), q!, 'IMPORTS' => !,neatvalue($imports), q!, 'DL_VARS' => !, neatvalue($vars), q!);" !); @@ -65,7 +70,21 @@ sub replace_manpage_separator { sub maybe_command { my($self,$file) = @_; - return "$file.exe" if -e "$file.exe"; + my @e = exists($ENV{'PATHEXT'}) + ? split(/;/, $ENV{PATHEXT}) + : qw(.com .exe .bat .cmd); + my $e = ''; + for (@e) { $e .= "\Q$_\E|" } + chop $e; + # see if file ends in one of the known extensions + if ($file =~ /($e)$/i) { + return $file if -e $file; + } + else { + for (@e) { + return "$file$_" if -e "$file$_"; + } + } return; } @@ -153,13 +172,19 @@ sub init_others $self->{'TEST_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e test_f'; $self->{'LD'} = $Config{'ld'} || 'link'; $self->{'AR'} = $Config{'ar'} || 'lib'; - $self->{'LDLOADLIBS'} - ||= ( $BORLAND - ? 'import32.lib cw32mti.lib ' - : 'msvcrt.lib oldnames.lib kernel32.lib comdlg32.lib winspool.lib gdi32.lib ' - .'advapi32.lib user32.lib shell32.lib netapi32.lib ole32.lib ' - .'oleaut32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib ' - ) . ' odbc32.lib odbccp32.lib'; + $self->{'LDLOADLIBS'} ||= $Config{'libs'}; + # -Lfoo must come first for Borland, so we put it in LDDLFLAGS + if ($BORLAND) { + my $libs = $self->{'LDLOADLIBS'}; + my $libpath = ''; + while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) { + $libpath .= ' ' if length $libpath; + $libpath .= $1; + } + $self->{'LDLOADLIBS'} = $libs; + $self->{'LDDLFLAGS'} ||= $Config{'lddlflags'}; + $self->{'LDDLFLAGS'} .= " $libpath"; + } $self->{'DEV_NULL'} = '> NUL'; # $self->{'NOECHO'} = ''; # till we have it working } @@ -344,7 +369,9 @@ END push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB}; push @m, -q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")' : '-out:$@ $(OBJECT)').q{ +q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")' + : ($GCC ? '-ru $@ $(OBJECT)' + : '-out:$@ $(OBJECT)')).q{ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld $(CHMOD) 755 $@ }; @@ -415,11 +442,25 @@ INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) '); - - push(@m, $BORLAND ? -q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,),$(RESFILES)} : -q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)} - ); + if ($GCC) { + push(@m, + q{ dlltool --def $(EXPORT_LIST) --output-exp dll.exp + $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp + dlltool --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp + $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp }); + } elsif ($BORLAND) { + push(@m, + q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,} + .($DMAKE ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) } + .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)} + : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) } + .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))}) + .q{,$(RESFILES)}); + } else { # VC + push(@m, + q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) } + .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)}); + } push @m, ' $(CHMOD) 755 $@ '; @@ -430,7 +471,13 @@ q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_AR sub perl_archive { - return '$(PERL_INC)\perl$(LIB_EXT)'; + my ($self) = @_; + if($OBJ) { + if ($self->{CAPI}) { + return '$(PERL_INC)\perlCAPI$(LIB_EXT)'; + } + } + return '$(PERL_INC)\\'.$Config{'libperl'}; } sub export_list @@ -487,10 +534,11 @@ 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[ }. - ($NMAKE ? '<<pmfiles.dat' - : '$(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n)'). - q{ ],'}.$autodir.q{')" + -e "pm_to_blib(}. + ($NMAKE ? 'qw[ <<pmfiles.dat ],' + : $DMAKE ? 'qw[ $(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n) ],' + : '{ qw[$(PM_TO_BLIB)] },' + ).q{'}.$autodir.q{')" }. ($NMAKE ? q{ $(PM_TO_BLIB) << @@ -693,6 +741,7 @@ We don't want manpage process. XXX add pod2html support later. =cut sub manifypods { + my($self) = shift; return "\nmanifypods :\n\t$self->{NOECHO}\$(NOOP)\n"; } @@ -782,3 +831,4 @@ __END__ =cut + diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm index b3e8a926099..1a177973f53 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.42"; +$VERSION = "5.4302"; $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.2 $, 10)) =~ s/\s+$//; +($Revision = substr(q$Revision: 1.3 $, 10)) =~ s/\s+$//; @@ -35,9 +35,7 @@ use vars qw( # @ISA = qw(Exporter); @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt); -@EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists - $Version); - # $Version in mixed case will go away! +@EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists); # # Dummy package MM inherits actual methods from OS-specific @@ -176,17 +174,19 @@ sub WriteMakefile { sub prompt ($;$) { my($mess,$def)=@_; - $ISA_TTY = -t STDIN && -t STDOUT ; + $ISA_TTY = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe? Carp::confess("prompt function called without an argument") unless defined $mess; my $dispdef = defined $def ? "[$def] " : " "; $def = defined $def ? $def : ""; my $ans; + local $|=1; + print "$mess $dispdef"; if ($ISA_TTY) { - local $|=1; - print "$mess $dispdef"; chomp($ans = <STDIN>); + } else { + print "$def\n"; } - return $ans || $def; + return ($ans ne '') ? $ans : $def; } sub eval_in_subdirs { @@ -235,27 +235,23 @@ sub full_setup { @Attrib_help = qw/ - 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 + AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION + C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS + EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H IMPORTS + INC INCLUDE_EXT 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 LIB LIBS + INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIB LIBPERL_A 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 + NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC + PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX + PL_FILES PM PMLIBDIRS PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit - - IMPORTS - - installpm /; - # IMPORTS is used under OS/2 - - # ^^^ installpm is deprecated, will go about Summer 96 + # IMPORTS is used under OS/2 and Win32 # @Overridable is close to @MM_Sections but not identical. The # order is important. Many subroutines declare macros. These @@ -278,15 +274,15 @@ sub full_setup { c_o xs_c xs_o top_targets linkext dlsyms dynamic dynamic_bs dynamic_lib static static_lib manifypods processPL installbin subdirs clean realclean dist_basics dist_core dist_dir dist_test dist_ci - install force perldepend makefile staticmake test + install force perldepend makefile staticmake test ppd ); # loses section ordering @Overridable = @MM_Sections; push @Overridable, qw[ - dir_target libscan makeaperl needs_linking subdir_x test_via_harness - test_via_script + dir_target libscan makeaperl needs_linking perm_rw perm_rwx + subdir_x test_via_harness test_via_script ]; @@ -307,7 +303,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 exe_ext + lib_ext obj_ext osname osvers ranlib sitelibexp sitearchexp so exe_ext ); my $item; @@ -381,8 +377,9 @@ sub ExtUtils::MakeMaker::new { eval $eval; if ($@){ warn "Warning: prerequisite $prereq $self->{PREREQ_PM}->{$prereq} not found"; - } else { - delete $self->{PREREQ_PM}{$prereq}; +# Why is/was this 'delete' here? We need PREREQ_PM later to make PPDs. +# } else { +# delete $self->{PREREQ_PM}{$prereq}; } } # if (@unsatisfied){ @@ -419,6 +416,7 @@ sub ExtUtils::MakeMaker::new { } my $newclass = ++$PACKNAME; + local @Parent = @Parent; # Protect against non-local exits { # no strict; print "Blessing Object into class [$newclass]\n" if $Verbose>=2; @@ -441,9 +439,17 @@ sub ExtUtils::MakeMaker::new { unless $self->file_name_is_absolute($self->{$key}) || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/)); } - $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT}; + if ($self->{PARENT}) { + $self->{PARENT}->{CHILDREN}->{$newclass} = $self; + if (exists $self->{PARENT}->{CAPI} + and not exists $self->{CAPI}) + { + # inherit, but only if already unspecified + $self->{CAPI} = $self->{PARENT}->{CAPI}; + } + } } else { - parse_args($self,@ARGV); + parse_args($self,split(' ', $ENV{PERL_MM_OPT} || ''),@ARGV); } $self->{NAME} ||= $self->guess_name; @@ -478,6 +484,9 @@ END $self->init_dirscan(); $self->init_others(); + my($argv) = neatvalue(\@ARGV); + $argv =~ s/^\[/(/; + $argv =~ s/\]$/)/; push @{$self->{RESULT}}, <<END; # This Makefile is for the $self->{NAME} extension to perl. @@ -488,6 +497,8 @@ END # # ANY CHANGES MADE HERE WILL BE LOST! # +# MakeMaker ARGV: $argv +# # MakeMaker Parameters: END @@ -532,11 +543,33 @@ END } push @{$self->{RESULT}}, "\n# End."; - pop @Parent; $self; } +sub WriteEmptyMakefile { + if (-f 'Makefile.old') { + chmod 0666, 'Makefile.old'; + unlink 'Makefile.old' or warn "unlink Makefile.old: $!"; + } + rename 'Makefile', 'Makefile.old' or warn "rename Makefile Makefile.old: $!" + if -f 'Makefile'; + open MF, '> Makefile' or die "open Makefile for write: $!"; + print MF <<'EOP'; +all: + +clean: + +install: + +makemakerdflt: + +test: + +EOP + close MF or die "close Makefile for write: $!"; +} + sub check_manifest { print STDOUT "Checking if your kit is complete...\n"; require ExtUtils::Manifest; @@ -994,7 +1027,7 @@ This will replace the string specified by $Config{prefix} in all $Config{install*} values. Note, that in both cases the tilde expansion is done by MakeMaker, not -by perl by default, nor by make. Conflicts between parmeters LIB, +by perl by default, nor by make. Conflicts between parameters LIB, PREFIX and the various INSTALL* arguments are resolved so that XXX @@ -1144,12 +1177,33 @@ recommends it (or you know what you're doing). The following attributes can be specified as arguments to WriteMakefile() or as NAME=VALUE pairs on the command line: -=cut +=over 2 -# The following "=item C" is used by the attrib_help routine -# likewise the "=back" below. So be careful when changing it! +=item AUTHOR -=over 2 +String containing name (and email address) of package author(s). Is used +in PPD (Perl Package Description) files for PPM (Perl Package Manager). + +=item ABSTRACT + +One line description of the module. Will be included in PPD file. + +=item ABSTRACT_FROM + +Name of the file that contains the package description. MakeMaker looks +for a line in the POD matching /^($package\s-\s)(.*)/. This is typically +the first line in the "=head1 NAME" section. $2 becomes the abstract. + +=item BINARY_LOCATION + +Used when creating PPD files for binary packages. It can be set to a +full or relative path or URL to the binary archive for a particular +architecture. For example: + + perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz + +builds a PPD package that references a binary of the C<Agent> package, +located in the C<x86> directory relative to the PPD itself. =item C @@ -1157,6 +1211,14 @@ 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 CAPI + +Switch to force usage of the Perl C API even when compiling for PERL_OBJECT. + +Note that this attribute is passed through to any recursive build, +but if and only if the submodule's Makefile.PL itself makes no mention +of the 'CAPI' attribute. + =item CCFLAGS String that will be included in the compiler call command line between @@ -1205,12 +1267,12 @@ NAME above. =item DL_FUNCS -Hashref of symbol names for routines to be made available as -universal symbols. Each key/value pair consists of the package name -and an array of routine names in that package. Used only under AIX -(export lists) and VMS (linker options) at present. The routine -names supplied will be expanded in the same way as XSUB names are -expanded by the XS() macro. Defaults to +Hashref of symbol names for routines to be made available as universal +symbols. Each key/value pair consists of the package name and an +array of routine names in that package. Used only under AIX, OS/2, +VMS and Win32 at present. The routine names supplied will be expanded +in the same way as XSUB names are expanded by the XS() macro. +Defaults to {"$(NAME)" => ["boot_$(NAME)" ] } @@ -1219,12 +1281,14 @@ e.g. {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )], "NetconfigPtr" => [ 'DESTROY'] } +Please see the L<ExtUtils::Mksymlists> documentation for more information +about the DL_FUNCS, DL_VARS and FUNCLIST attributes. + =item DL_VARS -Array of symbol names for variables to be made available as -universal symbols. Used only under AIX (export lists) and VMS -(linker options) at present. Defaults to []. (e.g. [ qw( -Foo_version Foo_numstreams Foo_tree ) ]) +Array of symbol names for variables to be made available as universal symbols. +Used only under AIX, OS/2, VMS and Win32 at present. Defaults to []. +(e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ]) =item EXCLUDE_EXT @@ -1233,7 +1297,7 @@ is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more details. (e.g. [ qw( Socket POSIX ) ] ) This attribute may be most useful when specified as a string on the -commandline: perl Makefile.PL EXCLUDE_EXT='Socket Safe' +command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe' =item EXE_FILES @@ -1241,13 +1305,6 @@ Ref to array of executable files. The files will be copied to the INST_SCRIPT directory. Make realclean will delete them from there again. -=item NO_VC - -In general any generated Makefile checks for the current version of -MakeMaker and the version the Makefile was built under. If NO_VC is -set, the version check is neglected. Do not write this into your -Makefile.PL, use it interactively instead. - =item FIRST_MAKEFILE The name of the Makefile to be produced. Defaults to the contents of @@ -1258,13 +1315,21 @@ that will be produced for the MAP_TARGET. Perl binary able to run this extension. +=item FUNCLIST + +This provides an alternate means to specify function names to be +exported from the extension. Its value is a reference to an +array of function names to be exported by the extension. These +names are passed through unaltered to the linker options file. + =item H Ref to array of *.h file names. Similar to C. =item IMPORTS -IMPORTS is only used on OS/2. +This attribute is used to specify names to be imported into the +extension. It is only used on OS/2 and Win32. =item INC @@ -1283,7 +1348,7 @@ filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then only DynaLoader and the current extension will be included in the build. This attribute may be most useful when specified as a string on the -commandline: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' +command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' =item INSTALLARCHLIB @@ -1321,14 +1386,14 @@ directory if INSTALLDIRS is set to perl. Used by 'make install' which copies files from INST_SCRIPT to this directory. -=item INSTALLSITELIB +=item INSTALLSITEARCH -Used by 'make install', which copies files from INST_LIB to this +Used by 'make install', which copies files from INST_ARCHLIB to this directory if INSTALLDIRS is set to site (default). -=item INSTALLSITEARCH +=item INSTALLSITELIB -Used by 'make install', which copies files from INST_ARCHLIB to this +Used by 'make install', which copies files from INST_LIB to this directory if INSTALLDIRS is set to site (default). =item INST_ARCHLIB @@ -1371,16 +1436,16 @@ defaults to "$(OBJECT)" and is used in the ld command to specify what files to link/load from (also see dynamic_lib below for how to specify ld flags) -=item LIBPERL_A - -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 LIBPERL_A + +The filename of the perllibrary that will be used together with this +extension. Defaults to libperl.a. + =item LIBS An anonymous array of alternative library @@ -1465,6 +1530,13 @@ itself. Boolean. Attribute to inhibit descending into subdirectories. +=item NO_VC + +In general any generated Makefile checks for the current version of +MakeMaker and the version the Makefile was built under. If NO_VC is +set, the version check is neglected. Do not write this into your +Makefile.PL, use it interactively instead. + =item OBJECT List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long @@ -1498,6 +1570,16 @@ Directory containing the Perl library to use. Directory containing the Perl source code (use of this should be avoided, it may be undefined) +=item PERM_RW + +Desired permission for read/writable files. Defaults to C<644>. +See also L<MM_Unix/perm_rw>. + +=item PERM_RWX + +Desired permission for executable files. Defaults to C<755>. +See also L<MM_Unix/perm_rwx>. + =item PL_FILES Ref to hash of files to be processed as perl programs. MakeMaker @@ -1507,7 +1589,11 @@ and the basename of the file being the value. E.g. {'foobar.PL' => 'foobar'} The *.PL files are expected to produce output to the target files -themselves. +themselves. If multiple files can be generated from the same *.PL +file then the value in the hash can be a reference to an array of +target file names. E.g. + + {'foobar.PL' => ['foobar1','foobar2']} =item PM @@ -1515,19 +1601,27 @@ Hashref of .pm files and *.pl files to be installed. e.g. {'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'} -By default this will include *.pm and *.pl. If a lib directory -exists and is not listed in DIR (above) then any *.pm and *.pl files -it contains will also be included by default. Defining PM in the +By default this will include *.pm and *.pl and the files found in +the PMLIBDIRS directories. Defining PM in the Makefile.PL will override PMLIBDIRS. =item PMLIBDIRS Ref to array of subdirectories containing library files. Defaults to -[ 'lib', $(BASEEXT) ]. The directories will be scanned and any files +[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. +=item PPM_INSTALL_EXEC + +Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl) + +=item PPM_INSTALL_SCRIPT + +Name of the script that gets executed by the Perl Package Manager after +the installation of a package. + =item PREFIX Can be used to set the three INSTALL* attributes in one go (except for @@ -1581,7 +1675,7 @@ MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; *VERSION = \'1.01'; - ( $VERSION ) = '$Revision: 1.2 $ ' =~ /\$Revision:\s+([^\s]+)/; + ( $VERSION ) = '$Revision: 1.3 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; *FOO::VERSION = \'1.11'; @@ -1647,7 +1741,7 @@ part of the Makefile. =item dist - {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => 'gz', + {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz', SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip', ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' } @@ -1662,10 +1756,6 @@ links the rest. Default is 'best'. {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'} -=item installpm - -Deprecated as of MakeMaker 5.23. See L<ExtUtils::MM_Unix/pm_to_blib>. - =item linkext {LINKTYPE => 'static', 'dynamic' or ''} @@ -1692,12 +1782,6 @@ be linked. =back -=cut - -# bug in pod2html, so leave the =back - -# Don't delete this cut, MM depends on it! - =head2 Overriding MakeMaker Methods If you cannot achieve the desired Makefile behaviour by specifying @@ -1717,14 +1801,14 @@ or you can edit the default by saying something like: $inherited; } -If you running experiments with embedding perl as a library into other -applications, you might find MakeMaker not sufficient. You'd better -have a look at ExtUtils::embed which is a collection of utilities for -embedding. +If you are running experiments with embedding perl as a library into +other applications, you might find MakeMaker is not sufficient. You'd +better have a look at ExtUtils::Embed which is a collection of utilities +for embedding. If you still need a different solution, try to develop another -subroutine, that fits your needs and submit the diffs to -F<perl5-porters@nicoh.com> or F<comp.lang.perl.misc> as appropriate. +subroutine that fits your needs and submit the diffs to +F<perl5-porters@perl.org> or F<comp.lang.perl.moderated> as appropriate. For a complete description of all MakeMaker methods see L<ExtUtils::MM_Unix>. @@ -1842,13 +1926,13 @@ reference to the dist attribute of the WriteMakefile call. The following parameters are recognized: CI ('ci -u') - COMPRESS ('compress') + COMPRESS ('gzip --best') POSTOP ('@ :') PREOP ('@ :') TO_UNIX (depends on the system) RCS_LABEL ('rcs -q -Nv$(VERSION_SYM):') SHAR ('shar') - SUFFIX ('Z') + SUFFIX ('.gz') TAR ('tar') TARFLAGS ('cvf') ZIP ('zip') @@ -1856,18 +1940,47 @@ following parameters are recognized: An example: - WriteMakefile( 'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" }) + WriteMakefile( 'dist' => { COMPRESS=>"bzip2", SUFFIX=>".bz2" }) + +=head2 Disabling an extension + +If some events detected in F<Makefile.PL> imply that there is no way +to create the Module, but this is a normal state of things, then you +can create a F<Makefile> which does nothing, but succeeds on all the +"usual" build targets. To do so, use + + ExtUtils::MakeMaker::WriteEmptyMakefile(); + +instead of WriteMakefile(). + +This may be useful if other modules expect this module to be I<built> +OK, as opposed to I<work> OK (say, this system-dependent module builds +in a subdirectory of some other distribution, or is listed as a +dependency in a CPAN::Bundle, but the functionality is supported by +different means on the current architecture). + +=head1 ENVIRONMENT + +=over 8 + +=item PERL_MM_OPT + +Command line options used by C<MakeMaker-E<gt>new()>, and thus by +C<WriteMakefile()>. The string is split on whitespace, and the result +is processed before any actual command line arguments are processed. + +=back =head1 SEE ALSO ExtUtils::MM_Unix, ExtUtils::Manifest, ExtUtils::testlib, -ExtUtils::Install, ExtUtils::embed +ExtUtils::Install, ExtUtils::Embed =head1 AUTHORS 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 +VMS support by Charles Bailey <F<bailey@newman.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 cc323c8924f..f2f62dec39d 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm @@ -10,7 +10,7 @@ use strict; use vars qw($VERSION @ISA @EXPORT_OK $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found); -$VERSION = substr(q$Revision: 1.2 $, 10); +$VERSION = substr(q$Revision: 1.3 $, 10); @ISA=('Exporter'); @EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck', 'skipcheck', 'maniread', 'manicopy'); @@ -87,10 +87,16 @@ sub _manicheck { my $read = maniread(); my $found = manifind(); my $file; + my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0); my(@missfile,@missentry); if ($arg & 1){ foreach $file (sort keys %$read){ warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug; + if ($dosnames){ + $file = lc $file; + $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge; + $file =~ s=((\w|-)+)=substr ($1,0,8)=ge; + } unless ( exists $found->{$file} ) { warn "No such file: $file\n" unless $Quiet; push @missfile, $file; @@ -236,7 +242,11 @@ sub ln { link($srcFile, $dstFile); local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x) my $mode= 0444 | (stat)[2] & 0700; - chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ ); + if (! chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ )) { + unlink $dstFile; + return; + } + 1; } sub best { @@ -288,7 +298,7 @@ but in doing so checks each line in an existing C<MANIFEST> file and includes any comments that are found in the existing C<MANIFEST> file in the new one. Anything between white space and an end of line within a C<MANIFEST> file is considered to be a comment. Filenames and -comments are seperated by one or more TAB characters in the +comments are separated by one or more TAB characters in the output. All files that match any regular expression in a file C<MANIFEST.SKIP> (if such a file exists) are ignored. @@ -307,7 +317,7 @@ Fullcheck() does both a manicheck() and a filecheck(). Skipcheck() lists all the files that are skipped due to your C<MANIFEST.SKIP> file. -Manifind() retruns a hash reference. The keys of the hash are the +Manifind() returns a hash reference. The keys of the hash are the files found below the current directory. Maniread($file) reads a named C<MANIFEST> file (defaults to diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm b/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm index ff0aa096b3e..907c168b434 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm @@ -1,7 +1,7 @@ package ExtUtils::Mkbootstrap; -$VERSION = substr q$Revision: 1.2 $, 10; -# $Date: 1997/11/30 07:57:31 $ +$VERSION = substr q$Revision: 1.3 $, 10; +# $Date: 1999/04/29 22:51:53 $ use Config; use Exporter; @@ -49,7 +49,7 @@ sub Mkbootstrap { print BS "# $baseext DynaLoader bootstrap file for $^O architecture.\n"; print BS "# Do not edit this file, changes will be lost.\n"; print BS "# This file was automatically generated by the\n"; - print BS "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$Version).\n"; + print BS "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n"; print BS "\@DynaLoader::dl_resolve_using = "; # If @all contains names in the form -lxxx or -Lxxx then it's asking for # runtime library location so we automatically add a call to dl_findfile() diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm b/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm index f47235d990b..1f2819dc221 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 = substr q$Revision: 1.2 $, 10; +$VERSION = substr q$Revision: 1.3 $, 10; sub Mksymlists { my(%spec) = @_; @@ -19,10 +19,10 @@ sub Mksymlists { $spec{DL_VARS} = [] unless $spec{DL_VARS}; ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE}; + $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; $spec{DL_FUNCS} = { $spec{NAME} => [] } unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or - $spec{FUNCLIST}); - $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; + @{$spec{FUNCLIST}}); if (defined $spec{DL_FUNCS}) { my($package); foreach $package (keys %{$spec{DL_FUNCS}}) { @@ -69,6 +69,8 @@ sub _write_aix { sub _write_os2 { my($data) = @_; + require Config; + my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : ""); if (not $data->{DLBASE}) { ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; @@ -79,6 +81,7 @@ sub _write_os2 { open(DEF,">$data->{FILE}.def") or croak("Can't create $data->{FILE}.def: $!\n"); print DEF "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n"; + print DEF "DESCRIPTION 'Perl (v$]$threaded) module $data->{NAME} v$data->{VERSION}'\n"; print DEF "CODE LOADONCALL\n"; print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n"; print DEF "EXPORTS\n "; @@ -86,10 +89,10 @@ sub _write_os2 { print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; if (%{$data->{IMPORTS}}) { print DEF "IMPORTS\n"; -my ($name, $exp); -while (($name, $exp)= each %{$data->{IMPORTS}}) { - print DEF " $name=$exp\n"; -} + my ($name, $exp); + while (($name, $exp)= each %{$data->{IMPORTS}}) { + print DEF " $name=$exp\n"; + } } close DEF; } @@ -107,9 +110,9 @@ sub _write_win32 { 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"; + if ($Config::Config{'cc'} !~ /^gcc/i) { + print DEF "LIBRARY \"$data->{DLBASE}\"\n"; + } print DEF "EXPORTS\n "; my @syms; # Export public symbols both with and without underscores to @@ -174,13 +177,6 @@ sub _write_vms { } close OPT; - # Options file specifying RTLs to which this extension must be linked. - # Eventually, the list of libraries will be supplied by a working - # extliblist routine. - open OPT,'>rtls.opt'; - print OPT "PerlShr/Share\n"; - foreach $rtl (split(/\s+/,$Config::Config{'libs'})) { print OPT "$rtl\n"; } - close OPT; } 1; @@ -211,10 +207,13 @@ keys are recognized: =over -=item NAME +=item DLBASE -This gives the name of the extension (I<e.g.> Tk::Canvas) for which -the linker option file will be produced. +This item specifies the name by which the linker knows the +extension, which may be different from the name of the +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 and Win32. =item DL_FUNCS @@ -223,7 +222,7 @@ from which it is usually taken. Its value is a reference to an associative array, in which each key is the name of a package, and each value is an a reference to an array of function names which should be exported by the extension. For instance, one might say -C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], +C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The function names should be identical to those in the XSUB code; C<Mksymlists> will alter the names written to the linker option @@ -247,7 +246,7 @@ be exported by the extension. This key can be used to specify the name of the linker option file (minus the OS-specific extension), if for some reason you do not want to use the default value, which is the last word of the NAME -attribute (I<e.g.> for Tk::Canvas, FILE defaults to 'Canvas'). +attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>). =item FUNCLIST @@ -255,14 +254,25 @@ This provides an alternate means to specify function names to be exported from the extension. Its value is a reference to an array of function names to be exported by the extension. These names are passed through unaltered to the linker options file. +Specifying a value for the FUNCLIST attribute suppresses automatic +generation of the bootstrap function for the package. To still create +the bootstrap name you have to specify the package name in the +DL_FUNCS hash: -=item DLBASE + Mksymlists({ NAME => $name , + FUNCLIST => [ $func1, $func2 ], + DL_FUNCS => { $pkg => [] } }); -This item specifies the name by which the linker knows the -extension, which may be different from the name of the -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. + +=item IMPORTS + +This attribute is used to specify names to be imported into the +extension. It is currently only used by OS/2 and Win32. + +=item NAME + +This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which +the linker option file will be produced. =back @@ -273,7 +283,7 @@ can be used to provide additional information to the linker. =head1 AUTHOR -Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> +Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> =head1 REVISION diff --git a/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm b/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm index 57ea87c82fe..91ea6596dd6 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm +++ b/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm @@ -1,6 +1,6 @@ package ExtUtils::testlib; -$VERSION = substr q$Revision: 1.2 $, 10; -# $Id: testlib.pm,v 1.2 1997/11/30 07:57:32 millert Exp $ +$VERSION = substr q$Revision: 1.3 $, 10; +# $Id: testlib.pm,v 1.3 1999/04/29 22:51:53 millert Exp $ use lib qw(blib/arch blib/lib); 1; diff --git a/gnu/usr.bin/perl/lib/ExtUtils/typemap b/gnu/usr.bin/perl/lib/ExtUtils/typemap index 20cc96f0b55..b1ec063dd75 100644 --- a/gnu/usr.bin/perl/lib/ExtUtils/typemap +++ b/gnu/usr.bin/perl/lib/ExtUtils/typemap @@ -1,12 +1,12 @@ # $Header$ # basic C types int T_IV -unsigned T_IV -unsigned int T_IV +unsigned T_UV +unsigned int T_UV long T_IV -unsigned long T_IV +unsigned long T_UV short T_IV -unsigned short T_IV +unsigned short T_UV char T_CHAR unsigned char T_U_CHAR char * T_PV @@ -34,7 +34,7 @@ I16 T_IV I8 T_IV U32 T_U_LONG U16 T_U_SHORT -U8 T_IV +U8 T_UV Result T_U_CHAR Boolean T_IV double T_DOUBLE @@ -73,6 +73,8 @@ T_CVREF croak(\"$var is not of type ${ntype}\") T_SYSRET $var NOT IMPLEMENTED +T_UV + $var = ($type)SvUV($arg) T_IV $var = ($type)SvIV($arg) T_INT @@ -82,19 +84,19 @@ T_ENUM T_BOOL $var = (int)SvIV($arg) T_U_INT - $var = (unsigned int)SvIV($arg) + $var = (unsigned int)SvUV($arg) T_SHORT $var = (short)SvIV($arg) T_U_SHORT - $var = (unsigned short)SvIV($arg) + $var = (unsigned short)SvUV($arg) T_LONG $var = (long)SvIV($arg) T_U_LONG - $var = (unsigned long)SvIV($arg) + $var = (unsigned long)SvUV($arg) T_CHAR - $var = (char)*SvPV($arg,na) + $var = (char)*SvPV($arg,PL_na) T_U_CHAR - $var = (unsigned char)SvIV($arg) + $var = (unsigned char)SvUV($arg) T_FLOAT $var = (float)SvNV($arg) T_NV @@ -102,7 +104,7 @@ T_NV T_DOUBLE $var = (double)SvNV($arg) T_PV - $var = ($type)SvPV($arg,na) + $var = ($type)SvPV($arg,PL_na) T_PTR $var = ($type)SvIV($arg) T_PTRREF @@ -158,7 +160,7 @@ T_REFOBJ T_OPAQUE $var NOT IMPLEMENTED T_OPAQUEPTR - $var = ($type)SvPV($arg,na) + $var = ($type)SvPV($arg,PL_na) T_PACKED $var = XS_unpack_$ntype($arg) T_PACKEDARRAY @@ -191,6 +193,8 @@ T_CVREF $arg = newRV((SV*)$var); T_IV sv_setiv($arg, (IV)$var); +T_UV + sv_setuv($arg, (UV)$var); T_INT sv_setiv($arg, (IV)$var); T_SYSRET @@ -205,19 +209,19 @@ T_ENUM T_BOOL $arg = boolSV($var); T_U_INT - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_SHORT sv_setiv($arg, (IV)$var); T_U_SHORT - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_LONG sv_setiv($arg, (IV)$var); T_U_LONG - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_CHAR sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR - sv_setiv($arg, (IV)$var); + sv_setuv($arg, (UV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV @@ -262,14 +266,14 @@ T_ARRAY ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM } - sp += $var.size - 1; + SP += $var.size - 1; T_IN { GV *gv = newGVgen("$Package"); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else - $arg = &sv_undef; + $arg = &PL_sv_undef; } T_INOUT { @@ -277,7 +281,7 @@ T_INOUT if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else - $arg = &sv_undef; + $arg = &PL_sv_undef; } T_OUT { @@ -285,5 +289,5 @@ T_OUT if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else - $arg = &sv_undef; + $arg = &PL_sv_undef; } diff --git a/gnu/usr.bin/perl/lib/ExtUtils/xsubpp b/gnu/usr.bin/perl/lib/ExtUtils/xsubpp index 04de166ad67..1ee7b29449e 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<-nolinenumbers>] [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>] [B<-object_capi>]... file.xs =head1 DESCRIPTION @@ -59,7 +59,11 @@ number. Prevents the inclusion of `#line' directives in the output. -=back +=item B<-object_capi> + +Compile code as C in a PERL_OBJECT environment. + +back =head1 ENVIRONMENT @@ -82,12 +86,15 @@ perl(1), perlxs(1), perlxstut(1) require 5.002; use Cwd; use vars '$cplusplus'; +use vars '%v'; + +use Config; sub Q ; # Global Constants -$XSUBPP_version = "1.9505"; +$XSUBPP_version = "1.9507"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -103,6 +110,8 @@ $FH = 'File0000' ; $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; +# mjn +$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; $except = ""; $WantPrototypes = -1 ; @@ -118,6 +127,7 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; + $WantCAPI = 1, next SWITCH if $flag eq 'object_capi'; $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'; @@ -234,7 +244,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 + SCOPE INTERFACE INTERFACE_MACRO C_ARGS )) . "|$END)\\s*:"; # Input: ($_, @line) == unparsed input. @@ -301,6 +311,20 @@ sub print_section { print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; } +sub merge_section { + my $in = ''; + + while (!/\S/ && @line) { + $_ = shift(@line); + } + + for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { + $in .= "$_\n"; + } + chomp $in; + return $in; +} + sub process_keyword($) { my($pattern) = @_ ; @@ -328,11 +352,11 @@ sub INPUT_handler { my $line = $_ ; # remove trailing semicolon if no initialisation - s/\s*;$//g unless /=/ ; + s/\s*;$//g unless /[=;+].*\S/ ; # check for optional initialisation code my $var_init = '' ; - $var_init = $1 if s/\s*(=.*)$//s ; + $var_init = $1 if s/\s*([=;+].*)$//s ; $var_init =~ s/"/\\"/g; s/\s+/ /g; @@ -355,10 +379,10 @@ sub INPUT_handler { $var_addr{$var_name} = 1; $func_args =~ s/\b($var_name)\b/&$1/; } - if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) { + if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) { print "\t$var_name;\n"; } elsif ($var_init =~ /\S/) { - &output_init($var_type, $var_num, "$var_name $var_init"); + &output_init($var_type, $var_num, $var_name, $var_init); } elsif ($var_num) { # generate initialization code &generate_init($var_type, $var_num, $var_name); @@ -371,6 +395,10 @@ sub INPUT_handler { sub OUTPUT_handler { for (; !/^$BLOCK_re/o; $_ = shift(@line)) { next unless /\S/; + if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { + $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); + next; + } my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next if $outargs{$outarg} ++ ; @@ -384,15 +412,52 @@ sub OUTPUT_handler { unless defined($args_match{$outarg}); blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next unless defined $var_types{$outarg} ; + $var_num = $args_match{$outarg}; if ($outcode) { print "\t$outcode\n"; + print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic; } else { - $var_num = $args_match{$outarg}; - &generate_output($var_types{$outarg}, $var_num, $outarg); + &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); } } } +sub C_ARGS_handler() { + my $in = merge_section(); + + TrimWhitespace($in); + $func_args = $in; +} + +sub INTERFACE_MACRO_handler() { + my $in = merge_section(); + + TrimWhitespace($in); + if ($in =~ /\s/) { # two + ($interface_macro, $interface_macro_set) = split ' ', $in; + } else { + $interface_macro = $in; + $interface_macro_set = 'UNKNOWN_CVT'; # catch later + } + $interface = 1; # local + $Interfaces = 1; # global +} + +sub INTERFACE_handler() { + my $in = merge_section(); + + TrimWhitespace($in); + + foreach (split /[\s,]+/, $in) { + $Interfaces{$_} = $_; + } + print Q<<"EOF"; +# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr); +EOF + $interface = 1; # local + $Interfaces = 1; # global +} + sub CLEANUP_handler() { print_section() } sub PREINIT_handler() { print_section() } sub INIT_handler() { print_section() } @@ -709,10 +774,16 @@ print("#line 1 \"$filename\"\n") while (<$FH>) { last if ($Module, $Package, $Prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; + + if ($OBJ) { + s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; + } print $_; } &Exit unless defined $_; +print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; + $lastline = $_; $lastline_no = $.; @@ -829,6 +900,9 @@ while (fetch_para()) { undef(@proto_arg) ; undef($proto_in_this_xsub) ; undef($scope_in_this_xsub) ; + undef($interface); + $interface_macro = 'XSINTERFACE_FUNC' ; + $interface_macro_set = 'XSINTERFACE_FUNC_SET' ; $ProtoThisXSUB = $WantPrototypes ; $ScopeThisXSUB = 0; @@ -849,7 +923,7 @@ while (fetch_para()) { # extract return type, function name and arguments - my($ret_type) = TidyType($_); + ($ret_type) = TidyType($_); # a function definition needs at least 2 lines blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH @@ -859,9 +933,10 @@ while (fetch_para()) { $func_header = shift(@line); blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH - unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s; + unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*$/s; ($class, $func_name, $orig_args) = ($1, $2, $3) ; + $class = "$4 $class" if $4; ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; ($clean_func_name = $func_name) =~ s/^$Prefix//; $Full_func_name = "${Packid}_$clean_func_name"; @@ -874,7 +949,8 @@ while (fetch_para()) { last; } $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; - %XsubAliases = %XsubAliasValues = (); + %XsubAliases = %XsubAliasValues = %Interfaces = (); + $DoSetMagic = 1; @args = split(/\s*,\s*/, $orig_args); if (defined($class)) { @@ -916,6 +992,7 @@ while (fetch_para()) { $EXPLICIT_RETURN = ($CODE && ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); $ALIAS = grep(/^\s*ALIAS\s*:/, @line); + $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); # print function header print Q<<"EOF"; @@ -926,6 +1003,9 @@ EOF print Q<<"EOF" if $ALIAS ; # dXSI32; EOF + print Q<<"EOF" if $INTERFACE ; +# dXSFUNCTION($ret_type); +EOF if ($elipsis) { $cond = ($min_args ? qq(items < $min_args) : 0); } @@ -978,7 +1058,7 @@ EOF $gotRETVAL = 0; INPUT_handler() ; - process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE|SCOPE") ; + process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ; print Q<<"EOF" if $ScopeThisXSUB; # ENTER; @@ -1012,7 +1092,7 @@ EOF print $deferred; - process_keyword("INIT|ALIAS|PROTOTYPE") ; + process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; if (check_keyword("PPCODE")) { print_section(); @@ -1045,6 +1125,7 @@ EOF } $func_name =~ s/^($spat)// if defined($spat); + $func_name = 'XSFUNCTION' if $interface; print "$func_name($func_args);\n"; } } @@ -1059,7 +1140,8 @@ EOF if ($gotRETVAL && $RETVAL_code) { print "\t$RETVAL_code\n"; } elsif ($gotRETVAL || $wantRETVAL) { - &generate_output($ret_type, 0, 'RETVAL'); + # RETVAL almost never needs SvSETMAGIC() + &generate_output($ret_type, 0, 'RETVAL', 0); } # do cleanup @@ -1152,6 +1234,18 @@ EOF # sv_setpv((SV*)cv$proto) ; EOF } + } + elsif ($interface) { + while ( ($name, $value) = each %Interfaces) { + $name = "$Package\::$name" unless $name =~ /::/; + push(@InitFileCode, Q<<"EOF"); +# cv = newXS(\"$name\", XS_$Full_func_name, file); +# $interface_macro_set(cv,$value) ; +EOF + push(@InitFileCode, Q<<"EOF") if $proto; +# sv_setpv((SV*)cv$proto) ; +EOF + } } else { push(@InitFileCode, @@ -1160,11 +1254,32 @@ EOF } # print initialization routine + print Q<<"EOF"; ##ifdef __cplusplus #extern "C" ##endif +EOF + +if ($WantCAPI) { +print Q<<"EOF"; +##ifdef PERL_CAPI +#XS(boot__CAPI_entry) +##else +EOF +} + +print Q<<"EOF"; #XS(boot_$Module_cname) +EOF + +if ($WantCAPI) { +print Q<<"EOF"; +##endif /* PERL_CAPI */ +EOF +} + +print Q<<"EOF"; #[[ # dXSARGS; # char* file = __FILE__; @@ -1176,7 +1291,7 @@ print Q<<"EOF" if $WantVersionChk ; # EOF -print Q<<"EOF" if defined $XsubAliases ; +print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; # { # CV * cv ; # @@ -1184,7 +1299,7 @@ EOF print @InitFileCode; -print Q<<"EOF" if defined $XsubAliases ; +print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; # } EOF @@ -1197,21 +1312,50 @@ if (@BootCode) } print Q<<"EOF";; -# ST(0) = &sv_yes; -# XSRETURN(1); +# XSRETURN_YES; #]] +# EOF +if ($WantCAPI) { +print Q<<"EOF"; +##ifdef PERL_CAPI +##define XSCAPI(name) void name(CV* cv, void* pPerl) +# +##ifdef __cplusplus +#extern "C" +##endif +#XSCAPI(boot_$Module_cname) +#[[ +# SetCPerlObj(pPerl); +# boot__CAPI_entry(cv); +#]] +##endif /* PERL_CAPI */ +EOF +} + warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") unless $ProtoUsed ; &Exit; - sub output_init { - local($type, $num, $init) = @_; + local($type, $num, $var, $init) = @_; local($arg) = "ST(" . ($num - 1) . ")"; - eval qq/print " $init\\\n"/; + if( $init =~ /^=/ ) { + eval qq/print "\\t$var $init\\n"/; + warn $@ if $@; + } else { + if( $init =~ s/^\+// && $num ) { + &generate_init($type, $num, $var); + } else { + eval qq/print "\\t$var;\\n"/; + warn $@ if $@; + $init =~ s/^;//; + } + $deferred .= eval qq/"\\n\\t$init\\n"/; + warn $@ if $@; + } } sub Warn @@ -1273,17 +1417,22 @@ sub generate_init { $expr =~ s/(\t+)/$1 /g; $expr =~ s/ /\t/g; eval qq/print "\\t$var;\\n"/; + warn $@ if $@; $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; + warn $@ if $@; } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) { eval qq/print "\\t$var;\\n"/; + warn $@ if $@; $deferred .= eval qq/"\\n$expr;\\n"/; + warn $@ if $@; } else { eval qq/print "$expr;\\n"/; + warn $@ if $@; } } sub generate_output { - local($type, $num, $var) = @_; + local($type, $num, $var, $do_setmagic) = @_; local($arg) = "ST(" . ($num - ($num != 0)) . ")"; local($argoff) = $num - 1; local($ntype); @@ -1291,6 +1440,7 @@ sub generate_output { $type = TidyType($type) ; if ($type =~ /^array\(([^,]*),(.*)\)/) { print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } else { blurt("Error: '$type' not in typemap"), return unless defined($type_kind{$type}); @@ -1312,23 +1462,25 @@ sub generate_output { $subexpr =~ s/\n\t/\n\t\t/g; $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; eval "print qq\a$expr\a"; + warn $@ if $@; + print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; } elsif ($var eq 'RETVAL') { if ($expr =~ /^\t\$arg = new/) { # We expect that $arg has refcnt 1, so we need to # mortalize it. eval "print qq\a$expr\a"; + warn $@ if $@; print "\tsv_2mortal(ST(0));\n"; + print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; } 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. + # to mortalize it! eval "print qq\a$expr\a"; - print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n"; + warn $@ if $@; + print "\tsv_2mortal(ST(0));\n"; + print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; } else { # Just hope that the entry would safely write it @@ -1337,10 +1489,14 @@ sub generate_output { # works too. print "\tST(0) = sv_newmortal();\n"; eval "print qq\a$expr\a"; + warn $@ if $@; + # new mortals don't have set magic } } elsif ($arg =~ /^ST\(\d+\)$/) { eval "print qq\a$expr\a"; + warn $@ if $@; + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } } } diff --git a/gnu/usr.bin/perl/lib/File/Basename.pm b/gnu/usr.bin/perl/lib/File/Basename.pm index e4863f8911a..69bb1fa5fdc 100644 --- a/gnu/usr.bin/perl/lib/File/Basename.pm +++ b/gnu/usr.bin/perl/lib/File/Basename.pm @@ -122,13 +122,15 @@ directory name to be F<.>). =cut -require 5.002; + +## use strict; +use re 'taint'; + 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"; +use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase); +$VERSION = "2.6"; # fileparse_set_fstype() - specify OS-based rules used in future @@ -141,7 +143,7 @@ sub fileparse_set_fstype { my @old = ($Fileparse_fstype, $Fileparse_igncase); if (@_) { $Fileparse_fstype = $_[0]; - $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32)/i); + $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i); } wantarray ? @old : $old[0]; } @@ -155,11 +157,13 @@ sub fileparse { my($fullname,@suffices) = @_; my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); my($dirpath,$tail,$suffix,$basename); + my($taint) = substr($fullname,0,0); # Is $fullname tainted? if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/); + $dirpath ||= ''; # should always be defined } } if ($fstype =~ /^MS(DOS|Win32)/i) { @@ -175,6 +179,10 @@ sub fileparse { } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); + if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + ($basename,$dirpath) = ('',$fullname); + } $dirpath = './' unless $dirpath; } @@ -183,12 +191,15 @@ sub fileparse { foreach $suffix (@suffices) { my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; if ($basename =~ s/$pat//) { + $taint .= substr($suffix,0,0); $tail = $1 . $tail; } } } - wantarray ? ($basename,$dirpath,$tail) : $basename; + $tail .= $taint if defined $tail; # avoid warning if $tail == undef + wantarray ? ($basename . $taint, $dirpath . $taint, $tail) + : $basename . $taint; } diff --git a/gnu/usr.bin/perl/lib/File/CheckTree.pm b/gnu/usr.bin/perl/lib/File/CheckTree.pm index a39308b6c96..dca7f6aff31 100644 --- a/gnu/usr.bin/perl/lib/File/CheckTree.pm +++ b/gnu/usr.bin/perl/lib/File/CheckTree.pm @@ -137,13 +137,13 @@ sub valmess { $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } - print STDERR $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; - print STDERR "Can't do $this.\n"; + $mess = "Can't do $this.\n"; } - if ($disposition eq 'die') { exit 1; } + die "$mess\n" if $disposition eq 'die'; + warn "$mess\n"; ++$warnings; } diff --git a/gnu/usr.bin/perl/lib/File/Copy.pm b/gnu/usr.bin/perl/lib/File/Copy.pm index e95168e24b8..e1da6b6e59c 100644 --- a/gnu/usr.bin/perl/lib/File/Copy.pm +++ b/gnu/usr.bin/perl/lib/File/Copy.pm @@ -62,7 +62,9 @@ sub copy { if (defined &syscopy && \&syscopy != \© && !$to_a_handle - && !($from_a_handle && $^O eq 'os2')) # OS/2 cannot handle handles + && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles + && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. + ) { return syscopy($from, $to); } @@ -174,7 +176,20 @@ sub move { *mv = \&move; # &syscopy is an XSUB under OS/2 -*syscopy = ($^O eq 'VMS' ? \&rmscopy : \©) unless defined &syscopy; +unless (defined &syscopy) { + if ($^O eq 'VMS') { + *syscopy = \&rmscopy; + } elsif ($^O eq 'mpeix') { + *syscopy = sub { + return 0 unless @_ == 2; + # Use the MPE cp program in order to + # preserve MPE file attributes. + return system('/bin/cp', '-f', $_[0], $_[1]) == 0; + }; + } else { + *syscopy = \© + } +} 1; @@ -220,7 +235,7 @@ 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.> Files are opened in binary mode where -applicable. To get a consistent behavour when copying from a +applicable. To get a consistent behaviour 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 @@ -259,7 +274,7 @@ 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 if C<syscopy> is defined (VMS and OS/2) +=head2 Special behaviour if C<syscopy> is defined (VMS and OS/2) If both arguments to C<copy> are not file handles, then C<copy> will perform a "system copy" of @@ -321,7 +336,7 @@ $! 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, -and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996. +and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996. =cut diff --git a/gnu/usr.bin/perl/lib/File/DosGlob.pm b/gnu/usr.bin/perl/lib/File/DosGlob.pm index 4597c715640..594ee2ec843 100644 --- a/gnu/usr.bin/perl/lib/File/DosGlob.pm +++ b/gnu/usr.bin/perl/lib/File/DosGlob.pm @@ -6,21 +6,6 @@ package File::DosGlob; -unless (caller) { - $| = 1; - while (@ARGV) { - # - # We have to do this one by one for compatibility reasons. - # If an arg doesn't match anything, we are supposed to return - # the original arg. I know, it stinks, eh? - # - my $arg = shift; - my @m = doglob(1,$arg); - print (@m ? join("\0", sort @m) : $arg); - print "\0" if @ARGV; - } -} - sub doglob { my $cond = shift; my @retval = (); @@ -112,17 +97,27 @@ my %entries; sub glob { my $pat = shift; my $cxix = shift; + my @pat; # glob without args defaults to $_ $pat = $_ unless defined $pat; + # extract patterns + if ($pat =~ /\s/) { + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$pat); + } + else { + push @pat, $pat; + } + # assume global context if not provided one $cxix = '_G_' unless defined $cxix; $iter{$cxix} = 0 unless exists $iter{$cxix}; # if we're just beginning, do it all first if ($iter{$cxix} == 0) { - $entries{$cxix} = [doglob(1,$pat)]; + $entries{$cxix} = [doglob(1,@pat)]; } # chuck it all out, quick or slow @@ -145,10 +140,10 @@ sub glob { sub import { my $pkg = shift; - my $callpkg = caller(0); + return unless @_; my $sym = shift; - *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} - if defined($sym) and $sym eq 'glob'; + my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0)); + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; } 1; @@ -159,8 +154,6 @@ __END__ File::DosGlob - DOS like globbing and then some -perlglob.bat - a more capable perlglob.exe replacement - =head1 SYNOPSIS require 5.004; @@ -168,19 +161,19 @@ perlglob.bat - a more capable perlglob.exe replacement # override CORE::glob in current package use File::DosGlob 'glob'; + # override CORE::glob in ALL packages (use with extreme caution!) + use File::DosGlob 'GLOBAL_glob'; + @perlfiles = glob "..\\pe?l/*.p?"; print <..\\pe?l/*.p?>; # from the command line (overrides only in main::) > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" - - > perlglob ../pe*/*p? =head1 DESCRIPTION A module that implements DOS-like globbing with a few enhancements. -This file is also a portable replacement for perlglob.exe. It -is largely compatible with perlglob.exe (the M$ setargv.obj +It is largely compatible with perlglob.exe (the M$ setargv.obj version) in all but one respect--it understands wildcards in directory components. @@ -191,16 +184,14 @@ backslashes and forward slashes are both accepted, and preserved. You may have to double the backslashes if you are putting them in literally, due to double-quotish parsing of the pattern by perl. -When invoked as a program, it will print null-separated filenames -to standard output. - -While one may replace perlglob.exe with this, usage by overriding -CORE::glob via importation should be much more efficient, because -it avoids launching a separate process, and is therefore strongly -recommended. Note that it is currently possible to override -builtins like glob() only on a per-package basis, not "globally". -Thus, every namespace that wants to override glob() must explicitly -request the override. See L<perlsub>. +Spaces in the argument delimit distinct patterns, so +C<glob('*.exe *.dll')> globs all filenames that end in C<.exe> +or C<.dll>. If you want to put in literal spaces in the glob +pattern, you can escape them with either double quotes, or backslashes. +e.g. C<glob('c:/"Program Files"/*/*.dll')>, or +C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using +C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details +of the quoting rules used. Extending it to csh patterns is left as an exercise to the reader. @@ -223,6 +214,10 @@ Gurusamy Sarathy <gsar@umich.edu> =item * +Support for globally overriding glob() (GSAR 3-JUN-98) + +=item * + Scalar context, independent iterator context fixes (GSAR 15-SEP-97) =item * @@ -246,5 +241,9 @@ Initial version (GSAR 20-FEB-97) perl +perlglob.bat + +Text::ParseWords + =cut diff --git a/gnu/usr.bin/perl/lib/File/Find.pm b/gnu/usr.bin/perl/lib/File/Find.pm index 033cfe5e9de..7e670032a30 100644 --- a/gnu/usr.bin/perl/lib/File/Find.pm +++ b/gnu/usr.bin/perl/lib/File/Find.pm @@ -1,10 +1,7 @@ package File::Find; require 5.000; require Exporter; -use Config; require Cwd; -require File::Basename; - =head1 NAME @@ -17,13 +14,24 @@ finddepth - traverse a directory structure depth-first use File::Find; find(\&wanted, '/foo','/bar'); sub wanted { ... } - + use File::Find; finddepth(\&wanted, '/foo','/bar'); sub wanted { ... } =head1 DESCRIPTION +The first argument to find() is either a hash reference describing the +operations to be performed for each file, a code reference, or a string +that contains a subroutine name. If it is a hash reference, then the +value for the key C<wanted> should be a code reference. This code +reference is called I<the wanted() function> below. + +Currently the only other supported key for the above hash is +C<bydepth>, in presense of which the walk over directories is +performed depth-first. Entry point finddepth() is a shortcut for +specifying C<{ bydepth => 1}> in the first argument of find(). + The wanted() function does whatever verifications you want. $File::Find::dir contains the current directory name, and $_ the current filename within that directory. $File::Find::name contains @@ -34,7 +42,7 @@ prune the tree. File::Find assumes that you don't alter the $_ variable. If you do then make sure you return it to its original value before exiting your function. -This library is primarily for the C<find2perl> tool, which when fed, +This library is useful for the C<find2perl> tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ -exec rm -f {} \; -o -fstype nfs -prune @@ -63,7 +71,7 @@ that don't resolve: sub wanted { -l && !-e && print "bogus link: $File::Find::name\n"; - } + } =head1 BUGS @@ -75,9 +83,10 @@ There is no way to make find or finddepth follow symlinks. @EXPORT = qw(find finddepth); -sub find { +sub find_opt { my $wanted = shift; - my $cwd = Cwd::cwd(); + my $bydepth = $wanted->{bydepth}; + my $cwd = $bydepth ? Cwd::fastcwd() : Cwd::cwd(); # Localize these rather than lexicalizing them for backwards # compatibility. local($topdir,$topdev,$topino,$topmode,$topnlink); @@ -87,16 +96,21 @@ sub find { || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { - ($dir,$_) = ($topdir,'.'); - $name = $topdir; $prune = 0; - &$wanted; - if (!$prune) { - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - $fixtopdir =~ s/\\dir$// if $Is_NT; - &finddir($wanted,$fixtopdir,$topnlink); + unless ($bydepth) { + ($dir,$_) = ($topdir,'.'); + $name = $topdir; + $wanted->{wanted}->(); + } + next if $prune; + my $fixtopdir = $topdir; + $fixtopdir =~ s,/$,, ; + $fixtopdir =~ s/\.dir$// if $Is_VMS; + &finddir($wanted,$fixtopdir,$topnlink, $bydepth); + if ($bydepth) { + ($dir,$_) = ($fixtopdir,'.'); + $name = $fixtopdir; + $wanted->{wanted}->(); } } else { @@ -104,25 +118,31 @@ sub find { } } else { + require File::Basename; unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } - $name = $topdir; - chdir $dir && &$wanted; + if (chdir($dir)) { + $name = $topdir; + $wanted->{wanted}->(); + } + else { + warn "Can't cd to $dir: $!\n"; + } } chdir $cwd; } } sub finddir { - my($wanted, $nlink); + my($wanted, $nlink, $bydepth); local($dir, $name); - ($wanted, $dir, $nlink) = @_; + ($wanted, $dir, $nlink, $bydepth) = @_; my($dev, $ino, $mode, $subcount); # Get the list of files in the current directory. - opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); + opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return); my(@filenames) = readdir(DIR); closedir(DIR); @@ -132,149 +152,81 @@ sub finddir { next if $_ eq '..'; $name = "$dir/$_"; $nlink = 0; - &$wanted; + $wanted->{wanted}->(); } } - else { # This dir has subdirectories. + else { # This dir has subdirectories. $subcount = $nlink - 2; for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; - $nlink = $prune = 0; + $nlink = 0; + $prune = 0 unless $bydepth; $name = "$dir/$_"; - &$wanted; + $wanted->{wanted}->() unless $bydepth; if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? # Get link count and check for directoriness. ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); # unless ($nlink || $dont_use_nlink); - + if (-d _) { # It really is a directory, so do it recursively. - if (!$prune && chdir $_) { + --$subcount; + next if $prune; + # Untaint $_, so that we can do a chdir + $_ = $1 if /^(.*)/; + if (chdir $_) { $name =~ s/\.dir$// if $Is_VMS; - $name =~ s/\\dir$// if $Is_NT; - &finddir($wanted,$name,$nlink); + &finddir($wanted,$name,$nlink, $bydepth); chdir '..'; } - --$subcount; + else { + warn "Can't cd to $_: $!\n"; + } } } + $wanted->{wanted}->() if $bydepth; } } } - -sub finddepth { - my $wanted = shift; - - $cwd = Cwd::fastcwd();; - - # Localize these rather than lexicalizing them for backwards - # compatibility. - local($topdir, $topdev, $topino, $topmode, $topnlink); - foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = - ($Is_VMS ? stat($topdir) : lstat($topdir))) - || (warn("Can't stat $topdir: $!\n"), next); - if (-d _) { - if (chdir($topdir)) { - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - $fixtopdir =~ s/\\dir$// if $Is_NT; - &finddepthdir($wanted,$fixtopdir,$topnlink); - ($dir,$_) = ($fixtopdir,'.'); - $name = $fixtopdir; - &$wanted; - } - else { - warn "Can't cd to $topdir: $!\n"; - } - } - else { - unless (($_,$dir) = File::Basename::fileparse($topdir)) { - ($dir,$_) = ('.', $topdir); - } - $name = $topdir; - chdir $dir && &$wanted; - } - chdir $cwd; - } +sub wrap_wanted { + my $wanted = shift; + ref($wanted) eq 'HASH' ? $wanted : { wanted => $wanted }; } -sub finddepthdir { - my($wanted, $nlink); - local($dir, $name); - ($wanted,$dir,$nlink) = @_; - my($dev, $ino, $mode, $subcount); - - # Get the list of files in the current directory. - opendir(DIR,'.') || warn "Can't open $dir: $!\n"; - my(@filenames) = readdir(DIR); - closedir(DIR); - - if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $name = "$dir/$_"; - $nlink = 0; - &$wanted; - } - } - else { # This dir has subdirectories. - $subcount = $nlink - 2; - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $nlink = 0; - $name = "$dir/$_"; - if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? - - # Get link count and check for directoriness. - - ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); - - if (-d _) { - - # It really is a directory, so do it recursively. - - if (chdir $_) { - $name =~ s/\.dir$// if $Is_VMS; - $name =~ s/\\dir$// if $Is_NT; - &finddepthdir($wanted,$name,$nlink); - chdir '..'; - } - --$subcount; - } - } - &$wanted; - } - } +sub find { + my $wanted = shift; + find_opt(wrap_wanted($wanted), @_); } -# Set dont_use_nlink in your hint file if your system's stat doesn't -# report the number of links in a directory as an indication -# of the number of files. -# See, e.g. hints/machten.sh for MachTen 2.2. -$dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +sub finddepth { + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + find_opt($wanted, @_); +} # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { $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' || $^O eq 'msdos' || $^O eq 'amigaos'; + if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; + +# Set dont_use_nlink in your hint file if your system's stat doesn't +# report the number of links in a directory as an indication +# of the number of files. +# See, e.g. hints/machten.sh for MachTen 2.2. +unless ($dont_use_nlink) { + require Config; + $dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +} 1; diff --git a/gnu/usr.bin/perl/lib/File/Path.pm b/gnu/usr.bin/perl/lib/File/Path.pm index 43856dfe7b9..225ecab4b61 100644 --- a/gnu/usr.bin/perl/lib/File/Path.pm +++ b/gnu/usr.bin/perl/lib/File/Path.pm @@ -88,11 +88,11 @@ in situations where security is an issue. =head1 AUTHORS Tim Bunce <F<Tim.Bunce@ig.co.uk>> and -Charles Bailey <F<bailey@genetics.upenn.edu>> +Charles Bailey <F<bailey@newman.upenn.edu>> =head1 REVISION -Current $VERSION is 1.04. +Current $VERSION is 1.0401. =cut @@ -103,7 +103,7 @@ use Exporter (); use strict; use vars qw( $VERSION @ISA @EXPORT ); -$VERSION = "1.04"; +$VERSION = "1.0401"; @ISA = qw( Exporter ); @EXPORT = qw( mkpath rmtree ); @@ -111,7 +111,7 @@ 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' +my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || $^O eq 'amigaos'); sub mkpath { @@ -124,15 +124,20 @@ sub mkpath { $paths = [$paths] unless ref $paths; my(@created,$path); foreach $path (@$paths) { + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:$/; # feature of CRT next if -d $path; # Logic wants Unix paths, so go with the flow. $path = VMS::Filespec::unixify($path) if $Is_VMS; my $parent = File::Basename::dirname($path); - push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + # Allow for creation of new logical filesystems under VMS + if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { + push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { - # allow for another process to have created it meanwhile - croak "mkdir $path: $!" unless -d $path; + my $e = $!; + # allow for another process to have created it meanwhile + croak "mkdir $path: $e" unless -d $path; } push(@created, $path); } @@ -202,18 +207,18 @@ sub rmtree { if $force_writeable; print "unlink $root\n" if $verbose; # delete all versions under VMS - while (-e $root || -l $root) { - if (unlink $root) { - ++$count; - } - else { + for (;;) { + unless (unlink $root) { 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"); } + last; } + ++$count; + last unless $Is_VMS && lstat $root; } } } diff --git a/gnu/usr.bin/perl/lib/FileHandle.pm b/gnu/usr.bin/perl/lib/FileHandle.pm index 455fc63917d..eec9b61f31b 100644 --- a/gnu/usr.bin/perl/lib/FileHandle.pm +++ b/gnu/usr.bin/perl/lib/FileHandle.pm @@ -112,7 +112,7 @@ FileHandle - supply object methods for filehandles use FileHandle; $fh = new FileHandle; - if ($fh->open "< file") { + if ($fh->open("< file")) { print <$fh>; $fh->close; } @@ -249,6 +249,10 @@ It will also croak() if accidentally called in a scalar context. =back +There are many other functions available since FileHandle is descended +from IO::File, IO::Seekable, and IO::Handle. Please see those +respective pages for documentation on more functions. + =head1 SEE ALSO The B<IO> extension, diff --git a/gnu/usr.bin/perl/lib/FindBin.pm b/gnu/usr.bin/perl/lib/FindBin.pm index 918775cda7f..9e1c0a06bf2 100644 --- a/gnu/usr.bin/perl/lib/FindBin.pm +++ b/gnu/usr.bin/perl/lib/FindBin.pm @@ -55,7 +55,10 @@ Workaround is to invoke perl as =head1 AUTHORS -Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> +FindBin is supported as part of the core perl distribution. Please send bug +reports to E<lt>F<perlbug@perl.org>E<gt> using the perlbug program included with perl. + +Graham Barr E<lt>F<gbarr@pobox.com>E<gt> Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt> =head1 COPYRIGHT @@ -64,10 +67,6 @@ Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=head1 REVISION - -$Revision: 1.4 $ - =cut package FindBin; @@ -77,31 +76,13 @@ require Exporter; use Cwd qw(getcwd abs_path); use Config; use File::Basename; +use File::Spec; @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir); %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); @ISA = qw(Exporter); -$VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); - -sub is_abs_path -{ - local $_ = shift if (@_); - if ($^O eq 'MSWin32') - { - return m#^[a-z]:[\\/]#i; - } - elsif ($^O eq 'VMS') - { - # If it's a logical name, expand it. - $_ = $ENV{$_} while /^[\w\$\-]+$/ and $ENV{$_}; - return m!^/! or m![<\[][^.\-\]>]! or /:[^<\[]/; - } - else - { - return m#^/#; - } -} +$VERSION = $VERSION = "1.42"; BEGIN { @@ -131,13 +112,12 @@ BEGIN && -f $script) { my $dir; - my $pathvar = ($IsWin32) ? 'Path' : 'PATH'; - - foreach $dir (split(/$Config{'path_sep'}/,$ENV{$pathvar})) + foreach $dir (File::Spec->path) { - if(-r "$dir/$script" && (!$IsWin32 || -x _)) + my $scr = File::Spec->catfile($dir, $script); + if(-r $scr && (!$IsWin32 || -x _)) { - $script = "$dir/$script"; + $script = $scr; if (-f $0) { @@ -160,7 +140,8 @@ BEGIN # Ensure $script contains the complete path incase we C<chdir> - $script = getcwd() . "/" . $script unless is_abs_path($script); + $script = File::Spec->catfile(getcwd(), $script) + unless File::Spec->file_name_is_absolute($script); ($Script,$Bin) = fileparse($script); @@ -172,9 +153,9 @@ BEGIN ($RealScript,$RealBin) = fileparse($script); last unless defined $linktext; - $script = (is_abs_path($linktext)) + $script = (File::Spec->file_name_is_absolute($linktext)) ? $linktext - : $RealBin . "/" . $linktext; + : File::Spec->catfile($RealBin, $linktext); } # Get absolute paths to directories diff --git a/gnu/usr.bin/perl/lib/Getopt/Long.pm b/gnu/usr.bin/perl/lib/Getopt/Long.pm index 4f23f5d6c13..e9a8f1a1cc8 100644 --- a/gnu/usr.bin/perl/lib/Getopt/Long.pm +++ b/gnu/usr.bin/perl/lib/Getopt/Long.pm @@ -2,508 +2,17 @@ package Getopt::Long; -# RCS Status : $Id: Long.pm,v 1.2 1997/11/30 07:57:41 millert Exp $ +# RCS Status : $Id: Long.pm,v 1.3 1999/04/29 22:51:55 millert Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Wed Sep 17 12:20:10 1997 -# Update Count : 608 +# Last Modified On: Fri Jan 8 14:48:43 1999 +# Update Count : 707 # Status : Released -=head1 NAME - -GetOptions - extended processing of command line options - -=head1 SYNOPSIS - - use Getopt::Long; - $result = GetOptions (...option-descriptions...); - -=head1 DESCRIPTION - -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 "--". 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 - -which means the combination of B<-v>, B<-a> and B<-x>. With the new -syntax B<--vax> would be a single option, probably indicating a -computer architecture. - -Command line options can be used to set values. These values can be -specified in one of two ways: - - --size 24 - --size=24 - -GetOptions is called with a list of option-descriptions, each of which -consists of two elements: the option specifier and the option linkage. -The option specifier defines the name of the option and, optionally, -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); - -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, 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"); - -Linkage may be specified using either of the above methods, or both. -Linkage specified in the argument list takes precedence over the -linkage specified in the HASH. - -The command line options are taken from array @ARGV. Upon completion -of GetOptions, @ARGV will contain the rest (i.e. the non-options) of -the command line. - -Each option specifier designates the name of the option, optionally -followed by an argument specifier. Values for argument specifiers are: - -=over 8 - -=item E<lt>noneE<gt> - -Option does not take an argument. -The option variable will be set to 1. - -=item ! - -Option does not take an argument and may be negated, i.e. prefixed by -"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo> -(with value 0). -The option variable will be set to 1, or 0 if negated. - -=item =s - -Option takes a mandatory string argument. -This string will be assigned to the option variable. -Note that even if the string argument starts with B<-> or B<-->, it -will not be considered an option on itself. - -=item :s - -Option takes an optional string argument. -This string will be assigned to the option variable. -If omitted, it will be assigned "" (an empty string). -If the string argument starts with B<-> or B<-->, it -will be considered an option on itself. - -=item =i - -Option takes a mandatory integer argument. -This value will be assigned to the option variable. -Note that the value may start with B<-> to indicate a negative -value. - -=item :i - -Option takes an optional integer argument. -This value will be assigned to the option variable. -If omitted, the value 0 will be assigned. -Note that the value may start with B<-> to indicate a negative -value. - -=item =f - -Option takes a mandatory real number argument. -This value will be assigned to the option variable. -Note that the value may start with B<-> to indicate a negative -value. - -=item :f - -Option takes an optional real number argument. -This value will be assigned to the option variable. -If omitted, the value 0 will be assigned. - -=back - -A lone dash B<-> is considered an option, the corresponding option -name is the empty string. - -A double dash on itself B<--> signals end of the options list. - -=head2 Linkage specification - -The linkage specifier is optional. If no linkage is explicitly -specified but a ref HASH is passed, GetOptions will place the value in -the HASH. For example: - - %optctl = (); - GetOptions (\%optctl, "size=i"); - -will perform the equivalent of the assignment - - $optctl{"size"} = 24; - -For array options, a reference to an array is used, e.g.: - - %optctl = (); - 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, -characters that are not part of the syntax for variables are -translated to underscores. For example, "--fpp-struct-return" will set -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@"); - -with command line "-size 10 -sizes 24 -sizes 48" will perform the -equivalent of the assignments - - $opt_size = 10; - @opt_sizes = (24, 48); - -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, 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 -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. - -=head2 Aliases and abbreviations - -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 -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 option B<auto_abbrev>. - -=head2 Non-option call-back routine - -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 configuration option B<permute>, see section -CONFIGURATION OPTIONS. - -See also the examples. - -=head2 Option starters - -On the command line, options can start with B<-> (traditional), B<--> -(POSIX) and B<+> (GNU, now being phased out). The latter is not -allowed if the environment variable B<POSIXLY_CORRECT> has been -defined. - -Options that start with "--" may have an argument appended, separated -with an "=", e.g. "--foo=bar". - -=head2 Return value - -A return status of 0 (false) indicates that the function detected -one or more errors. - -=head1 COMPATIBILITY - -Getopt::Long::GetOptions() is the successor of -B<newgetopt.pl> that came with Perl 4. It is fully upward compatible. -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. If explicit linkage is supplied, this must be a reference -to an ARRAY. - -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 -characters. Everything starting with one of these characters from the -starter will be considered an option. B<Using a starter argument is -strongly deprecated.> - -For convenience, option specifiers may have a leading B<-> or B<-->, -so it is possible to write: - - GetOptions qw(-foo=s --bar=i --ar=s); - -=head1 EXAMPLES - -If the option specifier is "one:i" (i.e. takes an optional integer -argument), then the following situations are handled: - - -one -two -> $opt_one = '', -two is next option - -one -2 -> $opt_one = -2 - -Also, assume specifiers "foo=s" and "bar:s" : - - -bar -xxx -> $opt_bar = '', '-xxx' is next option - -foo -bar -> $opt_foo = '-bar' - -foo -- -> $opt_foo = '--' - -In GNU or POSIX format, option names and values can be combined: - - +foo=blech -> $opt_foo = 'blech' - --bar= -> $opt_bar = '' - --bar=-- -> $opt_bar = '--' - -Example of using variable references: - - $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: - - $foo = 'blech' - $opt_bar = 24 - @ar = ('xx','yy') - -Example of using the E<lt>E<gt> option specifier: - - @ARGV = qw(-foo 1 bar -foo 2 blech); - GetOptions("foo=i", \$myfoo, "<>", \&mysub); - -Results: - - 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); - -This will leave the non-options in @ARGV: - - $myfoo -> 2 - @ARGV -> qw(bar blech) - -=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 options are available: - -=over 12 - -=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 set unless environment variable -POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset. - -=item getopt_compat - -Allow '+' to start options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset. - -=item require_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 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>. - -If B<permute> is set, this means that - - -foo arg1 -bar arg2 arg3 - -is equivalent to - - -foo -bar arg1 arg2 arg3 - -If a non-option call-back routine is specified, @ARGV will always be -empty upon succesful return of GetOptions since all options have been -processed, except when B<--> is used: - - -foo arg1 -bar arg2 -- arg3 - -will call the call-back routine for arg1 and arg2, and terminate -leaving arg2 in @ARGV. - -If B<require_order> is set, options processing -terminates when the first non-option is encountered. - - -foo arg1 -bar arg2 arg3 - -is equivalent to - - -foo -- arg1 -bar arg2 arg3 - -=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 - -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 - -=head1 OTHER USEFUL VARIABLES - -=over 12 - -=item $Getopt::Long::VERSION - -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 3.00; - -You can inspect $Getopt::Long::major_version and -$Getopt::Long::minor_version for the individual components. - -=item $Getopt::Long::error - -Internal error flag. May be incremented from a call-back routine to -cause options parsing to fail. - -=back - -=cut - ################ Copyright ################ -# This program is Copyright 1990,1997 by Johan Vromans. +# This program is Copyright 1990,1999 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 @@ -523,72 +32,124 @@ cause options parsing to fail. use strict; BEGIN { - require 5.003; + require 5.004; use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/); - - @ISA = qw(Exporter); - @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); - %EXPORT_TAGS = (); - @EXPORT_OK = qw(); + use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + $VERSION = "2.19"; + + @ISA = qw(Exporter); + @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); + %EXPORT_TAGS = qw(); + @EXPORT_OK = qw(); + use AutoLoader qw(AUTOLOAD); } -use vars @EXPORT, @EXPORT_OK; # User visible variables. +use vars @EXPORT, @EXPORT_OK; use vars qw($error $debug $major_version $minor_version); # Deprecated visible variables. use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order $passthrough); +# Official invisible variables. +use vars qw($genprefix); + +# Public subroutines. +sub Configure (@); +sub config (@); # deprecated name +sub GetOptions; + +# Private subroutines. +sub ConfigDefaults (); +sub FindOption ($$$$$$$); +sub Croak (@); # demand loading the real Croak ################ 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 ################ +################ Resident subroutines ################ + +sub ConfigDefaults () { + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $genprefix = "(--|-)"; + $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 { + $genprefix = "(--|-|\\+)"; + $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 +} + +################ 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. +ConfigDefaults (); + +################ Package return ################ + +1; + +__END__ + +################ AutoLoading subroutines ################ + +# RCS Status : $Id: Long.pm,v 1.3 1999/04/29 22:51:55 millert Exp $ +# Author : Johan Vromans +# Created On : Fri Mar 27 11:50:30 1998 +# Last Modified By: Johan Vromans +# Last Modified On: Sun Jun 14 13:54:35 1998 +# Update Count : 24 +# Status : Released sub GetOptions { my @optionlist = @_; # local copy of the option descriptions - $argend = '--'; # option list terminator - %opctl = (); # table of arg.specs (long and abbrevs) - %bopctl = (); # table of arg.specs (bundles) - $pkg = (caller)[0]; # current context + my $argend = '--'; # option list terminator + my %opctl = (); # table of arg.specs (long and abbrevs) + my %bopctl = (); # table of arg.specs (bundles) + my $pkg = (caller)[0]; # current context # Needed if linkage is omitted. - %aliases= (); # alias table + my %aliases= (); # alias table my @ret = (); # accum for non-options my %linkage; # linkage my $userlinkage; # user supplied HASH - $genprefix = $gen_prefix; # so we can call the same module many times - $error = 0; - - print STDERR ('GetOptions $Revision: 1.2 $ ', - "[GetOpt::Long $Getopt::Long::VERSION] -- ", - "called from package \"$pkg\".\n", - " (@ARGV)\n", - " autoabbrev=$autoabbrev". - ",bundling=$bundling", - ",getopt_compat=$getopt_compat", - ",order=$order", - ",\n ignorecase=$ignorecase", - ",passthrough=$passthrough", - ",genprefix=\"$genprefix\"", - ".\n") + my $opt; # current option + my $genprefix = $genprefix; # so we can call the same module many times + my @opctl; # the possible long option names + + $error = ''; + + print STDERR ("GetOpt::Long $Getopt::Long::VERSION ", + "called from package \"$pkg\".", + "\n ", + 'GetOptionsAl $Revision: 1.3 $ ', + "\n ", + "ARGV: (@ARGV)", + "\n ", + "autoabbrev=$autoabbrev,". + "bundling=$bundling,", + "getopt_compat=$getopt_compat,", + "order=$order,", + "\n ", + "ignorecase=$ignorecase,", + "passthrough=$passthrough,", + "genprefix=\"$genprefix\".", + "\n") if $debug; # Check for ref HASH as first argument. @@ -605,9 +166,9 @@ sub GetOptions { # starter characters. if ( $optionlist[0] =~ /^\W+$/ ) { $genprefix = shift (@optionlist); - # Turn into regexp. + # Turn into regexp. Needs to be parenthesized! $genprefix =~ s/(\W)/\\$1/g; - $genprefix = "[" . $genprefix . "]"; + $genprefix = "([" . $genprefix . "])"; } # Verify correctness of optionlist. @@ -617,7 +178,7 @@ sub GetOptions { my $opt = shift (@optionlist); # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $' if $opt =~ /^($genprefix)+/; + $opt = $+ if $opt =~ /^$genprefix+(.*)$/s; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -628,20 +189,19 @@ sub GetOptions { } unless ( @optionlist > 0 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { - warn ("Option spec <> requires a reference to a subroutine\n"); - $error++; + $error .= "Option spec <> requires a reference to a subroutine\n"; next; } $linkage{'<>'} = shift (@optionlist); next; } - if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) { - warn ("Error in option spec: \"", $opt, "\"\n"); - $error++; + # Match option spec. Allow '?' as an alias. + if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) { + $error .= "Error in option spec: \"$opt\"\n"; next; } - my ($o, $c, $a) = ($1, $2); + my ($o, $c, $a) = ($1, $5); $c = '' unless defined $c; if ( ! defined $o ) { @@ -718,18 +278,19 @@ sub GetOptions { $opctl{$o} .= '@' if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/; $bopctl{$o} .= '@' - if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; + if $bundling and defined $bopctl{$o} 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} !~ /\%$/; + if $bundling and defined $bopctl{$o} and + $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/; } else { - warn ("Invalid option linkage for \"", $opt, "\"\n"); - $error++; + $error .= "Invalid option linkage for \"$opt\"\n"; } } else { @@ -756,7 +317,8 @@ sub GetOptions { } # Bail out if errors found. - return 0 if $error; + die ($error) if $error; + $error = 0; # Sort the possible long option names. @opctl = sort(keys (%opctl)) if $autoabbrev; @@ -782,8 +344,6 @@ sub GetOptions { #### Get next argument #### $opt = shift (@ARGV); - $arg = undef; - $array = $hash = 0; print STDERR ("=> option \"", $opt, "\"\n") if $debug; #### Determine what we have #### @@ -797,11 +357,19 @@ sub GetOptions { } my $tryopt = $opt; + my $found; # success status + my $dsttype; # destination type ('@' or '%') + my $incr; # destination increment + my $key; # key (if hash type) + my $arg; # option argument - # find_option operates on the GLOBAL $opt and $arg! - if ( &$find_option () ) { + ($found, $opt, $arg, $dsttype, $incr, $key) = + FindOption ($genprefix, $argend, $opt, + \%opctl, \%bopctl, \@opctl, \%aliases); + + if ( $found ) { - # find_option undefines $opt in case of errors. + # FindOption undefines $opt in case of errors. next unless defined $opt; if ( defined $arg ) { @@ -812,8 +380,21 @@ sub GetOptions { ref($linkage{$opt}), "\n") if $debug; if ( ref($linkage{$opt}) eq 'SCALAR' ) { - print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug; - ${$linkage{$opt}} = $arg; + if ( $incr ) { + print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") + if $debug; + if ( defined ${$linkage{$opt}} ) { + ${$linkage{$opt}} += $arg; + } + else { + ${$linkage{$opt}} = $arg; + } + } + else { + print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") + if $debug; + ${$linkage{$opt}} = $arg; + } } elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") @@ -833,11 +414,11 @@ sub GetOptions { else { print STDERR ("Invalid REF type \"", ref($linkage{$opt}), "\" in linkage\n"); - die ("Getopt::Long -- internal error!\n"); + Croak ("Getopt::Long -- internal error!\n"); } } # No entry in linkage means entry in userlinkage. - elsif ( $array ) { + elsif ( $dsttype eq '@' ) { if ( defined $userlinkage->{$opt} ) { print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") if $debug; @@ -849,7 +430,7 @@ sub GetOptions { $userlinkage->{$opt} = [$arg]; } } - elsif ( $hash ) { + elsif ( $dsttype eq '%' ) { if ( defined $userlinkage->{$opt} ) { print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") if $debug; @@ -862,8 +443,20 @@ sub GetOptions { } } else { - print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; - $userlinkage->{$opt} = $arg; + if ( $incr ) { + print STDERR ("=> \$L{$opt} += \"$arg\"\n") + if $debug; + if ( defined $userlinkage->{$opt} ) { + $userlinkage->{$opt} += $arg; + } + else { + $userlinkage->{$opt} = $arg; + } + } + else { + print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; + $userlinkage->{$opt} = $arg; + } } } } @@ -873,7 +466,7 @@ sub GetOptions { # Try non-options call-back. my $cb; if ( (defined ($cb = $linkage{'<>'})) ) { - &$cb($tryopt); + &$cb ($tryopt); } else { print STDERR ("=> saving \"$tryopt\" ", @@ -903,92 +496,33 @@ sub GetOptions { return ($error == 0); } -sub config (@) { - my (@options) = @_; - my $opt; - foreach $opt ( @options ) { - my $try = lc ($opt); - my $action = 1; - if ( $try =~ /^no_?/ ) { - $action = 0; - $try = $'; - } - if ( $try eq 'default' or $try eq 'defaults' ) { - &$config_defaults () if $action; - } - 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\"") - } - } -} +# Option lookup. +sub FindOption ($$$$$$$) { -# 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; -} + # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay, + # returns (0) otherwise. + + my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_; + my $key; # hash key for a hash option + my $arg; -################ Private Subroutines ################ + print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug; -$find_option = sub { + return (0) unless $opt =~ /^$prefix(.*)$/s; - return 0 unless $opt =~ /^$genprefix/; + $opt = $+; + my ($starter) = $1; - $opt = $'; - my ($starter) = $&; + print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; my $optarg = undef; # value supplied with --opt=value my $rest = undef; # remainder from unbundling # If it is a long option, it may include the value. - if (($starter eq "--" || $getopt_compat) - && $opt =~ /^([^=]+)=/ ) { + if (($starter eq "--" || ($getopt_compat && !$bundling)) + && $opt =~ /^([^=]+)=(.*)$/s ) { $opt = $1; - $optarg = $'; + $optarg = $2; print STDERR ("=> option \"", $opt, "\", optarg = \"$optarg\"\n") if $debug; } @@ -996,8 +530,10 @@ $find_option = sub { #### Look it up ### my $tryopt = $opt; # option to try - my $optbl = \%opctl; # table to look it up (long names) + my $optbl = $opctl; # table to look it up (long names) my $type; + my $dsttype = ''; + my $incr = 0; if ( $bundling && $starter eq '-' ) { # Unbundle single letter option. @@ -1007,11 +543,12 @@ $find_option = sub { 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 + $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}) ) { + defined ($rest) and + defined ($type = $opctl->{$tryopt.$rest}) ) { print STDERR ("=> $starter$tryopt rebundled to ", "$starter$tryopt$rest\n") if $debug; $tryopt .= $rest; @@ -1026,26 +563,26 @@ $find_option = sub { # Turn option name into pattern. my $pat = quotemeta ($opt); # Look up in option names. - my @hits = grep (/^$pat/, @opctl); + my @hits = grep (/^$pat/, @{$names}); print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", - "out of ", scalar(@opctl), "\n") if $debug; + "out of ", scalar(@{$names}), "\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{$_}; + $_ = $aliases->{$_} if defined $aliases->{$_}; $hit{$_} = 1; } # Now see if it really is ambiguous. unless ( keys(%hit) == 1 ) { - return 0 if $passthrough; - print STDERR ("Option ", $opt, " is ambiguous (", - join(", ", @hits), ")\n"); + return (0) if $passthrough; + warn ("Option ", $opt, " is ambiguous (", + join(", ", @hits), ")\n"); $error++; undef $opt; - return 1; + return (1, $opt,$arg,$dsttype,$incr,$key); } @hits = keys(%hit); } @@ -1067,10 +604,10 @@ $find_option = sub { # Check validity by fetching the info. $type = $optbl->{$tryopt} unless defined $type; unless ( defined $type ) { - return 0 if $passthrough; + return (0) if $passthrough; warn ("Unknown option: ", $opt, "\n"); $error++; - return 1; + return (1, $opt,$arg,$dsttype,$incr,$key); } # Apparently valid. $opt = $tryopt; @@ -1079,42 +616,43 @@ $find_option = sub { #### Determine argument status #### # If it is an option w/o argument, we're almost finished with it. - if ( $type eq '' || $type eq '!' ) { + if ( $type eq '' || $type eq '!' || $type eq '+' ) { if ( defined $optarg ) { - return 0 if $passthrough; - print STDERR ("Option ", $opt, " does not take an argument\n"); + return (0) if $passthrough; + warn ("Option ", $opt, " does not take an argument\n"); $error++; undef $opt; } - elsif ( $type eq '' ) { + elsif ( $type eq '' || $type eq '+' ) { $arg = 1; # supply explicit value + $incr = $type eq '+'; } else { substr ($opt, 0, 2) = ''; # strip NO prefix $arg = 0; # supply explicit value } unshift (@ARGV, $starter.$rest) if defined $rest; - return 1; + return (1, $opt,$arg,$dsttype,$incr,$key); } # Get mandatory status and type info. my $mand; - ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/; + ($mand, $type, $dsttype, $key) = $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"); + return (0) if $passthrough; + warn ("Option ", $opt, " requires an argument\n"); $error++; undef $opt; } if ( $mand eq ":" ) { $arg = $type eq "s" ? '' : 0; } - return 1; + return (1, $opt,$arg,$dsttype,$incr,$key); } # Get (possibly optional) argument. @@ -1123,23 +661,24 @@ $find_option = sub { # Get key if this is a "name=value" pair for a hash option. $key = undef; - if ($hash && defined $arg) { - ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1); + if ($dsttype eq '%' && defined $arg) { + ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1); } #### Check if the argument is valid for this option #### if ( $type eq "s" ) { # string # A mandatory string takes anything. - return 1 if $mand eq "="; + return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "="; # An optional string takes almost anything. - return 1 if defined $optarg || defined $rest; - return 1 if $arg eq "-"; # ?? + return (1, $opt,$arg,$dsttype,$incr,$key) + if defined $optarg || defined $rest; + return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ?? # Check for option or option list terminator. if ($arg eq $argend || - $arg =~ /^$genprefix.+/) { + $arg =~ /^$prefix.+/) { # Push back. unshift (@ARGV, $arg); # Supply empty value. @@ -1148,15 +687,20 @@ $find_option = sub { } elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $arg !~ /^-?[0-9]+$/ ) { + if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) { + $arg = $1; + $rest = $2; + unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg !~ /^-?[0-9]+$/ ) { if ( defined $optarg || $mand eq "=" ) { if ( $passthrough ) { unshift (@ARGV, defined $rest ? $starter.$rest : $arg) unless defined $optarg; - return 0; + return (0); } - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (number expected)\n"); + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (number expected)\n"); $error++; undef $opt; # Push back. @@ -1172,15 +716,24 @@ $find_option = sub { } elsif ( $type eq "f" ) { # real number, int is also ok - if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) { + # We require at least one digit before a point or 'e', + # and at least one digit following the point and 'e'. + # [-]NN[.NN][eNN] + if ( $bundling && defined $rest && + $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) { + $arg = $1; + $rest = $+; + unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) { if ( defined $optarg || $mand eq "=" ) { if ( $passthrough ) { unshift (@ARGV, defined $rest ? $starter.$rest : $arg) unless defined $optarg; - return 0; + return (0); } - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (real number expected)\n"); + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); $error++; undef $opt; # Push back. @@ -1195,44 +748,635 @@ $find_option = sub { } } else { - die ("GetOpt::Long internal error (Can't happen)\n"); + Croak ("GetOpt::Long internal error (Can't happen)\n"); } - return 1; -}; + return (1, $opt, $arg, $dsttype, $incr, $key); +} -$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; +# Getopt::Long Configuration. +sub Configure (@) { + my (@options) = @_; + my $opt; + foreach $opt ( @options ) { + my $try = lc ($opt); + my $action = 1; + if ( $try =~ /^no_?(.*)$/s ) { + $action = 0; + $try = $+; + } + if ( $try eq 'default' or $try eq 'defaults' ) { + ConfigDefaults () if $action; + } + 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 =~ /^prefix=(.+)$/ ) { + $genprefix = $1; + # Turn into regexp. Needs to be parenthesized! + $genprefix = "(" . quotemeta($genprefix) . ")"; + eval { '' =~ /$genprefix/; }; + Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@; + } + elsif ( $try =~ /^prefix_pattern=(.+)$/ ) { + $genprefix = $1; + # Parenthesize if needed. + $genprefix = "(" . $genprefix . ")" + unless $genprefix =~ /^\(.*\)$/; + eval { '' =~ /$genprefix/; }; + Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@; + } + elsif ( $try eq 'debug' ) { + $debug = $action; + } + else { + Croak ("Getopt::Long: unknown config parameter \"$opt\"") + } } - # Other configurable settings. - $debug = 0; # for debugging - $error = 0; # error tally - $ignorecase = 1; # ignore case when matching options - $passthrough = 0; # leave unrecognized options alone +} + +# Deprecated name. +sub config (@) { + Configure (@_); +} + +# To prevent Carp from being loaded unnecessarily. +sub Croak (@) { + require 'Carp.pm'; + $Carp::CarpLevel = 1; + Carp::croak(@_); }; -################ Initialization ################ +################ Documentation ################ -# 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+)/; +=head1 NAME -# Set defaults. -&$config_defaults (); +GetOptions - extended processing of command line options -################ Package return ################ +=head1 SYNOPSIS -1; + use Getopt::Long; + $result = GetOptions (...option-descriptions...); + +=head1 DESCRIPTION + +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 "--". 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 + +which means the combination of B<-v>, B<-a> and B<-x>. With the new +syntax B<--vax> would be a single option, probably indicating a +computer architecture. + +Command line options can be used to set values. These values can be +specified in one of two ways: + + --size 24 + --size=24 + +GetOptions is called with a list of option-descriptions, each of which +consists of two elements: the option specifier and the option linkage. +The option specifier defines the name of the option and, optionally, +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); + +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, 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"); + +Linkage may be specified using either of the above methods, or both. +Linkage specified in the argument list takes precedence over the +linkage specified in the HASH. + +The command line options are taken from array @ARGV. Upon completion +of GetOptions, @ARGV will contain the rest (i.e. the non-options) of +the command line. + +Each option specifier designates the name of the option, optionally +followed by an argument specifier. + +Options that do not take arguments will have no argument specifier. +The option variable will be set to 1 if the option is used. + +For the other options, the values for argument specifiers are: + +=over 8 + +=item ! + +Option does not take an argument and may be negated, i.e. prefixed by +"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo> +(with value 0). +The option variable will be set to 1, or 0 if negated. + +=item + + +Option does not take an argument and will be incremented by 1 every +time it appears on the command line. E.g. "more+", when used with +B<--more --more --more>, will set the option variable to 3 (provided +it was 0 or undefined at first). + +The B<+> specifier is ignored if the option destination is not a SCALAR. + +=item =s + +Option takes a mandatory string argument. +This string will be assigned to the option variable. +Note that even if the string argument starts with B<-> or B<-->, it +will not be considered an option on itself. + +=item :s + +Option takes an optional string argument. +This string will be assigned to the option variable. +If omitted, it will be assigned "" (an empty string). +If the string argument starts with B<-> or B<-->, it +will be considered an option on itself. + +=item =i + +Option takes a mandatory integer argument. +This value will be assigned to the option variable. +Note that the value may start with B<-> to indicate a negative +value. + +=item :i + +Option takes an optional integer argument. +This value will be assigned to the option variable. +If omitted, the value 0 will be assigned. +Note that the value may start with B<-> to indicate a negative +value. + +=item =f + +Option takes a mandatory real number argument. +This value will be assigned to the option variable. +Note that the value may start with B<-> to indicate a negative +value. + +=item :f + +Option takes an optional real number argument. +This value will be assigned to the option variable. +If omitted, the value 0 will be assigned. + +=back + +A lone dash B<-> is considered an option, the corresponding option +name is the empty string. + +A double dash on itself B<--> signals end of the options list. + +=head2 Linkage specification + +The linkage specifier is optional. If no linkage is explicitly +specified but a ref HASH is passed, GetOptions will place the value in +the HASH. For example: + + %optctl = (); + GetOptions (\%optctl, "size=i"); + +will perform the equivalent of the assignment + + $optctl{"size"} = 24; + +For array options, a reference to an array is used, e.g.: + + %optctl = (); + 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, +characters that are not part of the syntax for variables are +translated to underscores. For example, "--fpp-struct-return" will set +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@"); + +with command line "-size 10 -sizes 24 -sizes 48" will perform the +equivalent of the assignments + + $opt_size = 10; + @opt_sizes = (24, 48); + +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, a reference to a hash or a reference to a subroutine. + +Note that, if your code is running under the recommended C<use strict +'vars'> pragma, it may be helpful to declare these package variables +via C<use vars> perhaps something like this: + + use vars qw/ $opt_size @opt_sizes $opt_bar /; + +If a REF SCALAR is supplied, the new value is stored in the referenced +variable. If the option occurs more than once, the previous value is +overwritten. + +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. + +=head2 Aliases and abbreviations + +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 +of this option. If no linkage is specified, options "foo", "bar" and +"blech" all will set $opt_foo. For convenience, the single character +"?" is allowed as an alias, e.g. "help|?". + +Option names may be abbreviated to uniqueness, depending on +configuration option B<auto_abbrev>. + +=head2 Non-option call-back routine + +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 configuration option B<permute>, see section +CONFIGURATION OPTIONS. + +See also the examples. + +=head2 Option starters + +On the command line, options can start with B<-> (traditional), B<--> +(POSIX) and B<+> (GNU, now being phased out). The latter is not +allowed if the environment variable B<POSIXLY_CORRECT> has been +defined. + +Options that start with "--" may have an argument appended, separated +with an "=", e.g. "--foo=bar". + +=head2 Return values and Errors + +Configuration errors and errors in the option definitions are +signalled using C<die()> and will terminate the calling +program unless the call to C<Getopt::Long::GetOptions()> was embedded +in C<eval { ... }> or C<die()> was trapped using C<$SIG{__DIE__}>. + +A return value of 1 (true) indicates success. + +A return status of 0 (false) indicates that the function detected one +or more errors during option parsing. These errors are signalled using +C<warn()> and can be trapped with C<$SIG{__WARN__}>. + +Errors that can't happen are signalled using C<Carp::croak()>. + +=head1 COMPATIBILITY + +Getopt::Long::GetOptions() is the successor of +B<newgetopt.pl> that came with Perl 4. It is fully upward compatible. +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. If explicit linkage is supplied, this must be a reference +to an ARRAY. + +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 +characters. Everything starting with one of these characters from the +starter will be considered an option. B<Using a starter argument is +strongly deprecated.> + +For convenience, option specifiers may have a leading B<-> or B<-->, +so it is possible to write: + + GetOptions qw(-foo=s --bar=i --ar=s); + +=head1 EXAMPLES + +If the option specifier is "one:i" (i.e. takes an optional integer +argument), then the following situations are handled: + + -one -two -> $opt_one = '', -two is next option + -one -2 -> $opt_one = -2 + +Also, assume specifiers "foo=s" and "bar:s" : + + -bar -xxx -> $opt_bar = '', '-xxx' is next option + -foo -bar -> $opt_foo = '-bar' + -foo -- -> $opt_foo = '--' + +In GNU or POSIX format, option names and values can be combined: + + +foo=blech -> $opt_foo = 'blech' + --bar= -> $opt_bar = '' + --bar=-- -> $opt_bar = '--' + +Example of using variable references: + + $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: + + $foo = 'blech' + $opt_bar = 24 + @ar = ('xx','yy') + +Example of using the E<lt>E<gt> option specifier: + + @ARGV = qw(-foo 1 bar -foo 2 blech); + GetOptions("foo=i", \$myfoo, "<>", \&mysub); + +Results: + + 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); + +This will leave the non-options in @ARGV: + + $myfoo -> 2 + @ARGV -> qw(bar blech) + +=head1 CONFIGURATION OPTIONS + +B<GetOptions> can be configured by calling subroutine +B<Getopt::Long::Configure>. 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 options are available: + +=over 12 + +=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 set unless environment variable +POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset. + +=item getopt_compat + +Allow '+' to start options. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset. + +=item require_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 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>. + +If B<permute> is set, this means that + + -foo arg1 -bar arg2 arg3 + +is equivalent to + + -foo -bar arg1 arg2 arg3 + +If a non-option call-back routine is specified, @ARGV will always be +empty upon succesful return of GetOptions since all options have been +processed, except when B<--> is used: + + -foo arg1 -bar arg2 -- arg3 + +will call the call-back routine for arg1 and arg2, and terminate +leaving arg2 in @ARGV. + +If B<require_order> is set, options processing +terminates when the first non-option is encountered. + + -foo arg1 -bar arg2 arg3 + +is equivalent to + + -foo -- arg1 -bar arg2 arg3 + +=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 + +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; for strings +this value is the rest of the bundle, but integer and floating values +may be combined in the bundle, e.g. + + scale -h24w80 + +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 prefix + +The string that starts options. See also B<prefix_pattern>. + +=item prefix_pattern + +A Perl pattern that identifies the strings that introduce options. +Default is C<(--|-|\+)> unless environment variable +POSIXLY_CORRECT has been set, in which case it is C<(--|-)>. + +=item debug (default: reset) + +Enable copious debugging output. + +=back + +=head1 OTHER USEFUL VARIABLES + +=over 12 + +=item $Getopt::Long::VERSION + +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 3.00; + +You can inspect $Getopt::Long::major_version and +$Getopt::Long::minor_version for the individual components. + +=item $Getopt::Long::error + +Internal error flag. May be incremented from a call-back routine to +cause options parsing to fail. + +=back + +=head1 AUTHOR + +Johan Vromans E<lt>jvromans@squirrel.nlE<gt> + +=head1 COPYRIGHT AND DISCLAIMER + +This program is Copyright 1990,1999 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 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +If you do not have a copy of the GNU General Public License write to +the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +MA 02139, USA. + +=cut diff --git a/gnu/usr.bin/perl/lib/Getopt/Std.pm b/gnu/usr.bin/perl/lib/Getopt/Std.pm index 27882935f99..390bf14e96c 100644 --- a/gnu/usr.bin/perl/lib/Getopt/Std.pm +++ b/gnu/usr.bin/perl/lib/Getopt/Std.pm @@ -27,6 +27,12 @@ switch name) to the value of the argument, or 1 if no argument. Switches which take an argument don't care whether there is a space between the switch and the argument. +Note that, if your code is running under the recommended C<use strict +'vars'> pragma, it may be helpful to declare these package variables +via C<use vars> perhaps something like this: + + use vars qw/ $opt_foo $opt_bar /; + For those of you who don't like additional variables being created, getopt() and getopts() will also accept a hash reference as an optional second argument. Hash keys will be x (where x is the switch name) with key values the value of @@ -36,8 +42,7 @@ the argument or 1 if no argument is specified. @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); - -# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ +$VERSION = $VERSION = '1.01'; # Process single-character switches with switch clustering. Pass one argument # which is a string containing all switches that take an argument. For each @@ -51,7 +56,7 @@ the argument or 1 if no argument is specified. sub getopt ($;$) { local($argumentative, $hash) = @_; local($_,$first,$rest); - local $Exporter::ExportLevel; + local @EXPORT; while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); @@ -87,8 +92,10 @@ sub getopt ($;$) { } } } - $Exporter::ExportLevel++; - import Getopt::Std; + unless (ref $hash) { + local $Exporter::ExportLevel = 1; + import Getopt::Std; + } } # Usage: @@ -99,7 +106,7 @@ sub getopts ($;$) { local($argumentative, $hash) = @_; local(@args,$_,$first,$rest); local($errs) = 0; - local $Exporter::ExportLevel; + local @EXPORT; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { @@ -137,7 +144,7 @@ sub getopts ($;$) { } } else { - print STDERR "Unknown option: $first\n"; + warn "Unknown option: $first\n"; ++$errs; if($rest ne '') { $ARGV[0] = "-$rest"; @@ -147,8 +154,10 @@ sub getopts ($;$) { } } } - $Exporter::ExportLevel++; - import Getopt::Std; + unless (ref $hash) { + local $Exporter::ExportLevel = 1; + import Getopt::Std; + } $errs == 0; } diff --git a/gnu/usr.bin/perl/lib/IPC/Open3.pm b/gnu/usr.bin/perl/lib/IPC/Open3.pm index 5bae5057367..e1cf12f7068 100644 --- a/gnu/usr.bin/perl/lib/IPC/Open3.pm +++ b/gnu/usr.bin/perl/lib/IPC/Open3.pm @@ -2,15 +2,15 @@ package IPC::Open3; use strict; no strict 'refs'; # because users pass me bareword filehandles -use vars qw($VERSION @ISA @EXPORT $Fh $Me); +use vars qw($VERSION @ISA @EXPORT $Me); require 5.001; require Exporter; use Carp; -use Symbol 'qualify'; +use Symbol qw(gensym qualify); -$VERSION = 1.0101; +$VERSION = 1.0103; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -66,8 +66,9 @@ C<cat -v> and continually read and write a line from it. # &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> +# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career # -# $Id: Open3.pm,v 1.2 1997/11/30 07:57:45 millert Exp $ +# $Id: Open3.pm,v 1.3 1999/04/29 22:51:56 millert Exp $ # # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); # @@ -93,7 +94,6 @@ C<cat -v> and continually read and write a line from it. # rdr or wtr are null # a system call fails -$Fh = 'FHOPEN000'; # package static in case called more than once $Me = 'open3 (bug)'; # you should never see this, it's always localized # Fatal.pm needs to be fixed WRT prototypes. @@ -119,7 +119,7 @@ sub xclose { close $_[0] or croak "$Me: close($_[0]) failed: $!"; } -my $do_spawn = $^O eq 'os2'; +my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; sub _open3 { local $Me = shift; @@ -139,9 +139,9 @@ sub _open3 { $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 = gensym; + my $kid_wtr = gensym; + my $kid_err = gensym; xpipe $kid_rdr, $dad_wtr if !$dup_wtr; xpipe $dad_rdr, $kid_wtr if !$dup_rdr; @@ -153,7 +153,7 @@ sub _open3 { # 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; + my $tmp = gensym; xopen($tmp, ">&$dad_err"); $dad_err = $tmp; } @@ -162,54 +162,54 @@ sub _open3 { xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr); } else { xclose $dad_wtr; - xopen \*STDIN, "<&$kid_rdr"; - xclose $kid_rdr; + xopen \*STDIN, "<&=" . fileno $kid_rdr; } if ($dup_rdr) { xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr); } else { xclose $dad_rdr; - xopen \*STDOUT, ">&$kid_wtr"; - xclose $kid_wtr; + xopen \*STDOUT, ">&=" . fileno $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - xopen \*STDERR, ">&$dad_err" + # I have to use a fileno here because in this one case + # I'm doing a dup but the filehandle might be a reference + # (from the special case above). + xopen \*STDERR, ">&" . fileno $dad_err if fileno(STDERR) != fileno($dad_err); } else { xclose $dad_err; - xopen \*STDERR, ">&$kid_err"; - xclose $kid_err; + xopen \*STDERR, ">&=" . fileno $kid_err; } } else { xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT); } local($")=(" "); exec @cmd - or croak "open3: exec of @cmd failed"; + or croak "$Me: exec of @cmd failed"; } elsif ($do_spawn) { # All the bookkeeping of coincidence between handles is # handled in spawn_with_handles. my @close; if ($dup_wtr) { - $kid_rdr = $dad_wtr; - push @close, \*{$kid_rdr}; + $kid_rdr = \*{$dad_wtr}; + push @close, $kid_rdr; } else { - push @close, \*{$dad_wtr}, \*{$kid_rdr}; + push @close, \*{$dad_wtr}, $kid_rdr; } if ($dup_rdr) { - $kid_wtr = $dad_rdr; - push @close, \*{$kid_wtr}; + $kid_wtr = \*{$dad_rdr}; + push @close, $kid_wtr; } else { - push @close, \*{$dad_rdr}, \*{$kid_wtr}; + push @close, \*{$dad_rdr}, $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - $kid_err = $dad_err ; - push @close, \*{$kid_err}; + $kid_err = \*{$dad_err}; + push @close, $kid_err; } else { - push @close, \*{$dad_err}, \*{$kid_err}; + push @close, \*{$dad_err}, $kid_err; } } else { $kid_err = $kid_wtr; @@ -217,17 +217,17 @@ sub _open3 { require IO::Pipe; $kidpid = eval { spawn_with_handles( [ { mode => 'r', - open_as => \*{$kid_rdr}, + open_as => $kid_rdr, handle => \*STDIN }, { mode => 'w', - open_as => \*{$kid_wtr}, + open_as => $kid_wtr, handle => \*STDOUT }, { mode => 'w', - open_as => \*{$kid_err}, + open_as => $kid_err, handle => \*STDERR }, ], \@close, @cmd); }; - die "open3: $@" if $@; + die "$Me: $@" if $@; } xclose $kid_rdr if !$dup_wtr; @@ -267,10 +267,12 @@ sub spawn_with_handles { $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 ($^O eq 'MSWin32') { + # 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) { diff --git a/gnu/usr.bin/perl/lib/Math/BigInt.pm b/gnu/usr.bin/perl/lib/Math/BigInt.pm index 422dca42fd6..b61b8845693 100644 --- a/gnu/usr.bin/perl/lib/Math/BigInt.pm +++ b/gnu/usr.bin/perl/lib/Math/BigInt.pm @@ -36,6 +36,12 @@ sub stringify { "${$_[0]}" } sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead # comparing to direct compilation based on # stringify +sub import { + shift; + return unless @_; + die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant'; + overload::constant integer => sub {Math::BigInt->new(shift)}; +} $zero = 0; @@ -76,8 +82,8 @@ sub external { #(int_num_array) return num_str # Negate input value. sub bneg { #(num_str) return num_str local($_) = &bnorm(@_); - vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; - s/^H/N/; + return $_ if $_ eq '+0' or $_ eq 'NaN'; + vec($_,0,8) ^= ord('+') ^ ord('-'); $_; } @@ -100,7 +106,7 @@ sub bcmp { #(num_str, num_str) return cond_code } elsif ($y eq 'NaN') { undef; } else { - &cmp($x,$y); + &cmp($x,$y) <=> 0; } } @@ -171,7 +177,7 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; + $x -= 1e5 if $car = (($x += (@y ? shift(@y) : 0) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; @@ -185,8 +191,8 @@ sub sub { #(int_num_array, int_num_array) return int_num_array local(*sx, *sy) = @_; $bar = 0; for $sx (@sx) { - last unless @y || $bar; - $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); + last unless @sy || $bar; + $sx += 1e5 if $bar = (($sx -= (@sy ? shift(@sy) : 0) + $bar) < 0); } @sx; } @@ -252,9 +258,9 @@ sub bdiv { #(dividend: num_str, divisor: num_str) return num_str else { push(@x, 0); } - @q = (); ($v2,$v1) = @y[-2,-1]; + @q = (); ($v2,$v1) = ($y[-2] || 0, $y[-1]); while ($#x > $#y) { - ($u2,$u1,$u0) = @x[-3..-1]; + ($u2,$u1,$u0) = ($x[-3] || 0, $x[-2] || 0, $x[-1]); $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1)); --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2); if ($q) { @@ -384,6 +390,19 @@ are not numbers, as well as the result of dividing by zero. '1 23 456 7890' canonical value '+1234567890' +=head1 Autocreating constants + +After C<use Math::BigInt ':constant'> all the integer decimal constants +in the given scope are converted to C<Math::BigInt>. This conversion +happens at compile time. + +In particular + + perl -MMath::BigInt=:constant -e 'print 2**100' + +print the integer value of C<2**100>. Note that without conversion of +constants the expression 2**100 will be calculated as floating point number. + =head1 BUGS The current version of this module is a preliminary version of the diff --git a/gnu/usr.bin/perl/lib/Math/Complex.pm b/gnu/usr.bin/perl/lib/Math/Complex.pm index b3d7e6084f2..0db5966e5c9 100644 --- a/gnu/usr.bin/perl/lib/Math/Complex.pm +++ b/gnu/usr.bin/perl/lib/Math/Complex.pm @@ -1,23 +1,20 @@ # # Complex numbers and associated mathematical functions -# -- Raphael Manfredi September 1996 -# -- Jarkko Hietaniemi March-October 1997 -# -- Daniel S. Lewart September-October 1997 +# -- Raphael Manfredi Since Sep 1996 +# -- Jarkko Hietaniemi Since Mar 1997 +# -- Daniel S. Lewart Since Sep 1997 # require Exporter; package Math::Complex; -$VERSION = 1.05; +use strict; -# $Id: Complex.pm,v 1.2 1997/11/30 07:57:47 millert Exp $ +use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS); -use strict; +my ( $i, $ip2, %logn ); -use vars qw($VERSION @ISA - @EXPORT %EXPORT_TAGS - $package $display - $i $ip2 $logn %logn); +$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.3 1999/04/29 22:51:56 millert Exp $ =~ /(\d+\.\d+)/); @ISA = qw(Exporter); @@ -34,7 +31,7 @@ my @trig = qw( ); @EXPORT = (qw( - i Re Im arg + i Re Im rho theta arg sqrt log ln log10 logn cbrt root cplx cplxe @@ -65,11 +62,12 @@ use overload qw("" stringify); # -# Package globals +# Package "privates" # -$package = 'Math::Complex'; # Package name -$display = 'cartesian'; # Default display format +my $package = 'Math::Complex'; # Package name +my $display = 'cartesian'; # Default display format +my $eps = 1e-14; # Epsilon # # Object attributes (internal): @@ -80,6 +78,12 @@ $display = 'cartesian'; # Default display format # display display format (package's global when not set) # +# Die on bad *make() arguments. + +sub _cannot_make { + die "@{[(caller(1))[3]]}: Cannot take $_[0] of $_[1].\n"; +} + # # ->make # @@ -88,9 +92,26 @@ $display = 'cartesian'; # Default display format sub make { my $self = bless {}, shift; my ($re, $im) = @_; - $self->{'cartesian'} = [$re, $im]; + my $rre = ref $re; + if ( $rre ) { + if ( $rre eq ref $self ) { + $re = Re($re); + } else { + _cannot_make("real part", $rre); + } + } + my $rim = ref $im; + if ( $rim ) { + if ( $rim eq ref $self ) { + $im = Im($im); + } else { + _cannot_make("imaginary part", $rim); + } + } + $self->{'cartesian'} = [ $re, $im ]; $self->{c_dirty} = 0; $self->{p_dirty} = 1; + $self->display_format('cartesian'); return $self; } @@ -102,6 +123,22 @@ sub make { sub emake { my $self = bless {}, shift; my ($rho, $theta) = @_; + my $rrh = ref $rho; + if ( $rrh ) { + if ( $rrh eq ref $self ) { + $rho = rho($rho); + } else { + _cannot_make("rho", $rrh); + } + } + my $rth = ref $theta; + if ( $rth ) { + if ( $rth eq ref $self ) { + $theta = theta($theta); + } else { + _cannot_make("theta", $rth); + } + } if ($rho < 0) { $rho = -$rho; $theta = ($theta <= 0) ? $theta + pi() : $theta - pi(); @@ -109,6 +146,7 @@ sub emake { $self->{'polar'} = [$rho, $theta]; $self->{p_dirty} = 0; $self->{c_dirty} = 1; + $self->display_format('polar'); return $self; } @@ -141,7 +179,7 @@ sub cplxe { # # The number defined as pi = 180 degrees # -use constant pi => 4 * atan2(1, 1); +use constant pi => 4 * CORE::atan2(1, 1); # # pit2 @@ -158,11 +196,19 @@ use constant pit2 => 2 * pi; use constant pip2 => pi / 2; # +# deg1 +# +# One degree in radians, used in stringify_polar. +# + +use constant deg1 => pi / 180; + +# # uplog10 # # Used in log10(). # -use constant uplog10 => 1 / log(10); +use constant uplog10 => 1 / CORE::log(10); # # i @@ -200,7 +246,7 @@ sub update_cartesian { my $self = shift; my ($r, $t) = @{$self->{'polar'}}; $self->{c_dirty} = 0; - return $self->{'cartesian'} = [$r * cos $t, $r * sin $t]; + return $self->{'cartesian'} = [$r * CORE::cos($t), $r * CORE::sin($t)]; } # @@ -214,7 +260,7 @@ sub update_polar { 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)]; + return $self->{'polar'} = [CORE::sqrt($x*$x + $y*$y), CORE::atan2($y, $x)]; } # @@ -355,45 +401,32 @@ sub divide { } # -# _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); + return 1 if $z1 == 0 || $z2 == 1; + return 0 if $z2 == 0 && Re($z1) > 0; } else { - return 0 if ($z1z); - return 1 if ($z2z or $z1 == 1); + return 1 if $z2 == 0 || $z1 == 1; + return 0 if $z1 == 0 && Re($z2) > 0; } - return $inverted ? exp($z1 * log $z2) : exp($z2 * log $z1); + my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) + : CORE::exp($z2 * CORE::log($z1)); + # If both arguments cartesian, return cartesian, else polar. + return $z1->{c_dirty} == 0 && + (not ref $z2 or $z2->{c_dirty} == 0) ? + cplx(@{$w->cartesian}) : $w; } # # (spaceship) # # Computes z1 <=> z2. -# Sorts on the real part first, then on the imaginary part. Thus 2-4i > 3+8i. +# Sorts on the real part first, then on the imaginary part. Thus 2-4i < 3+8i. # sub spaceship { my ($z1, $z2, $inverted) = @_; @@ -438,26 +471,46 @@ sub conjugate { # # (abs) # -# Compute complex's norm (rho). +# Compute or set complex's norm (rho). # sub abs { - my ($z) = @_; - my ($r, $t) = @{$z->polar}; - return $r; + my ($z, $rho) = @_; + return $z unless ref $z; + if (defined $rho) { + $z->{'polar'} = [ $rho, ${$z->polar}[1] ]; + $z->{p_dirty} = 0; + $z->{c_dirty} = 1; + return $rho; + } else { + return ${$z->polar}[0]; + } +} + +sub _theta { + my $theta = $_[0]; + + if ($$theta > pi()) { $$theta -= pit2 } + elsif ($$theta <= -pi()) { $$theta += pit2 } } # # arg # -# Compute complex's argument (theta). +# Compute or set 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; + my ($z, $theta) = @_; + return $z unless ref $z; + if (defined $theta) { + _theta(\$theta); + $z->{'polar'} = [ ${$z->polar}[0], $theta ]; + $z->{p_dirty} = 0; + $z->{c_dirty} = 1; + } else { + $theta = ${$z->polar}[1]; + _theta(\$theta); + } + return $theta; } # @@ -465,13 +518,22 @@ sub arg { # # Compute sqrt(z). # +# It is quite tempting to use wantarray here so that in list context +# sqrt() would return the two solutions. This, however, would +# break things like +# +# print "sqrt(z) = ", sqrt($z), "\n"; +# +# The two values would be printed side by side without no intervening +# whitespace, quite confusing. +# Therefore if you want the two solutions use the root(). +# 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 ($re, $im) = ref $z ? @{$z->cartesian} : ($z, 0); + return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re) if $im == 0; my ($r, $t) = @{$z->polar}; - return (ref $z)->emake(sqrt($r), $t/2); + return (ref $z)->emake(CORE::sqrt($r), $t/2); } # @@ -479,12 +541,14 @@ sub sqrt { # # Compute cbrt(z) (cubic root). # +# Why are we not returning three values? The same answer as for sqrt(). +# sub cbrt { my ($z) = @_; - return $z < 0 ? -exp(log(-$z)/3) : ($z > 0 ? exp(log($z)/3): 0) + return $z < 0 ? -CORE::exp(CORE::log(-$z)/3) : ($z > 0 ? CORE::exp(CORE::log($z)/3): 0) unless ref $z; my ($r, $t) = @{$z->polar}; - return (ref $z)->emake(exp(log($r)/3), $t/3); + return (ref $z)->emake(CORE::exp(CORE::log($r)/3), $t/3); } # @@ -515,15 +579,17 @@ sub _rootbad { 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 ($r, $t) = ref $z ? @{$z->polar} : (CORE::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; + my $cartesian = ref $z && $z->{c_dirty} == 0; for ($k = 0, $theta = $t / $n; $k < $n; $k++, $theta += $theta_inc) { - push(@root, $complex->emake($rho, $theta)); + my $w = cplxe($rho, $theta); + # Yes, $cartesian is loop invariant. + push @root, $cartesian ? cplx(@{$w->cartesian}) : $w; } return @root; } @@ -531,25 +597,53 @@ sub root { # # Re # -# Return Re(z). +# Return or set Re(z). # sub Re { - my ($z) = @_; + my ($z, $Re) = @_; return $z unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return $re; + if (defined $Re) { + $z->{'cartesian'} = [ $Re, ${$z->cartesian}[1] ]; + $z->{c_dirty} = 0; + $z->{p_dirty} = 1; + } else { + return ${$z->cartesian}[0]; + } } # # Im # -# Return Im(z). +# Return or set Im(z). # sub Im { - my ($z) = @_; - return 0 unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return $im; + my ($z, $Im) = @_; + return $z unless ref $z; + if (defined $Im) { + $z->{'cartesian'} = [ ${$z->cartesian}[0], $Im ]; + $z->{c_dirty} = 0; + $z->{p_dirty} = 1; + } else { + return ${$z->cartesian}[1]; + } +} + +# +# rho +# +# Return or set rho(w). +# +sub rho { + Math::Complex::abs(@_); +} + +# +# theta +# +# Return or set theta(w). +# +sub theta { + Math::Complex::arg(@_); } # @@ -560,7 +654,7 @@ sub Im { sub exp { my ($z) = @_; my ($x, $y) = @{$z->cartesian}; - return (ref $z)->emake(exp($x), $y); + return (ref $z)->emake(CORE::exp($x), $y); } # @@ -593,13 +687,13 @@ sub log { my ($z) = @_; unless (ref $z) { _logofzero("log") if $z == 0; - return $z > 0 ? log($z) : cplx(log(-$z), pi); + return $z > 0 ? CORE::log($z) : cplx(CORE::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); + return (ref $z)->make(CORE::log($r), $t); } # @@ -628,8 +722,8 @@ 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; + $logn = $logn{$n} = CORE::log($n) unless defined $logn; # Cache log(n) + return CORE::log($z) / $logn; } # @@ -640,10 +734,10 @@ sub logn { sub cos { my ($z) = @_; my ($x, $y) = @{$z->cartesian}; - my $ey = exp($y); + my $ey = CORE::exp($y); my $ey_1 = 1 / $ey; - return (ref $z)->make(cos($x) * ($ey + $ey_1)/2, - sin($x) * ($ey_1 - $ey)/2); + return (ref $z)->make(CORE::cos($x) * ($ey + $ey_1)/2, + CORE::sin($x) * ($ey_1 - $ey)/2); } # @@ -654,10 +748,10 @@ sub cos { sub sin { my ($z) = @_; my ($x, $y) = @{$z->cartesian}; - my $ey = exp($y); + my $ey = CORE::exp($y); my $ey_1 = 1 / $ey; - return (ref $z)->make(sin($x) * ($ey + $ey_1)/2, - cos($x) * ($ey - $ey_1)/2); + return (ref $z)->make(CORE::sin($x) * ($ey + $ey_1)/2, + CORE::cos($x) * ($ey - $ey_1)/2); } # @@ -667,9 +761,9 @@ sub sin { # sub tan { my ($z) = @_; - my $cz = cos($z); - _divbyzero "tan($z)", "cos($z)" if ($cz == 0); - return sin($z) / $cz; + my $cz = CORE::cos($z); + _divbyzero "tan($z)", "cos($z)" if (CORE::abs($cz) < $eps); + return CORE::sin($z) / $cz; } # @@ -679,7 +773,7 @@ sub tan { # sub sec { my ($z) = @_; - my $cz = cos($z); + my $cz = CORE::cos($z); _divbyzero "sec($z)", "cos($z)" if ($cz == 0); return 1 / $cz; } @@ -691,7 +785,7 @@ sub sec { # sub csc { my ($z) = @_; - my $sz = sin($z); + my $sz = CORE::sin($z); _divbyzero "csc($z)", "sin($z)" if ($sz == 0); return 1 / $sz; } @@ -710,9 +804,9 @@ sub cosec { Math::Complex::csc(@_) } # sub cot { my ($z) = @_; - my $sz = sin($z); + my $sz = CORE::sin($z); _divbyzero "cot($z)", "sin($z)" if ($sz == 0); - return cos($z) / $sz; + return CORE::cos($z) / $sz; } # @@ -729,17 +823,17 @@ sub cotan { Math::Complex::cot(@_) } # sub acos { my $z = $_[0]; - return atan2(sqrt(1-$z*$z), $z) if (! ref $z) && abs($z) <= 1; + return CORE::atan2(CORE::sqrt(1-$z*$z), $z) if (! ref $z) && CORE::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 $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = CORE::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)); + my $u = CORE::atan2(CORE::sqrt(1-$beta*$beta), $beta); + my $v = CORE::log($alpha + CORE::sqrt($alpha*$alpha-1)); $v = -$v if $y > 0 || ($y == 0 && $x < -1); return $package->make($u, $v); } @@ -751,17 +845,17 @@ sub acos { # sub asin { my $z = $_[0]; - return atan2($z, sqrt(1-$z*$z)) if (! ref $z) && abs($z) <= 1; + return CORE::atan2($z, CORE::sqrt(1-$z*$z)) if (! ref $z) && CORE::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 $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y); + my $t2 = CORE::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)); + my $u = CORE::atan2($beta, CORE::sqrt(1-$beta*$beta)); + my $v = -CORE::log($alpha + CORE::sqrt($alpha*$alpha-1)); $v = -$v if $y > 0 || ($y == 0 && $x < -1); return $package->make($u, $v); } @@ -773,10 +867,10 @@ sub asin { # sub atan { my ($z) = @_; - return atan2($z, 1) unless ref $z; + return CORE::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)); + my $log = CORE::log((i + $z) / (i - $z)); $ip2 = 0.5 * i unless defined $ip2; return $ip2 * $log; } @@ -817,9 +911,10 @@ sub acosec { Math::Complex::acsc(@_) } # 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); + _divbyzero "acot(0)" if (CORE::abs($z) < $eps); + return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z) unless ref $z; + _divbyzero "acot(i)" if (CORE::abs($z - i) < $eps); + _logofzero "acot(-i)" if (CORE::abs($z + i) < $eps); return atan(1 / $z); } @@ -839,14 +934,14 @@ sub cosh { my ($z) = @_; my $ex; unless (ref $z) { - $ex = exp($z); + $ex = CORE::exp($z); return ($ex + 1/$ex)/2; } my ($x, $y) = @{$z->cartesian}; - $ex = exp($x); + $ex = CORE::exp($x); my $ex_1 = 1 / $ex; - return (ref $z)->make(cos($y) * ($ex + $ex_1)/2, - sin($y) * ($ex - $ex_1)/2); + return (ref $z)->make(CORE::cos($y) * ($ex + $ex_1)/2, + CORE::sin($y) * ($ex - $ex_1)/2); } # @@ -858,14 +953,14 @@ sub sinh { my ($z) = @_; my $ex; unless (ref $z) { - $ex = exp($z); + $ex = CORE::exp($z); return ($ex - 1/$ex)/2; } my ($x, $y) = @{$z->cartesian}; - $ex = exp($x); + $ex = CORE::exp($x); my $ex_1 = 1 / $ex; - return (ref $z)->make(cos($y) * ($ex - $ex_1)/2, - sin($y) * ($ex + $ex_1)/2); + return (ref $z)->make(CORE::cos($y) * ($ex - $ex_1)/2, + CORE::sin($y) * ($ex + $ex_1)/2); } # @@ -938,15 +1033,15 @@ sub cotanh { Math::Complex::coth(@_) } sub acosh { my ($z) = @_; unless (ref $z) { - return log($z + sqrt($z*$z-1)) if $z >= 1; + return CORE::log($z + CORE::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 cplx(CORE::log($re + CORE::sqrt($re*$re - 1)), 0) if $re >= 1; + return cplx(0, CORE::atan2(CORE::sqrt(1-$re*$re), $re)) if CORE::abs($re) <= 1; } - return log($z + sqrt($z*$z - 1)); + return CORE::log($z + CORE::sqrt($z*$z - 1)); } # @@ -956,7 +1051,7 @@ sub acosh { # sub asinh { my ($z) = @_; - return log($z + sqrt($z*$z + 1)); + return CORE::log($z + CORE::sqrt($z*$z + 1)); } # @@ -967,12 +1062,12 @@ sub asinh { sub atanh { my ($z) = @_; unless (ref $z) { - return log((1 + $z)/(1 - $z))/2 if abs($z) < 1; + return CORE::log((1 + $z)/(1 - $z))/2 if CORE::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)); + return 0.5 * CORE::log((1 + $z) / (1 - $z)); } # @@ -1011,13 +1106,14 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; + _divbyzero 'acoth(0)' if (CORE::abs($z) < $eps); unless (ref $z) { - return log(($z + 1)/($z - 1))/2 if abs($z) > 1; + return CORE::log(($z + 1)/($z - 1))/2 if CORE::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; + _divbyzero 'acoth(1)', "$z - 1" if (CORE::abs($z - 1) < $eps); + _logofzero 'acoth(-1)', "1 / $z" if (CORE::abs($z + 1) < $eps); + return CORE::log((1 + $z) / ($z - 1)) / 2; } # @@ -1043,7 +1139,7 @@ sub atan2 { ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0); } if ($im2 == 0) { - return cplx(atan2($re1, $re2), 0) if $im1 == 0; + return cplx(CORE::atan2($re1, $re2), 0) if $im1 == 0; return cplx(($im1<=>0) * pip2, 0) if $re2 == 0; } my $w = atan($z1/$z2); @@ -1117,28 +1213,58 @@ 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); + if int(CORE::abs($x)) != int(CORE::abs($x) + $eps); $y = int($y + ($y < 0 ? -1 : 1) * $eps) - if int(abs($y)) != int(abs($y) + $eps); + if int(CORE::abs($y)) != int(CORE::abs($y) + $eps); - $re = "$x" if abs($x) >= $eps; + $re = "$x" if CORE::abs($x) >= $eps; if ($y == 1) { $im = 'i' } elsif ($y == -1) { $im = '-i' } - elsif (abs($y) >= $eps) { $im = $y . "i" } + elsif (CORE::abs($y) >= $eps) { $im = $y . "i" } my $str = ''; $str = $re if defined $re; $str .= "+$im" if defined $im; $str =~ s/\+-/-/; $str =~ s/^\+//; + $str =~ s/([-+])1i/$1i/; # Not redundant with the above 1/-1 tests. $str = '0' unless $str; return $str; } + +# Helper for stringify_polar, a Greatest Common Divisor with a memory. + +sub _gcd { + my ($a, $b) = @_; + + use integer; + + # Loops forever if given negative inputs. + + if ($b and $a > $b) { return gcd($a % $b, $b) } + elsif ($a and $b > $a) { return gcd($b % $a, $a) } + else { return $a ? $a : $b } +} + +my %gcd; + +sub gcd { + my ($a, $b) = @_; + + my $id = "$a $b"; + + unless (exists $gcd{$id}) { + $gcd{$id} = _gcd($a, $b); + $gcd{"$b $a"} = $gcd{$id}; + } + + return $gcd{$id}; +} + # # ->stringify_polar # @@ -1148,7 +1274,6 @@ sub stringify_polar { my $z = shift; my ($r, $t) = @{$z->polar}; my $theta; - my $eps = 1e-14; return '[0,0]' if $r <= $eps; @@ -1156,15 +1281,15 @@ sub stringify_polar { $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 (CORE::abs($nt) <= $eps) { $theta = 0 } + elsif (CORE::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); + if int(CORE::abs($r)) != int(CORE::abs($r) + $eps); $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps) if ($theta ne 'pi' and - int(abs($theta)) != int(abs($theta) + $eps)); + int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps)); return "\[$r,$theta\]"; } @@ -1173,24 +1298,35 @@ sub stringify_polar { # $nt -= pit2 if $nt > pi; - my ($n, $k, $kpi); - for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) { + if (CORE::abs($nt) >= deg1) { + 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; + if (CORE::abs($kpi/$n - $nt) <= $eps) { + $n = CORE::abs($n); + my $gcd = gcd($k, $n); + if ($gcd > 1) { + $k /= $gcd; + $n /= $gcd; + } + next if $n > 360; + $theta = ($nt < 0 ? '-':''). + ($k == 1 ? 'pi':"${k}pi"); + $theta .= '/'.$n if $n > 1; + last; } + } } $theta = $nt unless defined $theta; $r = int($r + ($r < 0 ? -1 : 1) * $eps) - if int(abs($r)) != int(abs($r) + $eps); + if int(CORE::abs($r)) != int(CORE::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)); + int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps)); return "\[$r,$theta\]"; } @@ -1323,6 +1459,8 @@ number) and the above definition states that sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i which is exactly what we had defined for negative real numbers above. +The C<sqrt> returns only one of the solutions: if you want the both, +use the C<root> function. All the common mathematical functions defined on real numbers that are extended to complex numbers share that same property of working @@ -1375,13 +1513,13 @@ the following (overloaded) operations are supported on complex numbers: 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)) + ~z = a - bi + abs(z) = r1 = sqrt(a*a + b*b) + sqrt(z) = sqrt(r1) * exp(i * t/2) + exp(z) = exp(a) * exp(i * b) + log(z) = log(r1) + i*t + sin(z) = 1/2i (exp(i * z1) - exp(-i * z)) + cos(z) = 1/2 (exp(i * z1) + exp(-i * z)) atan2(z1, z2) = atan(z1/z2) The following extra operations are supported on both real and complex @@ -1390,6 +1528,7 @@ numbers: Re(z) = a Im(z) = b arg(z) = t + abs(z) = r cbrt(z) = z ** (1/3) log10(z) = log(z) / log(10) @@ -1425,10 +1564,13 @@ numbers: 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. +I<arg>, I<abs>, I<log>, I<csc>, I<cot>, I<acsc>, I<acot>, I<csch>, +I<coth>, I<acosech>, I<acotanh>, have aliases I<rho>, I<theta>, I<ln>, +I<cosec>, I<cotan>, I<acosec>, I<acotan>, I<cosech>, I<cotanh>, +I<acosech>, I<acotanh>, respectively. C<Re>, C<Im>, C<arg>, C<abs>, +C<rho>, and C<theta> can be used also also mutators. The C<cbrt> +returns only one of the solutions: if you want all three, use the +C<root> function. The I<root> function is available to compute all the I<n> roots of some complex, where I<n> is a strictly positive integer. @@ -1479,6 +1621,13 @@ 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). +It is also possible to have a complex number as either argument of +either the C<make> or C<emake>: the appropriate component of +the argument will be used. + + $z1 = cplx(-2, 1); + $z2 = cplx($z1, 4); + =head1 STRINGIFICATION When printed, a complex number is usually shown under its cartesian @@ -1527,26 +1676,19 @@ Here are some examples: $k = exp(i * 2*pi/3); print "$j - $k = ", $j - $k, "\n"; -=head1 ERRORS DUE TO DIVISION BY ZERO + $z->Re(3); # Re, Im, arg, abs, + $j->arg(2); # (the last two aka rho, theta) + # can be used also as mutators. + +=head1 ERRORS DUE TO DIVISION BY ZERO OR LOGARITHM OF ZERO The division (/) and the following functions - tan - sec - csc - cot - asec - acsc - atan - acot - tanh - sech - csch - coth - atanh - asech - acsch - acoth + log ln log10 logn + tan sec csc cot + atan asec acsc 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 @@ -1562,13 +1704,30 @@ or 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. +C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the the +logarithmic functions and 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>, the argument cannot be I<pi/2 + k * pi>, where I<k> +is any integer. + +Note that because we are operating on approximations of real numbers, +these errors can happen when merely `too close' to the singularities +listed above. For example C<tan(2*atan2(1,1)+1e-15)> will die of +division by zero. + +=head1 ERRORS DUE TO INDIGESTIBLE ARGUMENTS + +The C<make> and C<emake> accept both real and complex arguments. +When they cannot recognize the arguments they will die with error +messages like the following + + Math::Complex::make: Cannot take real part of ... + Math::Complex::make: Cannot take real part of ... + Math::Complex::emake: Cannot take rho of ... + Math::Complex::emake: Cannot take theta of ... =head1 BUGS @@ -1580,6 +1739,11 @@ 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. +In Cray UNICOS there is some strange numerical instability that results +in root(), cos(), sin(), cosh(), sinh(), losing accuracy fast. Beware. +The bug may be in UNICOS math libs, in UNICOS C compiler, in Math::Complex. +Whatever it is, it does not manifest itself anywhere else where Perl runs. + =head1 AUTHORS Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>> and @@ -1589,4 +1753,6 @@ Extensive patches by Daniel S. Lewart <F<d-lewart@uiuc.edu>>. =cut +1; + # eof diff --git a/gnu/usr.bin/perl/lib/Math/Trig.pm b/gnu/usr.bin/perl/lib/Math/Trig.pm index a1cbb072340..924286d2049 100644 --- a/gnu/usr.bin/perl/lib/Math/Trig.pm +++ b/gnu/usr.bin/perl/lib/Math/Trig.pm @@ -1,6 +1,6 @@ # # Trigonometric functions, mostly inherited from Math::Complex. -# -- Jarkko Hietaniemi, April 1997 +# -- Jarkko Hietaniemi, since April 1997 # -- Raphael Manfredi, September 1996 (indirectly: because of Math::Complex) # @@ -13,7 +13,7 @@ use Math::Complex qw(:trig); use vars qw($VERSION $PACKAGE @ISA - @EXPORT); + @EXPORT @EXPORT_OK %EXPORT_TAGS); @ISA = qw(Exporter); @@ -26,13 +26,25 @@ my @angcnv = qw(rad2deg rad2grad @EXPORT = (@{$Math::Complex::EXPORT_TAGS{'trig'}}, @angcnv); -use constant pi2 => 2 * pi; -use constant DR => pi2/360; -use constant RD => 360/pi2; -use constant DG => 400/360; -use constant GD => 360/400; -use constant RG => 400/pi2; -use constant GR => pi2/400; +my @rdlcnv = qw(cartesian_to_cylindrical + cartesian_to_spherical + cylindrical_to_cartesian + cylindrical_to_spherical + spherical_to_cartesian + spherical_to_cylindrical); + +@EXPORT_OK = (@rdlcnv, 'great_circle_distance'); + +%EXPORT_TAGS = ('radial' => [ @rdlcnv ]); + +use constant pi2 => 2 * pi; +use constant pip2 => pi / 2; +use constant DR => pi2/360; +use constant RD => 360/pi2; +use constant DG => 400/360; +use constant GD => 360/400; +use constant RG => 400/pi2; +use constant GR => pi2/400; # # Truncating remainder. @@ -59,6 +71,61 @@ sub rad2grad ($) { remt(RG * $_[0], 400) } sub grad2rad ($) { remt(GR * $_[0], pi2) } +sub cartesian_to_spherical { + my ( $x, $y, $z ) = @_; + + my $rho = sqrt( $x * $x + $y * $y + $z * $z ); + + return ( $rho, + atan2( $y, $x ), + $rho ? acos( $z / $rho ) : 0 ); +} + +sub spherical_to_cartesian { + my ( $rho, $theta, $phi ) = @_; + + return ( $rho * cos( $theta ) * sin( $phi ), + $rho * sin( $theta ) * sin( $phi ), + $rho * cos( $phi ) ); +} + +sub spherical_to_cylindrical { + my ( $x, $y, $z ) = spherical_to_cartesian( @_ ); + + return ( sqrt( $x * $x + $y * $y ), $_[1], $z ); +} + +sub cartesian_to_cylindrical { + my ( $x, $y, $z ) = @_; + + return ( sqrt( $x * $x + $y * $y ), atan2( $y, $x ), $z ); +} + +sub cylindrical_to_cartesian { + my ( $rho, $theta, $z ) = @_; + + return ( $rho * cos( $theta ), $rho * sin( $theta ), $z ); +} + +sub cylindrical_to_spherical { + return ( cartesian_to_spherical( cylindrical_to_cartesian( @_ ) ) ); +} + +sub great_circle_distance { + my ( $theta0, $phi0, $theta1, $phi1, $rho ) = @_; + + $rho = 1 unless defined $rho; # Default to the unit sphere. + + my $lat0 = pip2 - $phi0; + my $lat1 = pip2 - $phi1; + + return $rho * + acos(cos( $lat0 ) * cos( $lat1 ) * cos( $theta0 - $theta1 ) + + sin( $lat0 ) * sin( $lat1 ) ); +} + +=pod + =head1 NAME Math::Trig - trigonometric functions @@ -86,68 +153,72 @@ conversions. The tangent - tan +=over 4 + +=item B<tan> + +=back The cofunctions of the sine, cosine, and tangent (cosec/csc and cotan/cot are aliases) - csc cosec sec cot cotan +B<csc>, B<cosec>, B<sec>, B<sec>, B<cot>, B<cotan> The arcus (also known as the inverse) functions of the sine, cosine, and tangent - asin acos atan +B<asin>, B<acos>, B<atan> The principal value of the arc tangent of y/x - atan2(y, x) +B<atan2>(y, x) The arcus cofunctions of the sine, cosine, and tangent (acosec/acsc and acotan/acot are aliases) - acsc acosec asec acot acotan +B<acsc>, B<acosec>, B<asec>, B<acot>, B<acotan> The hyperbolic sine, cosine, and tangent - sinh cosh tanh +B<sinh>, B<cosh>, B<tanh> The cofunctions of the hyperbolic sine, cosine, and tangent (cosech/csch and cotanh/coth are aliases) - csch cosech sech coth cotanh +B<csch>, B<cosech>, B<sech>, B<coth>, B<cotanh> The arcus (also known as the inverse) functions of the hyperbolic sine, cosine, and tangent - asinh acosh atanh +B<asinh>, B<acosh>, B<atanh> The arcus cofunctions of the hyperbolic sine, cosine, and tangent (acsch/acosech and acoth/acotanh are aliases) - acsch acosech asech acoth acotanh +B<acsch>, B<acosech>, B<asech>, B<acoth>, B<acotanh> The trigonometric constant B<pi> is also defined. - $pi2 = 2 * pi; +$pi2 = 2 * B<pi>; =head2 ERRORS DUE TO DIVISION BY ZERO The following functions - tan - sec - csc - cot - asec + acoth acsc - tanh - sech - csch - coth - atanh - asech acsch - acoth + asec + asech + atanh + cot + coth + csc + csch + sec + sech + tan + tanh cannot be computed for all arguments because that would mean dividing by zero or taking logarithm of zero. These situations cause fatal @@ -196,7 +267,7 @@ should produce something like this (take or leave few last decimals): That is, a complex number with the real part of approximately C<1.571> and the imaginary part of approximately C<-1.317>. -=head1 ANGLE CONVERSIONS +=head1 PLANE ANGLE CONVERSIONS (Plane, 2-dimensional) angles may be converted with the following functions. @@ -211,6 +282,135 @@ and the imaginary part of approximately C<-1.317>. The full circle is 2 I<pi> radians or I<360> degrees or I<400> gradians. +=head1 RADIAL COORDINATE CONVERSIONS + +B<Radial coordinate systems> are the B<spherical> and the B<cylindrical> +systems, explained shortly in more detail. + +You can import radial coordinate conversion functions by using the +C<:radial> tag: + + use Math::Trig ':radial'; + + ($rho, $theta, $z) = cartesian_to_cylindrical($x, $y, $z); + ($rho, $theta, $phi) = cartesian_to_spherical($x, $y, $z); + ($x, $y, $z) = cylindrical_to_cartesian($rho, $theta, $z); + ($rho_s, $theta, $phi) = cylindrical_to_spherical($rho_c, $theta, $z); + ($x, $y, $z) = spherical_to_cartesian($rho, $theta, $phi); + ($rho_c, $theta, $z) = spherical_to_cylindrical($rho_s, $theta, $phi); + +B<All angles are in radians>. + +=head2 COORDINATE SYSTEMS + +B<Cartesian> coordinates are the usual rectangular I<(x, y, +z)>-coordinates. + +Spherical coordinates, I<(rho, theta, pi)>, are three-dimensional +coordinates which define a point in three-dimensional space. They are +based on a sphere surface. The radius of the sphere is B<rho>, also +known as the I<radial> coordinate. The angle in the I<xy>-plane +(around the I<z>-axis) is B<theta>, also known as the I<azimuthal> +coordinate. The angle from the I<z>-axis is B<phi>, also known as the +I<polar> coordinate. The `North Pole' is therefore I<0, 0, rho>, and +the `Bay of Guinea' (think of the missing big chunk of Africa) I<0, +pi/2, rho>. In geographical terms I<phi> is latitude (northward +positive, southward negative) and I<theta> is longitude (eastward +positive, westward negative). + +B<BEWARE>: some texts define I<theta> and I<phi> the other way round, +some texts define the I<phi> to start from the horizontal plane, some +texts use I<r> in place of I<rho>. + +Cylindrical coordinates, I<(rho, theta, z)>, are three-dimensional +coordinates which define a point in three-dimensional space. They are +based on a cylinder surface. The radius of the cylinder is B<rho>, +also known as the I<radial> coordinate. The angle in the I<xy>-plane +(around the I<z>-axis) is B<theta>, also known as the I<azimuthal> +coordinate. The third coordinate is the I<z>, pointing up from the +B<theta>-plane. + +=head2 3-D ANGLE CONVERSIONS + +Conversions to and from spherical and cylindrical coordinates are +available. Please notice that the conversions are not necessarily +reversible because of the equalities like I<pi> angles being equal to +I<-pi> angles. + +=over 4 + +=item cartesian_to_cylindrical + + ($rho, $theta, $z) = cartesian_to_cylindrical($x, $y, $z); + +=item cartesian_to_spherical + + ($rho, $theta, $phi) = cartesian_to_spherical($x, $y, $z); + +=item cylindrical_to_cartesian + + ($x, $y, $z) = cylindrical_to_cartesian($rho, $theta, $z); + +=item cylindrical_to_spherical + + ($rho_s, $theta, $phi) = cylindrical_to_spherical($rho_c, $theta, $z); + +Notice that when C<$z> is not 0 C<$rho_s> is not equal to C<$rho_c>. + +=item spherical_to_cartesian + + ($x, $y, $z) = spherical_to_cartesian($rho, $theta, $phi); + +=item spherical_to_cylindrical + + ($rho_c, $theta, $z) = spherical_to_cylindrical($rho_s, $theta, $phi); + +Notice that when C<$z> is not 0 C<$rho_c> is not equal to C<$rho_s>. + +=back + +=head1 GREAT CIRCLE DISTANCES + +You can compute spherical distances, called B<great circle distances>, +by importing the C<great_circle_distance> function: + + use Math::Trig 'great_circle_distance' + + $distance = great_circle_distance($theta0, $phi0, $theta1, $phi1, [, $rho]); + +The I<great circle distance> is the shortest distance between two +points on a sphere. The distance is in C<$rho> units. The C<$rho> is +optional, it defaults to 1 (the unit sphere), therefore the distance +defaults to radians. + +If you think geographically the I<theta> are longitudes: zero at the +Greenwhich meridian, eastward positive, westward negative--and the +I<phi> are latitudes: zero at the North Pole, northward positive, +southward negative. B<NOTE>: this formula thinks in mathematics, not +geographically: the I<phi> zero is at the North Pole, not at the +Equator on the west coast of Africa (Bay of Guinea). You need to +subtract your geographical coordinates from I<pi/2> (also known as 90 +degrees). + + $distance = great_circle_distance($lon0, pi/2 - $lat0, + $lon1, pi/2 - $lat1, $rho); + +=head1 EXAMPLES + +To calculate the distance between London (51.3N 0.5W) and Tokyo (35.7N +139.8E) in kilometers: + + use Math::Trig qw(great_circle_distance deg2rad); + + # Notice the 90 - latitude: phi zero is at the North Pole. + @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); + @T = (deg2rad(139.8),deg2rad(90 - 35.7)); + + $km = great_circle_distance(@L, @T, 6378); + +The answer may be off by few percentages because of the irregular +(slightly aspherical) form of the Earth. + =head1 BUGS Saying C<use Math::Trig;> exports many mathematical routines in the diff --git a/gnu/usr.bin/perl/lib/Net/Ping.pm b/gnu/usr.bin/perl/lib/Net/Ping.pm index 91077ddad1c..495b82f95bb 100644 --- a/gnu/usr.bin/perl/lib/Net/Ping.pm +++ b/gnu/usr.bin/perl/lib/Net/Ping.pm @@ -106,7 +106,7 @@ sub new } elsif ($self->{"proto"} eq "icmp") { - croak("icmp ping requires root privilege") if $>; + croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS'); $self->{"proto_num"} = (getprotobyname('icmp'))[2] || croak("Can't get icmp protocol by name"); $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid diff --git a/gnu/usr.bin/perl/lib/Net/hostent.pm b/gnu/usr.bin/perl/lib/Net/hostent.pm index 96b090dae5a..d586358f0a5 100644 --- a/gnu/usr.bin/perl/lib/Net/hostent.pm +++ b/gnu/usr.bin/perl/lib/Net/hostent.pm @@ -89,7 +89,7 @@ $h_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $host_obj-E<gt>aliases() }> would be simply @h_aliases. -The gethost() funtion is a simple front-end that forwards a numeric +The gethost() function is a simple front-end that forwards a numeric argument to gethostbyaddr() by way of Socket::inet_aton, and the rest to gethostbyname(). diff --git a/gnu/usr.bin/perl/lib/Net/netent.pm b/gnu/usr.bin/perl/lib/Net/netent.pm index b82447cad71..fbc6d987fe5 100644 --- a/gnu/usr.bin/perl/lib/Net/netent.pm +++ b/gnu/usr.bin/perl/lib/Net/netent.pm @@ -92,7 +92,7 @@ $n_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $net_obj-E<gt>aliases() }> would be simply @n_aliases. -The getnet() funtion is a simple front-end that forwards a numeric +The getnet() function is a simple front-end that forwards a numeric argument to getnetbyaddr(), and the rest to getnetbyname(). diff --git a/gnu/usr.bin/perl/lib/Pod/Html.pm b/gnu/usr.bin/perl/lib/Pod/Html.pm index ffeb0b21361..e71afa814bd 100644 --- a/gnu/usr.bin/perl/lib/Pod/Html.pm +++ b/gnu/usr.bin/perl/lib/Pod/Html.pm @@ -3,21 +3,27 @@ package Pod::Html; use Pod::Functions; use Getopt::Long; # package for handling command-line parameters require Exporter; +use vars qw($VERSION); +$VERSION = 1.01; @ISA = Exporter; @EXPORT = qw(pod2html htmlify); use Cwd; use Carp; +use locale; # make \w work right in non-ASCII lands + use strict; +use Config; + =head1 NAME -Pod::HTML - module to convert pod files to HTML +Pod::Html - module to convert pod files to HTML =head1 SYNOPSIS - use Pod::HTML; + use Pod::Html; pod2html([options]); =head1 DESCRIPTION @@ -199,6 +205,8 @@ my %pages = (); # associative array used to find the location my %sections = (); # sections within this page my %items = (); # associative array used to find the location # of =item directives referenced by C<> links +my $Is83; # is dos with short filenames (8.3) + sub init_globals { $dircache = "pod2html-dircache"; $itemcache = "pod2html-itemcache"; @@ -244,7 +252,7 @@ $paragraph = ''; # which paragraph we're processing (used # of pages referenced by L<> links. #%items = (); # associative array used to find the location # of =item directives referenced by C<> links - +$Is83=$^O eq 'dos'; } sub pod2html { @@ -254,6 +262,8 @@ sub pod2html { init_globals(); + $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN()); + # cache of %pages and %items from last time we ran pod2html #undef $opt_help if defined $opt_help; @@ -292,18 +302,20 @@ sub pod2html { open(HTML, ">$htmlfile") || die "$0: cannot open $htmlfile file for output: $!\n"; - # put a title in the HTML file - $title = ''; - TITLE_SEARCH: { - for (my $i = 0; $i < @poddata; $i++) { - if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { - for my $para ( @poddata[$i, $i+1] ) { - last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+\s*.*)/s; - } - } + # put a title in the HTML file if one wasn't specified + if ($title eq '') { + TITLE_SEARCH: { + for (my $i = 0; $i < @poddata; $i++) { + if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { + for my $para ( @poddata[$i, $i+1] ) { + last TITLE_SEARCH + if ($title) = $para =~ /(\S+\s+-+.*\S)/s; + } + } - } - } + } + } + } if (!$title and $podfile =~ /\.pod$/) { # probably a split pod so take first =head[12] as title for (my $i = 0; $i < @poddata; $i++) { @@ -312,19 +324,22 @@ sub pod2html { warn "adopted '$title' as title for $podfile\n" if $verbose and $title; } - unless ($title) { + if ($title) { + $title =~ s/\s*\(.*\)//; + } else { warn "$0: no title for $podfile"; $podfile =~ /^(.*)(\.[^.\/]+)?$/; $title = ($podfile eq "-" ? 'No Title' : $1); warn "using $title" if $verbose; } print HTML <<END_OF_HEAD; - <HTML> - <HEAD> - <TITLE>$title</TITLE> - </HEAD> +<HTML> +<HEAD> +<TITLE>$title</TITLE> +<LINK REV="made" HREF="mailto:$Config{perladmin}"> +</HEAD> - <BODY> +<BODY> END_OF_HEAD @@ -364,9 +379,9 @@ END_OF_HEAD } else { next if @begin_stack && $begin_stack[-1] ne 'html'; - if (/^=(head[1-6])\s+(.*)/s) { # =head[1-6] heading + if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading process_head($1, $2); - } elsif (/^=item\s*(.*)/sm) { # =item text + } elsif (/^=item\s*(.*\S)/sm) { # =item text process_item($1); } elsif (/^=over\s*(.*)/) { # =over N process_over(); @@ -387,16 +402,16 @@ END_OF_HEAD next if @begin_stack && $begin_stack[-1] ne 'html'; my $text = $_; process_text(\$text, 1); - print HTML "$text\n<P>\n\n"; + print HTML "<P>\n$text"; } } # finish off any pending directives finish_list(); print HTML <<END_OF_TAIL; - </BODY> +</BODY> - </HTML> +</HTML> END_OF_TAIL # close the html file @@ -766,17 +781,19 @@ sub scan_headings { chomp($title); $$sections{htmlify(0,$title)} = 1; - if ($which_head > $listdepth) { - $index .= "\n" . ("\t" x $listdepth) . "<UL>\n"; - } elsif ($which_head < $listdepth) { - $listdepth--; - $index .= "\n" . ("\t" x $listdepth) . "</UL>\n"; + while ($which_head != $listdepth) { + if ($which_head > $listdepth) { + $index .= "\n" . ("\t" x $listdepth) . "<UL>\n"; + $listdepth++; + } elsif ($which_head < $listdepth) { + $listdepth--; + $index .= "\n" . ("\t" x $listdepth) . "</UL>\n"; + } } - $listdepth = $which_head; $index .= "\n" . ("\t" x $listdepth) . "<LI>" . "<A HREF=\"#" . htmlify(0,$title) . "\">" . - process_text(\$title, 0) . "</A>"; + html_escape(process_text(\$title, 0)) . "</A>"; } } @@ -817,8 +834,8 @@ sub scan_items { if ($1 eq "*") { # bullet list /\A=item\s+\*\s*(.*?)\s*\Z/s; $item = $1; - } elsif ($1 =~ /^[0-9]+/) { # numbered list - /\A=item\s+[0-9]+\.?(.*?)\s*\Z/s; + } elsif ($1 =~ /^\d+/) { # numbered list + /\A=item\s+\d+\.?(.*?)\s*\Z/s; $item = $1; } else { # /\A=item\s+(.*?)\s*\Z/s; @@ -850,6 +867,7 @@ sub process_head { print HTML "<H$level>"; # unless $listlevel; #print HTML "<H$level>" unless $listlevel; my $convert = $heading; process_text(\$convert, 0); + $convert = html_escape($convert); print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>"; print HTML "</H$level>"; # unless $listlevel; print HTML "\n"; @@ -892,30 +910,36 @@ sub process_item { print HTML "<UL>\n"; } - print HTML "<LI><STRONG>"; - $text =~ /\A\*\s*(.*)\Z/s; - print HTML "<A NAME=\"item_" . htmlify(1,$1) . "\">" if $1 && !$items_named{$1}++; - $quote = 1; - #print HTML process_puretext($1, \$quote); - print HTML $1; - print HTML "</A>" if $1; - print HTML "</STRONG>"; + print HTML '<LI>'; + if ($text =~ /\A\*\s*(.+)\Z/s) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($1); + } else { + my $name = 'item_' . htmlify(1,$1); + print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; + } + print HTML '</STRONG>'; + } - } elsif ($text =~ /\A[0-9#]+/) { # numbered list + } elsif ($text =~ /\A[\d#]+/) { # numbered list if ($need_preamble) { push(@listend, "</OL>"); print HTML "<OL>\n"; } - print HTML "<LI><STRONG>"; - $text =~ /\A[0-9]+\.?(.*)\Z/s; - print HTML "<A NAME=\"item_" . htmlify(0,$1) . "\">" if $1; - $quote = 1; - #print HTML process_puretext($1, \$quote); - print HTML $1 if $1; - print HTML "</A>" if $1; - print HTML "</STRONG>"; + print HTML '<LI>'; + if ($text =~ /\A\d+\.?\s*(.+)\Z/s) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($1); + } else { + my $name = 'item_' . htmlify(0,$1); + print HTML qq(<A NAME="$name">), html_escape($1), '</A>'; + } + print HTML '</STRONG>'; + } } else { # all others @@ -924,18 +948,17 @@ sub process_item { print HTML "<DL>\n"; } - print HTML "<DT><STRONG>"; - print HTML "<A NAME=\"item_" . htmlify(1,$text) . "\">" - if $text && !$items_named{($text =~ /(\S+)/)[0]}++; - # preceding craziness so that the duplicate leading bits in - # perlfunc work to find just the first one. otherwise - # open etc would have many names - $quote = 1; - #print HTML process_puretext($text, \$quote); - print HTML $text; - print HTML "</A>" if $text; - print HTML "</STRONG>"; - + print HTML '<DT>'; + if ($text =~ /(\S+)/) { + print HTML '<STRONG>'; + if ($items_named{$1}++) { + print HTML html_escape($text); + } else { + my $name = 'item_' . htmlify(1,$text); + print HTML qq(<A NAME="$name">), html_escape($text), '</A>'; + } + print HTML '</STRONG>'; + } print HTML '<DD>'; } @@ -991,13 +1014,19 @@ sub process_pod { # # process_for - process a =for pod tag. if it's for html, split -# it out verbatim, otherwise ignore it. +# it out verbatim, if illustration, center it, otherwise ignore it. # sub process_for { my($whom, $text) = @_; if ( $whom =~ /^(pod2)?html$/i) { print HTML $text; - } + } elsif ($whom =~ /^illustration$/i) { + 1 while chomp $text; + for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) { + $text .= $ext, last if -r "$text$ext"; + } + print HTML qq{<p align = "center"><img src = "$text" alt = "$text illustration"></p>}; + } } # @@ -1063,6 +1092,8 @@ sub process_text { }{ if (defined $pages{$2}) { # is a link qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>); + } elsif (defined $pages{dosify($2)}) { # is a link + qq($1<A HREF="$htmlroot/$pages{dosify($2)}">$2</A>); } else { "$1$2"; } @@ -1110,7 +1141,7 @@ sub process_text { # parse through the string, stopping each time we find a # pod-escape. once the string has been throughly processed # we can output it. - while ($rest) { + while (length $rest) { # check to see if there are any possible pod directives in # the remaining part of the text. if ($rest =~ m/[BCEIFLSZ]</) { @@ -1266,14 +1297,17 @@ sub process_puretext { } elsif ($word =~ m,^\w+://\w,) { # looks like a URL $word = qq(<A HREF="$word">$word</A>); - } elsif ($word =~ /[\w.-]+\@\w+\.\w/) { + } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) { # looks like an e-mail address - $word = qq(<A HREF="MAILTO:$word">$word</A>); + my ($w1, $w2, $w3) = ("", $word, ""); + ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/; + ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/; + $word = qq($w1<A HREF="mailto:$w2">$w2</A>$w3); } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) { # all uppercase? - $word = html_escape($word) if $word =~ /[&<>]/; + $word = html_escape($word) if $word =~ /["&<>]/; $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape; } else { - $word = html_escape($word) if $word =~ /[&<>]/; + $word = html_escape($word) if $word =~ /["&<>]/; } } @@ -1309,6 +1343,19 @@ sub pre_escape { } # +# dosify - convert filenames to 8.3 +# +sub dosify { + my($str) = @_; + if ($Is83) { + $str = lc $str; + $str =~ s/(\.\w+)/substr ($1,0,4)/ge; + $str =~ s/(\w+)/substr ($1,0,8)/ge; + } + return $str; +} + +# # process_L - convert a pod L<> directive to a corresponding HTML link. # most of the links made are inferred rather than known about directly # (i.e it's not known whether the =head\d section exists in the target file, @@ -1320,13 +1367,13 @@ sub pre_escape { # sub process_L { my($str) = @_; - my($s1, $s2, $linktext, $page, $section, $link); # work strings + my($s1, $s2, $linktext, $page, $page83, $section, $link); # work strings $str =~ s/\n/ /g; # undo word-wrapped tags $s1 = $str; for ($s1) { - # a :: acts like a / - s,::,/,; + # LREF: a la HREF L<show this text|man/section> + $linktext = $1 if s:^([^|]+)\|::; # make sure sections start with a / s,^",/",g; @@ -1346,15 +1393,22 @@ sub process_L { } } + $page83=dosify($page); + $page=$page83 if (defined $pages{$page83}); if ($page eq "") { $link = "#" . htmlify(0,$section); - $linktext = $section; + $linktext = $section unless defined($linktext); + } elsif ( $page =~ /::/ ) { + $linktext = ($section ? "$section" : "$page"); + $page =~ s,::,/,g; + $link = "$htmlroot/$page.html"; + $link .= "#" . htmlify(0,$section) if ($section); } elsif (!defined $pages{$page}) { warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n"; $link = ""; - $linktext = $page; + $linktext = $page unless defined($linktext); } else { - $linktext = ($section ? "$section" : "the $page manpage"); + $linktext = ($section ? "$section" : "the $page manpage") unless defined($linktext); $section = htmlify(0,$section) if $section ne ""; # if there is a directory by the name of the page, then assume that an @@ -1376,7 +1430,7 @@ sub process_L { warn "$0: $podfile: cannot resolve L$str in paragraph $paragraph: ". "no .pod or .pm found\n"; $link = ""; - $linktext = $section; + $linktext = $section unless defined($linktext); } } } @@ -1417,6 +1471,7 @@ sub process_C { $s1 =~ s/\([^()]*\)//g; # delete parentheses $s2 = $s1; $s1 =~ s/\W//g; # delete bogus characters + $str = html_escape($str); # if there was a pod file that we found earlier with an appropriate # =item directive, then create a link to that page. @@ -1486,7 +1541,7 @@ sub process_X { # after the entire pod file has been read and converted. # sub finish_list { - while ($listlevel >= 0) { + while ($listlevel > 0) { print HTML "</DL>\n"; $listlevel--; } @@ -1520,4 +1575,3 @@ BEGIN { } 1; - diff --git a/gnu/usr.bin/perl/lib/Pod/Text.pm b/gnu/usr.bin/perl/lib/Pod/Text.pm index 2b6c6b62971..549bab5a8e2 100644 --- a/gnu/usr.bin/perl/lib/Pod/Text.pm +++ b/gnu/usr.bin/perl/lib/Pod/Text.pm @@ -52,6 +52,8 @@ require Exporter; use vars qw($VERSION); $VERSION = "1.0203"; +use locale; # make \w work right in non-ASCII lands + $termcap=0; $opt_alt_format = 0; @@ -79,7 +81,7 @@ if($termcap and !$setuptermcap) { $SCREEN = ($_[0] =~ /^-(\d+)/ && (shift, $1)) || $ENV{COLUMNS} || ($ENV{TERMCAP} =~ /co#(\d+)/)[0] - || ($^O ne 'MSWin32' && (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0]) + || ($^O ne 'MSWin32' && $^O ne 'dos' && (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0]) || 72; @_ = ("<&STDIN") unless @_; @@ -165,6 +167,10 @@ sub prepare_for_output { s/I<(.*?)>/*$1*/sg; # s/[CB]<(.*?)>/bold($1)/ge; s/X<.*?>//sg; + + # LREF: a la HREF L<show this text|man/section> + s:L<([^|>]+)\|[^>]+>:$1:g; + # LREF: a manpage(3f) s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the $1$2 manpage:g; # LREF: an =item on another manpage @@ -269,14 +275,14 @@ sub prepare_for_output { my $paratag = $_; $_ = <IN>; if (/^=/) { # tricked! - local($indent) = $indent[$#index - 1] || $DEF_INDENT; + local($indent) = $indent[$#indent - 1] || $DEF_INDENT; output($paratag); redo POD_DIRECTIVE; } &prepare_for_output; IP_output($paratag, $_); } else { - local($indent) = $indent[$#index - 1] || $DEF_INDENT; + local($indent) = $indent[$#indent - 1] || $DEF_INDENT; output($_, 0); } } @@ -364,7 +370,7 @@ sub fill { sub IP_output { local($tag, $_) = @_; - local($tag_indent) = $indent[$#index - 1] || $DEF_INDENT; + local($tag_indent) = $indent[$#indent - 1] || $DEF_INDENT; $tag_cols = $SCREEN - $tag_indent; $cols = $SCREEN - $indent; $tag =~ s/\s*$//; diff --git a/gnu/usr.bin/perl/lib/SelfLoader.pm b/gnu/usr.bin/perl/lib/SelfLoader.pm index f93841c862a..311d953721f 100644 --- a/gnu/usr.bin/perl/lib/SelfLoader.pm +++ b/gnu/usr.bin/perl/lib/SelfLoader.pm @@ -3,7 +3,8 @@ use Carp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(AUTOLOAD); -$VERSION = 1.07; sub Version {$VERSION} +$VERSION = "1.08"; +sub Version {$VERSION} $DEBUG = 0; my %Cache; # private cache for all SelfLoader's client packages @@ -45,6 +46,7 @@ sub _load_stubs { unless fileno($fh); $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached + local($/) = "\n"; 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)); @@ -131,7 +133,7 @@ is available for reading via the filehandle FOOBAR::DATA, 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. +automatically retrievable, whereas data after C<__DATA__> is. The C<__DATA__> token is not recognized in versions of perl prior to 5.001m. @@ -201,7 +203,7 @@ There is no need to inherit from the B<SelfLoader>. 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 +There is a maintenance 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 C<__DATA__>. Details of the B<AutoLoader> and diff --git a/gnu/usr.bin/perl/lib/Symbol.pm b/gnu/usr.bin/perl/lib/Symbol.pm index 6807e74479a..a842c1cd7be 100644 --- a/gnu/usr.bin/perl/lib/Symbol.pm +++ b/gnu/usr.bin/perl/lib/Symbol.pm @@ -27,6 +27,11 @@ Symbol - manipulate Perl symbols and their names print { qualify_to_ref $fh } "foo!\n"; $ref = qualify_to_ref $name, $pkg; + use Symbol qw(delete_package); + delete_package('Foo::Bar'); + print "deleted\n" unless exists $Foo::{'Bar::'}; + + =head1 DESCRIPTION C<Symbol::gensym> creates an anonymous glob and returns a reference @@ -41,7 +46,7 @@ C<Symbol::qualify> turns unqualified symbol names into qualified 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 +variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with "main::". Qualification applies only to symbol names (strings). References are @@ -52,6 +57,10 @@ 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. +C<Symbol::delete_package> wipes out a whole package namespace. Note +this routine is not exported by default--you may want to import it +explicitly. + =cut BEGIN { require 5.002; } @@ -59,6 +68,7 @@ BEGIN { require 5.002; } require Exporter; @ISA = qw(Exporter); @EXPORT = qw(gensym ungensym qualify qualify_to_ref); +@EXPORT_OK = qw(delete_package); $VERSION = 1.02; @@ -101,4 +111,29 @@ sub qualify_to_ref ($;$) { return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller }; } +# +# of Safe.pm lineage +# +sub delete_package ($) { + my $pkg = shift; + + # expand to full symbol table name if needed + + unless ($pkg =~ /^main::.*::$/) { + $pkg = "main$pkg" if $pkg =~ /^::/; + $pkg = "main::$pkg" unless $pkg =~ /^main::/; + $pkg .= '::' unless $pkg =~ /::$/; + } + + my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + my $stem_symtab = *{$stem}{HASH}; + return unless defined $stem_symtab and exists $stem_symtab->{$leaf}; + + my $leaf_glob = $stem_symtab->{$leaf}; + my $leaf_symtab = *{$leaf_glob}{HASH}; + + %$leaf_symtab = (); + delete $stem_symtab->{$leaf}; +} + 1; diff --git a/gnu/usr.bin/perl/lib/Sys/Syslog.pm b/gnu/usr.bin/perl/lib/Sys/Syslog.pm index 709f5785f5d..e8faac71262 100644 --- a/gnu/usr.bin/perl/lib/Sys/Syslog.pm +++ b/gnu/usr.bin/perl/lib/Sys/Syslog.pm @@ -5,6 +5,7 @@ use Carp; @ISA = qw(Exporter); @EXPORT = qw(openlog closelog setlogmask syslog); +@EXPORT_OK = qw(setlogsock); use Socket; use Sys::Hostname; @@ -14,6 +15,10 @@ use Sys::Hostname; # Tom Christiansen <tchrist@convex.com> # modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> # NOTE: openlog now takes three arguments, just like openlog(3) +# Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu> +# with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list + +# Todo: enable connect to try all three types before failing (auto setlogsock)? =head1 NAME @@ -21,8 +26,10 @@ Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX =head1 SYNOPSIS - use Sys::Syslog; + use Sys::Syslog; # all except setlogsock, or: + use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock + setlogsock $sock_type; openlog $ident, $logopt, $facility; syslog $priority, $format, @args; $oldmask = setlogmask $mask_priority; @@ -41,7 +48,7 @@ Syslog provides the functions: =item openlog $ident, $logopt, $facility 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<$logopt> contains zero or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>. I<$facility> specifies the part of the system =item syslog $priority, $format, @args @@ -54,20 +61,18 @@ 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) - +=item setlogsock $sock_type (added in 5.004_02) + Sets the socket type to be used for the next call to -C<openlog()> or C<syslog()>. - +C<openlog()> or C<syslog()> and returns TRUE on success, +undef on failure. + 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. +C<_PATH_LOG> in F<syslog.ph>. 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. @@ -135,14 +140,19 @@ sub setlogmask { sub setlogsock { local($setsock) = shift; + &disconnect if $connected; if (lc($setsock) eq 'unix') { - if (defined &_PATH_LOG) { - $sock_unix = 1; - } else { - return undef; - } + if (defined &_PATH_LOG) { + $sock_type = 1; + } else { + return undef; + } } elsif (lc($setsock) eq 'inet') { - undef($sock_unix); + if (getservbyname('syslog','udp')) { + undef($sock_type); + } else { + return undef; + } } else { croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; } @@ -238,7 +248,7 @@ sub connect { my($host_uniq) = Sys::Hostname::hostname(); ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } - unless ( $sock_unix ) { + unless ( $sock_type ) { my $udp = getprotobyname('udp'); my $syslog = getservbyname('syslog','udp'); my $this = sockaddr_in($syslog, INADDR_ANY); @@ -248,8 +258,11 @@ sub 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: $!"; + socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!"; + if (!connect(SYSLOG,$that)) { + socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0) || croak "socket: $!"; + connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)"; + } } 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 5703405c9d2..1e95ec33b69 100644 --- a/gnu/usr.bin/perl/lib/Term/Cap.pm +++ b/gnu/usr.bin/perl/lib/Term/Cap.pm @@ -106,7 +106,7 @@ sub termcap_path { ## private # $TERMCAP, if it's a filespec push(@termcap_path, $ENV{TERMCAP}) if ((exists $ENV{TERMCAP}) && - (($^O eq 'os2' || $^O eq 'MSWin32') + (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/i : $ENV{TERMCAP} =~ /^\//)); if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) { diff --git a/gnu/usr.bin/perl/lib/Term/Complete.pm b/gnu/usr.bin/perl/lib/Term/Complete.pm index 275aadeb651..445dfca02a2 100644 --- a/gnu/usr.bin/perl/lib/Term/Complete.pm +++ b/gnu/usr.bin/perl/lib/Term/Complete.pm @@ -5,7 +5,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(Complete); -# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 +# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 =head1 NAME @@ -13,8 +13,8 @@ Term::Complete - Perl word completion module =head1 SYNOPSIS - $input = complete('prompt_string', \@completion_list); - $input = complete('prompt_string', @completion_list); + $input = Complete('prompt_string', \@completion_list); + $input = Complete('prompt_string', @completion_list); =head1 DESCRIPTION @@ -56,7 +56,7 @@ Bell sounds when word completion fails. =head1 BUGS -The completion charater E<lt>tabE<gt> cannot be changed. +The completion character E<lt>tabE<gt> cannot be changed. =head1 AUTHOR @@ -72,7 +72,11 @@ CONFIG: { } sub Complete { - my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); + my($prompt, @cmp_list, $cmp, $test, $l, @match); + my ($return, $r) = ("", 0); + + $return = ""; + $r = 0; $prompt = shift; if (ref $_[0] || $_[0] =~ /^\*/) { @@ -90,17 +94,17 @@ sub Complete { # (TAB) attempt completion $_ eq "\t" && do { @match = grep(/^$return/, @cmp_lst); - $l = length($test = shift(@match)); unless ($#match < 0) { + $l = length($test = shift(@match)); foreach $cmp (@match) { until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { $l--; } } print("\a"); + print($test = substr($test, $r, $l - $r)); + $r = length($return .= $test); } - print($test = substr($test, $r, $l - $r)); - $r = length($return .= $test); last CASE; }; @@ -113,8 +117,8 @@ sub Complete { # (^U) kill $_ eq $kill && do { if ($r) { - undef $r; - undef $return; + $r = 0; + $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 b6923dd1e7c..e7cf00cb8d1 100644 --- a/gnu/usr.bin/perl/lib/Term/ReadLine.pm +++ b/gnu/usr.bin/perl/lib/Term/ReadLine.pm @@ -139,12 +139,23 @@ 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>. +The environment 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. +As a special case, if the value of this variable is space-separated, +the tail might be used to disable the ornaments by setting the tail to +be C<o=0> or C<ornaments=0>. The head should be as described above, say + +If the variable is not set, or if the head of space-separated list is +empty, the best available package is loaded. + + export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments + export "PERL_RL= o=0" # Use best available ReadLine without ornaments + +(Note that processing of C<PERL_RL> for ornaments is in the discretion of the +particular used C<Term::ReadLine::*> package). =cut @@ -182,7 +193,7 @@ sub findConsole { $console = "sys\$command"; } - if ($^O eq 'amigaos') { + if (($^O eq 'amigaos') || ($^O eq 'beos')) { $console = undef; } elsif ($^O eq 'os2') { @@ -205,7 +216,7 @@ sub new { die "method new called with wrong number of arguments" unless @_==2 or @_==4; #local (*FIN, *FOUT); - my ($FIN, $FOUT); + my ($FIN, $FOUT, $ret); if (@_==2) { ($console, $consoleOUT) = findConsole; @@ -215,15 +226,21 @@ sub new { $sel = select(FOUT); $| = 1; # for DB::OUT select($sel); - bless [\*FIN, \*FOUT]; + $ret = bless [\*FIN, \*FOUT]; } else { # Filehandles supplied $FIN = $_[2]; $FOUT = $_[3]; #OUT->autoflush(1); # Conflicts with debugger? $sel = select($FOUT); $| = 1; # for DB::OUT select($sel); - bless [$FIN, $FOUT]; + $ret = bless [$FIN, $FOUT]; } + if ($ret->Features->{ornaments} + and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) { + local $Term::ReadLine::termcap_nowarn = 1; + $ret->ornaments(1); + } + return $ret; } sub newTTY { @@ -245,7 +262,7 @@ sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? -my $which = $ENV{PERL_RL}; +my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; if ($which) { if ($which =~ /\bgnu\b/i){ eval "use Term::ReadLine::Gnu;"; @@ -254,7 +271,7 @@ if ($which) { } else { eval "use Term::ReadLine::$which;"; } -} elsif (defined $which) { # Defined but false +} elsif (defined $which and $which ne '') { # Defined but false # Do nothing fancy } else { eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1"; @@ -293,10 +310,14 @@ sub ornaments { return $rl_term_set unless @_; $rl_term_set = shift; $rl_term_set ||= ',,,'; - $rl_term_set = 'us,ue,md,me' if $rl_term_set == 1; + $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1'; my @ts = split /,/, $rl_term_set, 4; eval { LoadTermCap }; - warn("Cannot find termcap: $@\n"), return unless defined $terminal; + unless (defined $terminal) { + warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn; + $rl_term_set = ',,,'; + return; + } @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts; return $rl_term_set; } @@ -336,6 +357,7 @@ sub get_line { my $self = shift; $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; my $in = $self->IN; + local ($/) = "\n"; return scalar <$in>; } diff --git a/gnu/usr.bin/perl/lib/Test/Harness.pm b/gnu/usr.bin/perl/lib/Test/Harness.pm index f5fc3d8cc55..935e8f07d22 100644 --- a/gnu/usr.bin/perl/lib/Test/Harness.pm +++ b/gnu/usr.bin/perl/lib/Test/Harness.pm @@ -11,7 +11,15 @@ use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest @ISA @EXPORT @EXPORT_OK); $have_devel_corestack = 0; -$VERSION = "1.1502"; +$VERSION = "1.1602"; + +# Some experimental versions of OS/2 build have broken $? +my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE}; + +my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR}; + +my $tests_skipped = 0; +my $subtests_skipped = 0; @ISA=('Exporter'); @EXPORT= qw(&runtests); @@ -40,10 +48,12 @@ format STDOUT = $verbose = 0; $switches = "-w"; +sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f } + sub runtests { my(@tests) = @_; local($|) = 1; - my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests); + my($test,$te,$ok,$next,$max,$pct,$totok,$totbonus,@failed,%failedtests); my $totmax = 0; my $files = 0; my $bad = 0; @@ -56,6 +66,7 @@ sub runtests { if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g } + my @dir_files = globdir $files_in_dir if defined $files_in_dir; my $t_start = new Benchmark; while ($test = shift(@tests)) { $te = $test; @@ -68,16 +79,27 @@ sub runtests { my $s = $switches; $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/; $fh->close or print "can't close $test. $!\n"; - my $cmd = "$^X $s $test|"; + my $cmd = ($ENV{'COMPILE_TEST'})? +"./perl -I../lib ../utils/perlcc $test -run -verbose dcf -log ./compilelog |" + : "$^X $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; $fh->open($cmd) or print "can't run $test. $!\n"; $ok = $next = $max = 0; @failed = (); + my %todo = (); + my $bonus = 0; + my $skipped = 0; while (<$fh>) { if( $verbose ){ print $_; } - if (/^1\.\.([0-9]+)/) { + if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) { + $max = $1; + for (split(/\s+/, $2)) { $todo{$_} = 1; } + $totmax += $max; + $files++; + $next = 1; + } elsif (/^1\.\.([0-9]+)/) { $max = $1; $totmax += $max; $files++; @@ -86,11 +108,18 @@ sub runtests { my $this = $next; if (/^not ok\s*(\d*)/){ $this = $1 if $1 > 0; - push @failed, $this; - } elsif (/^ok\s*(\d*)/) { + if (!$todo{$this}) { + push @failed, $this; + } else { + $ok++; + $totok++; + } + } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip)?/) { $this = $1 if $1 > 0; $ok++; $totok++; + $skipped++ if defined $2; + $bonus++, $totbonus++ if $todo{$this}; } if ($this > $next) { # warn "Test output counter mismatch [test $this]\n"; @@ -105,7 +134,7 @@ sub runtests { } } $fh->close; # must close to reap child resource values - my $wstatus = $?; + my $wstatus = $ignore_exitcode ? 0 : $?; # Can trust $? ? my $estatus; $estatus = ($^O eq 'VMS' ? eval 'use vmsish "status"; $estatus = $?' @@ -131,7 +160,7 @@ sub runtests { } else { push @failed, $next..$max; $failed = @failed; - (my $txt, $canon) = canonfailed($max,@failed); + (my $txt, $canon) = canonfailed($max,$skipped,@failed); $percent = 100*(scalar @failed)/$max; print "DIED. ",$txt; } @@ -142,10 +171,19 @@ sub runtests { estat => $estatus, wstat => $wstatus, }; } elsif ($ok == $max && $next == $max+1) { - if ($max) { + if ($max and $skipped + $bonus) { + my @msg; + push(@msg, "$skipped/$max subtest".($skipped>1?'s':'')." skipped") + if $skipped; + push(@msg, "$bonus subtest".($bonus>1?'s':''). + " unexpectedly succeeded") + if $bonus; + print "ok, ".join(', ', @msg)."\n"; + } elsif ($max) { print "ok\n"; } else { print "skipping test on this platform\n"; + $tests_skipped++; } $good++; } elsif ($max) { @@ -153,7 +191,7 @@ sub runtests { push @failed, $next..$max; } if (@failed) { - my ($txt, $canon) = canonfailed($max,@failed); + my ($txt, $canon) = canonfailed($max,$skipped,@failed); print $txt; $failedtests{$test} = { canon => $canon, max => $max, failed => scalar @failed, @@ -178,6 +216,18 @@ sub runtests { estat => '', wstat => '', }; } + $subtests_skipped += $skipped; + if (defined $files_in_dir) { + my @new_dir_files = globdir $files_in_dir; + if (@new_dir_files != @dir_files) { + my %f; + @f{@new_dir_files} = (1) x @new_dir_files; + delete @f{@dir_files}; + my @f = sort keys %f; + print "LEAKED FILES: @f\n"; + @dir_files = @new_dir_files; + } + } } my $t_total = timediff(new Benchmark, $t_start); @@ -188,8 +238,22 @@ sub runtests { delete $ENV{PERL5LIB}; } } + my $bonusmsg = ''; + $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':''). + " UNEXPECTEDLY SUCCEEDED)") + if $totbonus; + if ($tests_skipped) { + $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '') . + ' skipped'; + } + if ($subtests_skipped) { + $bonusmsg .= ($tests_skipped ? ', plus ' : ', '). + "$subtests_skipped subtest" + . ($subtests_skipped != 1 ? 's' : '') . + " skipped"; + } if ($bad == 0 && $totmax) { - print "All tests successful.\n"; + print "All tests successful$bonusmsg.\n"; } elsif ($total==0){ die "FAILED--no tests were run for some reason.\n"; } elsif ($totmax==0) { @@ -205,6 +269,8 @@ sub runtests { write; } if ($bad) { + $bonusmsg =~ s/^,\s*//; + print "$bonusmsg.\n" if $bonusmsg; die "Failed $bad/$total test scripts, $pct% okay.$subpct\n"; } } @@ -234,7 +300,7 @@ sub corestatus { } sub canonfailed ($@) { - my($max,@failed) = @_; + my($max,$skipped,@failed) = @_; my %seen; @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed; my $failed = @failed; @@ -264,7 +330,12 @@ sub canonfailed ($@) { } push @result, "\tFailed $failed/$max tests, "; - push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n"; + push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay"; + my $ender = 's' x ($skipped > 1); + my $good = $max - $failed - $skipped; + my $goodper = sprintf("%.2f",100*($good/$max)); + push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped; + push @result, "\n"; my $txt = join "", @result; ($txt, $canon); } @@ -284,6 +355,10 @@ runtests(@tests); =head1 DESCRIPTION +(By using the L<Test> module, you can write test scripts without +knowing the exact output this module expects. However, if you need to +know the specifics, read on!) + 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 script is C<"1..M"> with C<M> being the @@ -328,6 +403,11 @@ 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>. +If the standard output line contains substring C< # Skip> (with +variations in spacing and case) after C<ok> or C<ok NUMBER>, it is +counted as a skipped test. If the whole testscript succeeds, the +count of skipped tests is included in the generated output. + =head1 EXPORT C<&runtests> is exported by Test::Harness per default. @@ -360,9 +440,25 @@ above messages. =back +=head1 ENVIRONMENT + +Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status +of child processes. + +If C<HARNESS_FILELEAK_IN_DIR> is set to the name of a directory, harness +will check after each test whether new files appeared in that directory, +and report them as + + LEAKED FILES: scr.tmp 0 my.db + +If relative, directory name is with respect to the current directory at +the moment runtests() was called. Putting absolute path into +C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results. + =head1 SEE ALSO -See L<Benchmark> for the underlying timing routines. +L<Test> for writing test scripts and also L<Benchmark> for the +underlying timing routines. =head1 AUTHORS diff --git a/gnu/usr.bin/perl/lib/Text/ParseWords.pm b/gnu/usr.bin/perl/lib/Text/ParseWords.pm index 62da1d273fe..065c2f72551 100644 --- a/gnu/usr.bin/perl/lib/Text/ParseWords.pm +++ b/gnu/usr.bin/perl/lib/Text/ParseWords.pm @@ -1,140 +1,102 @@ package Text::ParseWords; -require 5.000; -use Carp; +use vars qw($VERSION @ISA @EXPORT $PERL_SINGLE_QUOTE); +$VERSION = "3.1"; -require AutoLoader; -*AUTOLOAD = \&AutoLoader::AUTOLOAD; +require 5.000; -require Exporter; +use Exporter; @ISA = qw(Exporter); -@EXPORT = qw(shellwords quotewords); +@EXPORT = qw(shellwords quotewords nested_quotewords parse_line); @EXPORT_OK = qw(old_shellwords); -=head1 NAME - -Text::ParseWords - parse text into an array of tokens - -=head1 SYNOPSIS - - use Text::ParseWords; - @words = "ewords($delim, $keep, @lines); - @words = &shellwords(@lines); - @words = &old_shellwords(@lines); - -=head1 DESCRIPTION -"ewords() accepts a delimiter (which can be a regular expression) -and a list of lines and then breaks those lines up into a list of -words ignoring delimiters that appear inside quotes. - -The $keep argument is a boolean flag. If true, the quotes are kept -with each word, otherwise quotes are stripped in the splitting process. -$keep also defines whether unprotected backslashes are retained. - -A &shellwords() replacement is included to demonstrate the new package. -This version differs from the original in that it will _NOT_ default -to using $_ if no arguments are given. I personally find the old behavior -to be a mis-feature. - -"ewords() works by simply jamming all of @lines into a single -string in $_ and then pulling off words a bit at a time until $_ -is exhausted. +sub shellwords { + local(@lines) = @_; + $lines[$#lines] =~ s/\s+$//; + return(quotewords('\s+', 0, @lines)); +} -=head1 AUTHORS -Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 -Basically an update and generalization of the old shellwords.pl. -Much code shamelessly stolen from the old version (author unknown). +sub quotewords { + my($delim, $keep, @lines) = @_; + my($line, @words, @allwords); + + + foreach $line (@lines) { + @words = parse_line($delim, $keep, $line); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); +} -=cut -1; -__END__ -sub shellwords { - local(@lines) = @_; - $lines[$#lines] =~ s/\s+$//; - "ewords('\s+', 0, @lines); +sub nested_quotewords { + my($delim, $keep, @lines) = @_; + my($i, @allwords); + + for ($i = 0; $i < @lines; $i++) { + @{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]); + return() unless (@{$allwords[$i]} || !length($lines[$i])); + } + return(@allwords); } -sub quotewords { +sub parse_line { + # We will be testing undef strings + local($^W) = 0; -# The inner "for" loop builds up each word (or $field) one $snippet -# at a time. A $snippet is a quoted string, a backslashed character, -# or an unquoted string. We fall out of the "for" loop when we reach -# the end of $_ or when we hit a delimiter. Falling out of the "for" -# loop, we push the $field we've been building up onto the list of -# @words we'll be returning, and then loop back and pull another word -# off of $_. -# -# The first two cases inside the "for" loop deal with quoted strings. -# The first case matches a double quoted string, removes it from $_, -# and assigns the double quoted string to $snippet in the body of the -# conditional. The second case handles single quoted strings. In -# the third case we've found a quote at the current beginning of $_, -# but it didn't match the quoted string regexps in the first two cases, -# so it must be an unbalanced quote and we croak with an error (which can -# be caught by eval()). -# -# The next case handles backslashed characters, and the next case is the -# exit case on reaching the end of the string or finding a delimiter. -# -# Otherwise, we've found an unquoted thing and we pull of characters one -# at a time until we reach something that could start another $snippet-- -# a quote of some sort, a backslash, or the delimiter. This one character -# at a time behavior was necessary if the delimiter was going to be a -# regexp (love to hear it if you can figure out a better way). - - my ($delim, $keep, @lines) = @_; - my (@words, $snippet, $field); - - local $_ = join ('', @lines); - - while (length) { - $field = ''; + my($delimiter, $keep, $line) = @_; + my($quote, $quoted, $unquoted, $delim, $word, @pieces); - for (;;) { - $snippet = ''; + while (length($line)) { - if (s/^"([^"\\]*(\\.[^"\\]*)*)"//) { - $snippet = $1; - $snippet = qq|"$snippet"| if $keep; - } - elsif (s/^'([^'\\]*(\\.[^'\\]*)*)'//) { - $snippet = $1; - $snippet = "'$snippet'" if $keep; - } - elsif (/^["']/) { - croak 'Unmatched quote'; - } - elsif (s/^\\(.)//) { - $snippet = $1; - $snippet = "\\$snippet" if $keep; - } - elsif (!length || s/^$delim//) { - last; - } - else { - while (length && !(/^$delim/ || /^['"\\]/)) { - $snippet .= substr ($_, 0, 1); - substr($_, 0, 1) = ''; - } - } + ($quote, $quoted, undef, $unquoted, $delim, undef) = + $line =~ m/^(["']) # a $quote + ((?:\\.|(?!\1)[^\\])*) # and $quoted text + \1 # followed by the same quote + ([\000-\377]*) # and the rest + | # --OR-- + ^((?:\\.|[^\\"'])*?) # an $unquoted text + (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["'])) + # plus EOL, delimiter, or quote + ([\000-\377]*) # the rest + /x; # extended layout + return() unless( $quote || length($unquoted) || length($delim)); - $field .= $snippet; - } + $line = $+; - push @words, $field; + if ($keep) { + $quoted = "$quote$quoted$quote"; + } + else { + $unquoted =~ s/\\(.)/$1/g; + if (defined $quote) { + $quoted =~ s/\\(.)/$1/g if ($quote eq '"'); + $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); + } + } + $word .= defined $quote ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); + } } - - return @words; + return(@pieces); } + sub old_shellwords { # Usage: @@ -154,13 +116,13 @@ sub old_shellwords { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { - croak "Unmatched double quote: $_"; + return(); } elsif (s/^'(([^'\\]|\\.)*)'//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^'/) { - croak "Unmatched single quote: $_"; + return(); } elsif (s/^\\(.)//) { $snippet = $1; @@ -178,3 +140,117 @@ sub old_shellwords { } @words; } + +1; + +__END__ + +=head1 NAME + +Text::ParseWords - parse text into an array of tokens or array of arrays + +=head1 SYNOPSIS + + use Text::ParseWords; + @lists = &nested_quotewords($delim, $keep, @lines); + @words = "ewords($delim, $keep, @lines); + @words = &shellwords(@lines); + @words = &parse_line($delim, $keep, $line); + @words = &old_shellwords(@lines); # DEPRECATED! + +=head1 DESCRIPTION + +The &nested_quotewords() and "ewords() functions accept a delimiter +(which can be a regular expression) +and a list of lines and then breaks those lines up into a list of +words ignoring delimiters that appear inside quotes. "ewords() +returns all of the tokens in a single long list, while &nested_quotewords() +returns a list of token lists corresponding to the elements of @lines. +&parse_line() does tokenizing on a single string. The &*quotewords() +functions simply call &parse_lines(), so if you're only splitting +one line you can call &parse_lines() directly and save a function +call. + +The $keep argument is a boolean flag. If true, then the tokens are +split on the specified delimiter, but all other characters (quotes, +backslashes, etc.) are kept in the tokens. If $keep is false then the +&*quotewords() functions remove all quotes and backslashes that are +not themselves backslash-escaped or inside of single quotes (i.e., +"ewords() tries to interpret these characters just like the Bourne +shell). NB: these semantics are significantly different from the +original version of this module shipped with Perl 5.000 through 5.004. +As an additional feature, $keep may be the keyword "delimiters" which +causes the functions to preserve the delimiters in each string as +tokens in the token lists, in addition to preserving quote and +backslash characters. + +&shellwords() is written as a special case of "ewords(), and it +does token parsing with whitespace as a delimiter-- similar to most +Unix shells. + +=head1 EXAMPLES + +The sample program: + + use Text::ParseWords; + @words = "ewords('\s+', 0, q{this is "a test" of\ quotewords \"for you}); + $i = 0; + foreach (@words) { + print "$i: <$_>\n"; + $i++; + } + +produces: + + 0: <this> + 1: <is> + 2: <a test> + 3: <of quotewords> + 4: <"for> + 5: <you> + +demonstrating: + +=over 4 + +=item 0 +a simple word + +=item 1 +multiple spaces are skipped because of our $delim + +=item 2 +use of quotes to include a space in a word + +=item 3 +use of a backslash to include a space in a word + +=item 4 +use of a backslash to remove the special meaning of a double-quote + +=item 5 +another simple word (note the lack of effect of the +backslashed double-quote) + +=back + +Replacing C<"ewords('\s+', 0, q{this is...})> +with C<&shellwords(q{this is...})> +is a simpler way to accomplish the same thing. + +=head1 AUTHORS + +Maintainer is Hal Pomeranz <pomeranz@netcom.com>, 1994-1997 (Original +author unknown). Much of the code for &parse_line() (including the +primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>. + +Examples section another documentation provided by John Heidemann +<johnh@ISI.EDU> + +Bug reports, patches, and nagging provided by lots of folks-- thanks +everybody! Special thanks to Michael Schwern <schwern@envirolink.org> +for assuring me that a &nested_quotewords() would be useful, and to +Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about +error-checking (sort of-- you had to be there). + +=cut diff --git a/gnu/usr.bin/perl/lib/Text/Soundex.pm b/gnu/usr.bin/perl/lib/Text/Soundex.pm index a70c14219a5..c8619011b8e 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.2 1997/11/30 07:58:05 millert Exp $ +# $Id: Soundex.pm,v 1.3 1999/04/29 22:52:00 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.2 1997/11/30 07:58:05 millert -# perl 5.004_04 +# Revision 1.3 1999/04/29 22:52:00 millert +# perl5.005_03 (stock) # # Revision 1.2 1994/03/24 00:30:27 mike # Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> diff --git a/gnu/usr.bin/perl/lib/Text/Wrap.pm b/gnu/usr.bin/perl/lib/Text/Wrap.pm index 0910a2ab345..5f95edb69c7 100644 --- a/gnu/usr.bin/perl/lib/Text/Wrap.pm +++ b/gnu/usr.bin/perl/lib/Text/Wrap.pm @@ -2,18 +2,20 @@ package Text::Wrap; require Exporter; -@ISA = (Exporter); -@EXPORT = qw(wrap); -@EXPORT_OK = qw($columns); +@ISA = qw(Exporter); +@EXPORT = qw(wrap fill); +@EXPORT_OK = qw($columns $break $huge); -$VERSION = 97.011701; +$VERSION = 98.112902; -use vars qw($VERSION $columns $debug); +use vars qw($VERSION $columns $debug $break $huge); use strict; BEGIN { $columns = 76; # <= screen width $debug = 0; + $break = '\s'; + $huge = 'wrap'; # alternatively: 'die' } use Text::Tabs qw(expand unexpand); @@ -25,38 +27,29 @@ sub wrap my $r = ""; my $t = expand(join(" ",@t)); my $lead = $ip; - my $ll = $columns - length(expand($lead)) - 1; + my $ll = $columns - length(expand($ip)) - 1; + my $nll = $columns - length(expand($xp)) - 1; my $nl = ""; - - # remove up to a line length of things that aren't - # new lines and tabs. - - if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm) { - - # accept it. - $r .= unexpand($lead . $1); - - # recompute the leader - $lead = $xp; - $ll = $columns - length(expand($lead)) - 1; - $nl = $2; - - # repeat the above until there's none left - while ($t) { - if ( $t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm ) { - print "\$2 is '$2'\n" if $debug; - $nl = $2; - $r .= unexpand("\n" . $lead . $1); - } elsif ($t =~ s/^([^\n]{$ll})//) { - $nl = "\n"; - $r .= unexpand("\n" . $lead . $1); - } + my $remainder = ""; + + while ($t !~ /^\s*$/) { + if ($t =~ s/^([^\n]{0,$ll})($break|\Z(?!\n))//xm) { + $r .= unexpand($nl . $lead . $1); + $remainder = $2; + } elsif ($huge eq 'wrap' && $t =~ s/^([^\n]{$ll})//) { + $r .= unexpand($nl . $lead . $1); + $remainder = "\n"; + } elsif ($huge eq 'die') { + die "couldn't wrap '$t'"; + } else { + die "This shouldn't happen"; } - $r .= $nl; - } - - die "couldn't wrap '$t'" - if length($t) > $ll; + + $lead = $xp; + $ll = $nll; + $nl = "\n"; + } + $r .= $remainder; print "-----------$r---------\n" if $debug; @@ -68,6 +61,24 @@ sub wrap return $r; } +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); +} + 1; __END__ @@ -80,66 +91,42 @@ Text::Wrap - line wrapping to form simple paragraphs use Text::Wrap print wrap($initial_tab, $subsequent_tab, @text); + print fill($initial_tab, $subsequent_tab, @text); - use Text::Wrap qw(wrap $columns); + use Text::Wrap qw(wrap $columns $huge); $columns = 132; + $huge = 'die'; + $huge = 'wrap'; =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. +single paragraph at a time by breaking lines at word boundaries. 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. +all subsequent lines ($subsequent_tab) independently. -=head1 EXAMPLE - - print wrap("\t","","This is a bit of text that forms - a normal book-style paragraph"); +Lines are wrapped at $Text::Wrap::columns columns. +$Text::Wrap::columns should be set to the full width of your output device. -=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`); +When words that are longer than $columns are encountered, they +are broken up. Previous versions of wrap() die()ed instead. +To restore the old (dying) behavior, set $Text::Wrap::huge to +'die'. 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 +will destroy 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; +=head1 EXAMPLE - for $pp (split(/\n\s+/, join("\n",@raw))) { - $pp =~ s/\s+/ /g; - my $x = wrap($ip, $xp, $pp); - push(@para, $x); - } + print wrap("\t","","This is a bit of text that forms + a normal book-style paragraph"); - # if paragraph_indent is the same as line_indent, - # separate paragraphs with blank lines +=head1 AUTHOR - return join ($ip eq $xp ? "\n\n" : "\n", @para); -} +David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and +many many others. diff --git a/gnu/usr.bin/perl/lib/Tie/Hash.pm b/gnu/usr.bin/perl/lib/Tie/Hash.pm index 2117c54c183..2902efb4d0d 100644 --- a/gnu/usr.bin/perl/lib/Tie/Hash.pm +++ b/gnu/usr.bin/perl/lib/Tie/Hash.pm @@ -67,7 +67,7 @@ Return the (key, value) pair for the first key in the hash. =item NEXTKEY this, lastkey -Return the next (key, value) pair for the hash. +Return the next key for the hash. =item EXISTS this, key @@ -92,7 +92,7 @@ but may be omitted in favor of a simple default. =head1 MORE INFORMATION -The packages relating to various DBM-related implemetations (F<DB_File>, +The packages relating to various DBM-related implementations (F<DB_File>, F<NDBM_File>, etc.) show examples of general tied hashes, as does the L<Config> module. While these do not utilize B<Tie::Hash>, they serve as good working examples. @@ -110,7 +110,7 @@ sub new { sub TIEHASH { my $pkg = shift; - if (defined &{"{$pkg}::new"}) { + if (defined &{"${pkg}::new"}) { carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" if $^W; $pkg->new(@_); diff --git a/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm b/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm index 44c2140c7be..4b18a58e122 100644 --- a/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm +++ b/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm @@ -69,7 +69,7 @@ sub FETCH { sub STORE { local($self,$key,$val) = @_; local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; - croak("Table is full") if $self[5] == $tsize; + croak("Table is full") if $$self[5] == $tsize; croak(qq/Value "$val" is not $vlen characters long./) if length($val) != $vlen; my $writeoffset; diff --git a/gnu/usr.bin/perl/lib/Time/Local.pm b/gnu/usr.bin/perl/lib/Time/Local.pm index eef412d46d7..b2fba7ccc1e 100644 --- a/gnu/usr.bin/perl/lib/Time/Local.pm +++ b/gnu/usr.bin/perl/lib/Time/Local.pm @@ -17,16 +17,18 @@ Time::Local - efficiently compute time from local and GMT time =head1 DESCRIPTION -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. +These routines are quite efficient and yet are always guaranteed to +agree with localtime() and gmtime(), the most notable points being +that year is year-1900 and month is 0..11. 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. 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 diff --git a/gnu/usr.bin/perl/lib/Time/gmtime.pm b/gnu/usr.bin/perl/lib/Time/gmtime.pm index c1d11d74dbb..9b823f601e3 100644 --- a/gnu/usr.bin/perl/lib/Time/gmtime.pm +++ b/gnu/usr.bin/perl/lib/Time/gmtime.pm @@ -69,7 +69,7 @@ still overrides your core functions.) Access these fields as variables named with a preceding C<tm_> in front their method names. Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. -The gmctime() funtion provides a way of getting at the +The gmctime() function provides a way of getting at the scalar sense of the original CORE::gmtime() function. To access this functionality without the core overrides, diff --git a/gnu/usr.bin/perl/lib/Time/localtime.pm b/gnu/usr.bin/perl/lib/Time/localtime.pm index 94377525973..18a36c7fb91 100644 --- a/gnu/usr.bin/perl/lib/Time/localtime.pm +++ b/gnu/usr.bin/perl/lib/Time/localtime.pm @@ -65,7 +65,7 @@ variables named with a preceding C<tm_> in front their method names. Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. -The ctime() funtion provides a way of getting at the +The ctime() function provides a way of getting at the scalar sense of the original CORE::localtime() function. To access this functionality without the core overrides, diff --git a/gnu/usr.bin/perl/lib/User/grent.pm b/gnu/usr.bin/perl/lib/User/grent.pm index deb0a8d1be9..e4e226d119a 100644 --- a/gnu/usr.bin/perl/lib/User/grent.pm +++ b/gnu/usr.bin/perl/lib/User/grent.pm @@ -74,7 +74,7 @@ to $gr_gid if you import the fields. Array references are available as regular array variables, so C<@{ $group_obj-E<gt>members() }> would be simply @gr_members. -The getpw() funtion is a simple front-end that forwards +The getpw() function is a simple front-end that forwards a numeric argument to getpwuid() and the rest to getpwnam(). To access this functionality without the core overrides, diff --git a/gnu/usr.bin/perl/lib/User/pwent.pm b/gnu/usr.bin/perl/lib/User/pwent.pm index 32301cadfc5..bb2dace6823 100644 --- a/gnu/usr.bin/perl/lib/User/pwent.pm +++ b/gnu/usr.bin/perl/lib/User/pwent.pm @@ -84,7 +84,7 @@ variables named with a preceding C<pw_> in front their method names. Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import the fields. -The getpw() funtion is a simple front-end that forwards +The getpw() function is a simple front-end that forwards a numeric argument to getpwuid() and the rest to getpwnam(). To access this functionality without the core overrides, diff --git a/gnu/usr.bin/perl/lib/autouse.pm b/gnu/usr.bin/perl/lib/autouse.pm index ab95a19d8ab..4445c6c419b 100644 --- a/gnu/usr.bin/perl/lib/autouse.pm +++ b/gnu/usr.bin/perl/lib/autouse.pm @@ -146,15 +146,6 @@ The first line ensures that the errors in your argument specification are found early. When you ship your application you should comment out the first line, since it makes the second one useless. -=head1 BUGS - -If Module::func3() is autoused, and the module is loaded between the -C<autouse> directive and a call to Module::func3(), warnings about -redefinition would appear if warnings are enabled. - -If Module::func3() is autoused, warnings are disabled when loading the -module via autoused functions. - =head1 AUTHOR Ilya Zakharevich (ilya@math.ohio-state.edu) diff --git a/gnu/usr.bin/perl/lib/base.pm b/gnu/usr.bin/perl/lib/base.pm index e20a64bc9a4..3500cbfb898 100644 --- a/gnu/usr.bin/perl/lib/base.pm +++ b/gnu/usr.bin/perl/lib/base.pm @@ -5,7 +5,6 @@ base - Establish IS-A relationship with base class at compile time =head1 SYNOPSIS package Baz; - use base qw(Foo Bar); =head1 DESCRIPTION @@ -18,11 +17,19 @@ Roughly similar in effect to push @ISA, qw(Foo Bar); } +Will also initialize the %FIELDS hash if one of the base classes has +it. Multiple inheritance of %FIELDS is not supported. The 'base' +pragma will croak if multiple base classes has a %FIELDS hash. See +L<fields> for a description of this feature. + +When strict 'vars' is in scope I<base> also let you assign to @ISA +without having to declare @ISA with the 'vars' pragma first. + This module was introduced with Perl 5.004_04. -=head1 BUGS +=head1 SEE ALSO -Needs proper documentation! +L<fields> =cut @@ -30,10 +37,14 @@ package base; sub import { my $class = shift; + my $fields_base; foreach my $base (@_) { unless (defined %{"$base\::"}) { eval "require $base"; + # Only ignore "Can't locate" errors from our eval require. + # Other fatal errors (syntax etc) must be reported. + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; unless (defined %{"$base\::"}) { require Carp; Carp::croak("Base class package \"$base\" is empty.\n", @@ -41,9 +52,26 @@ sub import { "which defines that package first.)"); } } + + # A simple test like (defined %{"$base\::FIELDS"}) will + # sometimes produce typo warnings because it would create + # the hash if it was not present before. + my $fglob; + if ($fglob = ${"$base\::"}{"FIELDS"} and *$fglob{HASH}) { + if ($fields_base) { + require Carp; + Carp::croak("Can't multiply inherit %FIELDS"); + } else { + $fields_base = $base; + } + } + } + my $pkg = caller(0); + push @{"$pkg\::ISA"}, @_; + if ($fields_base) { + require fields; + fields::inherit($pkg, $fields_base); } - - push @{caller(0) . '::ISA'}, @_; } 1; diff --git a/gnu/usr.bin/perl/lib/bigint.pl b/gnu/usr.bin/perl/lib/bigint.pl index bfd2efa88c8..adeb17f28a9 100644 --- a/gnu/usr.bin/perl/lib/bigint.pl +++ b/gnu/usr.bin/perl/lib/bigint.pl @@ -74,7 +74,7 @@ sub external { #(int_num_array) return num_str sub main'bneg { #(num_str) return num_str local($_) = &'bnorm(@_); vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; - s/^H/N/; + s/^./N/ unless /^[-+]/; # works both in ASCII and EBCDIC $_; } diff --git a/gnu/usr.bin/perl/lib/blib.pm b/gnu/usr.bin/perl/lib/blib.pm index 9e0f6c07c3d..1d56a58174e 100644 --- a/gnu/usr.bin/perl/lib/blib.pm +++ b/gnu/usr.bin/perl/lib/blib.pm @@ -45,6 +45,7 @@ sub import { my $package = shift; my $dir = getcwd; + if ($^O eq 'VMS') { ($dir = VMS::Filespec::unixify($dir)) =~ s-/$--; } if (@_) { $dir = shift; diff --git a/gnu/usr.bin/perl/lib/constant.pm b/gnu/usr.bin/perl/lib/constant.pm index a0d4f9d5cda..5d3dd91b46f 100644 --- a/gnu/usr.bin/perl/lib/constant.pm +++ b/gnu/usr.bin/perl/lib/constant.pm @@ -20,6 +20,18 @@ constant - Perl pragma to declare constants print "This line does nothing" unless DEBUGGING; + # references can be declared constant + use constant CHASH => { foo => 42 }; + use constant CARRAY => [ 1,2,3,4 ]; + use constant CPSEUDOHASH => [ { foo => 1}, 42 ]; + use constant CCODE => sub { "bite $_[0]\n" }; + + print CHASH->{foo}; + print CARRAY->[$i]; + print CPSEUDOHASH->{foo}; + print CCODE->("me"); + print CHASH->[10]; # compile-time error + =head1 DESCRIPTION This will declare a symbol to be a constant with the given scalar @@ -86,6 +98,8 @@ constants at compile time, allowing for way cool stuff like this. print E2BIG, "\n"; # something like "Arg list too long" print 0+E2BIG, "\n"; # "7" +Errors in dereferencing constant references are trapped at compile-time. + =head1 TECHNICAL NOTE In the current implementation, scalar constants are actually @@ -106,6 +120,15 @@ name as a constant. This is probably a Good Thing. Unlike constants in some languages, these cannot be overridden on the command line or via environment variables. +You can get into trouble if you use constants in a context which +automatically quotes barewords (as is true for any subroutine call). +For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will +be interpreted as a string. Use C<$hash{CONSTANT()}> or +C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from +kicking in. Similarly, since the C<=E<gt>> operator quotes a bareword +immediately to its left you have to say C<CONSTANT() =E<gt> 'value'> +instead of C<CONSTANT =E<gt> 'value'>. + =head1 AUTHOR Tom Phoenix, E<lt>F<rootbeer@teleport.com>E<gt>, with help from diff --git a/gnu/usr.bin/perl/lib/diagnostics.pm b/gnu/usr.bin/perl/lib/diagnostics.pm index 78bf4457cba..b9aaba5c392 100644 --- a/gnu/usr.bin/perl/lib/diagnostics.pm +++ b/gnu/usr.bin/perl/lib/diagnostics.pm @@ -27,7 +27,7 @@ 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 with the more +perl compiler and the perl interpreter, augmenting them with the more explicative and endearing descriptions found in L<perldiag>. Like the other pragmata, it affects the compilation phase of your program rather than merely the execution phase. diff --git a/gnu/usr.bin/perl/lib/dumpvar.pl b/gnu/usr.bin/perl/lib/dumpvar.pl index c32bc2fb5e1..32d4692d13a 100644 --- a/gnu/usr.bin/perl/lib/dumpvar.pl +++ b/gnu/usr.bin/perl/lib/dumpvar.pl @@ -22,6 +22,8 @@ $printUndef = 1 unless defined $printUndef; $tick = "auto" unless defined $tick; $unctrl = 'quote' unless defined $unctrl; $subdump = 1; +$dumpReused = 0 unless defined $dumpReused; +$bareStringify = 1 unless defined $bareStringify; sub main::dumpValue { local %address; @@ -49,6 +51,10 @@ sub stringify { return 'undef' unless defined $_ or not $printUndef; return $_ . "" if ref \$_ eq 'GLOB'; + $_ = &{'overload::StrVal'}($_) + if $bareStringify and ref $_ + and defined %overload:: and defined &{'overload::StrVal'}; + if ($tick eq 'auto') { if (/[\000-\011\013-\037\177]/) { $tick = '"'; @@ -109,7 +115,7 @@ sub unwrap { return if $DB::signal; local($v) = shift ; local($s) = shift ; # extra no of spaces - local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ; + local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ; local($tHashDepth,$tArrayDepth) ; $sp = " " x $s ; @@ -117,9 +123,11 @@ sub unwrap { # Check for reused addresses if (ref $v) { - ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; - if (defined $address) { - ($type) = $v =~ /=(.*?)\([^=]+$/ ; + my $val = $v; + $val = &{'overload::StrVal'}($v) + if defined %overload:: and defined &{'overload::StrVal'}; + ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; + if (!$dumpReused && defined $address) { $address{$address}++ ; if ( $address{$address} > 1 ) { print "${sp}-> REUSED_ADDRESS\n" ; diff --git a/gnu/usr.bin/perl/lib/ftp.pl b/gnu/usr.bin/perl/lib/ftp.pl index 61848fea5d4..92594cde47b 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.2 1997/11/30 07:56:58 millert Exp $ +# $Header: /cvs/OpenBSD/src/gnu/usr.bin/perl/lib/Attic/ftp.pl,v 1.3 1999/04/29 22:51:46 millert Exp $ # $Log: ftp.pl,v $ -# Revision 1.2 1997/11/30 07:56:58 millert -# perl 5.004_04 +# Revision 1.3 1999/04/29 22:51:46 millert +# perl5.005_03 (stock) # # Revision 1.17 1993/04/21 10:06:54 lmjm # Send all status reports to STDERR not to STDOUT (to allow use by ftpcat). diff --git a/gnu/usr.bin/perl/lib/lib.pm b/gnu/usr.bin/perl/lib/lib.pm index 4d32f963551..6e6e15e4ce9 100644 --- a/gnu/usr.bin/perl/lib/lib.pm +++ b/gnu/usr.bin/perl/lib/lib.pm @@ -18,6 +18,10 @@ sub import { Carp::carp("Empty compile time value given to use lib"); # at foo.pl line ... } + if (-e && ! -d _) { + require Carp; + Carp::carp("Parameter to use lib must be directory, not file"); + } unshift(@INC, $_); # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. diff --git a/gnu/usr.bin/perl/lib/overload.pm b/gnu/usr.bin/perl/lib/overload.pm index c9044db0dc5..f06b49cd5ea 100644 --- a/gnu/usr.bin/perl/lib/overload.pm +++ b/gnu/usr.bin/perl/lib/overload.pm @@ -62,7 +62,10 @@ sub OverloadedStringify { my $package = shift; $package = ref $package if ref $package; #$package->can('(""') - ov_method mycan($package, '(""'), $package; + ov_method mycan($package, '(""'), $package + or ov_method mycan($package, '(0+'), $package + or ov_method mycan($package, '(bool'), $package + or ov_method mycan($package, '(nomethod'), $package; } sub Method { @@ -100,6 +103,44 @@ sub mycan { # Real can would leave stubs. return undef; } +%constants = ( + 'integer' => 0x1000, + 'float' => 0x2000, + 'binary' => 0x4000, + 'q' => 0x8000, + 'qr' => 0x10000, + ); + +%ops = ( with_assign => "+ - * / % ** << >> x .", + assign => "+= -= *= /= %= **= <<= >>= x= .=", + str_comparison => "< <= > >= == !=", + '3way_comparison'=> "<=> cmp", + num_comparison => "lt le gt ge eq ne", + binary => "& | ^", + unary => "neg ! ~", + mutators => '++ --', + func => "atan2 cos sin exp abs log sqrt", + conversion => 'bool "" 0+', + special => 'nomethod fallback ='); + +sub constant { + # Arguments: what, sub + while (@_) { + $^H{$_[0]} = $_[1]; + $^H |= $constants{$_[0]} | 0x20000; + shift, shift; + } +} + +sub remove_constant { + # Arguments: what, sub + while (@_) { + delete $^H{$_[0]}; + $^H &= ~ $constants{$_[0]}; + shift, shift; + } +} + 1; __END__ @@ -126,13 +167,6 @@ overload - Package for overloading perl operations ... $strval = overload::StrVal $b; -=head1 CAVEAT SCRIPTOR - -Overloading of operators is a subject not to be taken lightly. -Neither its precise implementation, syntax, nor semantics are -100% endorsed by Larry Wall. So any of these may be changed -at some point in the future. - =head1 DESCRIPTION =head2 Declaration of overloaded functions @@ -194,7 +228,8 @@ the arguments are reversed. the current operation is an assignment variant (as in C<$a+=7>), but the usual function is called instead. This additional -information can be used to generate some optimizations. +information can be used to generate some optimizations. Compare +L<Calling Conventions for Mutators>. =back @@ -204,9 +239,67 @@ Unary operation are considered binary operations with the second argument being C<undef>. Thus the functions that overloads C<{"++"}> is called with arguments C<($a,undef,'')> when $a++ is executed. +=head2 Calling Conventions for Mutators + +Two types of mutators have different calling conventions: + +=over + +=item C<++> and C<--> + +The routines which implement these operators are expected to actually +I<mutate> their arguments. So, assuming that $obj is a reference to a +number, + + sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n} + +is an appropriate implementation of overloaded C<++>. Note that + + sub incr { ++$ {$_[0]} ; shift } + +is OK if used with preincrement and with postincrement. (In the case +of postincrement a copying will be performed, see L<Copy Constructor>.) + +=item C<x=> and other assignment versions + +There is nothing special about these methods. They may change the +value of their arguments, and may leave it as is. The result is going +to be assigned to the value in the left-hand-side if different from +this value. + +This allows for the same method to be used as overloaded C<+=> and +C<+>. Note that this is I<allowed>, but not recommended, since by the +semantic of L<"Fallback"> Perl will call the method for C<+> anyway, +if C<+=> is not overloaded. + +=back + +B<Warning.> Due to the presense of assignment versions of operations, +routines which may be called in assignment context may create +self-referential structures. Currently Perl will not free self-referential +structures until cycles are C<explicitly> broken. You may get problems +when traversing your structures too. + +Say, + + use overload '+' => sub { bless [ \$_[0], \$_[1] ] }; + +is asking for trouble, since for code C<$obj += $foo> the subroutine +is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj, +\$foo]>. If using such a subroutine is an important optimization, one +can overload C<+=> explicitly by a non-"optimized" version, or switch +to non-optimized version if C<not defined $_[2]> (see +L<Calling Conventions for Binary Operations>). + +Even if no I<explicit> assignment-variants of operators are present in +the script, they may be generated by the optimizer. Say, C<",$obj,"> or +C<',' . $obj . ','> may be both optimized to + + my $tmp = ',' . $obj; $tmp .= ','; + =head2 Overloadable Operations -The following symbols can be specified in C<use overload>: +The following symbols can be specified in C<use overload> directive: =over 5 @@ -221,6 +314,10 @@ the assignment variant is not available. Methods for operations "C<+>", increment and decrement methods. The operation "C<->" can be used to autogenerate missing methods for unary minus or C<abs>. +See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and +L<"Calling Conventions for Binary Operations">) for details of these +substitutions. + =item * I<Comparison operations> "<", "<=", ">", ">=", "==", "!=", "<=>", @@ -272,7 +369,23 @@ see L<SPECIAL SYMBOLS FOR C<use overload>>. =back -See L<"Fallback"> for an explanation of when a missing method can be autogenerated. +See L<"Fallback"> for an explanation of when a missing method can be +autogenerated. + +A computer-readable form of the above table is available in the hash +%overload::ops, with values being space-separated lists of names: + + with_assign => '+ - * / % ** << >> x .', + assign => '+= -= *= /= %= **= <<= >>= x= .=', + str_comparison => '< <= > >= == !=', + '3way_comparison'=> '<=> cmp', + num_comparison => 'lt le gt ge eq ne', + binary => '& | ^', + unary => 'neg ! ~', + mutators => '++ --', + func => 'atan2 cos sin exp abs log sqrt', + conversion => 'bool "" 0+', + special => 'nomethod fallback =' =head2 Inheritance and overloading @@ -375,15 +488,15 @@ to a reference that shares its object with some other reference, such as $a=$b; - $a++; + ++$a; To make this change $a and not change $b, a copy of C<$$a> is made, and $a is assigned a reference to this new object. This operation is -done during execution of the C<$a++>, and not during the assignment, +done during execution of the C<++$a>, and not during the assignment, (so before the increment C<$$a> coincides with C<$$b>). This is only -done if C<++> is expressed via a method for C<'++'> or C<'+='>. Note -that if this operation is expressed via C<'+'> a nonmutator, i.e., as -in +done if C<++> is expressed via a method for C<'++'> or C<'+='> (or +C<nomethod>). Note that if this operation is expressed via C<'+'> +a nonmutator, i.e., as in $a=$b; $a=$a+1; @@ -417,6 +530,9 @@ C<'='> was overloaded with C<\&clone>. =back +Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for +C<$b = $a; ++$a>. + =head1 MAGIC AUTOGENERATION If a method for an operation is not found, and the value for C<"fallback"> is @@ -473,7 +589,7 @@ value is a scalar and not a reference. =back -=head1 WARNING +=head1 Losing overloading The restriction for the comparison operation is that even if, for example, `C<cmp>' should return a blessed reference, the autogenerated `C<lt>' @@ -522,6 +638,72 @@ Returns C<undef> or a reference to the method that implements C<op>. =back +=head1 Overloading constants + +For some application Perl parser mangles constants too much. It is possible +to hook into this process via overload::constant() and overload::remove_constant() +functions. + +These functions take a hash as an argument. The recognized keys of this hash +are + +=over 8 + +=item integer + +to overload integer constants, + +=item float + +to overload floating point constants, + +=item binary + +to overload octal and hexadecimal constants, + +=item q + +to overload C<q>-quoted strings, constant pieces of C<qq>- and C<qx>-quoted +strings and here-documents, + +=item qr + +to overload constant pieces of regular expressions. + +=back + +The corresponding values are references to functions which take three arguments: +the first one is the I<initial> string form of the constant, the second one +is how Perl interprets this constant, the third one is how the constant is used. +Note that the initial string form does not +contain string delimiters, and has backslashes in backslash-delimiter +combinations stripped (thus the value of delimiter is not relevant for +processing of this string). The return value of this function is how this +constant is going to be interpreted by Perl. The third argument is undefined +unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote +context (comes from strings, regular expressions, and single-quote HERE +documents), it is C<tr> for arguments of C<tr>/C<y> operators, +it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise. + +Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>, +it is expected that overloaded constant strings are equipped with reasonable +overloaded catenation operator, otherwise absurd results will result. +Similarly, negative numbers are considered as negations of positive constants. + +Note that it is probably meaningless to call the functions overload::constant() +and overload::remove_constant() from anywhere but import() and unimport() methods. +From these methods they may be called as + + sub import { + shift; + return unless @_; + die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant'; + overload::constant integer => sub {Math::BigInt->new(shift)}; + } + +B<BUGS> Currently overloaded-ness of constants does not propagate +into C<eval '...'>. + =head1 IMPLEMENTATION What follows is subject to change RSN. @@ -559,7 +741,7 @@ 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. +overloading, and carries the cache table 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 @@ -569,6 +751,416 @@ behavior by defining your own copy constructor (see L<"Copy Constructor">). It is expected that arguments to methods that are not explicitly supposed to be changed are constant (but this is not enforced). +=head1 Metaphor clash + +One may wonder why the semantic of overloaded C<=> is so counter intuitive. +If it I<looks> counter intuitive to you, you are subject to a metaphor +clash. + +Here is a Perl object metaphor: + +I< object is a reference to blessed data> + +and an arithmetic metaphor: + +I< object is a thing by itself>. + +The I<main> problem of overloading C<=> is the fact that these metaphors +imply different actions on the assignment C<$a = $b> if $a and $b are +objects. Perl-think implies that $a becomes a reference to whatever +$b was referencing. Arithmetic-think implies that the value of "object" +$a is changed to become the value of the object $b, preserving the fact +that $a and $b are separate entities. + +The difference is not relevant in the absence of mutators. After +a Perl-way assignment an operation which mutates the data referenced by $a +would change the data referenced by $b too. Effectively, after +C<$a = $b> values of $a and $b become I<indistinguishable>. + +On the other hand, anyone who has used algebraic notation knows the +expressive power of the arithmetic metaphor. Overloading works hard +to enable this metaphor while preserving the Perlian way as far as +possible. Since it is not not possible to freely mix two contradicting +metaphors, overloading allows the arithmetic way to write things I<as +far as all the mutators are called via overloaded access only>. The +way it is done is described in L<Copy Constructor>. + +If some mutator methods are directly applied to the overloaded values, +one may need to I<explicitly unlink> other values which references the +same value: + + $a = new Data 23; + ... + $b = $a; # $b is "linked" to $a + ... + $a = $a->clone; # Unlink $b from $a + $a->increment_by(4); + +Note that overloaded access makes this transparent: + + $a = new Data 23; + $b = $a; # $b is "linked" to $a + $a += 4; # would unlink $b automagically + +However, it would not make + + $a = new Data 23; + $a = 4; # Now $a is a plain 4, not 'Data' + +preserve "objectness" of $a. But Perl I<has> a way to make assignments +to an object do whatever you want. It is just not the overload, but +tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method +which returns the object itself, and STORE() method which changes the +value of the object, one can reproduce the arithmetic metaphor in its +completeness, at least for variables which were tie()d from the start. + +(Note that a workaround for a bug may be needed, see L<"BUGS">.) + +=head1 Cookbook + +Please add examples to what follows! + +=head2 Two-face scalars + +Put this in F<two_face.pm> in your Perl library directory: + + package two_face; # Scalars with separate string and + # numeric values. + sub new { my $p = shift; bless [@_], $p } + use overload '""' => \&str, '0+' => \&num, fallback => 1; + sub num {shift->[1]} + sub str {shift->[0]} + +Use it as follows: + + require two_face; + my $seven = new two_face ("vii", 7); + printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1; + print "seven contains `i'\n" if $seven =~ /i/; + +(The second line creates a scalar which has both a string value, and a +numeric value.) This prints: + + seven=vii, seven=7, eight=8 + seven contains `i' + +=head2 Symbolic calculator + +Put this in F<symbolic.pm> in your Perl library directory: + + package symbolic; # Primitive symbolic calculator + use overload nomethod => \&wrap; + + sub new { shift; bless ['n', @_] } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + +This module is very unusual as overloaded modules go: it does not +provide any usual overloaded operators, instead it provides the L<Last +Resort> operator C<nomethod>. In this example the corresponding +subroutine returns an object which encapsulates operations done over +the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new +symbolic 3> contains C<['+', 2, ['n', 3]]>. + +Here is an example of the script which "calculates" the side of +circumscribed octagon using the above package: + + require symbolic; + my $iter = 1; # 2**($iter+2) = 8 + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt--) { + $side = (sqrt(1 + $side**2) - 1)/$side; + } + print "OK\n"; + +The value of $side is + + ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]], + undef], 1], ['n', 1]] + +Note that while we obtained this value using a nice little script, +there is no simple way to I<use> this value. In fact this value may +be inspected in debugger (see L<perldebug>), but ony if +C<bareStringify> B<O>ption is set, and not via C<p> command. + +If one attempts to print this value, then the overloaded operator +C<""> will be called, which will call C<nomethod> operator. The +result of this operator will be stringified again, but this result is +again of type C<symbolic>, which will lead to an infinite loop. + +Add a pretty-printer method to the module F<symbolic.pm>: + + sub pretty { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + $b = 'u' unless defined $b; + $a = $a->pretty if ref $a; + $b = $b->pretty if ref $b; + "[$meth $a $b]"; + } + +Now one can finish the script by + + print "side = ", $side->pretty, "\n"; + +The method C<pretty> is doing object-to-string conversion, so it +is natural to overload the operator C<""> using this method. However, +inside such a method it is not necessary to pretty-print the +I<components> $a and $b of an object. In the above subroutine +C<"[$meth $a $b]"> is a catenation of some strings and components $a +and $b. If these components use overloading, the catenation operator +will look for an overloaded operator C<.>, if not present, it will +look for an overloaded operator C<"">. Thus it is enough to use + + use overload nomethod => \&wrap, '""' => \&str; + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + $b = 'u' unless defined $b; + "[$meth $a $b]"; + } + +Now one can change the last line of the script to + + print "side = $side\n"; + +which outputs + + side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]] + +and one can inspect the value in debugger using all the possible +methods. + +Something is is still amiss: consider the loop variable $cnt of the +script. It was a number, not an object. We cannot make this value of +type C<symbolic>, since then the loop will not terminate. + +Indeed, to terminate the cycle, the $cnt should become false. +However, the operator C<bool> for checking falsity is overloaded (this +time via overloaded C<"">), and returns a long string, thus any object +of type C<symbolic> is true. To overcome this, we need a way to +compare an object to 0. In fact, it is easier to write a numeric +conversion routine. + +Here is the text of F<symbolic.pm> with such a routine added (and +slightly modified str()): + + package symbolic; # Primitive symbolic calculator + use overload + nomethod => \&wrap, '""' => \&str, '0+' => \# + + sub new { shift; bless ['n', @_] } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + if (defined $b) { + "[$meth $a $b]"; + } else { + "[$meth $a]"; + } + } + my %subr = ( n => sub {$_[0]}, + sqrt => sub {sqrt $_[0]}, + '-' => sub {shift() - shift()}, + '+' => sub {shift() + shift()}, + '/' => sub {shift() / shift()}, + '*' => sub {shift() * shift()}, + '**' => sub {shift() ** shift()}, + ); + sub num { + my ($meth, $a, $b) = @{+shift}; + my $subr = $subr{$meth} + or die "Do not know how to ($meth) in symbolic"; + $a = $a->num if ref $a eq __PACKAGE__; + $b = $b->num if ref $b eq __PACKAGE__; + $subr->($a,$b); + } + +All the work of numeric conversion is done in %subr and num(). Of +course, %subr is not complete, it contains only operators used in the +example below. Here is the extra-credit question: why do we need an +explicit recursion in num()? (Answer is at the end of this section.) + +Use this module like this: + + require symbolic; + my $iter = new symbolic 2; # 16-gon + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt) { + $cnt = $cnt - 1; # Mutator `--' not implemented + $side = (sqrt(1 + $side**2) - 1)/$side; + } + printf "%s=%f\n", $side, $side; + printf "pi=%f\n", $side*(2**($iter+2)); + +It prints (without so many line breaks) + + [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] + [n 1]] 2]]] 1] + [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912 + pi=3.182598 + +The above module is very primitive. It does not implement +mutator methods (C<++>, C<-=> and so on), does not do deep copying +(not required without mutators!), and implements only those arithmetic +operations which are used in the example. + +To implement most arithmetic operations is easy, one should just use +the tables of operations, and change the code which fills %subr to + + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + print "defining `$op'\n"; + $subr{$op} = eval "sub {$op shift()}"; + } + +Due to L<Calling Conventions for Mutators>, we do not need anything +special to make C<+=> and friends work, except filling C<+=> entry of +%subr, and defining a copy constructor (needed since Perl has no +way to know that the implementation of C<'+='> does not mutate +the argument, compare L<Copy Constructor>). + +To implement a copy constructor, add C<'=' => \&cpy> to C<use overload> +line, and code (this code assumes that mutators change things one level +deep only, so recursive copying is not needed): + + sub cpy { + my $self = shift; + bless [@$self], ref $self; + } + +To make C<++> and C<--> work, we need to implement actual mutators, +either directly, or in C<nomethod>. We continue to do things inside +C<nomethod>, thus add + + if ($meth eq '++' or $meth eq '--') { + @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference + return $obj; + } + +after the first line of wrap(). This is not a most effective +implementation, one may consider + + sub inc { $_[0] = bless ['++', shift, 1]; } + +instead. + +As a final remark, note that one can fill %subr by + + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + $subr{$op} = eval "sub {$op shift()}"; + } + $subr{'++'} = $subr{'+'}; + $subr{'--'} = $subr{'-'}; + +This finishes implementation of a primitive symbolic calculator in +50 lines of Perl code. Since the numeric values of subexpressions +are not cached, the calculator is very slow. + +Here is the answer for the exercise: In the case of str(), we need no +explicit recursion since the overloaded C<.>-operator will fall back +to an existing overloaded operator C<"">. Overloaded arithmetic +operators I<do not> fall back to numeric conversion if C<fallback> is +not explicitly requested. Thus without an explicit recursion num() +would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild +the argument of num(). + +If you wonder why defaults for conversion are different for str() and +num(), note how easy it was to write the symbolic calculator. This +simplicity is due to an appropriate choice of defaults. One extra +note: due to the explicit recursion num() is more fragile than sym(): +we need to explicitly check for the type of $a and $b. If components +$a and $b happen to be of some related type, this may lead to problems. + +=head2 I<Really> symbolic calculator + +One may wonder why we call the above calculator symbolic. The reason +is that the actual calculation of the value of expression is postponed +until the value is I<used>. + +To see it in action, add a method + + sub STORE { + my $obj = shift; + $#$obj = 1; + @$obj->[0,1] = ('=', shift); + } + +to the package C<symbolic>. After this change one can do + + my $a = new symbolic 3; + my $b = new symbolic 4; + my $c = sqrt($a**2 + $b**2); + +and the numeric value of $c becomes 5. However, after calling + + $a->STORE(12); $b->STORE(5); + +the numeric value of $c becomes 13. There is no doubt now that the module +symbolic provides a I<symbolic> calculator indeed. + +To hide the rough edges under the hood, provide a tie()d interface to the +package C<symbolic> (compare with L<Metaphor clash>). Add methods + + sub TIESCALAR { my $pack = shift; $pack->new(@_) } + sub FETCH { shift } + sub nop { } # Around a bug + +(the bug is described in L<"BUGS">). One can use this new interface as + + tie $a, 'symbolic', 3; + tie $b, 'symbolic', 4; + $a->nop; $b->nop; # Around a bug + + my $c = sqrt($a**2 + $b**2); + +Now numeric value of $c is 5. After C<$a = 12; $b = 5> the numeric value +of $c becomes 13. To insulate the user of the module add a method + + sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } + +Now + + my ($a, $b); + symbolic->vars($a, $b); + my $c = sqrt($a**2 + $b**2); + + $a = 3; $b = 4; + printf "c5 %s=%f\n", $c, $c; + + $a = 12; $b = 5; + printf "c13 %s=%f\n", $c, $c; + +shows that the numeric value of $c follows changes to the values of $a +and $b. + =head1 AUTHOR Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>. @@ -584,7 +1176,7 @@ 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). +function of module C<overload>). =head1 BUGS @@ -597,7 +1189,21 @@ 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. +Relation between overloading and tie()ing is broken. Overloading is +triggered or not basing on the I<previous> class of tie()d value. + +This happens because the presence of overloading is checked too early, +before any tie()d access is attempted. If the FETCH()ed class of the +tie()d value does not change, a simple workaround is to access the value +immediately after tie()ing, so that after this call the I<previous> class +coincides with the current one. + +B<Needed:> a way to fix this without a speed penalty. + +Barewords are not covered by overloaded string constants. + +This document is confusing. There are grammos and misleading language +used in places. It would seem a total rewrite is needed. =cut diff --git a/gnu/usr.bin/perl/lib/perl5db.pl b/gnu/usr.bin/perl/lib/perl5db.pl index d5dbfbdd68b..4d05e6d9307 100644 --- a/gnu/usr.bin/perl/lib/perl5db.pl +++ b/gnu/usr.bin/perl/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.01; +$VERSION = 1.0402; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -173,26 +173,30 @@ $trace = $signal = $single = 0; # Uninitialized warning suppression # (local $^W cannot help - other packages!). $inhibit_exit = $option{PrintRet} = 1; -@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages +@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused compactDump veryCompact quote HighBit undefPrint globPrint PrintRet UsageOnly frame AutoTrace TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments - signalLevel warnLevel dieLevel inhibit_exit); + signalLevel warnLevel dieLevel inhibit_exit + ImmediateStop bareStringify); %optionVars = ( hashDepth => \$dumpvar::hashDepth, arrayDepth => \$dumpvar::arrayDepth, DumpDBFiles => \$dumpvar::dumpDBFiles, DumpPackages => \$dumpvar::dumpPackages, + DumpReused => \$dumpvar::dumpReused, HighBit => \$dumpvar::quoteHighBit, undefPrint => \$dumpvar::printUndef, globPrint => \$dumpvar::globPrint, UsageOnly => \$dumpvar::usageOnly, + bareStringify => \$dumpvar::bareStringify, frame => \$frame, AutoTrace => \$trace, inhibit_exit => \$inhibit_exit, maxTraceLen => \$maxtrace, + ImmediateStop => \$ImmediateStop, ); %optionAction = ( @@ -231,7 +235,11 @@ $pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager; +&pager((defined($ENV{PAGER}) + ? $ENV{PAGER} + : ($^O eq 'os2' + ? 'cmd /c more' + : 'more'))) unless defined $pager; &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; $maxtrace = 400 unless defined $maxtrace; @@ -290,7 +298,7 @@ if ($notty) { if (-e "/dev/tty") { $console = "/dev/tty"; - } elsif (-e "con" or $^O eq 'MSWin32') { + } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { $console = "con"; } else { $console = "sys\$command"; @@ -357,18 +365,21 @@ sub DB { # _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; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } $single = 0; # return; # Would not print trace! + } elsif ($ImmediateStop) { + $ImmediateStop = 0; + $signal = 1; } } $runnonstop = 0 if $single or $signal; # Disable it if interactive. &save; ($package, $filename, $line) = caller; $filename_ini = $filename; - $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . + $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = $main::{'_<' . $filename}; $max = $#dbline; @@ -376,17 +387,48 @@ sub DB { if ($stop eq '1') { $signal |= 1; } elsif ($stop) { - $evalarg = "\$DB::signal |= do {$stop;}"; &eval; + $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval; $dbline{$line} =~ s/;9($|\0)/$1/; } } my $was_signal = $signal; + if ($trace & 2) { + for (my $n = 0; $n <= $#to_watch; $n++) { + $evalarg = $to_watch[$n]; + local $onetimeDump; # Do not output results + my ($val) = &eval; # Fix context (&eval is doing array)? + $val = ( (defined $val) ? "'$val'" : 'undef' ); + if ($val ne $old_watch[$n]) { + $signal = 1; + print $OUT <<EOP; +Watchpoint $n:\t$to_watch[$n] changed: + old value:\t$old_watch[$n] + new value:\t$val +EOP + $old_watch[$n] = $val; + } + } + } + if ($trace & 4) { # User-installed watch + return if watchfunction($package, $filename, $line) + and not $single and not $was_signal and not ($trace & ~4); + } + $was_signal = $signal; $signal = 0; - if ($single || $trace || $was_signal) { - $term || &setterm; + if ($single || ($trace & 1) || $was_signal) { if ($emacs) { $position = "\032\032$filename:$line:0\n"; print $LINEINFO $position; + } elsif ($package eq 'DB::fake') { + $term || &setterm; + print_help(<<EOP); +Debugged program terminated. Use B<q> to quit or B<R> to restart, + use B<O> I<inhibit_exit> to avoid stopping after program termination, + B<h q>, B<h R> or B<h O> to get additional info. +EOP + $package = 'main'; + $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . + "package $package;"; # this won't let them modify, alas } else { $sub =~ s/\'/::/; $prefix = $sub =~ /::/ ? "" : "${'package'}::"; @@ -401,7 +443,7 @@ sub DB { $position = "$prefix$line$infix$dbline[$line]$after"; } if ($frame) { - print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after"; + print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after"; } else { print $LINEINFO $position; } @@ -412,7 +454,7 @@ sub DB { $incr_pos = "$prefix$i$infix$dbline[$i]$after"; $position .= $incr_pos; if ($frame) { - print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after"; + print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after"; } else { print $LINEINFO $incr_pos; } @@ -425,7 +467,7 @@ sub DB { foreach $evalarg (@$pre) { &eval; } - print $OUT $#stack . " levels deep in subroutine calls!\n" + print $OUT $stack_depth . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; $incr = -1; # for backward motion. @@ -449,24 +491,25 @@ sub DB { eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i}; $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^h$/ && do { - print $OUT $help; + print_help($help); next CMD; }; $cmd =~ /^h\s+h$/ && do { - print $OUT $summary; + print_help($summary); next CMD; }; $cmd =~ /^h\s+(\S)$/ && do { my $asked = "\Q$1"; - if ($help =~ /^$asked/m) { - while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) { - print $OUT $1; + if ($help =~ /^(?:[IB]<)$asked/m) { + while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) { + print_help($1); } } else { - print $OUT "`$asked' is not a debugger command.\n"; + print_help("B<$asked> is not a debugger command.\n"); } next CMD; }; $cmd =~ /^t$/ && do { - $trace = !$trace; - print $OUT "Trace = ".($trace?"on":"off")."\n"; + ($trace & 1) ? ($trace &= ~1) : ($trace |= 1); + print $OUT "Trace = " . + (($trace & 1) ? "on" : "off" ) . "\n"; next CMD; }; $cmd =~ /^S(\s+(!)?(.+))?$/ && do { $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1; @@ -601,8 +644,9 @@ sub DB { $arrow .= 'b' if $stop; $arrow .= 'a' if $action; print $OUT "$i$arrow\t", $dbline[$i]; - last if $signal; + $i++, last if $signal; } + print $OUT "\n" unless $dbline[$i-1] =~ /\n$/; } $start = $i; # remember in case they want more $start = $max if $start > $max; @@ -686,6 +730,14 @@ sub DB { last if $signal; } } + if ($trace & 2) { + print $OUT "Watch-expressions:\n"; + my $expr; + for $expr (@to_watch) { + print $OUT " $expr\n"; + last if $signal; + } + } next CMD; }; $cmd =~ /^b\b\s*load\b\s*(.*)/ && do { my $file = $1; $file =~ s/\s+$//; @@ -832,14 +884,14 @@ sub DB { } $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. } - for ($i=0; $i <= $#stack; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } last CMD; }; $cmd =~ /^r$/ && do { end_report(), next CMD if $finished and $level <= 1; - $stack[$#stack] |= 1; - $doret = $option{PrintRet} ? $#stack - 1 : -2; + $stack[$stack_depth] |= 1; + $doret = $option{PrintRet} ? $stack_depth - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { print $OUT "Warning: some settings and command-line options may be lost!\n"; @@ -925,6 +977,18 @@ sub DB { $cmd =~ /^T$/ && do { print_trace($OUT, 1); # skip DB next CMD; }; + $cmd =~ /^W\s*$/ && do { + $trace &= ~2; + @to_watch = @old_watch = (); + next CMD; }; + $cmd =~ /^W\b\s*(.*)/s && do { + push @to_watch, $1; + $evalarg = $1; + my ($val) = &eval; + $val = (defined $val) ? "'$val'" : 'undef' ; + push @old_watch, $val; + $trace |= 2; + next CMD; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])/$:$1:; @@ -986,7 +1050,7 @@ sub DB { $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do { pop(@hist) if length($cmd) > 1; $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist); - $cmd = $hist[$i] . "\n"; + $cmd = $hist[$i]; print $OUT $cmd; redo CMD; }; $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { @@ -1002,7 +1066,7 @@ sub DB { print $OUT "No such command!\n\n"; next CMD; } - $cmd = $hist[$i] . "\n"; + $cmd = $hist[$i]; print $OUT $cmd; redo CMD; }; $cmd =~ /^$sh$/ && do { @@ -1062,7 +1126,7 @@ sub DB { $cmd =~ s/^\|+\s*//; redo PIPE; }; # XXX Local variants do not work! - $cmd =~ s/^t\s/\$DB::trace = 1;\n/; + $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'}; } # PIPE: @@ -1098,7 +1162,7 @@ sub DB { &eval; } } # if ($single || $signal) - ($@, $!, $,, $/, $\, $^W) = @saved; + ($@, $!, $^E, $,, $/, $\, $^W) = @saved; (); } @@ -1110,24 +1174,30 @@ sub sub { if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { $al = " for $$sub"; } - push(@stack, $single); + local $stack_depth = $stack_depth + 1; # Protect from non-local exits + $#stack = $stack_depth; + $stack[-1] = $single; $single &= 1; - $single |= 4 if $#stack == $deep; + $single |= 4 if $stack_depth == $deep; ($frame & 4 - ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "), + ? ( (print $LINEINFO ' ' x ($stack_depth - 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; + : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame; if (wantarray) { @ret = &$sub; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "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; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh ' ' x $stack_depth if $frame & 16; + print $fh "list context return from $sub:\n"; + dumpit($fh, \@ret ); + $doret = -2; + } @ret; } else { if (defined wantarray) { @@ -1135,20 +1205,26 @@ sub sub { } else { &$sub; undef $ret; }; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "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; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16 and defined wantarray) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh (' ' x $stack_depth) if $frame & 16; + print $fh (defined wantarray + ? "scalar context return from $sub: " + : "void context return from $sub\n"); + dumpit( $fh, $ret ) if defined wantarray; + $doret = -2; + } $ret; } } sub save { - @saved = ($@, $!, $,, $/, $\, $^W); + @saved = ($@, $!, $^E, $,, $/, $\, $^W); $, = ""; $/ = "\n"; $\ = ""; $^W = 0; } @@ -1157,7 +1233,6 @@ sub save { sub eval { my @res; { - local (@stack) = @stack; # guard against recursive debugging my $otrace = $trace; my $osingle = $single; my $od = $^D; @@ -1168,14 +1243,15 @@ sub eval { } my $at = $@; local $saved[0]; # Preserve the old value of $@ - eval "&DB::save"; + eval { &DB::save }; if ($at) { print $OUT $at; } elsif ($onetimeDump eq 'dump') { - dumpit(\@res); + dumpit($OUT, \@res); } elsif ($onetimeDump eq 'methods') { methods($res[0]); } + @res; } sub postponed_sub { @@ -1202,6 +1278,10 @@ sub postponed_sub { } sub postponed { + if ($ImmediateStop) { + $ImmediateStop = 0; + $signal = 1; + } return &postponed_sub unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. # Cannot be done before the file is compiled @@ -1210,7 +1290,7 @@ sub postponed { $filename =~ s/^_<//; $signal = 1, print $OUT "'$filename' loaded...\n" if $break_on_load{$filename}; - print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame; + print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame; return unless $postponed_file{$filename}; $had_breakpoints{$filename}++; #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic @@ -1222,7 +1302,7 @@ sub postponed { } sub dumpit { - local ($savout) = select($OUT); + local ($savout) = select(shift); my $osingle = $single; my $otrace = $trace; $single = $trace = 0; @@ -1303,7 +1383,7 @@ sub dump_trace { push(@a, $_); } } - $context = $context ? '@' : "\$"; + $context = $context ? '@' : (defined $context ? "\$" : '.'); $args = $h ? [@a] : undef; $e =~ s/\n\s*\;\s*\Z// if $e; $e =~ s/([\\\'])/\\$1/g if $e; @@ -1342,7 +1422,7 @@ sub system { # We save, change, then restore STDIN and STDOUT to avoid fork() since # many non-Unix systems can do system() but have problems with fork(). open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN"); - open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT"); + open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT"); open(STDIN,"<&IN") || &warn("Can't redirect STDIN"); open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT"); system(@_); @@ -1358,7 +1438,6 @@ sub system { sub setterm { local $frame = 0; local $doret = -2; - local @stack = @stack; # Prevent growth by failing `use'. eval { require Term::ReadLine } or die $@; if ($notty) { if ($tty) { @@ -1417,8 +1496,14 @@ sub resetterm { # We forked, so we need a different 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"; + print_help(<<EOP); +I<#########> Forked, but do not know how to change a B<TTY>. I<#########> + Define B<\$DB::fork_TTY> + - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>. + The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use. + On I<UNIX>-like systems one can get the name of a I<TTY> for the given window + by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>. +EOP } } @@ -1667,146 +1752,155 @@ sub list_versions { } $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"; - } + dumpit($OUT,\%version); } sub sethelp { $help = " -T Stack trace. -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|sub] Continue; optionally inserts a one-time-only breakpoint +B<T> Stack trace. +B<s> [I<expr>] Single step [in I<expr>]. +B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. +<B<CR>> Repeat last B<n> or B<s> command. +B<r> Return from current subroutine. +B<c> [I<line>|I<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. -l subname List first window of lines from subroutine. -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. 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. -S [[!]pattern] List subroutine names [not] matching pattern. -t Toggle trace mode. -t expr Trace through execution of expr. -b [line] [condition] - Set breakpoint; line defaults to the current execution line; - condition breaks if it evaluates to true, defaults to '1'. -b subname [condition] +B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. +B<l> I<min>B<->I<max> List lines I<min> through I<max>. +B<l> I<line> List single I<line>. +B<l> I<subname> List first window of lines from subroutine. +B<l> List next window of lines. +B<-> List previous window of lines. +B<w> [I<line>] List window around I<line>. +B<.> Return to the executed line. +B<f> I<filename> Switch to viewing I<filename>. Must be loaded. +B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. +B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. +B<L> List all breakpoints and actions. +B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. +B<t> Toggle trace mode. +B<t> I<expr> Trace through execution of I<expr>. +B<b> [I<line>] [I<condition>] + Set breakpoint; I<line> defaults to the current execution line; + I<condition> breaks if it evaluates to true, defaults to '1'. +B<b> I<subname> [I<condition>] Set breakpoint at first line of subroutine. -b load filename Set breakpoint on `require'ing the given file. -b postpone subname [condition] +B<b> B<load> I<filename> Set breakpoint on `require'ing the given file. +B<b> B<postpone> I<subname> [I<condition>] Set breakpoint at first line of subroutine after it is compiled. -b compile subname +B<b> B<compile> I<subname> Stop after the subroutine is compiled. -d [line] Delete the breakpoint for line. -D Delete all breakpoints. -a [line] command - Set an action to be done before the line is executed. - Sequence is: check for breakpoint, print line if necessary, - do action, prompt user if breakpoint or step, evaluate line. -A Delete all actions. -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 +B<d> [I<line>] Delete the breakpoint for I<line>. +B<D> Delete all breakpoints. +B<a> [I<line>] I<command> + Set an action to be done before the I<line> is executed. + Sequence is: check for breakpoint/watchpoint, print line + if necessary, do action, prompt user if necessary, + execute expression. +B<A> Delete all actions. +B<W> I<expr> Add a global watch-expression. +B<W> Delete all watch-expressions. +B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). + Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. +B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". +B<x> I<expr> Evals expression in array context, dumps the result. +B<m> I<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 +B<m> I<class> Prints methods callable via the given class. +B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... + Set or query values of options. I<val> defaults to 1. I<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; - globPrint: whether to print contents of globs; - DumpDBFiles: dump arrays holding debugged files; - DumpPackages: dump symbol tables of packages; - quote, HighBit, undefPrint: change style of string dump; - 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. + I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell; + I<pager>: program for output of \"|cmd\"; + I<tkRunning>: run Tk while prompting (with ReadLine); + I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity; + I<inhibit_exit> Allows stepping off the end of the script. + I<ImmediateStop> Debugger should stop as early as possible. + The following options affect what happens with B<V>, B<X>, and B<x> commands: + I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all); + I<compactDump>, I<veryCompact>: change style of array and hash dump; + I<globPrint>: whether to print contents of globs; + I<DumpDBFiles>: dump arrays holding debugged files; + I<DumpPackages>: dump symbol tables of packages; + I<DumpReused>: dump contents of \"reused\" addresses; + I<quote>, I<HighBit>, I<undefPrint>: change style of string dump; + I<bareStringify>: Do not print the overload-stringified value; + Option I<PrintRet> affects printing of return value after B<r> command, + I<frame> affects printing messages on entry and exit from subroutines. + I<AutoTrace> affects printing messages on every possible breaking point. + I<maxTraceLen> gives maximal length of evals/args listed in stack trace. + I<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 (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. - See 'O recallCommand' too. -$psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" + You can put additional initialization options I<TTY>, I<noTTY>, + I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them). +B<<> I<expr> Define Perl command to run before each prompt. +B<<<> I<expr> Add to the list of Perl commands to run before each prompt. +B<>> I<expr> Define Perl command to run after each prompt. +B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. +B<{> I<db_command> Define debugger command to run before each prompt. +B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. +B<$prc> I<number> Redo a previous command (default previous command). +B<$prc> I<-number> Redo number'th-to-last command. +B<$prc> I<pattern> Redo last command that started with I<pattern>. + See 'B<O> I<recallCommand>' too. +B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" . ( $rc eq $sh ? "" : " -$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. -|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. -v Show versions of loaded modules. -R Pure-man-restart of debugger, some of debugger state +B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " + See 'B<O> I<shellBang>' too. +B<H> I<-number> Display last number commands (default all). +B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. +B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. +B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well. +B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. +I<command> Execute as a perl statement in current package. +B<v> Show versions of loaded modules. +B<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. Set \$DB::finished to 0 to debug global destruction. + history, breakpoints and actions, debugger B<O>ptions + and the following command-line options: I<-w>, I<-I>, I<-e>. +B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. +B<h h> Summary of debugger commands. +B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. "; $summary = <<"END_SUM"; -List/search source lines: Control script execution: - l [ln|sub] List source code T Stack trace - - 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/ ?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] - <[<] 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 - h [db_cmd] Get help on command A Delete all 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]\". +I<List/search source lines:> I<Control script execution:> + B<l> [I<ln>|I<sub>] List source code B<T> Stack trace + B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] + B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs + B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s> + B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine + B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position +I<Debugger controls:> B<L> List break/watch/actions + B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr] + B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint + B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub + B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints + B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line + B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression + B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch + B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess + B<q> or B<^D> Quit B<R> Attempt a restart +I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> + B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods. + B<p> I<expr> Print expression (uses script's current package). + B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern + B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. + B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". END_SUM # ')}}; # Fix balance of Emacs parsing } +sub print_help { + my $message = shift; + if (@Term::ReadLine::TermCap::rl_term_set) { + $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g; + $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g; + } + print $OUT $message; +} + sub diesignal { local $frame = 0; local $doret = -2; @@ -1978,6 +2072,7 @@ BEGIN { # This does not compile, alas. # @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); + $stack_depth = 0; # Localized $#stack $doret = -2; $frame = 0; } diff --git a/gnu/usr.bin/perl/lib/strict.pm b/gnu/usr.bin/perl/lib/strict.pm index 8492e933fd6..940e8bf7ff3 100644 --- a/gnu/usr.bin/perl/lib/strict.pm +++ b/gnu/usr.bin/perl/lib/strict.pm @@ -38,6 +38,7 @@ use symbolic references (see L<perlref>). =item C<strict vars> This generates a compile-time error if you access a variable that wasn't +declared via C<use vars>, localized via C<my()> or wasn't fully qualified. Because this is to avoid variable suicide problems and subtle dynamic scoping issues, a merely local() variable isn't good enough. See L<perlfunc/my> and @@ -48,6 +49,10 @@ L<perlfunc/local>. my $foo = 10; # ok, my() var local $foo = 9; # blows up + package Cinna; + use vars qw/ $bar /; # Declares $bar in current package + $bar = 'HgS'; # ok, global declared via pragma + The local() generated a compile-time error because you just touched a global name without fully qualifying it. @@ -67,19 +72,22 @@ appears in curly braces or on the left hand side of the "=E<gt>" symbol. =back -See L<perlmod/Pragmatic Modules>. +See L<perlmodlib/Pragmatic Modules>. =cut +$strict::VERSION = "1.01"; + +my %bitmask = ( +refs => 0x00000002, +subs => 0x00000200, +vars => 0x00000400 +); + sub bits { my $bits = 0; - my $sememe; - foreach $sememe (@_) { - $bits |= 0x00000002, next if $sememe eq 'refs'; - $bits |= 0x00000200, next if $sememe eq 'subs'; - $bits |= 0x00000400, next if $sememe eq 'vars'; - } + foreach my $s (@_){ $bits |= $bitmask{$s} || 0; }; $bits; } diff --git a/gnu/usr.bin/perl/lib/subs.pm b/gnu/usr.bin/perl/lib/subs.pm index 512bc9be9a5..aa332a67858 100644 --- a/gnu/usr.bin/perl/lib/subs.pm +++ b/gnu/usr.bin/perl/lib/subs.pm @@ -20,7 +20,7 @@ C<use subs> declarations are not BLOCK-scoped. They are thus effective for the entire file in which they appear. You may not rescind such declarations with C<no vars> or C<no subs>. -See L<perlmod/Pragmatic Modules> and L<strict/strict subs>. +See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>. =cut diff --git a/gnu/usr.bin/perl/lib/vars.pm b/gnu/usr.bin/perl/lib/vars.pm index 5723ac6c2cb..334af9630ad 100644 --- a/gnu/usr.bin/perl/lib/vars.pm +++ b/gnu/usr.bin/perl/lib/vars.pm @@ -13,11 +13,20 @@ sub import { my $callpack = caller; my ($pack, @imports, $sym, $ch) = @_; foreach $sym (@imports) { - if ($sym =~ /::/) { - require Carp; - Carp::croak("Can't declare another package's variables"); - } ($ch, $sym) = unpack('a1a*', $sym); + if ($sym =~ tr/A-Za-Z_0-9//c) { + # time for a more-detailed check-up + if ($sym =~ /::/) { + require Carp; + Carp::croak("Can't declare another package's variables"); + } elsif ($sym =~ /^\w+[[{].*[]}]$/) { + require Carp; + Carp::croak("Can't declare individual elements of hash or array"); + } elsif ($^W and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { + require Carp; + Carp::carp("No need to declare built-in vars"); + } + } *{"${callpack}::$sym"} = ( $ch eq "\$" ? \$ {"${callpack}::$sym"} : $ch eq "\@" ? \@ {"${callpack}::$sym"} @@ -26,7 +35,7 @@ sub import { : $ch eq "\&" ? \& {"${callpack}::$sym"} : do { require Carp; - Carp::croak("'$ch$sym' is not a valid variable name\n"); + Carp::croak("'$ch$sym' is not a valid variable name"); }); } }; @@ -61,6 +70,6 @@ outside of the package), it can act as an acceptable substitute by pre-declaring global symbols, ensuring their availability to the later-loaded routines. -See L<perlmod/Pragmatic Modules>. +See L<perlmodlib/Pragmatic Modules>. =cut |