diff options
| -rwxr-xr-x | Configure | 2 | ||||
| -rw-r--r-- | INSTALL | 9 | ||||
| -rw-r--r-- | ext/IO/lib/IO/File.pm | 8 | ||||
| -rw-r--r-- | hints/machten_2.sh | 10 | ||||
| -rw-r--r-- | hints/os2.sh | 4 | ||||
| -rw-r--r-- | lib/Benchmark.pm | 4 | ||||
| -rw-r--r-- | lib/ExtUtils/Liblist.pm | 17 | ||||
| -rw-r--r-- | lib/ExtUtils/MakeMaker.pm | 4 | ||||
| -rw-r--r-- | lib/Getopt/Long.pm | 368 | ||||
| -rw-r--r-- | lib/Term/ReadLine.pm | 90 | ||||
| -rw-r--r-- | lib/Text/ParseWords.pm | 6 | ||||
| -rw-r--r-- | lib/perl5db.pl | 36 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 8 | ||||
| -rw-r--r-- | pod/pod2html.PL | 268 | ||||
| -rwxr-xr-x | t/TEST | 22 | ||||
| -rwxr-xr-x | t/op/taint.t | 3 | ||||
| -rwxr-xr-x | t/pragma/locale.t | 2 | ||||
| -rw-r--r-- | utils/h2ph.PL | 2 |
18 files changed, 233 insertions, 630 deletions
@@ -8115,7 +8115,7 @@ EOCP dflt=`./try` else dflt='8' - echo "(I can't seem to compile the test program...)" + echo"(I can't seem to compile the test program...)" fi ;; *) dflt="$alignbytes" @@ -978,7 +978,7 @@ specific rule. SCO prior to 3.2.4 may be missing dbmclose(). An upgrade to 3.2.4 that includes libdbm.nfs (which includes dbmclose()) may be available. -=item Note (probably harmless): No library found for -lsomething +=item Warning (will try anyway): No library found for -lposix If you see such a message during the building of an extension, but the extension passes its tests anyway (see L<"make test"> below), @@ -987,14 +987,13 @@ Makefile.PL goes looking for various libraries needed on various systems; few systems will need all the possible libraries listed. For example, a system may have -lcposix or -lposix, but it's unlikely to have both, so most users will see warnings for the one -they don't have. The phrase 'probably harmless' is intended to -reassure you that nothing unusual is happening, and the build -process is continuing. +they don't have. The message 'will try anyway' is intended to +reassure you that the process is continuing. On the other hand, if you are building GDBM_File and you get the message - Note (probably harmless): No library found for -lgdbm + Warning (will try anyway): No library found for -lgdbm then it's likely you're going to run into trouble somewhere along the line, since it's hard to see how you can use the GDBM_File diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index c194a0dead..0f8df001de 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -55,14 +55,6 @@ Creates a C<IO::File>. If it receives any parameters, they are passed to the method C<open>; if the open fails, the object is destroyed. Otherwise, it is returned to the caller. -=item new_tmpfile - -Creates an C<IO::File> opened for read/write on a newly created temporary -file. On systems where this is possible, the temporary file is anonymous -(i.e. it is unlinked after creation, but held open). If the temporary -file cannot be created or opened, the C<IO::File> object is destroyed. -Otherwise, it is returned to the caller. - =back =head1 METHODS diff --git a/hints/machten_2.sh b/hints/machten_2.sh index dfcedede4e..aae73f592d 100644 --- a/hints/machten_2.sh +++ b/hints/machten_2.sh @@ -15,10 +15,6 @@ # Original version was for MachTen 2.1.1. # Last modified by Andy Dougherty <doughera@lafcol.lafayette.edu> # Tue Aug 13 12:31:01 EDT 1996 -# -# Warning about tests which no longer fail -# fixed by Tom Phoenix <rootbeer@teleport.com> -# March 5, 1997 # I don't know why this is needed. It might be similar to NeXT's # problem. See hints/next_3.sh. @@ -42,11 +38,15 @@ i_db=$undef # This will generate a harmless message: # Hmm...You had some extra variables I don't know about...I'll try to keep 'em. # Propagating recommended variable dont_use_nlink -# Without this, tests io/fs #4 and op/stat #3 will fail. dont_use_nlink=define cat <<'EOM' >&4 +Tests + io/fs test 4 and + op/stat test 3 +may fail since MachTen versions 2.X have no hard links. + At the end of Configure, you will see a harmless message Hmm...You had some extra variables I don't know about...I'll try to keep 'em. diff --git a/hints/os2.sh b/hints/os2.sh index 70e478b96f..9bce2a594c 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -32,9 +32,7 @@ libemx="`../UU/loc . X c:/emx/lib d:/emx/lib e:/emx/lib f:/emx/lib g:/emx/lib h: if test "$libemx" = "X"; then echo "Cannot find C library!"; fi -# Acute backslashitis: -libpth="`echo \"$LIBRARY_PATH\" | tr ';\\\' ' /'`" -libpth="$libpth $libemx/mt $libemx" +libpth="$libemx/mt $libemx" set `emxrev -f emxlibcm` emxcrtrev=$5 diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index ee7cf74cc3..c382fcb1c4 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -329,9 +329,7 @@ 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 $subcode = "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }"; my $subref = eval $subcode; croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; print STDERR "runloop $n '$subcode'\n" if ($debug); diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 2a43022638..a885653820 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/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.2201 $, 10; +$VERSION = substr q$Revision: 1.22 $, 10; use Config; use Cwd 'cwd'; @@ -173,8 +173,7 @@ sub _unix_os2_ext { } last; # found one here so don't bother looking further } - print STDOUT "Note (probably harmless): " - ."No library found for -l$thislib\n" + print STDOUT "Warning (will try anyway): No library found for -l$thislib\n" unless $found_lib>0; } return ('','','','') unless $found; @@ -257,13 +256,11 @@ sub _vms_ext { if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; } elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } elsif ($test =~ /(?:$obj_ext|obj)$/i) { - print STDOUT "Note (probably harmless): " - ."Plain object file $test found in library list\n"; + print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n"; $type = 'obj'; } else { - print STDOUT "Note (probably harmless): " - ."Unknown library type for $test; assuming shared\n"; + print STDOUT "Warning (will try anyway): Unknown library type for $test; assuming shared\n"; $type = 'sh'; } } @@ -281,8 +278,7 @@ sub _vms_ext { elsif (not length($ctype) and # If we've got a lib already, don't bother ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) { - print STDOUT "Note (probably harmless): " - ."Plain object file $test found in library list\n"; + print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n"; $type = 'obj'; $name = $test unless $test =~ /obj;?\d*$/i; } @@ -298,8 +294,7 @@ sub _vms_ext { next LIB; } } - print STDOUT "Note (probably harmless): " - ."No library found for $lib\n"; + print STDOUT "Warning (will try anyway): No library found for $lib\n"; } @libs = sort keys %obj; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 7145737930..77e4e2b545 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -244,11 +244,11 @@ sub full_setup { XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit - installpm IMPORTS + installpm + /; # ^^^ installpm is deprecated, will go about Summer 96 - # IMPORTS is used under OS/2 # @Overridable is close to @MM_Sections but not identical. The # order is important. Many subroutines declare macros. These diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index ec4ccd98e9..221cc54b39 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -1,15 +1,26 @@ -# GetOpt::Long.pm -- Universal options parsing +# GetOpt::Long.pm -- POSIX compatible options parsing -package Getopt::Long; - -# RCS Status : $Id: GetoptLong.pm,v 2.9 1997-03-02 15:00:05+01 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.6 1997-01-11 13:12:01+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Sun Mar 2 14:59:41 1997 -# Update Count : 586 +# Last Modified On: Sat Jan 11 13:11:35 1997 +# Update Count : 506 # Status : Released +package Getopt::Long; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); +$VERSION = sprintf("%d.%02d", '$Revision: 2.6002 $ ' =~ /(\d+)\.(\d+)/); +use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order + $passthrough $error $debug + $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER + $VERSION $major_version $minor_version); +use strict; + =head1 NAME GetOptions - extended processing of command line options @@ -218,7 +229,7 @@ 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>. +configuration variable $Getopt::Long::autoabbrev. =head2 Non-option call-back routine @@ -226,9 +237,7 @@ 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. - +This feature requires $Getopt::Long::order to have the value $PERMUTE. See also the examples. =head2 Option starters @@ -264,10 +273,10 @@ 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 configuration variable $Getopt::Long::getopt_compat is set to a +non-zero value, 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 @@ -331,59 +340,33 @@ 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. +=head1 CONFIGURATION VARIABLES -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: +The following variables can be set to change the default behaviour of +GetOptions(): =over 12 -=item default - -This option causes all configuration options to be reset to their -default values. - -=item auto_abbrev +=item $Getopt::Long::autoabbrev 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. +Default is 1 unless environment variable +POSIXLY_CORRECT has been set. -=item getopt_compat +=item $Getopt::Long::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. +Default is 1 unless environment variable +POSIXLY_CORRECT has been set. -See also B<permute>, which is the opposite of B<require_order>. - -=item permute +=item $Getopt::Long::order Whether non-options are allowed to be mixed with options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case B<permute> is reset. -Note that B<permute> is the opposite of B<require_order>. +Default is $REQUIRE_ORDER if environment variable +POSIXLY_CORRECT has been set, $PERMUTE otherwise. -If B<permute> is set, this means that +$PERMUTE means that -foo arg1 -bar arg2 arg3 @@ -400,7 +383,7 @@ processed, except when B<--> is used: will call the call-back routine for arg1 and arg2, and terminate leaving arg2 in @ARGV. -If B<require_order> is set, options processing +If $Getopt::Long::order is $REQUIRE_ORDER, options processing terminates when the first non-option is encountered. -foo arg1 -bar arg2 arg3 @@ -409,7 +392,9 @@ is equivalent to -foo -- arg1 -bar arg2 arg3 -=item bundling (default: reset) +$RETURN_IN_ORDER is not supported by GetOptions(). + +=item $Getopt::Long::bundling Setting this variable to a non-zero value will allow single-character options to be bundled. To distinguish bundles from long option names, @@ -434,51 +419,24 @@ 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. +=item $Getopt::Long::ignorecase -Note: resetting B<ignore_case_always> also resets B<ignore_case>. +Ignore case when matching options. Default is 1. When bundling is in +effect, case is ignored on single-character options only if +$Getopt::Long::ignorecase is greater than 1. -=item pass_through (default: reset) +=item $Getopt::Long::passthrough 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 +This can be very confusing, especially when $Getopt::Long::order is +set to $PERMUTE. =item $Getopt::Long::VERSION @@ -486,7 +444,7 @@ The version number of this Getopt::Long implementation in the format C<major>.C<minor>. This can be used to have Exporter check the version, e.g. - use Getopt::Long 3.00; + use Getopt::Long 2.00; You can inspect $Getopt::Long::major_version and $Getopt::Long::minor_version for the individual components. @@ -496,13 +454,17 @@ $Getopt::Long::minor_version for the individual components. Internal error flag. May be incremented from a call-back routine to cause options parsing to fail. +=item $Getopt::Long::debug + +Enable copious debugging output. Default is 0. + =back =cut -################ Copyright ################ - -# This program is Copyright 1990,1997 by Johan Vromans. +################ Introduction ################ +# +# This program is Copyright 1990,1996 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 @@ -517,66 +479,58 @@ cause options parsing to fail. # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, # MA 02139, USA. -################ Module Preamble ################ +################ Configuration Section ################ -use strict; +# Values for $order. See GNU getopt.c for details. +($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); -BEGIN { - require 5.00327; - use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = sprintf("%d.%02d", q$Revision: 2.9 $ =~ /(\d+)\.(\d+)/); +my $gen_prefix; # generic prefix (option starters) - @ISA = qw(Exporter); - @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); - %EXPORT_TAGS = (); - @EXPORT_OK = qw(); +# 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; } -use vars @EXPORT, @EXPORT_OK; -# User visible variables. -use vars qw(&config $error $debug $major_version $minor_version); -# Deprecated visible variables. -use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order - $passthrough); - -################ Local Variables ################ +# Other configurable settings. +$debug = 0; # for debugging +$error = 0; # error tally +$ignorecase = 1; # ignore case when matching options +$passthrough = 0; # leave unrecognized options alone +($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; -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 +use vars qw($genprefix %opctl @opctl %bopctl $opt $arg $argend $array); +use vars qw(%aliases $hash $key); ################ Subroutines ################ 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 + local ($argend) = '--'; # option list terminator + local (%opctl); # table of arg.specs (long and abbrevs) + local (%bopctl); # table of arg.specs (bundles) + my $pkg = (caller)[0]; # current context # Needed if linkage is omitted. - %aliases= (); # alias table + local (%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 + local ($genprefix) = $gen_prefix; # so we can call the same module more + # than once in differing environments $error = 0; - print STDERR ('GetOptions $Revision: 2.9 $ ', + print STDERR ('GetOptions $Revision: 2.6001 $ ', "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", " (@ARGV)\n", @@ -612,7 +566,7 @@ sub GetOptions { my $opt = shift (@optionlist); # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $' if $opt =~ /^($genprefix)+/; + $opt =~ s/^(?:$genprefix)+//s; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -748,7 +702,7 @@ sub GetOptions { return 0 if $error; # Sort the possible long option names. - @opctl = sort(keys (%opctl)) if $autoabbrev; + local (@opctl) = sort(keys (%opctl)) if $autoabbrev; # Show the options tables if debugging. if ( $debug ) { @@ -765,6 +719,12 @@ sub GetOptions { } } + local ($opt); # current option + local ($arg); # current option value, if any + local ($array); # current option is array typed + local ($hash); # current option is hash typed + local ($key); # hash key for a hash option + # Process argument list while ( @ARGV > 0 ) { @@ -788,7 +748,7 @@ sub GetOptions { my $tryopt = $opt; # find_option operates on the GLOBAL $opt and $arg! - if ( &$find_option () ) { + if ( &find_option ) { # find_option undefines $opt in case of errors. next unless defined $opt; @@ -892,92 +852,21 @@ 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\"") - } - } -} - -# 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; -} - -################ Private Subroutines ################ - -$find_option = sub { +sub find_option { - return 0 unless $opt =~ /^$genprefix/; + return 0 unless $opt =~ /^($genprefix)(.*)/s; - $opt = $'; - my ($starter) = $&; + $opt = $+; + my ($starter) = $1; 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 =~ /^([^=]+)=/ ) { + && $opt =~ /^([^=]+)=(.*)/s ) { $opt = $1; - $optarg = $'; + $optarg = $2; print STDERR ("=> option \"", $opt, "\", optarg = \"$optarg\"\n") if $debug; } @@ -986,7 +875,6 @@ $find_option = sub { my $tryopt = $opt; # option to try my $optbl = \%opctl; # table to look it up (long names) - my $type; if ( $bundling && $starter eq '-' ) { # Unbundle single letter option. @@ -997,15 +885,6 @@ $find_option = sub { "$starter$tryopt$rest\n") if $debug; $rest = undef unless $rest ne ''; $optbl = \%bopctl; # look it up in the short names table - - # If bundling == 2, long options can override bundles. - if ( $bundling == 2 and - defined ($type = $opctl{$tryopt.$rest}) ) { - print STDERR ("=> $starter$tryopt rebundled to ", - "$starter$tryopt$rest\n") if $debug; - $tryopt .= $rest; - undef $rest; - } } # Try auto-abbreviation. @@ -1054,7 +933,7 @@ $find_option = sub { } # Check validity by fetching the info. - $type = $optbl->{$tryopt} unless defined $type; + my $type = $optbl->{$tryopt}; unless ( defined $type ) { return 0 if $passthrough; warn ("Unknown option: ", $opt, "\n"); @@ -1113,7 +992,7 @@ $find_option = sub { # Get key if this is a "name=value" pair for a hash option. $key = undef; if ($hash && defined $arg) { - ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1); + ($key, $arg) = ($arg =~ /(.*?)=(.*)/s) ? ($1, $2) : ($arg, 1); } #### Check if the argument is valid for this option #### @@ -1179,40 +1058,7 @@ $find_option = sub { die ("GetOpt::Long internal error (Can't happen)\n"); } return 1; -}; - -$config_defaults = sub { - # Handle POSIX compliancy. - if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $gen_prefix = "(--|-)"; - $autoabbrev = 0; # no automatic abbrev of options - $bundling = 0; # no bundling of single letter switches - $getopt_compat = 0; # disallow '+' to start options - $order = $REQUIRE_ORDER; - } - else { - $gen_prefix = "(--|-|\\+)"; - $autoabbrev = 1; # automatic abbrev of options - $bundling = 0; # bundling off by default - $getopt_compat = 1; # allow '+' to start options - $order = $PERMUTE; - } - # Other configurable settings. - $debug = 0; # for debugging - $error = 0; # error tally - $ignorecase = 1; # ignore case when matching options - $passthrough = 0; # leave unrecognized options alone -}; - -################ Initialization ################ - -# Values for $order. See GNU getopt.c for details. -($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); -# Version major/minor numbers. -($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; - -# Set defaults. -&$config_defaults (); +} ################ Package return ################ diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm index 0c88a76e41..88fc6386c3 100644 --- a/lib/Term/ReadLine.pm +++ b/lib/Term/ReadLine.pm @@ -76,12 +76,6 @@ history. Returns the old value. returns an array with two strings that give most appropriate names for files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">. -=item Attribs - -returns a reference to a hash which describes internal configuration -of the package. Names of keys in this hash conform to standard -conventions with the leading C<rl_> stripped. - =item C<Features> Returns a reference to a hash with keys being features present in @@ -92,49 +86,26 @@ C<MinLine> method is not dummy. C<autohistory> should be present if lines are put into history automatically (maybe subject to C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy. -If C<Features> method reports a feature C<attribs> as present, the -method C<Attribs> is not dummy. - =back -=head1 Additional supported functions - Actually C<Term::ReadLine> can use some other package, that will support reacher set of commands. -All these commands are callable via method interface and have names -which conform to standard conventions with the leading C<rl_> stripped. - =head1 EXPORTS None -=head1 ENVIRONMENT - -The variable C<PERL_RL> governs which ReadLine clone is loaded. If the -value is false, a dummy interface is used. If the value is true, it -should be tail of the name of the package to use, such as C<Perl> or -C<Gnu>. - -If the variable is not set, the best available package is loaded. - =cut package Term::ReadLine::Stub; -@ISA = 'Term::ReadLine::Tk'; $DB::emacs = $DB::emacs; # To peacify -w sub ReadLine {'Term::ReadLine::Stub'} sub readline { - my $self = shift; - my ($in,$out,$str) = @$self; + my ($in,$out,$str) = @{shift()}; print $out shift; - $self->register_Tk - if not $Term::ReadLine::registered and $Term::ReadLine::toloop - and defined &Tk::DoOneEvent; - #$str = scalar <$in>; - $str = $self->get_line; + $str = scalar <$in>; # bug in 5.000: chomping empty string creats length -1: chomp $str if defined $str; $str; @@ -195,27 +166,10 @@ sub new { sub IN { shift->[0] } sub OUT { shift->[1] } sub MinLine { undef } -sub Attribs { {} } - -my %features = (tkRunning => 1); -sub Features { \%features } +sub Features { {} } package Term::ReadLine; # So late to allow the above code be defined? - -my $which = $ENV{PERL_RL}; -if ($which) { - if ($which =~ /\bgnu\b/i){ - eval "use Term::ReadLine::Gnu;"; - } elsif ($which =~ /\bperl\b/i) { - eval "use Term::ReadLine::Perl;"; - } else { - eval "use Term::ReadLine::$which;"; - } -} elsif (defined $which) { # Defined but false - # Do nothing fancy -} else { - eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1"; -} +eval "use Term::ReadLine::Gnu;" or eval "use Term::ReadLine::Perl;"; #require FileHandle; @@ -230,42 +184,6 @@ if (defined &Term::ReadLine::Gnu::readline) { @ISA = qw(Term::ReadLine::Stub); } -package Term::ReadLine::Tk; - -$count_handle = $count_DoOne = $count_loop = 0; - -sub handle {$giveup = 1; $count_handle++} - -sub Tk_loop { - # Tk->tkwait('variable',\$giveup); # needs Widget - $count_DoOne++, Tk::DoOneEvent(0) until $giveup; - $count_loop++; - $giveup = 0; -} - -sub register_Tk { - my $self = shift; - $Term::ReadLine::registered++ - or Tk->fileevent($self->IN,'readable',\&handle); -} - -sub tkRunning { - $Term::ReadLine::toloop = $_[1] if @_ > 1; - $Term::ReadLine::toloop; -} - -sub get_c { - my $self = shift; - $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; - return getc $self->IN; -} - -sub get_line { - my $self = shift; - $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; - my $in = $self->IN; - return scalar <$in>; -} 1; diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index f2e1514972..f86c8c2991 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -95,12 +95,12 @@ sub quotewords { while (length($_)) { $field = ''; for (;;) { - $snippet = ''; - if (s/^"(([^"\\]|\\.)*)"//) { + $snippet = ''; + if (s/^"(([^"\\]|\\[\\"])*)"//) { $snippet = $1; $snippet = "\"$snippet\"" if ($keep); } - elsif (s/^'(([^'\\]|\\.)*)'//) { + elsif (s/^'(([^'\\]|\\[\\'])*)'//) { $snippet = $1; $snippet = "'$snippet'" if ($keep); } diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 26a3309ca1..11d0de7bf4 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 0.9907; +$VERSION = 0.9906; $header = "perl5db.pl patch level $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -157,6 +157,7 @@ warn ( # Do not ;-) $dumpvar::quoteHighBit, $dumpvar::printUndef, $dumpvar::globPrint, + $readline::Tk_toloop, $dumpvar::usageOnly, @ARGS, $Carp::CarpLevel, @@ -188,6 +189,7 @@ $inhibit_exit = $option{PrintRet} = 1; HighBit => \$dumpvar::quoteHighBit, undefPrint => \$dumpvar::printUndef, globPrint => \$dumpvar::globPrint, + tkRunning => \$readline::Tk_toloop, UsageOnly => \$dumpvar::usageOnly, frame => \$frame, AutoTrace => \$trace, @@ -210,7 +212,6 @@ $inhibit_exit = $option{PrintRet} = 1; signalLevel => \&signalLevel, warnLevel => \&warnLevel, dieLevel => \&dieLevel, - tkRunning => \&tkRunning, ); %optionRequire = ( @@ -1356,13 +1357,15 @@ sub setterm { } else { $term = new Term::ReadLine 'perldb', $IN, $OUT; - $rl_attribs = $term->Attribs; - $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' - if defined $rl_attribs->{basic_word_break_characters} - and index($rl_attribs->{basic_word_break_characters}, ":") == -1; - $rl_attribs->{special_prefixes} = '$@&%'; - $rl_attribs->{completer_word_break_characters} .= '$@&%'; - $rl_attribs->{completion_function} = \&db_complete; + $readline::rl_basic_word_break_characters .= "[:" + if defined $readline::rl_basic_word_break_characters + and index($readline::rl_basic_word_break_characters, ":") == -1; + $readline::rl_special_prefixes = + $readline::rl_special_prefixes = '$@&%'; + $readline::rl_completer_word_break_characters = + $readline::rl_completer_word_break_characters . '$@&%'; + $readline::rl_completion_function = + $readline::rl_completion_function = \&db_complete; } $LINEINFO = $OUT unless defined $LINEINFO; $lineinfo = $console unless defined $lineinfo; @@ -1521,15 +1524,6 @@ sub ReadLine { $rl; } -sub tkRunning { - if ($ {$term->Features}{tkRunning}) { - return $term->tkRunning(@_); - } else { - print $OUT "tkRunning not supported by current ReadLine package.\n"; - 0; - } -} - sub NonStop { if ($term) { &warn("Too late to set up NonStop mode!\n") if @_; @@ -1996,10 +1990,12 @@ sub db_complete { $out = "=$val "; } # Default to value if one completion, to question if many - $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? '); + $readline::rl_completer_terminator_character + = $readline::rl_completer_terminator_character + = (@out == 1 ? $out : '? '); return sort @out; } - return $term->filename_list($text); # filenames + return &readline::rl_filename_list($text); # filenames } sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" } diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 09b5ad3df7..cf5dd8fef2 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -606,10 +606,8 @@ extirpated as a potential munition). This can prove useful for checking the password file for lousy passwords, amongst other things. Only the guys wearing white hats should do this. -Note that crypt is intended to be a one-way function, much like breaking -eggs to make an omelette. There is no (known) corresponding decrypt -function. As a result, this function isn't all that useful for -cryptography. (For that, see your nearby CPAN mirror.) +Note that there is no corresponding decrypt, so this fucntion isn't +all that useful for cryptography. (For that, see your nearby CPAN mirror.) Here's an example that makes sure that whoever runs this program knows their own password: @@ -706,6 +704,8 @@ Examples: print "$val\n" while defined($val = pop(@ary)); die "Can't readlink $sym: $!" unless defined($value = readlink $sym); + eval '@foo = ()' if defined(@foo); + die "No XYZ package defined" unless defined %_XYZ; sub foo { defined &$bar ? &$bar(@_) : die "No bar"; } $debugging = 0 unless defined $debugging; diff --git a/pod/pod2html.PL b/pod/pod2html.PL index 76a3479855..602a866e42 100644 --- a/pod/pod2html.PL +++ b/pod/pod2html.PL @@ -35,7 +35,7 @@ print OUT <<'!NO!SUBS!'; # # pod2html - convert pod format to html -# Version 1.21 +# Version 1.15 # usage: pod2html [podfiles] # Will read the cwd and parse all files with .pod extension # if no arguments are given on the command line. @@ -45,13 +45,11 @@ print OUT <<'!NO!SUBS!'; # # Please send patches/fixes/features to me # - -require 'find.pl'; - +# +# *RS = */; *ERRNO = *!; - ################################################################################ # Invoke with various levels of debugging possible ################################################################################ @@ -66,151 +64,67 @@ while ($ARGV[0]) { } ################################################################################ -# CONFIGURE - change the following to suit your OS and taste -################################################################################ +# CONFIGURE +# # The beginning of the url for the anchors to the other sections. # Edit $type to suit. It's configured for relative url's now. # Other possibilities are: # $type = '<A HREF="file://localhost/usr/local/htmldir/'; # file url # $type = '<A HREF="http://www.bozo.com/perl/manual/html/' # server - -$type = '<A HREF="'; - -################################################################################ -# location of all podfiles unless on command line -# $installprivlib="HD:usr:local:lib:perl5"; # uncomment and reset for Mac -# $installprivlib="C:\usr\local\lib\perl5"; # uncomment and reset for DOS (I hope) - -# $installprivlib="/usr/local/lib/perl5"; # Unix -$installprivlib="./"; # Standard perl pod directory for intallation - -################################################################################ -# Where to write out the html files -# $installhtmldir="HD:usr:local:lib:perl5:html"; # uncomment and reset for Mac -# $installhtmldir="C:\usr\local\lib\perl5\html"; # uncomment and reset for DOS (I hope) -$installhtmldir = "./"; - -# test for validness - -if(!(-d $installhtmldir)){ - print "Installation directory $installhtmldir does not exist, using cwd\n"; - print "Hit ^C now to edit this script and configure installhtmldir\n"; - $installhtmldir = '.'; -} - -################################################################################ -# the html extension, change to htm for DOS - -$htmlext = "html"; - +# ################################################################################ -# arbitrary name for this group of pods -$package = "perl"; +$type = '<A HREF="'; +$dir = "."; # location of pods -################################################################################ -# look in these pods for links to things not found within the current pod +# look in these pods for things not found within the current pod # be careful tho, namespace collisions cause stupid links -@inclusions = qw[ perlfunc perlvar perlrun perlop ]; - -################################################################################ -# Directory path separator -# $sep= ":"; # uncomment for Mac -# $sep= "\"; # uncomment for DOS - -$sep= "/"; - -################################################################################ -# Create 8.3 html files if this equals 1 - -$DOSify=0; - -################################################################################ -# Create maximum 32 character html files if this equals 1 -$MACify=0; - +@inclusions = qw[ + perlfunc perlvar perlrun perlop +]; ################################################################################ # END CONFIGURE -# Beyond here be dragons. :-) ################################################################################ $A = {}; # The beginning of all things -unless(@Pods){ - find($installprivlib); - splice(@Pods,$#Pods+1,0,@modpods);; +unless (@Pods) { + opendir(DIR,$dir) or die "Can't opendir $dir: $ERRNO"; + @Pods = grep(/\.pod$/,readdir(DIR)); + closedir(DIR) or die "Can't closedir $dir: $ERRNO"; } - @Pods or die "aak, expected pods"; -open(INDEX,">".$installhtmldir.$sep."index.".$htmlext) or - (die "cant open index.$htmlext"); -print INDEX "\n<HTML>\n<HEAD>\n<TITLE>Index of all pods for $package</TITLE></HEAD>\n<BODY>\n"; -print INDEX "<H1>Index of all pods for $package</H1>\n<hr><UL>\n"; + # loop twice through the pods, first to learn the links, then to produce html for $count (0,1) { print STDERR "Scanning pods...\n" unless $count; -loop1: foreach $podfh ( @Pods ) { - $didindex = 0; - $refname = $podfh; - $refname =~ s/$installprivlib${sep}?//; - $refname =~ s/${sep}/::/g; - $refname =~ s/\.p(m|od)$//; - $refname =~ s/^pod:://; - $savename = $refname; - $refname =~ s/::/_/g; - if($DOSify && !$count){ # shorten the name for DOS - (length($refname) > 8) and ( $refname = substr($refname,0,8)); - while(defined($DosNames{$refname})){ - @refname=split(//,$refname); - # allow 25 of em - ($refname[$#refname] eq "z") and ($refname[$#refname] = "a"); - $refname[$#refname]++; - $refname=join('',@refname); - $refname =~ s/\W/_/g; - } - $DosNames{$refname} = 1; - $Podnames{$savename} = $refname . ".$htmlext"; - } - elsif(!$DOSify and !$count){ - $Podnames{$savename} = $refname . ".$htmlext"; - } - $pod = $savename; + ($pod = $podfh) =~ s/\.(?:pod|pm)$//; Debug("files", "opening 2 $podfh" ); - print "Creating $Podnames{$savename} from $podfh\n" if $count; + print "Creating $pod.html from $podfh\n" if $count; $RS = "\n="; # grok pods by item (Nonstandard but effecient) open($podfh,"<".$podfh) || die "can't open $podfh: $ERRNO"; @all = <$podfh>; close($podfh); $RS = "\n"; - ($all[0] =~ s/^=//) || pop(@all); - for ($i=0;$i <= $#all;$i++){ splice(@all,$i+1,1) unless - (($all[$i] =~ s/=$//) && ($all[$i+1] !~ /^cut/)) ; # whoa.. - } + + $all[0] =~ s/^=//; + for (@all) { s/=$// } + $Podnames{$pod} = 1; $in_list = 0; - unless (grep(/NAME/,@all)){ - print STDERR "NAME header not found in $podfh, skipping\n"; - #delete($Podnames{$savename}); - next loop1; + $html = $pod.".html"; + if ($count) { # give us a html and rcs header + open(HTML,">$html") || die "can't create $html: $ERRNO"; + print HTML '<!-- $Id$ -->',"\n",'<HTML><HEAD>',"\n"; + print HTML "<CENTER>" unless $NO_NS; + print HTML "<TITLE>$pod</TITLE>"; + print HTML "</CENTER>" unless $NO_NS; + print HTML "\n</HEAD>\n<BODY>"; } - if ($count) { - next unless length($Podnames{$savename}); - open(HTML,">".$installhtmldir.$sep.$Podnames{$savename}) or - (die "can't create $Podnames{$savename}: $ERRNO"); - print HTML "<HTML><HEAD>"; - print HTML "<TITLE>$refname</TITLE>\n</HEAD>\n<BODY>"; - } - for ($i = 0; $i <= $#all; $i++) { # decide what to do with each chunk $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ; ($cmd, $title, $rest) = ($1,$2,$3); - if(length($cmd)){$cutting =0;} - next if $cutting; - if(($title =~ /NAME/) and ($didindex == 0) and $count){ - print INDEX "<LI><A HREF=\"$Podnames{$savename}\">$rest</A>\n"; - $didindex=1; - } if ($cmd eq "item") { if ($count ) { # producing html do_list("over",$all[$i],\$in_list,\$depth) unless $depth; @@ -238,7 +152,7 @@ loop1: if ($count) { # producing html ($depth) or next; # just skip it do_list("back",$all[$i+1],\$in_list,\$depth); - do_rest("$title$rest"); + do_rest($title.$rest); } } elsif ($cmd =~ /^cut/) { @@ -248,7 +162,7 @@ loop1: if ($count) { # producing html if ($title =~ s/^html//) { $in_html =1; - do_rest("$title$rest"); + do_rest($title.$rest); } } } @@ -275,7 +189,6 @@ loop1: } } } -print INDEX "\n</UL></BODY>\n</HTML>\n"; sub do_list{ # setup a list type, depending on some grok logic my($which,$next_one,$list_type,$depth) = @_; @@ -297,7 +210,7 @@ sub do_list{ # setup a list type, depending on some grok logic } print HTML qq{\n}; - print HTML qq{<$$list_type>}; + print HTML $$list_type eq 'DL' ? qq{<DL COMPACT>} : qq{<$$list_type>}; $$depth++; } elsif ($which eq "back") { @@ -308,57 +221,28 @@ sub do_list{ # setup a list type, depending on some grok logic sub do_hdr{ # headers my($num,$title,$rest,$depth) = @_; - my($savename,$restofname); print HTML qq{<p><hr>\n} if $num == 1; - ($savename = $title) =~ s/^(\w+)([\s,]+.*)/$1/; - $restofname = $2; - (defined($Podnames{$savename})) ? ($savename = $savename) : ($savename = 0); process_thing(\$title,"NAME"); print HTML qq{\n<H$num> }; - if($savename){ - print HTML "<A HREF=\"$Podnames{$savename}\">$savename$restofname</A>"; - } - else{ - print HTML $title; - } + print HTML $title; print HTML qq{</H$num>\n}; do_rest($rest); } sub do_item{ # list items my($title,$rest,$list_type) = @_; - my $bullet_only; - $bullet_only = ($title eq '*' and $list_type eq 'UL') ? 1 : 0; - my($savename); - $savename = $title; - (defined($Podnames{$savename})) ? ($savename = $savename) : ($savename = 0); + my $bullet_only = $title eq '*' and $list_type eq 'UL'; process_thing(\$title,"NAME"); if ($list_type eq "DL") { - print HTML qq{\n<DT>\n}; - if($savename){ - print HTML "<A HREF=\"$Podnames{$savename}\">$savename $rest</A>\n</DT>"; - } - - else{ - (print HTML qq{\n<STRONG>\n}) unless ($title =~ /STRONG/); - print HTML $title; - if($title !~ /STRONG/){ - print HTML "\n</STRONG></DT>\n"; - } else { - print HTML "</DT>\n"; - } - } + print HTML qq{\n<DT><STRONG>\n}; + print HTML $title; + print HTML qq{\n</STRONG>\n}; print HTML qq{<DD>\n}; } else { print HTML qq{\n<LI>}; unless ($bullet_only or $list_type eq "OL") { - if($savename){ - print HTML "<A HREF=\"$savename.$htmlext\">$savename</A>"; - } - else{ - print HTML $title,"\n"; - } + print HTML $title,"\n"; } } do_rest($rest); @@ -381,7 +265,7 @@ sub do_rest{ # the rest of the chunk handled here foreach $line (@lines) { ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2)); print HTML defined($Podnames{$key}) - ? "<LI>$type$Podnames{$key}\">$key<\/A>\t$rem</LI>\n" + ? "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n" : "<LI>$line</LI>\n"; } print HTML qq{</UL>\n}; @@ -392,7 +276,7 @@ sub do_rest{ # the rest of the chunk handled here $inpre=1; } else { # Still cant beat XMP. Yes, I know - print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions? + print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions? $inpre = 0; } while (defined($paras[$p])) { @@ -421,7 +305,6 @@ sub do_rest{ # the rest of the chunk handled here @lines = split(/\n/,$paras[$p]); foreach $line (@lines) { process_thing(\$line,"HTML"); - $line =~ s/STRONG([^>])/STRONG>$1/; # lame attempt to fix strong print HTML qq{$line\n}; } } @@ -440,6 +323,7 @@ sub scan_thing{ # scan a chunk for later references my($cmd,$title,$pod) = @_; $_ = $title; s/\n$//; + s/E<(\d+)>/&#$1;/g; s/E<(.*?)>/&$1;/g; # remove any formatting information for the headers s/[SFCBI]<(.*?)>/$1/g; @@ -496,27 +380,21 @@ sub picrefs { } } if (length($key)) { - ($pod2, $num) = $value =~ /^(.*)_(\S+_\d+)$/; + ($pod2, $num) = $value =~ /^(.*)_(\S+_\d+)$/; if ($htype eq "NAME") { - return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n" + return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n" } else { - 1; # break here - return "\n$type$Podnames{$pod2}\#".$value."\">$bigkey<\/A>\n"; + return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n"; } } } if ($char =~ /[IF]/) { return "<EM>$bigkey</EM>"; } elsif ($char =~ /C/) { - return "<CODE>$bigkey</CODE>"; + return "<CODE>$bigkey</CODE>"; } else { - if($bigkey =~ /STRONG/){ - return $bigkey; - } - else { - return "<STRONG>$bigkey</STRONG>"; - } + return "<STRONG>$bigkey</STRONG>"; } } @@ -558,7 +436,7 @@ sub lrefs { $item =~ s/\(\)$//; if (!$item) { if (!defined $section && defined $Podnames{$page}) { - return "\n$type$Podnames{$page}\">\nthe <EM>$page</EM> manpage<\/A>\n"; + return "\n$type$page.html\">\nthe <EM>$page</EM> manpage<\/A>\n"; } else { (warn "Bizarre entry $page/$item") if $Debug; return "the <EM>$_[0]</EM> manpage\n"; @@ -576,18 +454,18 @@ sub lrefs { undef $value; if ($ref eq "Items") { if (defined($value = $A->{$podname}->{$ref}->{$item})) { - ($pod2,$num) = split(/_/,$value,2); # break here - return (($pod eq $pod2) && ($htype eq "NAME")) - ? "\n<A NAME=\"".$value."\">\n$text</A>\n" - : "\n$type$Podnames{$pod2}\#".$value."\">$text<\/A>\n"; - } - } + ($pod2,$num) = split(/_/,$value,2); + return (($pod eq $pod2) && ($htype eq "NAME")) + ? "\n<A NAME=\"".$value."\">\n$text</A>\n" + : "\n$type$pod2.html\#".$value."\">$text<\/A>\n"; + } + } elsif ($ref eq "Headers") { if (defined($value = $A->{$podname}->{$ref}->{$item})) { - ($pod2,$num) = split(/_/,$value,2); # break here + ($pod2,$num) = split(/_/,$value,2); return (($pod eq $pod2) && ($htype eq "NAME")) ? "\n<A NAME=\"".$value."\">\n$text</A>\n" - : "\n$type$Podnames{$pod2}\#".$value."\">$text<\/A>\n"; + : "\n$type$pod2.html\#".$value."\">$text<\/A>\n"; } } } @@ -603,16 +481,11 @@ sub varrefs { Debug("vars", "way cool -- var ref on $var"); return (($pod eq $pod2) && ($htype eq "NAME")) # INHERIT $_, $pod ? "\n<A NAME=\"".$value."\">\n$var</A>\n" - : "\n$type$Podnames{$pod2}\#".$value."\">$var<\/A>\n"; + : "\n$type$pod2.html\#".$value."\">$var<\/A>\n"; } } Debug( "vars", "bummer, $var not a var"); - if($var =~ /STRONG/){ - return $var; - } - else{ - return "<STRONG>$var</STRONG>"; - } + return "<STRONG>$var</STRONG>"; } sub gensym { @@ -630,13 +503,13 @@ sub gensym { sub pre_escapes { # twiddle these, and stay up late :-) my($thing) = @_; for ($$thing) { - s/([\200-\377])/noremap("&#".ord($1).";")/ge; - s/"(.*?)"/``$1''/gs; - s/&/noremap("&")/ge; - s/<</noremap("<<")/eg; - s/([^ESIBLCF])</$1\<\;/g; - s/E<(\d+)>/\&#$1\;/g; # embedded numeric special - s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special + s/([\200-\377])/noremap("&#".ord($1).";")/ge; + s/"(.*?)"/``$1''/gs; + s/&/noremap("&")/ge; + s/<</noremap("<<")/eg; + s/([^ESIBLCF])</$1\<\;/g; + s/E<(\d+)>/\&#$1\;/g; # embedded numeric special + s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special } } sub noremap { # adding translator for hibit chars soon @@ -673,15 +546,6 @@ sub trim { s/\s\n?$//; } } -sub wanted { - my $name = $name; - if (-f $_) { - if ($name =~ /\.p(m|od)$/){ - push(@modpods, $name) if ($name =~ /\.p(m|od)$/); - } - } -} - !NO!SUBS! close OUT or die "Can't close $file: $!"; @@ -7,19 +7,19 @@ $| = 1; -if ($#ARGV >= 0 && $ARGV[0] eq '-v') { +if ($ARGV[0] eq '-v') { $verbose = 1; shift; } chdir 't' if -f 't/TEST'; -die "You need to run \"make test\" first to set things up.\n" +die "You need to run \"make test\" first to set things up.\n" unless -e 'perl' or -e 'perl.exe'; $ENV{EMXSHELL} = 'sh'; # For OS/2 -if ($#ARGV == -1) { +if ($ARGV[0] eq '') { @ARGV = split(/[ \n]/, `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); } @@ -49,11 +49,11 @@ while ($test = shift) { chop($te); print "$te" . '.' x (18 - length($te)); if ($sharpbang) { - open(RESULTS,"./$test |") || (print "can't run.\n"); + open(results,"./$test |") || (print "can't run.\n"); } else { - open(SCRIPT,"$test") || die "Can't run $test.\n"; - $_ = <SCRIPT>; - close(SCRIPT); + open(script,"$test") || die "Can't run $test.\n"; + $_ = <script>; + close(script); if (/#!..perl(.*)/) { $switch = $1; if ($^O eq 'VMS') { @@ -63,13 +63,11 @@ while ($test = shift) { } else { $switch = ''; } - open(RESULTS,"./perl$switch $test |") || (print "can't run.\n"); + open(results,"./perl$switch $test |") || (print "can't run.\n"); } $ok = 0; $next = 0; - $files = 0; - $totmax = 0; - while (<RESULTS>) { + while (<results>) { if ($verbose) { print $_; } @@ -139,4 +137,4 @@ SHRDLU ($user,$sys,$cuser,$csys) = times; print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", $user,$sys,$cuser,$csys,$files,$totmax); -exit ($bad != 0); +exit $bad != 0; diff --git a/t/op/taint.t b/t/op/taint.t index 5758441218..32277181f6 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -94,9 +94,8 @@ print "1..96\n"; test 4, $@ =~ /^Insecure \$ENV{IFS}/, $@; my ($tmp) = grep { (stat)[2] & 2 } '/tmp', '/var/tmp', '/usr/tmp'; - if ($tmp and $^O ne 'os2') { # All dirs are writable under OS/2 + if ($tmp) { $ENV{PATH} = $tmp; - $ENV{IFS} = ''; test 5, eval { `$echo 1` } eq ''; test 6, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; } diff --git a/t/pragma/locale.t b/t/pragma/locale.t index 05891fad77..298e5bab80 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; - if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { + if ($Config{ccflags} =~ /\bD?NO_LOCALE\b/) { print "1..0\n"; exit; } diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 70f9e01bc1..2aa57ad2f3 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -228,7 +228,7 @@ sub expr { $id .= ' ' . $1; $isatype{$id} = 1; } - elsif ($id eq 'unsigned' || $id eq 'long') { + elsif ($id eq 'unsigned') { s/^\s+(\w+)//; $id .= ' ' . $1; $isatype{$id} = 1; |