diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1996-11-19 14:16:00 +1200 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1996-11-19 14:16:00 +1200 |
commit | 55497cffdd24c959994f9a8ddd56db8ce85e1c5b (patch) | |
tree | 444dfb8adc0e5b96d56e0532791122c366f50a3e /lib | |
parent | c822f08a5087943f7d9e2c36ce42ea035f03ab97 (diff) | |
download | perl-55497cffdd24c959994f9a8ddd56db8ce85e1c5b.tar.gz |
[inseparable changes from patch from perl5.003_07 to perl5.003_08]
CORE LANGUAGE CHANGES
Subject: Bitwise op sign rationalization
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c opcode.pl pod/perlop.pod pod/perltoc.pod pp.c pp.h pp_hot.c proto.h sv.c t/op/bop.t
Make bitwise ops result in unsigned values, unless C<use
integer> is in effect. Includes initial support for UVs.
Subject: Defined scoping for C<my> in control structures
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c perly.c perly.c.diff perly.h perly.y proto.h toke.c
Finally defines semantics of "my" in control expressions,
like the condition of "if" and "while". In all cases, scope
of a "my" var extends to the end of the entire control
structure. Also adds new construct "for my", which
automatically declares the control variable "my" and limits
its scope to the loop.
Subject: Fix ++/-- after int conversion (e.g. 'printf "%d"')
From: Chip Salzenberg <chip@atlantic.net>
Files: pp.c pp_hot.c sv.c
This patch makes Perl correctly ignore SvIVX() if either
NOK or POK is true, since SvIVX() may be a truncated or
overflowed version of the real value.
Subject: Make code match Camel II re: functions that use $_
From: Paul Marquess <pmarquess@bfsec.bt.co.uk>
Files: opcode.pl
Subject: Provide scalar context on left side of "->"
From: Chip Salzenberg <chip@atlantic.net>
Files: perly.c perly.y
Subject: Quote bearword package/handle FOO in "funcname FOO => 'bar'"
From: Chip Salzenberg <chip@atlantic.net>
Files: toke.c
OTHER CORE CHANGES
Subject: Warn on overflow of octal and hex integers
From: Chip Salzenberg <chip@atlantic.net>
Files: proto.h toke.c util.c
Subject: If -w active, warn for commas and hashes ('#') in qw()
From: Chip Salzenberg <chip@atlantic.net>
Files: toke.c
Subject: Fixes for pack('w')
From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
Files: pp.c t/op/pack.t
Subject: More complete output from sv_dump()
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: sv.c
Subject: Major '..' and debugger patches
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: lib/perl5db.pl op.c pp_ctl.c scope.c scope.h
Subject: Fix for formline()
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: global.sym mg.c perl.h pod/perldiag.pod pp_ctl.c proto.h sv.c t/op/write.t
Subject: Fix stack botch in untie and binmode
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: pp_sys.c
Subject: Complete EMBED, including symbols from interp.sym
From: Chip Salzenberg <chip@atlantic.net>
Files: MANIFEST embed.pl ext/DynaLoader/dlutils.c ext/SDBM_File/sdbm/sdbm.h global.sym handy.h malloc.c perl.h pp_sys.c proto.h regexec.c toke.c util.c x2p/Makefile.SH x2p/a2p.h x2p/handy.h x2p/util.h
New define EMBEDMYMALLOC makes embedding total by
avoiding "Mymalloc" etc.
Subject: Support old embedding for people who want it
From: Chip Salzenberg <chip@atlantic.net>
Files: MANIFEST Makefile.SH old_embed.pl old_global.sym
PORTABILITY
Subject: Miscellaneous VMS fixes
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_VMS.pm lib/Math/Complex.pm lib/Time/Local.pm lib/timelocal.pl perl.h perl_exp.SH proto.h t/TEST t/io/read.t t/lib/findbin.t t/lib/getopt.t util.c utils/h2xs.PL vms/Makefile vms/config.vms vms/descrip.mms vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs vms/perlvms.pod vms/test.com vms/vms.c
Subject: DJGPP patches (MS-DOS)
From: "Douglas E. Wegscheid" <wegscd@whirlpool.com>
Files: doio.c dosish.h ext/SDBM_File/sdbm/sdbm.c handy.h lib/AutoSplit.pm lib/Cwd.pm lib/File/Find.pm malloc.c perl.c perl.h pp_sys.c proto.h sv.c util.c
Subject: Patch to make Perl work under AmigaOS
From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de>
Files: MANIFEST hints/amigaos.sh installman lib/File/Basename.pm lib/File/Find.pm pod/pod2man.PL pp_sys.c util.c
Diffstat (limited to 'lib')
38 files changed, 845 insertions, 381 deletions
diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index 7d781d13c0..fa9a322449 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -95,10 +95,6 @@ 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. -Calling foo($1) for the autoloaded function foo() might not work as -expected, because the AUTOLOAD function of B<AutoLoader> clobbers the -regexp variables. Invoking it as foo("$1") avoids this problem. - =cut AUTOLOAD { diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index b582f78d69..d9bd17a7f7 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -195,6 +195,7 @@ sub autosplit_file{ die "Package $package does not match filename $filename" unless ($filename =~ m/$modpname.pm$/ or + ($^O eq "msdos") or $Is_VMS && $filename =~ m/$modpname.pm/i); if ($check_mod_time){ diff --git a/lib/Carp.pm b/lib/Carp.pm index 5de8f83d14..1a1b79ea3f 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -29,6 +29,8 @@ not where carp() was called. $CarpLevel = 0; # How many extra package levels to skip on carp. $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. +$MaxArgLen = 64; # How much of each argument to print. 0 = all. +$MaxArgNums = 8; # How many arguments to print. 0 = all. require Exporter; @ISA = Exporter; @@ -38,8 +40,10 @@ sub longmess { my $error = shift; my $mess = ""; my $i = 1 + $CarpLevel; - my ($pack,$file,$line,$sub,$eval,$require); - while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) { + my ($pack,$file,$line,$sub,$hargs,$eval,$require); + my (@a); + while (do { { package DB; @a = caller($i++) } } ) { + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; if ($error =~ m/\n$/) { $mess .= $error; } else { @@ -56,6 +60,21 @@ sub longmess { } elsif ($sub eq '(eval)') { $sub = 'eval {...}'; } + if ($hargs) { + @a = @DB::args; # must get local copy of args + if ($MaxArgNums and @a > $MaxArgNums) { + $#a = $MaxArgNums; + $a[$#a] = "..."; + } + for (@a) { + s/'/\\'/g; + substr($_,$MaxArgLen) = '...' if $MaxArgLen and $MaxArgLen < length; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + $sub .= '(' . join(', ', @a) . ')'; + } $mess .= "\t$sub " if $error eq "called"; $mess .= "$error at $file line $line\n"; } diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 83b472cf6a..d7a4875574 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -38,7 +38,7 @@ the trailing line terminator). It is recommended that cwd (or another If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See -L<perlsub/Overriding builtin functions>.) Note that it will only be +L<perlsub/Overriding Builtin Functions>.) Note that it will only be kept up to date if all packages which use chdir import it from Cwd. =cut @@ -108,7 +108,7 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; + # warn "lstat($dotdots/$dir): $!"; # Just because you can't lstat this directory # doesn't mean you'll never find the right one. # closedir(PARENT); @@ -172,7 +172,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -237,6 +237,13 @@ sub _os2_cwd { return $ENV{'PWD'}; } +sub _msdos_cwd { + $ENV{'PWD'} = `command /c cd`; + chop $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} + my($oldw) = $^W; $^W = 0; # assignments trigger 'subroutine redefined' warning if ($^O eq 'VMS') { @@ -259,7 +266,13 @@ elsif ($^O eq 'os2') { *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - } +} +elsif ($^O eq 'msdos') { + *cwd = \&_msdos_cwd; + *getcwd = \&_msdos_cwd; + *fastgetcwd = \&_msdos_cwd; + *fastcwd = \&_msdos_cwd; +} $^W = $oldw; # package main; eval join('',<DATA>) || die $@; # quick test diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index dc8b94334e..eac7c13ad5 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -8,9 +8,12 @@ use Config; use Cwd 'cwd'; use File::Basename; -my $Config_libext = $Config{lib_ext} || ".a"; - sub ext { + if ($^O eq 'VMS') { return &_vms_ext; } + else { return &_unix_os2_ext; } +} + +sub _unix_os2_ext { my($self,$potential_libs, $Verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including @@ -24,6 +27,8 @@ sub ext { my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs @@ -174,6 +179,136 @@ sub ext { ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); } + +sub _vms_ext { + my($self, $potential_libs,$verbose) = @_; + return ('', '', '', '') unless $potential_libs; + + my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj); + my $cwd = cwd(); + my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'}; + # List of common Unix library names and there VMS equivalents + # (VMS equivalent of '' indicates that the library is automatially + # searched by the linker, and should be skipped here.) + my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', + 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', + 'socket' => '', 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR'); + if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } + + print STDOUT "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + foreach $lib (split ' ',$potential_libs) { + push(@dirs,$1), next if $lib =~ /^-L(.*)/; + push(@dirs,$lib), next if $lib =~ /[:>\]]$/; + push(@dirs,$lib), next if -d $lib; + push(@libs,$1), next if $lib =~ /^-l(.*)/; + push(@libs,$lib); + } + push(@dirs,split(' ',$Config{'libpth'})); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach $dir (@dirs) { + unless (-d $dir) { + print STDOUT "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + print STDOUT "Resolving directory $dir\n" if $verbose; + if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); } + else { $dir = $self->catdir($cwd,$dir); } + } + @dirs = grep { length($_) } @dirs; + unshift(@dirs,''); # Check each $lib without additions first + + LIB: foreach $lib (@libs) { + if (exists $libmap{$lib}) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my(@variants,$variant,$name,$test,$cand); + my($ctype) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ($lib !~ /\.[^:>\]]*$/) { + push(@variants,"${lib}shr","${lib}rtl","${lib}lib"); + push(@variants,"lib$lib") if $lib !~ /[:>\]]/; + } + push(@variants,$lib); + print STDOUT "Looking for $lib\n" if $verbose; + foreach $variant (@variants) { + foreach $dir (@dirs) { + my($type); + + $name = "$dir$variant"; + print "\tChecking $name\n" if $verbose > 2; + if (-f ($test = VMS::Filespec::rmsexpand($name))) { + # It's got its own suffix, so we'll have to figure out the type + if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; } + elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } + elsif ($test =~ /(?:$obj_ext|obj)$/i) { + print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n"; + $type = 'obj'; + } + else { + print STDOUT "Warning (will try anyway): Unknown library type for $test; assuming shared\n"; + $type = 'sh'; + } + } + elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) { + $type = 'sh'; + $name = $test unless $test =~ /exe;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, don't bother + ( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.olb')))) { + $type = 'olb'; + $name = $test unless $test =~ /olb;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, don't bother + ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or + -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) { + print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n"; + $type = 'obj'; + $name = $test unless $test =~ /obj;?\d*$/i; + } + if (defined $type) { + $ctype = $type; $cand = $name; + last if $ctype eq 'sh'; + } + } + if ($ctype) { + eval '$' . $ctype . "{'$cand'}++"; + die "Error recording library: $@" if $@; + print STDOUT "\tFound as $name (really $test), type $type\n" if $verbose > 1; + next LIB; + } + } + print STDOUT "Warning (will try anyway): No library found for $lib\n"; + } + + @libs = sort keys %obj; + # This has to precede any other CRTLs, so just make it first + if ($olb{VAXCCURSE}) { + push(@libs,"$olb{VAXCCURSE}/Library"); + delete $olb{VAXCCURSE}; + } + push(@libs, map { "$_/Library" } sort keys %olb); + push(@libs, map { "$_/Share" } sort keys %sh); + $lib = join(' ',@libs); + print "Result: $lib\n" if $verbose; + wantarray ? ($lib, '', $lib, '') : $lib; +} + 1; __END__ @@ -247,11 +382,55 @@ object file. This list is used to create a .bs (bootstrap) file. This module deals with a lot of system dependencies and has quite a few architecture specific B<if>s in the code. +=head2 VMS implementation + +The version of ext() which is executed under VMS differs from the +Unix-OS/2 version in several respects: + +=over 2 + +=item * + +Input library and path specifications are accepted with or without the +C<-l> and C<-L> prefices used by Unix linkers. If neither prefix is +present, a token is considered a directory to search if it is in fact +a directory, and a library to search for otherwise. Authors who wish +their extensions to be portable to Unix or OS/2 should use the Unix +prefixes, since the Unix-OS/2 version of ext() requires them. + +=item * + +Wherever possible, shareable images are preferred to object libraries, +and object libraries to plain object files. In accordance with VMS +naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl; +it also looks for I<lib>lib and libI<lib> to accomodate Unix conventions +used in some ported software. + +=item * + +For each library that is found, an appropriate directive for a linker options +file is generated. The return values are space-separated strings of +these directives, rather than elements used on the linker command line. + +=item * + +LDLOADLIBS and EXTRALIBS are always identical under VMS, and BSLOADLIBS +and LD_RIN_PATH are always empty. + +=back + +In addition, an attempt is made to recognize several common Unix library +names, and filter them out or convert them to their VMS equivalents, as +appropriate. + +In general, the VMS version of ext() should properly handle input from +extensions originally designed for a Unix or VMS environment. If you +encounter problems, or discover cases where the search could be improved, +please let us know. + =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut - - diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index ca2bf652ee..5d97956405 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1701,7 +1701,7 @@ sub init_others { # --- Initialize Other Attributes }; # These get overridden for VMS and maybe some other systems - $self->{NOOP} ||= "sh -c true"; + $self->{NOOP} ||= '$(SHELL) -c true'; $self->{FIRST_MAKEFILE} ||= "Makefile"; $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; $self->{MAKE_APERL_FILE} ||= "Makefile.aperl"; @@ -1923,6 +1923,10 @@ sub macro { Called by staticmake. Defines how to write the Makefile to produce a static new perl. +By default the Makefile produced includes all the static extensions in +the perl library. (Purified versions of library files, e.g., +DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.) + =cut sub makeaperl { @@ -1987,6 +1991,8 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) File::Find::find(sub { return unless m/\Q$self->{LIB_EXT}\E$/; return if m/^libperl/; + # Skip purified versions of libraries (e.g., DynaLoader_pure_p1_c0_032.a) + return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; if( exists $self->{INCLUDE_EXT} ){ my $found = 0; @@ -2107,7 +2113,7 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -e 'use ExtUtils::Miniperl; \\ - writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@.tmp && mv $@.tmp $@ + writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@t && mv $@t $@ }; @@ -2451,7 +2457,7 @@ $(OBJECT) : $(PERL_HDRS) =item pm_to_blib Defines target that copies all files in the hash PM to their -destination and autosplits them. See L<ExtUtils::Install/pm_to_blib> +destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> =cut diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index d05ddac6b8..1a63f215da 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -6,7 +6,7 @@ # Author: Charles Bailey bailey@genetics.upenn.edu package ExtUtils::MM_VMS; -$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.38 (02-Oct-1996)'; +$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.38 (22-Oct-1996)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; use Config; @@ -194,6 +194,7 @@ sub updir { package ExtUtils::MM_VMS; +sub ExtUtils::MM_VMS::ext; sub ExtUtils::MM_VMS::guess_name; sub ExtUtils::MM_VMS::find_perl; sub ExtUtils::MM_VMS::path; @@ -204,7 +205,6 @@ sub ExtUtils::MM_VMS::file_name_is_absolute; sub ExtUtils::MM_VMS::replace_manpage_separator; sub ExtUtils::MM_VMS::init_others; sub ExtUtils::MM_VMS::constants; -sub ExtUtils::MM_VMS::const_loadlibs; sub ExtUtils::MM_VMS::cflags; sub ExtUtils::MM_VMS::const_cccmd; sub ExtUtils::MM_VMS::pm_to_blib; @@ -268,6 +268,16 @@ sub AUTOLOAD { #__DATA__ + +# This isn't really an override. It's just here because ExtUtils::MM_VMS +# appears in @MM::ISA before ExtUtils::Liblist, so if there isn't an ext() +# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just +# mimic inheritance here and hand off to ExtUtils::Liblist. +sub ext { + ExtUtils::Liblist::ext(@_); +} + + =head2 SelfLoaded methods Those methods which override default MM_Unix methods are marked @@ -289,12 +299,24 @@ package name. sub guess_name { my($self) = @_; - my($defname,$defpm); + my($defname,$defpm,@pm,%xs,$pm); local *PM; $defname = basename(fileify($ENV{'DEFAULT'})); $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version $defpm = $defname; + # Fallback in case for some reason a user has copied the files for an + # extension into a working directory whose name doesn't reflect the + # extension's name. We'll use the name of a unique .pm file, or the + # first .pm file with a matching .xs file. + if (not -e "${defpm}.pm") { + @pm = map { s/.pm$//; $_ } glob('*.pm'); + if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } + elsif (@pm) { + %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); + if (%xs) { foreach $pm (@pm) { $defpm = $pm, last if exists $xs{$pm}; } } + } + } if (open(PM,"${defpm}.pm")){ while (<PM>) { if (/^\s*package\s+([^;]+)/i) { @@ -700,57 +722,6 @@ PM_TO_BLIB = ',join(', ',@{$self->{PM_TO_BLIB}}),' join('',@m); } -=item const_loadlibs (override) - -Basically a stub which passes through library specfications provided -by the caller. Will be updated or removed when VMS support is added -to ExtUtils::Liblist. - -=cut - -sub const_loadlibs { - my($self) = @_; - my (@m); - push @m, " -# $self->{NAME} might depend on some other libraries. -# (These comments may need revising:) -# -# Dependent libraries can be linked in one of three ways: -# -# 1. (For static extensions) by the ld command when the perl binary -# is linked with the extension library. See EXTRALIBS below. -# -# 2. (For dynamic extensions) by the ld command when the shared -# object is built/linked. See LDLOADLIBS below. -# -# 3. (For dynamic extensions) by the DynaLoader when the shared -# object is loaded. See BSLOADLIBS below. -# -# EXTRALIBS = List of libraries that need to be linked with when -# linking a perl binary which includes this extension -# Only those libraries that actually exist are included. -# These are written to a file and used when linking perl. -# -# LDLOADLIBS = List of those libraries which can or must be linked into -# the shared library when created using ld. These may be -# static or dynamic libraries. -# LD_RUN_PATH is a colon separated list of the directories -# in LDLOADLIBS. It is passed as an environment variable to -# the process that links the shared library. -# -# BSLOADLIBS = List of those libraries that are needed but can be -# linked in dynamically at run time on this platform. -# SunOS/Solaris does not need this because ld records -# the information (from LDLOADLIBS) into the object file. -# This list is used to create a .bs (bootstrap) file. -# -EXTRALIBS = ",map($self->fixpath($_) . ' ',$self->{'EXTRALIBS'})," -BSLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'BSLOADLIBS'})," -LDLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'LDLOADLIBS'}),"\n"; - - join('',@m); -} - =item cflags (override) Bypass shell script and produce qualifiers for CC directly (but warn @@ -1271,7 +1242,21 @@ $(BASEEXT).opt : Makefile.PL $(PERL) -e "print ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET) '); + if (length $self->{LDLOADLIBS}) { + my($lib); my($line) = ''; + foreach $lib (split ' ', $self->{LDLOADLIBS}) { + $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs + if (length($line) + length($lib) > 160) { + push @m, "\t\$(PERL) -e \"print qq[$line]\" >>\$(MMS\$TARGET)\n"; + $line = $lib . '\n'; + } + else { $line .= $lib . '\n'; } + } + push @m, "\t\$(PERL) -e \"print qq[$line]\" >>\$(MMS\$TARGET)\n" if $line; + } + join('',@m); + } =item dynamic_lib (override) @@ -1414,8 +1399,7 @@ sub manifypods { } else { $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man'); } - if ($pod2man_exe = $self->perl_script($pod2man_exe)) { $found_pod2man = 1; } - else { + if (not ($pod2man_exe = $self->perl_script($pod2man_exe))) { # No pod2man but some MAN3PODS to be installed print <<END; @@ -2255,18 +2239,6 @@ map_clean : join '', @m; } -=item ext (specific) - -Stub routine standing in for C<ExtUtils::LibList::ext> until VMS -support is added to that package. - -=cut - -sub ext { - my($self) = @_; - '','',''; -} - # --- Output postprocessing section --- =item nicetext (override) diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 14d1222e63..c65b1cf35d 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -127,7 +127,7 @@ T_REF_IV_PTR else croak(\"$var is not of type ${ntype}\") T_PTROBJ - if (sv_isa($arg, \"${ntype}\")) { + if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index eaf5bd4342..6823955113 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -76,7 +76,7 @@ perl(1), perlxs(1), perlxstut(1), perlxs(1) =cut # Global Constants -$XSUBPP_version = "1.938"; +$XSUBPP_version = "1.939"; require 5.002; use vars '$cplusplus'; @@ -741,7 +741,9 @@ while (fetch_para()) { $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; } - death ("Code is not inside a function") + death ("Code is not inside a function" + ." (maybe last function was ended by a blank line " + ." followed by a a statement on column one?)") if $line[0] =~ /^\s/; # initialize info arrays diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 2602f0d530..ad44c5df32 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -2,8 +2,6 @@ package File::Basename; =head1 NAME -Basename - parse file specifications - fileparse - split a pathname into pieces basename - extract just the filename from a path @@ -35,10 +33,10 @@ pieces using the syntax of different operating systems. You select the syntax via the routine fileparse_set_fstype(). If the argument passed to it contains one of the substrings -"VMS", "MSDOS", or "MacOS", the file specification syntax of that -operating system is used in future calls to fileparse(), -basename(), and dirname(). If it contains none of these -substrings, UNIX syntax is used. This pattern matching is +"VMS", "MSDOS", "MacOS" or "AmigaOS", the file specification +syntax of that operating system is used in future calls to +fileparse(), basename(), and dirname(). If it contains none of +these substrings, UNIX syntax is used. This pattern matching is case-insensitive. If you've selected VMS syntax, and the file specification you pass to one of these routines contains a "/", they assume you are using UNIX emulation and apply the UNIX syntax @@ -156,6 +154,9 @@ sub fileparse { elsif ($fstype =~ /^MacOS/i) { ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); } + elsif ($fstype =~ /^AmigaOS/i) { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); $dirpath = './' unless $dirpath; @@ -206,6 +207,11 @@ sub dirname { $dirname =~ s:[^\\]+$:: unless length($basename); $dirname = '.' unless length($dirname); } + elsif ($fstype =~ /AmigaOS/i) { + if ( $dirname =~ /:$/) { return $dirname } + chop $dirname; + $dirname =~ s#[^:/]+$## unless length($basename); + } else { if ( $dirname =~ m:^/+$:) { return '/'; } chop $dirname; diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 5cea310265..2e555590f7 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -7,6 +7,7 @@ package File::Copy; require Exporter; use Carp; +use UNIVERSAL qw(isa); @ISA=qw(Exporter); @EXPORT=qw(copy); @@ -24,10 +25,11 @@ sub copy { croak("Usage: copy( file1, file2 [, buffersize]) ") unless(@_ == 2 || @_ == 3); - if (($^O eq 'VMS' or $^O eq 'os2') && ref(\$_[1]) ne 'GLOB' && - !(defined ref $_[1] and (ref($_[1]) eq 'GLOB' || - ref($_[1]) eq 'FileHandle' || ref($_[1]) eq 'VMS::Stdio'))) - { return File::Copy::syscopy($_[0],$_[1]) } + if (defined &File::Copy::syscopy && + \&File::Copy::syscopy != \&File::Copy::copy && + ref(\$_[1]) ne 'GLOB' && + !(defined ref $_[1] and isa($_[1], 'GLOB'))) + { return File::Copy::syscopy($_[0],$_[1]) } my $from = shift; my $to = shift; @@ -158,10 +160,10 @@ C<copy> routine. For VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> XSUB directly. -=head2 Special behavior under VMS +=head2 Special behavior if C<syscopy> is defined (VMS and OS/2) If the second argument to C<copy> is not a file handle for an -already opened file, then C<copy> will perform an RMS copy of +already opened file, then C<copy> will perform an "system copy" of the input file to a new output file, in order to preserve file attributes, indexed file structure, I<etc.> The buffer size parameter is ignored. If the second argument to C<copy> is a @@ -169,10 +171,12 @@ Perl handle to an opened file, then data is copied using Perl operators, and no effort is made to preserve file attributes or record structure. -The RMS copy routine may also be called directly under VMS -as C<File::Copy::rmscopy> (or C<File::Copy::syscopy>, which +The system copy routine may also be called directly under VMS and OS/2 +as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which is just an alias for this routine). +=over + =item rmscopy($from,$to[,$date_flag]) The first and second arguments may be strings, typeglobs, or @@ -207,6 +211,8 @@ it defaults to 0. Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, it sets C<$!>, deletes the output file, and returns 0. +=back + =head1 RETURN Returns 1 on success, 0 on failure. $! will be set if an error was diff --git a/lib/File/Find.pm b/lib/File/Find.pm index b0312be10e..c5ce68ca1a 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -259,7 +259,8 @@ if ($^O =~ m:^mswin32:i) { $dont_use_nlink = 1; } -$dont_use_nlink = 1 if $^O eq 'os2'; +$dont_use_nlink = 1 + if $^O eq 'os2' || $^O eq 'msdos' || $^O eq 'amigaos'; 1; diff --git a/lib/FindBin.pm b/lib/FindBin.pm index 45d9e33341..bbd72a2aa2 100644 --- a/lib/FindBin.pm +++ b/lib/FindBin.pm @@ -96,7 +96,7 @@ $VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); # $realpath; #} -sub abs_path +sub my_abs_path { my $start = shift || '.'; my($dotdots, $cwd, @pst, @cst, $dir, @tst); @@ -154,6 +154,8 @@ BEGIN { *Dir = \$Bin; *RealDir = \$RealBin; + if (defined &Cwd::sys_abspath) { *abs_path = \&Cwd::sys_abspath} + else { *abs_path = \&my_abs_path} if($0 eq '-e' || $0 eq '-') { diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 11d10f8d03..d684577f8d 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -80,7 +80,7 @@ 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: diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index a4d8b6bd18..f76f2611f0 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -171,11 +171,11 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5); + $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; } (@x, @y, $car); } diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 5ec4a5661e..aec0776c6c 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -699,6 +699,11 @@ sub stringify_cartesian { my ($x, $y) = @{$z->cartesian}; my ($re, $im); + $x = int($x + ($x < 0 ? -1 : 1) * 1e-14) + if int(abs($x)) != int(abs($x) + 1e-14); + $y = int($y + ($y < 0 ? -1 : 1) * 1e-14) + if int(abs($y)) != int(abs($y) + 1e-14); + $re = "$x" if abs($x) >= 1e-14; if ($y == 1) { $im = 'i' } elsif ($y == -1) { $im = '-i' } @@ -734,7 +739,13 @@ sub stringify_polar { if (abs($nt) <= 1e-14) { $theta = 0 } elsif (abs(pi-$nt) <= 1e-14) { $theta = 'pi' } - return "\[$r,$theta\]" if defined $theta; + if (defined $theta) { + $r = int($r + ($r < 0 ? -1 : 1) * 1e-14) + if int(abs($r)) != int(abs($r) + 1e-14); + $theta = int($theta + ($theta < 0 ? -1 : 1) * 1e-14) + if int(abs($theta)) != int(abs($theta) + 1e-14); + return "\[$r,$theta\]"; + } # # Okay, number is not a real. Try to identify pi/n and friends... @@ -753,6 +764,11 @@ sub stringify_polar { $theta = $nt unless defined $theta; + $r = int($r + ($r < 0 ? -1 : 1) * 1e-14) + if int(abs($r)) != int(abs($r) + 1e-14); + $theta = int($theta + ($theta < 0 ? -1 : 1) * 1e-14) + if int(abs($theta)) != int(abs($theta) + 1e-14); + return "\[$r,$theta\]"; } diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm index 4faed4904e..9998c48e24 100644 --- a/lib/Pod/Text.pm +++ b/lib/Pod/Text.pm @@ -1,6 +1,6 @@ package Pod::Text; -# Version 1.01 +# Version 1.02 =head1 NAME @@ -116,14 +116,14 @@ sub prepare_for_output { $maxnest = 10; while ($maxnest-- && /[A-Z]</) { unless ($FANCY) { - s/C<(.*?)>/`$1'/g; + s/C<(.*?)>/`$1'/sg; } else { - s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/ge; + s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/sge; } # s/[IF]<(.*?)>/italic($1)/ge; - s/I<(.*?)>/*$1*/g; + s/I<(.*?)>/*$1*/sg; # s/[CB]<(.*?)>/bold($1)/ge; - s/X<.*?>//g; + s/X<.*?>//sg; # LREF: a manpage(3f) s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the $1$2 manpage:g; # LREF: an =item on another manpage @@ -167,9 +167,9 @@ sub prepare_for_output { ? "the section on \"$2\" in the $1 manpage" : "the section on \"$2\"" } - }gex; + }sgex; - s/[A-Z]<(.*?)>/$1/g; + s/[A-Z]<(.*?)>/$1/sg; } clear_noremap(1); } diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index 9df3161a63..c5241703da 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -7,6 +7,7 @@ use Carp; @EXPORT = qw(openlog closelog setlogmask syslog); use Socket; +use Sys::Hostname; # adapted from syslog.pl # @@ -85,7 +86,7 @@ L<syslog(3)> =head1 AUTHOR -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<lwall@sems.com>E<gt> +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt> =cut @@ -190,7 +191,7 @@ sub syslog { sub xlate { local($name) = @_; - $name =~ y/a-z/A-Z/; + $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "Sys::Syslog::$name"; eval(&$name) || -1; diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm index d4d91c6827..5a73ecfc52 100644 --- a/lib/Term/Cap.pm +++ b/lib/Term/Cap.pm @@ -195,11 +195,8 @@ sub Tgetent { ## public -- static method last; } } - if (defined $entry) { - $entry .= $_; - } else { - $entry = $_; - } + defined $entry or $entry = ''; + $entry .= $_; }; while ($state != 0) { diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm index 884f83fa90..bdab2ad81d 100644 --- a/lib/Term/Complete.pm +++ b/lib/Term/Complete.pm @@ -71,6 +71,8 @@ CONFIG: { } sub Complete { + my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); + $prompt = shift; if (ref $_[0] || $_[0] =~ /^\*/) { @cmp_lst = sort @{$_[0]}; diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 33b683525d..f86c8c2991 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -115,7 +115,7 @@ sub quotewords { last; } else { - while ($_ && !(/^$delim/ || /^['"\\]/)) { + while ($_ ne '' && !(/^$delim/ || /^['"\\]/)) { $snippet .= substr($_, 0, 1); substr($_, 0, 1) = ''; } diff --git a/lib/Text/Soundex.pm b/lib/Text/Soundex.pm index a334404667..ddc758c94e 100644 --- a/lib/Text/Soundex.pm +++ b/lib/Text/Soundex.pm @@ -48,7 +48,7 @@ sub soundex foreach (@s) { - tr/a-z/A-Z/; + $_ = uc $_; tr/A-Z//cd; if ($_ eq '') diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm index 1fab298e0a..2bdf23cb1b 100644 --- a/lib/Time/Local.pm +++ b/lib/Time/Local.pm @@ -40,12 +40,12 @@ after the 1st of January, 2038 on most machines. =cut BEGIN { - @epoch = localtime(0); - $SEC = 1; $MIN = 60 * $SEC; $HR = 60 * $MIN; $DAY = 24 * $HR; + $epoch = (localtime(2*$DAY))[5]; # Allow for bugs near localtime == 0. + $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; my $t = time; @@ -71,13 +71,13 @@ BEGIN { sub timegm { $ym = pack(C2, @_[5,4]); $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0; + return -1 if $cheat<0 and $^O ne 'VMS'; $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY; } sub timelocal { $time = &timegm + $tzsec; - return -1 if $cheat<0; + return -1 if $cheat<0 and $^O ne 'VMS'; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; $time; @@ -100,7 +100,7 @@ sub cheat { if $_[0] > 59 || $_[0] < 0; $guess = $^T; @g = gmtime($guess); - $year += $YearFix if $year < $epoch[5]; + $year += $YearFix if $year < $epoch; $lastguess = ""; while ($diff = $year - $g[5]) { $guess += $diff * (363 * $DAY); diff --git a/lib/abbrev.pl b/lib/abbrev.pl index c233d4af7e..62975e66f3 100644 --- a/lib/abbrev.pl +++ b/lib/abbrev.pl @@ -17,7 +17,7 @@ sub main'abbrev { $len = 1; foreach $cmp (@cmp) { next if $cmp eq $name; - while (substr($cmp,0,$len) eq $abbrev) { + while (@extra && substr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } diff --git a/lib/bigint.pl b/lib/bigint.pl index a274736e44..bfd2efa88c 100644 --- a/lib/bigint.pl +++ b/lib/bigint.pl @@ -168,11 +168,11 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; - $y -= 1e5 if $car = (($y += $car) >= 1e5); + $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; } (@x, @y, $car); } diff --git a/lib/complete.pl b/lib/complete.pl index 1e08f9145a..335245269c 100644 --- a/lib/complete.pl +++ b/lib/complete.pl @@ -35,7 +35,7 @@ CONFIG: { sub Complete { package Complete; - local($[,$return) = 0; + local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); if ($_[1] =~ /^StB\0/) { ($prompt, *_) = @_; } diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index a8af08f8c2..02fae7aa9f 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -415,10 +415,27 @@ sub warn_trap { sub death_trap { my $exception = $_[0]; - splainthis($exception); + + # See if we are coming from anywhere within an eval. If so we don't + # want to explain the exception because it's going to get caught. + my $in_eval = 0; + my $i = 0; + while (1) { + my $caller = (caller($i++))[3] or last; + if ($caller eq '(eval)') { + $in_eval = 1; + last; + } + } + + splainthis($exception) unless $in_eval; if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; - $SIG{__DIE__} = $SIG{__WARN__} = ''; + + # We don't want to unset these if we're coming from an eval because + # then we've turned off diagnostics. (Actually what does this next + # line do? -PSeibel) + $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval; local($Carp::CarpLevel) = 1; confess "Uncaught exception from user code:\n\t$exception"; # up we go; where we stop, nobody knows, but i think we die now diff --git a/lib/getcwd.pl b/lib/getcwd.pl index d8860181c1..9dd694500c 100644 --- a/lib/getcwd.pl +++ b/lib/getcwd.pl @@ -44,9 +44,9 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; - closedir(getcwd'PARENT); #'); - return ''; + # warn "lstat($dotdots/$dir): $!"; + # closedir(getcwd'PARENT); #'); + # return ''; } } while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] || diff --git a/lib/getopts.pl b/lib/getopts.pl index a0818d1e3a..852aae89b1 100644 --- a/lib/getopts.pl +++ b/lib/getopts.pl @@ -8,23 +8,22 @@ sub Getopts { local($argumentative) = @_; local(@args,$_,$first,$rest); local($errs) = 0; - local($[) = 0; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); $pos = index($argumentative,$first); - if($pos >= $[) { - if($args[$pos+1] eq ':') { + if($pos >= 0) { + if($pos < $#args && $args[$pos+1] eq ':') { shift(@ARGV); if($rest eq '') { ++$errs unless @ARGV; $rest = shift(@ARGV); } - eval "\$opt_$first = \$rest;"; + ${"opt_$first"} = $rest; } else { - eval "\$opt_$first = 1"; + ${"opt_$first"} = 1; if($rest eq '') { shift(@ARGV); } diff --git a/lib/look.pl b/lib/look.pl index 4c14e64727..e8dc8aacb6 100644 --- a/lib/look.pl +++ b/lib/look.pl @@ -10,7 +10,7 @@ sub look { $blksize,$blocks) = stat(FH); $blksize = 8192 unless $blksize; $key =~ s/[^\w\s]//g if $dict; - $key =~ y/A-Z/a-z/ if $fold; + $key = lc $key if $fold; $max = int($size / $blksize); while ($max - $min > 1) { $mid = int(($max + $min) / 2); @@ -19,7 +19,7 @@ sub look { $_ = <FH>; chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; if ($_ lt $key) { $min = $mid; } @@ -33,7 +33,7 @@ sub look { while (<FH>) { chop; s/[^\w\s]//g if $dict; - y/A-Z/a-z/ if $fold; + $_ = lc $_ if $fold; last if $_ ge $key; $min = tell(FH); } diff --git a/lib/perl5db.pl b/lib/perl5db.pl index a57475ce06..3f3a4c2762 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.95; +$VERSION = 0.96; $header = "perl5db.pl patch level $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -23,6 +23,27 @@ $header = "perl5db.pl patch level $VERSION"; # $DB::sub being the called subroutine. It also inserts a BEGIN # {require 'perl5db.pl'} before the first line. # +# After each `require'd file is compiled, but before it is executed, a +# call to DB::postponed(*{"_<$filename"}) is emulated. Here the +# $filename is the expanded name of the `require'd file (as found as +# value of %INC). +# +# Additional services from Perl interpreter: +# +# if caller() is called from the package DB, it provides some +# additional data. +# +# The array @{"_<$filename"} is the line-by-line contents of +# $filename. +# +# The hash %{"_<$filename"} contains breakpoints and action (it is +# keyed by line number), and individual entries are settable (as +# opposed to the whole hash). Only true/false is important to the +# interpreter, though the values used by perl5db.pl have the form +# "$break_condition\0$action". Values are magical in numeric context. +# +# The scalar ${"_<$filename"} contains "_<$filename". +# # Note that no subroutine call is possible until &DB::sub is defined # (for subroutines defined outside this file). In fact the same is # true if $deep is not defined. @@ -64,8 +85,6 @@ $header = "perl5db.pl patch level $VERSION"; # information into db.out. (If you interrupt it, you would better # reset LineInfo to something "interactive"!) # -# Changes: 0.95: v command shows versions. - ################################################################## # Changelog: @@ -82,6 +101,26 @@ $header = "perl5db.pl patch level $VERSION"; # the deletion of data may be postponed until the next function call, # due to the need to examine the return value. +# Changes: 0.95: `v' command shows versions. +# Changes: 0.96: `v' command shows version of readline. +# primitive completion works (dynamic variables, subs for `b' and `l', +# options). Can `p %var' +# Better help (`h <' now works). New commands <<, >>, {, {{. +# {dump|print}_trace() coded (to be able to do it from <<cmd). +# `c sub' documented. +# At last enough magic combined to stop after the end of debuggee. +# !! should work now (thanks to Emacs bracket matching an extra +# `]' in a regexp is caught). +# `L', `D' and `A' span files now (as documented). +# Breakpoints in `require'd code are possible (used in `R'). +# Some additional words on internal work of debugger. +# `b load filename' implemented. +# `b postpone subr' implemented. +# now only `q' exits debugger (overwriteable on $inhibit_exit). +# When restarting debugger breakpoints/actions persist. +# Buglet: When restarting debugger only one breakpoint/action per +# autoloaded function persists. + #################################################################### # Needed for the statement after exec(): @@ -111,11 +150,7 @@ warn ( # Do not ;-) $trace = $signal = $single = 0; # Uninitialized warning suppression # (local $^W cannot help - other packages!). -$doret = -2; -$frame = 0; -@stack = (0); - -$option{PrintRet} = 1; +$inhibit_exit = $option{PrintRet} = 1; @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages compactDump veryCompact quote HighBit undefPrint @@ -165,6 +200,9 @@ $rl = 1 unless defined $rl; $warnLevel = 1 unless defined $warnLevel; $dieLevel = 1 unless defined $dieLevel; $signalLevel = 1 unless defined $signalLevel; +$pre = [] unless defined $pre; +$post = [] unless defined $post; +$pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); @@ -194,9 +232,11 @@ if (exists $ENV{PERLDB_RESTART}) { delete $ENV{PERLDB_RESTART}; # $restart = 1; @hist = get_list('PERLDB_HIST'); - my @visited = get_list("PERLDB_VISITED"); - for (0 .. $#visited) { - %{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_"); + %break_on_load = get_list("PERLDB_ON_LOAD"); + %postponed = get_list("PERLDB_POSTPONE"); + my @had_breakpoints= get_list("PERLDB_VISITED"); + for (0 .. $#had_breakpoints) { + %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_"); } my %opt = get_list("PERLDB_OPT"); my ($opt,$val); @@ -285,14 +325,6 @@ sub DB { $single = 0; return; } - # Define a subroutine in which we will stop -# eval <<'EOE'; -# sub at_end::db {"Debuggee terminating";} -# END { -# $DB::step = 1; -# print $OUT "Debuggee terminating.\n"; -# &at_end::db;} -# EOE } &save; ($package, $filename, $line) = caller; @@ -300,7 +332,6 @@ sub DB { $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = "::_<$filename"; - install_breakpoints($filename) unless $visited{$filename}++; $max = $#dbline; if (($stop,$action) = split(/\0/,$dbline{$line})) { if ($stop eq '1') { @@ -342,23 +373,23 @@ sub DB { $evalarg = $action, &eval if $action; if ($single || $signal) { local $level = $level + 1; - $evalarg = $pre, &eval if $pre; + map {$evalarg = $_, &eval} @$pre; print $OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; + @typeahead = @$pretype, @typeahead; CMD: while (($term || &setterm), defined ($cmd=&readline(" DB" . ('<' x $level) . ($#hist+1) . ('>' x $level) . " "))) { - #{ # <-- Do we know what this brace is for? $single = 0; $signal = 0; $cmd =~ s/\\$/\n/ && do { $cmd .= &readline(" cont: "); redo CMD; }; - $cmd =~ /^q$/ && exit 0; + $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; PIPE: { @@ -372,8 +403,10 @@ sub DB { next CMD; }; $cmd =~ /^h\s+(\S)$/ && do { my $asked = "\Q$1"; - if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) { + if ($help =~ /^$asked/m) { + while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) { print $OUT $1; + } } else { print $OUT "`$asked' is not a debugger command.\n"; } @@ -429,7 +462,6 @@ sub DB { next CMD; } elsif ($file ne $filename) { *dbline = "::_<$file"; - $visited{$file}++; $max = $#dbline; $filename = $file; $start = 1; @@ -445,7 +477,6 @@ sub DB { $file = join(':', @pieces); if ($file ne $filename) { *dbline = "::_<$file"; - $visited{$file}++; $max = $#dbline; $filename = $file; } @@ -508,7 +539,13 @@ sub DB { $start = $max if $start > $max; next CMD; }; $cmd =~ /^D$/ && do { - print $OUT "Deleting all breakpoints...\n"; + print $OUT "Deleting all breakpoints...\n"; + my $file; + for $file (keys %had_breakpoints) { + local *dbline = "::_<$file"; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/^[^\0]+//; @@ -517,19 +554,89 @@ sub DB { } } } - next CMD; }; + } + undef %postponed; + undef %postponed_file; + undef %break_on_load; + undef %had_breakpoints; + next CMD; }; $cmd =~ /^L$/ && do { + my $file; + for $file (keys %had_breakpoints) { + local *dbline = "::_<$file"; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max; $i++) { if (defined $dbline{$i}) { - print $OUT "$i:\t", $dbline[$i]; + print "$file:\n" unless $was++; + print $OUT " $i:\t", $dbline[$i]; ($stop,$action) = split(/\0/, $dbline{$i}); - print $OUT " break if (", $stop, ")\n" + print $OUT " break if (", $stop, ")\n" if $stop; - print $OUT " action: ", $action, "\n" + print $OUT " action: ", $action, "\n" if $action; last if $signal; } } + } + if (%postponed) { + print $OUT "Postponed breakpoints in subroutines:\n"; + my $subname; + for $subname (keys %postponed) { + print $OUT " $subname\t$postponed{$subname}\n"; + last if $signal; + } + } + my @have = map { # Combined keys + keys %{$postponed_file{$_}} + } keys %postponed_file; + if (@have) { + print $OUT "Postponed breakpoints in files:\n"; + my ($file, $line); + for $file (keys %postponed_file) { + my %db = %{$postponed_file{$file}}; + next unless keys %db; + print $OUT " $file:\n"; + for $line (sort {$a <=> $b} keys %db) { + print $OUT " $i:\n"; + my ($stop,$action) = split(/\0/, $db{$line}); + print $OUT " break if (", $stop, ")\n" + if $stop; + print $OUT " action: ", $action, "\n" + if $action; + last if $signal; + } + last if $signal; + } + } + if (%break_on_load) { + print $OUT "Breakpoints on load:\n"; + my $file; + for $file (keys %break_on_load) { + print $OUT " $file\n"; + last if $signal; + } + } + next CMD; }; + $cmd =~ /^b\b\s*load\b\s*(.*)/ && do { + my $file = $1; + { + $break_on_load{$file} = 1; + $break_on_load{$::INC{$file}} = 1 if $::INC{$file}; + $file .= '.pm', redo unless $file =~ /\./; + } + $had_breakpoints{$file} = 1; + print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n"; + next CMD; }; + $cmd =~ /^b\b\s*postpone\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { + my $cond = $2 || '1'; + my $subname = $1; + $subname =~ s/\'/::/; + $subname = "${'package'}::" . $subname + unless $subname =~ /::/; + $subname = "main".$subname if substr($subname,0,2) eq "::"; + $postponed{$subname} = "break +0 if $cond"; next CMD; }; $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { $subname = $1; @@ -544,7 +651,7 @@ sub DB { if ($i) { $filename = $file; *dbline = "::_<$filename"; - $visited{$filename}++; + $had_breakpoints{$filename} = 1; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; $dbline{$i} =~ s/^[^\0]*/$cond/; @@ -558,6 +665,7 @@ sub DB { if ($dbline[$i] == 0) { print $OUT "Line $i not breakable.\n"; } else { + $had_breakpoints{$filename} = 1; $dbline{$i} =~ s/^[^\0]*/$cond/; } next CMD; }; @@ -567,13 +675,20 @@ sub DB { delete $dbline{$i} if $dbline{$i} eq ''; next CMD; }; $cmd =~ /^A$/ && do { + my $file; + for $file (keys %had_breakpoints) { + local *dbline = "::_<$file"; + my $max = $#dbline; + my $was; + for ($i = 1; $i <= $max ; $i++) { if (defined $dbline{$i}) { $dbline{$i} =~ s/\0[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; } } - next CMD; }; + } + next CMD; }; $cmd =~ /^O\s*$/ && do { for (@options) { &dump_option($_); @@ -582,11 +697,26 @@ sub DB { $cmd =~ /^O\s*(\S.*)/ && do { parse_options($1); next CMD; }; + $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE + push @$pre, action($1); + next CMD; }; + $cmd =~ /^>>\s*(.*)/ && do { + push @$post, action($1); + next CMD; }; $cmd =~ /^<\s*(.*)/ && do { - $pre = action($1); + $pre = [], next CMD unless $1; + $pre = [action($1)]; next CMD; }; $cmd =~ /^>\s*(.*)/ && do { - $post = action($1); + $post = [], next CMD unless $1; + $post = [action($1)]; + next CMD; }; + $cmd =~ /^\{\{\s*(.*)/ && do { + push @$pretype, $1; + next CMD; }; + $cmd =~ /^\{\s*(.*)/ && do { + $pretype = [], next CMD unless $1; + $pretype = [$1]; next CMD; }; $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { $i = $1; $j = $3; @@ -598,14 +728,17 @@ sub DB { } next CMD; }; $cmd =~ /^n$/ && do { + next CMD if $finished and $level <= 1; $single = 2; $laststep = $cmd; last CMD; }; $cmd =~ /^s$/ && do { + next CMD if $finished and $level <= 1; $single = 1; $laststep = $cmd; last CMD; }; $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { + next CMD if $finished and $level <= 1; $i = $1; if ($i =~ /\D/) { # subroutine name ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/); @@ -613,7 +746,7 @@ sub DB { if ($i) { $filename = $file; *dbline = "::_<$filename"; - $visited{$filename}++; + $had_breakpoints{$filename}++; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; } else { @@ -633,11 +766,12 @@ sub DB { } last CMD; }; $cmd =~ /^r$/ && do { + next CMD if $finished and $level <= 1; $stack[$#stack] |= 1; $doret = $option{PrintRet} ? $#stack - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { - print $OUT "Warning: a lot of settings and command-line options may be lost!\n"; + print $OUT "Warning: some settings and command-line options may be lost!\n"; my (@script, @flags, $cl); push @flags, '-w' if $ini_warn; # Put all the old includes at the start to get @@ -658,52 +792,63 @@ sub DB { set_list("PERLDB_HIST", $term->Features->{getHistory} ? $term->GetHistory : @hist); - my @visited = keys %visited; - set_list("PERLDB_VISITED", @visited); + my @had_breakpoints = keys %had_breakpoints; + set_list("PERLDB_VISITED", @had_breakpoints); set_list("PERLDB_OPT", %option); - for (0 .. $#visited) { - *dbline = "::_<$visited[$_]"; - set_list("PERLDB_FILE_$_", %dbline); + set_list("PERLDB_ON_LOAD", %break_on_load); + my @hard; + for (0 .. $#had_breakpoints) { + my $file = $had_breakpoints[$_]; + *dbline = "::_<$file"; + next unless %dbline or %{$postponed_file{$file}}; + (push @hard, $file), next + if $file =~ /^\(eval \d+\)$/; + my @add; + @add = %{$postponed_file{$file}} + if %{$postponed_file{$file}}; + set_list("PERLDB_FILE_$_", %dbline, @add); + } + for (@hard) { # Yes, really-really... + # Find the subroutines in this eval + *dbline = "::_<$_"; + my ($quoted, $sub, %subs, $line) = quotemeta $_; + for $sub (keys %sub) { + next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/; + $subs{$sub} = [$1, $2]; + } + unless (%subs) { + print $OUT + "No subroutines in $_, ignoring breakpoints.\n"; + next; + } + LINES: for $line (keys %dbline) { + # One breakpoint per sub only: + my ($offset, $sub, $found); + SUBS: for $sub (keys %subs) { + if ($subs{$sub}->[1] >= $line # Not after the subroutine + and (not defined $offset # Not caught + or $offset < 0 )) { # or badly caught + $found = $sub; + $offset = $line - $subs{$sub}->[0]; + $offset = "+$offset", last SUBS if $offset >= 0; + } + } + if (defined $offset) { + $postponed{$found} = + "break $offset if $dbline{$line}"; + } else { + print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n"; + } + } } + set_list("PERLDB_POSTPONE", %postponed); $ENV{PERLDB_RESTART} = 1; #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS"; exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS; print $OUT "exec failed: $!\n"; last CMD; }; $cmd =~ /^T$/ && do { - local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub); - for ($i = 1; - ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); - $i++) { - @a = (); - for $arg (@args) { - $_ = "$arg"; - s/([\'\\])/\\$1/g; - s/([^\0]*)/'$1'/ - unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - push(@a, $_); - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - $e =~ s/\n\s*\;\s*\Z// if $e; - $e =~ s/[\\\']/\\$1/g if $e; - if ($r) { - $s = "require '$e'"; - } elsif (defined $r) { - $s = "eval '$e'"; - } elsif ($s eq '(eval)') { - $s = "eval {...}"; - } - $f = "file `$f'" unless $f eq '-e'; - push(@sub, "$w$s$a called from $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print $OUT $sub[$i]; - } + print_trace($OUT, 3); # skip DB print_trace dump_trace next CMD; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; @@ -767,7 +912,7 @@ sub DB { $cmd = $hist[$i] . "\n"; print $OUT $cmd; redo CMD; }; - $cmd =~ /^$sh$sh\s*([\x00-\xff]]*)/ && do { + $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { &system($1); next CMD; }; $cmd =~ /^$rc([^$rc].*)$/ && do { @@ -844,7 +989,6 @@ sub DB { $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'}; } # PIPE: - #} # <-- Do we know what this brace is for? $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; if ($onetimeDump) { $onetimeDump = undef; @@ -872,9 +1016,7 @@ sub DB { $piped= ""; } } # CMD: - if ($post) { - $evalarg = $post; &eval; - } + map {$evalarg = $_; &eval} @$post; } # if ($single || $signal) ($@, $!, $,, $/, $\, $^W) = @saved; (); @@ -937,16 +1079,44 @@ sub eval { } } -sub install_breakpoints { - my $filename = shift; - return unless exists $postponed{$filename}; - my %break = %{$postponed{$filename}}; - for (keys %break) { - my $i = $_; - #if (/\D/) { # Subroutine name - #} - $dbline{$i} = $break{$_}; # Cannot be done before the file is around +sub postponed_sub { + my $subname = shift; + if ($postponed{$subname} =~ s/break\s([+-]?\d+)\s+if\s//) { + my $offset = $1 || 0; + # Filename below can contain ':' + my ($file,$i) = ($sub{$subname} =~ /^(.*):(\d+)-.*$/); + $i += $offset; + if ($i) { + local *dbline = "::_<$file"; + local $^W = 0; # != 0 is magical below + $had_breakpoints{$file}++; + my $max = $#dbline; + ++$i until $dbline[$i] != 0 or $i >= $max; + $dbline{$i} = delete $postponed{$subname}; + } else { + print $OUT "Subroutine $subname not found.\n"; + } + return; + } + print $OUT "In postponed_sub for `$subname'.\n"; +} + +sub postponed { + return &postponed_sub + unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. + # Cannot be done before the file is compiled + local *dbline = shift; + my $filename = $dbline; + $filename =~ s/^_<//; + $signal = 1, print $OUT "'$filename' loaded...\n" if $break_on_load{$filename}; + return unless %{$postponed_file{$filename}}; + $had_breakpoints{$filename}++; + #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic + my $key; + for $key (keys %{$postponed_file{$filename}}) { + $dbline{$key} = $ {$postponed_file{$filename}}{$key}; } + undef %{$postponed_file{$filename}}; } sub dumpit { @@ -969,6 +1139,57 @@ sub dumpit { select ($savout); } +sub print_trace { + my $fh = shift; + my @sub = dump_trace(@_); + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + local $" = ', '; + my $args = defined $sub[$i]{args} + ? "(@{ $sub[$i]{args} })" + : '' ; + $file = $sub[$i]{file} eq '-e' ? $sub[$i]{file} : + "file `$sub[$i]{file}'"; + print $fh "$sub[$i]{context}$sub[$i]{sub}$args" . + " called from $file" . + " line $sub[$i]{line}\n"; + } +} + +sub dump_trace { + my $skip = shift; + my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context); + for ($i = $skip; + ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); + $i++) { + @a = (); + for $arg (@args) { + $_ = "$arg"; + s/([\'\\])/\\$1/g; + s/([^\0]*)/'$1'/ + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + push(@a, $_); + } + $context = $context ? '@ = ' : '$ = '; + $args = $h ? [@a] : undef; + $e =~ s/\n\s*\;\s*\Z// if $e; + $e =~ s/[\\\']/\\$1/g if $e; + if ($r) { + $sub = "require '$e'"; + } elsif (defined $r) { + $sub = "eval '$e'"; + } elsif ($sub eq '(eval)') { + $sub = "eval {...}"; + } + push(@sub, {context => $context, sub => $sub, args => $args, + file => $file, line => $line}); + last if $signal; + } + @sub; +} + sub action { my $action = shift; while ($action =~ s/\\$//) { @@ -1032,6 +1253,12 @@ sub setterm { $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; @@ -1057,6 +1284,14 @@ sub readline { sub dump_option { my ($opt, $val)= @_; + $val = option_val($opt,'N/A'); + $val =~ s/([\\\'])/\\$1/g; + printf $OUT "%20s = '%s'\n", $opt, $val; +} + +sub option_val { + my ($opt, $default)= @_; + my $val; if (defined $optionVars{$opt} and defined $ {$optionVars{$opt}}) { $val = $ {$optionVars{$opt}}; @@ -1067,12 +1302,11 @@ sub dump_option { and not defined $option{$opt} or defined $optionVars{$opt} and not defined $ {$optionVars{$opt}}) { - $val = 'N/A'; + $val = $default; } else { $val = $option{$opt}; } - $val =~ s/([\\\'])/\\$1/g; - printf $OUT "%20s = '%s'\n", $opt, $val; + $val } sub parse_options { @@ -1244,6 +1478,7 @@ sub list_versions { s,\.p[lm]$,,i ; s,/,::,g ; s/^perl5db$/DB/; + s/^Term::ReadLine::readline$/readline/; if (defined $ { $_ . '::VERSION' }) { $version{$file} = "$ { $_ . '::VERSION' } from "; } @@ -1265,8 +1500,8 @@ s [expr] Single step [in expr]. n [expr] Next, steps over subroutine calls [in expr]. <CR> Repeat last n or s command. r Return from current subroutine. -c [line] Continue; optionally inserts a one-time-only breakpoint - at the specified line. +c [line|sub] Continue; optionally inserts a one-time-only breakpoint + at the specified position. l min+incr List incr+1 lines starting at min. l min-max List lines min through max. l line List single line. @@ -1287,6 +1522,10 @@ b [line] [condition] condition breaks if it evaluates to true, defaults to '1'. b subname [condition] Set breakpoint at first line of subroutine. +b load filename Set breakpoint on `require'ing the given file. +b postpone subname [condition] + Set breakpoint at first line of subroutine after + it is compiled. d [line] Delete the breakpoint for line. D Delete all breakpoints. a [line] command @@ -1317,8 +1556,12 @@ O [opt[=val]] [opt\"val\"] [opt?]... During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options TTY, noTTY, ReadLine, and NonStop there. -< command Define command to run before each prompt. -> command Define command to run after each prompt. +< 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. @@ -1334,8 +1577,8 @@ p expr Same as \"print {DB::OUT} expr\" in current package. \= [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, debugger state and command-line - options are lost. +R Pure-man-restart of debugger, some of debugger state + and command-line options may be lost. h [db_command] Get help [on a specific debugger command], enter |h to page. h h Summary of debugger commands. q or ^D Quit. @@ -1348,11 +1591,11 @@ List/search source lines: Control script execution: 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 [line] Continue until line + v Show versions of modules c [ln|sub] Continue until position Debugger controls: L List break pts & actions O [...] Set debugger options t [expr] Toggle trace [trace expr] - < command Command for before prompt b [ln] [c] Set breakpoint - > command Command for after prompt b sub [c] Set breakpoint for sub + <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint + >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub $prc [N|pat] Redo a previous command d [line] Delete a breakpoint H [-num] Display last num commands D Delete all breakpoints = [a val] Define/list an alias a [ln] cmd Do cmd before line @@ -1360,13 +1603,13 @@ Debugger controls: L List break pts & actions |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess q or ^D Quit R Attempt a restart Data Examination: expr Execute perl code, also see: s,n,t expr + x expr Evals expression in array context, dumps the result. + p expr Print expression (uses script's current package). S [[!]pat] List subroutine names [not] matching pattern V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern. X [Vars] Same as \"V current_package [Vars]\". - x expr Evals expression in array context, dumps the result. - p expr Print expression (uses script's current package). END_SUM - # '); # Fix balance of Emacs parsing + # ')}}; # Fix balance of Emacs parsing } sub diesignal { @@ -1500,10 +1743,86 @@ BEGIN { # This does not compile, alas. $db_stop = 0; # Compiler warning $db_stop = 1 << 30; $level = 0; # Level of recursive debugging + # @stack and $doret are needed in sub sub, which is called for DB::postponed. + # Triggers bug (?) in perl is we postpone this until runtime: + @postponed = @stack = (0); + $doret = -2; + $frame = 0; } BEGIN {$^W = $ini_warn;} # Switch warnings back #use Carp; # This did break, left for debuggin +sub db_complete { + my($text, $line, $start) = @_; + my ($itext, $prefix, $pack) = $text; + + if ((substr $text, 0, 1) eq '&') { # subroutines + $text = substr $text, 1; + $prefix = "&"; + return map "$prefix$_", grep /^\Q$text/, keys %sub; + } + if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package + $pack = ($1 eq 'main' ? '' : $1) . '::'; + $prefix = (substr $text, 0, 1) . $1 . '::'; + $text = $2; + my @out + = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ; + if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { + return db_complete($out[0], $line, $start); + } + return @out; + } + if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main) + $pack = ($package eq 'main' ? '' : $package) . '::'; + $prefix = substr $text, 0, 1; + $text = substr $text, 1; + my @out = map "$prefix$_", grep /^\Q$text/, + (grep /^_?[a-zA-Z]/, keys %$pack), + ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ; + if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { + return db_complete($out[0], $line, $start); + } + return @out; + } + return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines + if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\s+)?$/; + return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages + if (substr $line, 0, $start) =~ /^V\s+$/; + if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space + my @out = grep /^\Q$text/, @options; + my $val = option_val($out[0], undef); + my $out = '? '; + if (not defined $val or $val =~ /[\n\r]/) { + # Can do nothing better + } elsif ($val =~ /\s/) { + my $found; + foreach $l (split //, qq/\"\'\#\|/) { + $out = "$l$val$l ", last if (index $val, $l) == -1; + } + } else { + $out = "=$val "; + } + # Default to value if one completion, to question if many + $readline::rl_completer_terminator_character + = $readline::rl_completer_terminator_character + = (@out == 1 ? $out : '? '); + return @out; + } + return &readline::rl_filename_list($text); # filenames +} + +END { + $finished = $inhibit_exit; # So that some keys may be disabled. + $DB::single = 1; + DB::fake::at_exit() unless $exiting; +} + +package DB::fake; + +sub at_exit { + "Debuggee terminated. Use `q' to quit and `R' to restart."; +} + 1; diff --git a/lib/sigtrap.pm b/lib/sigtrap.pm index 378ca899a0..ed5925b0ab 100644 --- a/lib/sigtrap.pm +++ b/lib/sigtrap.pm @@ -8,7 +8,7 @@ sigtrap - Perl pragma to enable simple signal handling use Carp; -$VERSION = 1.01; +$VERSION = 1.02; $Verbose ||= 0; sub import { @@ -29,13 +29,16 @@ sub import { } } elsif ($_ eq 'normal-signals') { - unshift @_, qw(HUP INT PIPE TERM); + unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM)); } elsif ($_ eq 'error-signals') { - unshift @_, qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP); + unshift @_, grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP)); } elsif ($_ eq 'old-interface-signals') { - unshift @_, qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP); + unshift @_, + grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP)); } elsif ($_ eq 'stack-trace') { $handler = \&handler_traceback; @@ -204,10 +207,15 @@ QUIT, SEGV, SYS and TRAP. These are the signals which were trapped by default by the old B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to -B<sigtrap> this list is used. +B<sigtrap>, this list is used. =back +For each of these three lists, the collection of signals set to be +trapped is checked before trapping; if your architecture does not +implement a particular signal, it will not be trapped but rather +silently ignored. + =head2 OTHER =over 4 diff --git a/lib/strict.pm b/lib/strict.pm index 4aa55eb4f3..e261e92f67 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -11,7 +11,6 @@ strict - Perl pragma to restrict unsafe constructs use strict "vars"; use strict "refs"; use strict "subs"; - use strict "untie"; use strict; no strict "vars"; @@ -20,8 +19,8 @@ strict - Perl pragma to restrict unsafe constructs If no import list is supplied, all possible restrictions are assumed. (This is the safest mode to operate in, but is sometimes too strict for -casual programming.) Currently, there are four possible things to be -strict about: "subs", "vars", "refs", and "untie". +casual programming.) Currently, there are three possible things to be +strict about: "subs", "vars", and "refs". =over 6 @@ -66,24 +65,6 @@ appears in curly braces or on the left hand side of the "=E<gt>" symbol. -=item C<strict untie> - -This generates a runtime error if any references to the object returned -by C<tie> (or C<tied>) still exist when C<untie> is called. Note that -to get this strict behaviour, the C<use strict 'untie'> statement must -be in the same scope as the C<untie>. See L<perlfunc/tie>, -L<perlfunc/untie>, L<perlfunc/tied> and L<perltie>. - - use strict 'untie'; - $a = tie %a, 'SOME_PKG'; - $b = tie %b, 'SOME_PKG'; - $b = 0; - tie %c, PKG; - $c = tied %c; - untie %a ; # blows up, $a is a valid object reference. - untie %b; # ok, $b is not a reference to the object. - untie %c ; # blows up, $c is a valid object reference. - =back See L<perlmod/Pragmatic Modules>. @@ -97,19 +78,18 @@ sub bits { $bits |= 0x00000002 if $sememe eq 'refs'; $bits |= 0x00000200 if $sememe eq 'subs'; $bits |= 0x00000400 if $sememe eq 'vars'; - $bits |= 0x00000800 if $sememe eq 'untie'; } $bits; } sub import { shift; - $^H |= bits(@_ ? @_ : qw(refs subs vars untie)); + $^H |= bits(@_ ? @_ : qw(refs subs vars)); } sub unimport { shift; - $^H &= ~ bits(@_ ? @_ : qw(refs subs vars untie)); + $^H &= ~ bits(@_ ? @_ : qw(refs subs vars)); } 1; diff --git a/lib/subs.pm b/lib/subs.pm index 84c913a346..aa4c7e751e 100644 --- a/lib/subs.pm +++ b/lib/subs.pm @@ -15,7 +15,12 @@ This will predeclare all the subroutine whose names are in the list, allowing you to use them without parentheses even before they're declared. -See L<perlmod/Pragmatic Modules> and L<strict/subs>. +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +C<use subs> declarations are not BLOCK-scoped. They are thus effective +for the entire file in which they appear. You may not rescind such +declarations with C<no vars> or C<no subs>. + +See L<perlmod/Pragmatic Modules> and L<strict/strict subs>. =cut require 5.000; diff --git a/lib/syslog.pl b/lib/syslog.pl index 614068e7fc..8807ef027d 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -140,7 +140,7 @@ sub main'syslog { sub xlate { local($name) = @_; - $name =~ y/a-z/A-Z/; + $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "syslog'$name"; eval(&$name) || -1; diff --git a/lib/termcap.pl b/lib/termcap.pl index e8f108df06..c36575aa45 100644 --- a/lib/termcap.pl +++ b/lib/termcap.pl @@ -63,6 +63,9 @@ sub Tgetent { $entry = $1; $_ = $2; s/\\E/\033/g; + s/\\(200)/pack('c',0)/eg; # NUL character + s/\\(0\d\d)/pack('c',oct($1))/eg; # octal + s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; s/\\n/\n/g; s/\\r/\r/g; diff --git a/lib/timelocal.pl b/lib/timelocal.pl index 75f1ac1851..ad322756e3 100644 --- a/lib/timelocal.pl +++ b/lib/timelocal.pl @@ -4,106 +4,15 @@ ;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); ;# $time = timegm($sec,$min,$hours,$mday,$mon,$year); -;# These routines are quite efficient and yet are always guaranteed to agree -;# with localtime() and gmtime(). We manage this by caching the start times -;# of any months we've seen before. If we know the start time of the month, -;# we can always calculate any time within the month. The start times -;# themselves are guessed by successive approximation starting at the -;# current time, since most dates seen in practice are close to the -;# current date. Unlike algorithms that do a binary search (calling gmtime -;# once for each bit of the time value, resulting in 32 calls), this algorithm -;# calls it at most 6 times, and usually only once or twice. If you hit -;# the month cache, of course, it doesn't call it at all. +;# This file has been superseded by the Time::Local library module. +;# It is implemented as a call to that module for backwards compatibility +;# with code written for perl4; new code should use Time::Local directly. -;# timelocal is implemented using the same cache. We just assume that we're -;# translating a GMT time, and then fudge it when we're done for the timezone -;# and daylight savings arguments. The timezone is determined by examining -;# the result of localtime(0) when the package is initialized. The daylight -;# savings offset is currently assumed to be one hour. +;# The current implementation shares with the original the questionable +;# behavior of defining the timelocal() and timegm() functions in the +;# namespace of whatever package was current when the first instance of +;# C<require 'timelocal.pl';> was executed in a program. -;# Both routines return -1 if the integer limit is hit. I.e. for dates -;# after the 1st of January, 2038 on most machines. +use Time::Local; -CONFIG: { - package timelocal; - - local($[) = 0; - @epoch = localtime(0); - $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT - if ($tzmin > 0) { - $tzmin = 24 * 60 - $tzmin; # minutes west of GMT - $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line - } - - $SEC = 1; - $MIN = 60 * $SEC; - $HR = 60 * $MIN; - $DAYS = 24 * $HR; - $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; - 1; -} - -sub timegm { - package timelocal; - - local($[) = 0; - $ym = pack(C2, @_[5,4]); - $cheat = $cheat{$ym} || &cheat; - return -1 if $cheat<0; - $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; -} - -sub timelocal { - package timelocal; - - local($[) = 0; - $time = &main'timegm + $tzmin*$MIN; - return -1 if $cheat<0; - @test = localtime($time); - $time -= $HR if $test[2] != $_[2]; - $time; -} - -package timelocal; - -sub cheat { - $year = $_[5]; - $month = $_[4]; - die "Month out of range 0..11 in timelocal.pl\n" - if $month > 11 || $month < 0; - die "Day out of range 1..31 in timelocal.pl\n" - if $_[3] > 31 || $_[3] < 1; - die "Hour out of range 0..23 in timelocal.pl\n" - if $_[2] > 23 || $_[2] < 0; - die "Minute out of range 0..59 in timelocal.pl\n" - if $_[1] > 59 || $_[1] < 0; - die "Second out of range 0..59 in timelocal.pl\n" - if $_[0] > 59 || $_[0] < 0; - $guess = $^T; - @g = gmtime($guess); - $year += $YearFix if $year < $epoch[5]; - $lastguess = ""; - while ($diff = $year - $g[5]) { - $guess += $diff * (363 * $DAYS); - @g = gmtime($guess); - if (($thisguess = "@g") eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $lastguess = $thisguess; - } - while ($diff = $month - $g[4]) { - $guess += $diff * (27 * $DAYS); - @g = gmtime($guess); - if (($thisguess = "@g") eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $lastguess = $thisguess; - } - @gfake = gmtime($guess-1); #still being sceptic - if ("@gfake" eq $lastguess){ - return -1; #date beyond this machine's integer limit - } - $g[3]--; - $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; - $cheat{$ym} = $guess; -} +*timelocal::cheat = \&Time::Local::cheat; diff --git a/lib/vars.pm b/lib/vars.pm index 0dd5758297..f0a6e54988 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -14,6 +14,11 @@ This will predeclare all the variables whose names are in the list, allowing you to use them under "use strict", and disabling any typo warnings. +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +C<use subs> declarations are not BLOCK-scoped. They are thus effective +for the entire file in which they appear. You may not rescind such +declarations with C<no vars> or C<no subs>. + Packages such as the B<AutoLoader> and B<SelfLoader> that delay loading of subroutines within packages can create problems with package lexicals defined using C<my()>. While the B<vars> pragma cannot duplicate the |