diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | Makefile.SH | 85 | ||||
| -rwxr-xr-x | cflags.SH | 9 | ||||
| -rwxr-xr-x | configpm | 16 | ||||
| -rw-r--r-- | ext/util/make_ext | 9 | ||||
| -rw-r--r-- | lib/AutoSplit.pm | 2 | ||||
| -rw-r--r-- | lib/Carp.pm | 180 | ||||
| -rw-r--r-- | lib/Carp/Heavy.pm | 204 | ||||
| -rwxr-xr-x | makedepend.SH | 51 | ||||
| -rw-r--r-- | pod/pod2html.PL | 11 | ||||
| -rw-r--r-- | pod/pod2latex.PL | 10 | ||||
| -rw-r--r-- | pod/pod2man.PL | 10 | ||||
| -rw-r--r-- | pod/pod2text.PL | 8 | ||||
| -rw-r--r-- | pod/pod2usage.PL | 10 | ||||
| -rw-r--r-- | pod/podchecker.PL | 10 | ||||
| -rw-r--r-- | pod/podselect.PL | 10 | ||||
| -rw-r--r-- | writemain.SH | 3 | ||||
| -rwxr-xr-x | x2p/Makefile.SH | 12 |
18 files changed, 311 insertions, 330 deletions
@@ -539,6 +539,7 @@ lib/CPAN.pm Interface to Comprehensive Perl Archive Network lib/CPAN/FirstTime.pm Utility for creating CPAN config files lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions lib/Carp.pm Error message base class +lib/Carp/Heavy.pm Error message workhorse lib/Class/Struct.pm Declare struct-like datatypes as Perl classes lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) lib/DB.pm Debugger API (draft) diff --git a/Makefile.SH b/Makefile.SH index 42e9e797d1..626dfe1183 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -194,22 +194,7 @@ SHELL = $sh # how to tr(anslate) newlines TRNL = '$trnl' -# this is where the sources are -src = $src -# this is src quoted for use in regexen -srcqre = `echo $src|sed -e 's@^\.$@\\\.@' -e 's@^\./$@\\\./@' -e 's@^\.\./@\\\.\\\./@g` - -# nice makes grok this -!GROK!THIS! -if $test X. != X$src; then -$spitshell >>Makefile <<!GROK!THIS! -VPATH = .:$src !GROK!THIS! -else -$spitshell >>Makefile <<!GROK!THIS! -VPATH = . -!GROK!THIS! -fi ## In the following dollars and backticks do not need the extra backslash. $spitshell >>Makefile <<'!NO!SUBS!' @@ -296,12 +281,12 @@ utilities: miniperl lib/Config.pm FORCE FORCE: @sh -c true -miniperlmain$(OBJ_EXT): $(src)/miniperlmain.c +miniperlmain$(OBJ_EXT): miniperlmain.c $(CCCMD) $(PLDLFLAGS) $*.c -perlmain.c: $(src)/miniperlmain.c config.sh $(FIRSTMAKEFILE) +perlmain.c: miniperlmain.c config.sh $(FIRSTMAKEFILE) sh writemain $(DYNALOADER) $(static_ext) > writemain.tmp - sh $(src)/mv-if-diff writemain.tmp perlmain.c + sh mv-if-diff writemain.tmp perlmain.c perlmain$(OBJ_EXT): perlmain.c $(CCCMD) $(PLDLFLAGS) $*.c @@ -421,7 +406,7 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj) $(LIBPERLEXPORT) miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs) - $(LDLIBPTH) ./miniperl -w -Ilib -I$(src)/lib -MExporter -e 0 || $(MAKE) minitest + $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT) $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) @@ -455,41 +440,32 @@ sperl$(OBJ_EXT): perl.c perly.h patchlevel.h $(h) $(CCCMD) -DIAMSUID sperl.c $(RMS) sperl.c -lib: - @sh ./makedir lib - # We have to call our ./makedir because Ultrix 4.3 make can't handle the line # test -d lib/auto || mkdir lib/auto # preplibrary: miniperl lib/Config.pm $(plextract) @sh ./makedir lib/auto @echo " AutoSplitting perl library" - $(LDLIBPTH) ./miniperl -Ilib -I$(src)/lib -e 'use AutoSplit; \ - autosplit_lib_modules(@ARGV)' $(src)/lib/*.pm $(src)/lib/*/*.pm + $(LDLIBPTH) ./miniperl -Ilib -e 'use AutoSplit; \ + autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm # Take care to avoid modifying lib/Config.pm without reason # (If trying to create a new port and having problems with the configpm script, # try 'make minitest' and/or commenting out the tests at the end of configpm.) -lib/Config.pm: lib config.sh miniperl configpm +lib/Config.pm: config.sh miniperl configpm $(LDLIBPTH) ./miniperl configpm configpm.tmp - sh $(src)/mv-if-diff configpm.tmp $@ - -lib/ExtUtils: lib - @sh ./makedir lib/ExtUtils + sh mv-if-diff configpm.tmp $@ -lib/ExtUtils/Miniperl.pm: lib/ExtUtils miniperlmain.c miniperl minimod.pl lib/Config.pm +lib/ExtUtils/Miniperl.pm: miniperlmain.c miniperl minimod.pl lib/Config.pm $(LDLIBPTH) ./miniperl minimod.pl > minimod.tmp - sh $(src)/mv-if-diff minimod.tmp $@ + sh mv-if-diff minimod.tmp $@ -lib/re.pm: lib $(src)/ext/re/re.pm +lib/re.pm: ext/re/re.pm rm -f $@ - cat $(src)/ext/re/re.pm > $@ + cat ext/re/re.pm > $@ -pod: - @sh ./makedir pod - -$(plextract): pod miniperl lib/Config.pm lib/re.pm - $(LDLIBPTH) ./miniperl -Ilib -I$(src)/lib $(src)/$@.PL +$(plextract): miniperl lib/Config.pm lib/re.pm + $(LDLIBPTH) ./miniperl -Ilib $@.PL install: all install.perl install.man @@ -537,16 +513,13 @@ run_byacc: FORCE chmod 664 vms/perly_c.vms vms/perly_h.vms perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms -perly$(OBJ_EXT): $(src)/perly.c - $(CCCMD) $(PLDLFLAGS) $(src)/perly.c - # We don't want to regenerate perly.c and perly.h, but they might # appear out-of-date after a patch is applied or a new distribution is # made. -perly.c: $(src)/perly.y +perly.c: perly.y -@sh -c true -perly.h: $(src)/perly.y +perly.h: perly.y -@sh -c true # No compat3.sym here since and including the 5.004_50. @@ -590,16 +563,16 @@ regen_headers: FORCE # DynaLoader may be needed for extensions that use Makefile.PL. $(DYNALOADER): miniperl preplibrary FORCE - @$(LDLIBPTH) sh $(src)/ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) + @$(LDLIBPTH) sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) d_dummy $(dynamic_ext): miniperl preplibrary $(DYNALOADER) FORCE - @$(LDLIBPTH) sh $(src)/ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) + @$(LDLIBPTH) sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) s_dummy $(static_ext): miniperl preplibrary $(DYNALOADER) FORCE - @$(LDLIBPTH) sh $(src)/ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) + @$(LDLIBPTH) sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) n_dummy $(nonxs_ext): miniperl preplibrary $(DYNALOADER) FORCE - @$(LDLIBPTH) sh $(src)/ext/util/make_ext nonxs $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) + @$(LDLIBPTH) sh ext/util/make_ext nonxs $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) clean: _tidy _mopup @@ -676,8 +649,8 @@ depend: makedepend cd x2p; $(MAKE) depend # Cannot postpone this until $firstmakefile is ready ;-) -makedepend: $(src)/makedepend.SH config.sh - sh $(src)/makedepend.SH +makedepend: makedepend.SH config.sh + sh ./makedepend.SH # Cannot delegate rebuilding of t/perl to make to allow interlaced # test and minitest @@ -717,25 +690,25 @@ minitest: miniperl lib/re.pm # Please *don't* use this unless all tests pass. # If you want to report test failures, use "make nok" instead. ok: utilities - $(LDLIBPTH) ./perl -Ilib -I$(src)/lib utils/perlbug -ok -s '(UNINSTALLED)' + $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' okfile: utilities - $(LDLIBPTH) ./perl -Ilib -I$(src)/lib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok + $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok nok: utilities - $(LDLIBPTH) ./perl -Ilib -I$(src)/lib utils/perlbug -nok -s '(UNINSTALLED)' + $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' clist: $(c) - echo $(c) | tr ' ' $(TRNL) | sed -e "s@^$(srcqre)/@@" >.clist + echo $(c) | tr ' ' $(TRNL) >.clist hlist: $(h) - echo $(h) | tr ' ' $(TRNL) | sed -e "s@^$(srcqre)/@@" >.hlist + echo $(h) | tr ' ' $(TRNL) >.hlist shlist: $(sh) - echo $(sh) | tr ' ' $(TRNL) | sed -e "s@^$(srcqre)/@@" >.shlist + echo $(sh) | tr ' ' $(TRNL) >.shlist pllist: $(pl) - echo $(pl) | tr ' ' $(TRNL) | sed -e "s@^$(srcqre)/@@" >.pllist + echo $(pl) | tr ' ' $(TRNL) >.pllist Makefile: Makefile.SH ./config.sh $(SHELL) Makefile.SH @@ -1,4 +1,4 @@ -case $CONFIGDOTSH in +case $CONFIG in '') if test -f config.sh; then TOP=.; elif test -f ../config.sh; then TOP=..; @@ -24,7 +24,6 @@ echo "Extracting cflags (with variable substitutions)" rm -f cflags $spitshell >cflags <<!GROK!THIS! $startsh -src=$src !GROK!THIS! : In the following dollars and backticks do not need the extra backslash. @@ -75,12 +74,6 @@ for file do *) echo $n " $file.c $c" ;; esac - : allow for out-of-source experience - - if test "X$src" != X.; then - ccflags="$ccflags -I$src -I." - fi - : allow variables like toke_cflags to be evaluated if echo $file | grep -v / >/dev/null @@ -1,15 +1,7 @@ #!./miniperl -w -# File::Spec? my $config_pm = $ARGV[0] || 'lib/Config.pm'; -my $src = '.'; -# File::Dirname? File::Spec? -if ($0 =~ m!^(?:(.+)/)configpm$!) { - $src = $1; - unshift @INC, "$1/lib"; -} -# File::Spec? -my $glossary = $ARGV[1] || "$src/Porting/Glossary"; +my $glossary = $ARGV[1] || 'Porting/Glossary'; @ARGV = "./config.sh"; # list names to put first (and hence lookup fastest) @@ -93,11 +85,7 @@ print CONFIG "\n", print CONFIG "my \$summary = <<'!END!';\n"; -# File::Spec? -my $myconfigdotSH = - $src eq "." ? "myconfig.SH" : "$src/myconfig.SH"; - -open(MYCONFIG,"<$myconfigdotSH") || die "open $myconfigdotSH failed: $!"; +open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!"; 1 while defined($_ = <MYCONFIG>) && !/^Summary of/; do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/; close(MYCONFIG); diff --git a/ext/util/make_ext b/ext/util/make_ext index 9afbbcccbb..54caf7dfd8 100644 --- a/ext/util/make_ext +++ b/ext/util/make_ext @@ -75,7 +75,7 @@ makefile=Makefile makeargs='' makeopts='' -if test ! -d "$src/ext/$pname"; then +if test ! -d "ext/$pname"; then echo " Skipping $extspec (directory does not exist)" exit 0 # not an error ? fi @@ -83,11 +83,6 @@ fi echo " Making $mname ($target)" -mkdir ext 2>/dev/null -mkdir ext/$pname 2>/dev/null -if test ! -f ext/$pname/Makefile.PL; then - cat $src/ext/$pname/Makefile.PL > ext/$pname/Makefile.PL -fi cd ext/$pname # check link type and do any preliminaries @@ -121,7 +116,7 @@ nonxs) makeargs=""; esac if test ! -f $makefile ; then - test -f Makefile.PL && ../$depth/miniperl -I../$depth/lib -I$src/lib Makefile.PL INSTALLDIRS=perl $passthru + test -f Makefile.PL && ../$depth/miniperl -I../$depth/lib Makefile.PL INSTALLDIRS=perl $passthru fi if test ! -f $makefile ; then if test -f Makefile.SH; then diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index eaa0691093..33c0b9a03d 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -176,7 +176,7 @@ sub autosplit_lib_modules{ $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } - autosplit_file("$_", "lib/auto", + autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime); } 0; diff --git a/lib/Carp.pm b/lib/Carp.pm index 364442436b..eaa4d53d8a 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -94,103 +94,8 @@ sub export_fail { # each function call on the stack. sub longmess { - return @_ if ref $_[0]; - my $error = join '', @_; - my $mess = ""; - my $i = 1 + $CarpLevel; - my ($pack,$file,$line,$sub,$hargs,$eval,$require); - my (@a); - # - # crawl up the stack.... - # - while (do { { package DB; @a = caller($i++) } } ) { - # get copies of the variables returned from caller() - ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; - # - # if the $error error string is newline terminated then it - # is copied into $mess. Otherwise, $mess gets set (at the end of - # the 'else {' section below) to one of two things. The first time - # through, it is set to the "$error at $file line $line" message. - # $error is then set to 'called' which triggers subsequent loop - # iterations to append $sub to $mess before appending the "$error - # at $file line $line" which now actually reads "called at $file line - # $line". Thus, the stack trace message is constructed: - # - # first time: $mess = $error at $file line $line - # subsequent times: $mess .= $sub $error at $file line $line - # ^^^^^^ - # "called" - if ($error =~ m/\n$/) { - $mess .= $error; - } else { - # Build a string, $sub, which names the sub-routine called. - # This may also be "require ...", "eval '...' or "eval {...}" - if (defined $eval) { - if ($require) { - $sub = "require $eval"; - } else { - $eval =~ s/([\\\'])/\\$1/g; - if ($MaxEvalLen && length($eval) > $MaxEvalLen) { - substr($eval,$MaxEvalLen) = '...'; - } - $sub = "eval '$eval'"; - } - } elsif ($sub eq '(eval)') { - $sub = 'eval {...}'; - } - # if there are any arguments in the sub-routine call, format - # them according to the format variables defined earlier in - # this file and join them onto the $sub sub-routine string - if ($hargs) { - # we may trash some of the args so we take a copy - @a = @DB::args; # must get local copy of args - # don't print any more than $MaxArgNums - if ($MaxArgNums and @a > $MaxArgNums) { - # cap the length of $#a and set the last element to '...' - $#a = $MaxArgNums; - $a[$#a] = "..."; - } - for (@a) { - # set args to the string "undef" if undefined - $_ = "undef", next unless defined $_; - if (ref $_) { - # dunno what this is for... - $_ .= ''; - s/'/\\'/g; - } - else { - s/'/\\'/g; - # terminate the string early with '...' if too long - substr($_,$MaxArgLen) = '...' - if $MaxArgLen and $MaxArgLen < length; - } - # 'quote' arg unless it looks like a number - $_ = "'$_'" unless /^-?[\d.]+$/; - # print high-end chars as 'M-<char>' or '^<char>' - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - # append ('all', 'the', 'arguments') to the $sub string - $sub .= '(' . join(', ', @a) . ')'; - } - # here's where the error message, $mess, gets constructed - $mess .= "\t$sub " if $error eq "called"; - $mess .= "$error at $file line $line"; - if (exists $main::{'Thread::'}) { - my $tid = Thread->self->tid; - $mess .= " thread $tid" if $tid; - } - $mess .= "\n"; - } - # we don't need to print the actual error message again so we can - # change this to "called" so that the string "$error at $file line - # $line" makes sense as "called at $file line $line". - $error = "called"; - } - # this kludge circumvents die's incorrect handling of NUL - my $msg = \($mess || $error); - $$msg =~ tr/\0//d; - $$msg; + require Carp::Heavy; + goto &longmess_heavy; } @@ -201,85 +106,8 @@ sub longmess { # you always get a stack trace sub shortmess { # Short-circuit &longmess if called via multiple packages - goto &longmess if $Verbose; - return @_ if ref $_[0]; - my $error = join '', @_; - my ($prevpack) = caller(1); - my $extra = $CarpLevel; - my $i = 2; - my ($pack,$file,$line); - # when reporting an error, we want to report it from the context of the - # calling package. So what is the calling package? Within a module, - # there may be many calls between methods and perhaps between sub-classes - # and super-classes, but the user isn't interested in what happens - # inside the package. We start by building a hash array which keeps - # track of all the packages to which the calling package belongs. We - # do this by examining its @ISA variable. Any call from a base class - # method (one of our caller's @ISA packages) can be ignored - my %isa = ($prevpack,1); - - # merge all the caller's @ISA packages into %isa. - @isa{@{"${prevpack}::ISA"}} = () - if(@{"${prevpack}::ISA"}); - - # now we crawl up the calling stack and look at all the packages in - # there. For each package, we look to see if it has an @ISA and then - # we see if our caller features in that list. That would imply that - # our caller is a derived class of that package and its calls can also - # be ignored - while (($pack,$file,$line) = caller($i++)) { - if(@{$pack . "::ISA"}) { - my @i = @{$pack . "::ISA"}; - my %i; - @i{@i} = (); - # merge any relevant packages into %isa - @isa{@i,$pack} = () - if(exists $i{$prevpack} || exists $isa{$pack}); - } - - # and here's where we do the ignoring... if the package in - # question is one of our caller's base or derived packages then - # we can ignore it (skip it) and go onto the next (but note that - # the continue { } block below gets called every time) - next - if(exists $isa{$pack}); - - # Hey! We've found a package that isn't one of our caller's - # clan....but wait, $extra refers to the number of 'extra' levels - # we should skip up. If $extra > 0 then this is a false alarm. - # We must merge the package into the %isa hash (so we can ignore it - # if it pops up again), decrement $extra, and continue. - if ($extra-- > 0) { - %isa = ($pack,1); - @isa{@{$pack . "::ISA"}} = () - if(@{$pack . "::ISA"}); - } - else { - # OK! We've got a candidate package. Time to construct the - # relevant error message and return it. die() doesn't like - # to be given NUL characters (which $msg may contain) so we - # remove them first. - my $msg; - $msg = "$error at $file line $line"; - if (exists $main::{'Thread::'}) { - my $tid = Thread->self->tid; - $mess .= " thread $tid" if $tid; - } - $msg .= "\n"; - $msg =~ tr/\0//d; - return $msg; - } - } - continue { - $prevpack = $pack; - } - - # uh-oh! It looks like we crawled all the way up the stack and - # never found a candidate package. Oh well, let's call longmess - # to generate a full stack trace. We use the magical form of 'goto' - # so that this shortmess() function doesn't appear on the stack - # to further confuse longmess() about it's calling package. - goto &longmess; + require Carp::Heavy; + goto &shortmess_heavy; } diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm new file mode 100644 index 0000000000..0672efea7d --- /dev/null +++ b/lib/Carp/Heavy.pm @@ -0,0 +1,204 @@ +package Carp; +# This package is heavily used. Be small. Be fast. Be good. + +# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an +# _almost_ complete understanding of the package. Corrections and +# comments are welcome. + +# longmess() crawls all the way up the stack reporting on all the function +# calls made. The error string, $error, is originally constructed from the +# arguments passed into longmess() via confess(), cluck() or shortmess(). +# This gets appended with the stack trace messages which are generated for +# each function call on the stack. + +sub longmess_heavy { + return @_ if ref $_[0]; + my $error = join '', @_; + my $mess = ""; + my $i = 1 + $CarpLevel; + my ($pack,$file,$line,$sub,$hargs,$eval,$require); + my (@a); + # + # crawl up the stack.... + # + while (do { { package DB; @a = caller($i++) } } ) { + # get copies of the variables returned from caller() + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # + # if the $error error string is newline terminated then it + # is copied into $mess. Otherwise, $mess gets set (at the end of + # the 'else {' section below) to one of two things. The first time + # through, it is set to the "$error at $file line $line" message. + # $error is then set to 'called' which triggers subsequent loop + # iterations to append $sub to $mess before appending the "$error + # at $file line $line" which now actually reads "called at $file line + # $line". Thus, the stack trace message is constructed: + # + # first time: $mess = $error at $file line $line + # subsequent times: $mess .= $sub $error at $file line $line + # ^^^^^^ + # "called" + if ($error =~ m/\n$/) { + $mess .= $error; + } else { + # Build a string, $sub, which names the sub-routine called. + # This may also be "require ...", "eval '...' or "eval {...}" + if (defined $eval) { + if ($require) { + $sub = "require $eval"; + } else { + $eval =~ s/([\\\'])/\\$1/g; + if ($MaxEvalLen && length($eval) > $MaxEvalLen) { + substr($eval,$MaxEvalLen) = '...'; + } + $sub = "eval '$eval'"; + } + } elsif ($sub eq '(eval)') { + $sub = 'eval {...}'; + } + # if there are any arguments in the sub-routine call, format + # them according to the format variables defined earlier in + # this file and join them onto the $sub sub-routine string + if ($hargs) { + # we may trash some of the args so we take a copy + @a = @DB::args; # must get local copy of args + # don't print any more than $MaxArgNums + if ($MaxArgNums and @a > $MaxArgNums) { + # cap the length of $#a and set the last element to '...' + $#a = $MaxArgNums; + $a[$#a] = "..."; + } + for (@a) { + # set args to the string "undef" if undefined + $_ = "undef", next unless defined $_; + if (ref $_) { + # dunno what this is for... + $_ .= ''; + s/'/\\'/g; + } + else { + s/'/\\'/g; + # terminate the string early with '...' if too long + substr($_,$MaxArgLen) = '...' + if $MaxArgLen and $MaxArgLen < length; + } + # 'quote' arg unless it looks like a number + $_ = "'$_'" unless /^-?[\d.]+$/; + # print high-end chars as 'M-<char>' + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + # print remaining control chars as ^<char> + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + # append ('all', 'the', 'arguments') to the $sub string + $sub .= '(' . join(', ', @a) . ')'; + } + # here's where the error message, $mess, gets constructed + $mess .= "\t$sub " if $error eq "called"; + $mess .= "$error at $file line $line"; + if (exists $main::{'Thread::'}) { + my $tid = Thread->self->tid; + $mess .= " thread $tid" if $tid; + } + $mess .= "\n"; + } + # we don't need to print the actual error message again so we can + # change this to "called" so that the string "$error at $file line + # $line" makes sense as "called at $file line $line". + $error = "called"; + } + # this kludge circumvents die's incorrect handling of NUL + my $msg = \($mess || $error); + $$msg =~ tr/\0//d; + $$msg; +} + + +# shortmess() is called by carp() and croak() to skip all the way up to +# the top-level caller's package and report the error from there. confess() +# and cluck() generate a full stack trace so they call longmess() to +# generate that. In verbose mode shortmess() calls longmess() so +# you always get a stack trace + +sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages + goto &longmess_heavy if $Verbose; + return @_ if ref $_[0]; + my $error = join '', @_; + my ($prevpack) = caller(1); + my $extra = $CarpLevel; + my $i = 2; + my ($pack,$file,$line); + # when reporting an error, we want to report it from the context of the + # calling package. So what is the calling package? Within a module, + # there may be many calls between methods and perhaps between sub-classes + # and super-classes, but the user isn't interested in what happens + # inside the package. We start by building a hash array which keeps + # track of all the packages to which the calling package belongs. We + # do this by examining its @ISA variable. Any call from a base class + # method (one of our caller's @ISA packages) can be ignored + my %isa = ($prevpack,1); + + # merge all the caller's @ISA packages into %isa. + @isa{@{"${prevpack}::ISA"}} = () + if(@{"${prevpack}::ISA"}); + + # now we crawl up the calling stack and look at all the packages in + # there. For each package, we look to see if it has an @ISA and then + # we see if our caller features in that list. That would imply that + # our caller is a derived class of that package and its calls can also + # be ignored + while (($pack,$file,$line) = caller($i++)) { + if(@{$pack . "::ISA"}) { + my @i = @{$pack . "::ISA"}; + my %i; + @i{@i} = (); + # merge any relevant packages into %isa + @isa{@i,$pack} = () + if(exists $i{$prevpack} || exists $isa{$pack}); + } + + # and here's where we do the ignoring... if the package in + # question is one of our caller's base or derived packages then + # we can ignore it (skip it) and go onto the next (but note that + # the continue { } block below gets called every time) + next + if(exists $isa{$pack}); + + # Hey! We've found a package that isn't one of our caller's + # clan....but wait, $extra refers to the number of 'extra' levels + # we should skip up. If $extra > 0 then this is a false alarm. + # We must merge the package into the %isa hash (so we can ignore it + # if it pops up again), decrement $extra, and continue. + if ($extra-- > 0) { + %isa = ($pack,1); + @isa{@{$pack . "::ISA"}} = () + if(@{$pack . "::ISA"}); + } + else { + # OK! We've got a candidate package. Time to construct the + # relevant error message and return it. die() doesn't like + # to be given NUL characters (which $msg may contain) so we + # remove them first. + my $msg; + $msg = "$error at $file line $line"; + if (exists $main::{'Thread::'}) { + my $tid = Thread->self->tid; + $mess .= " thread $tid" if $tid; + } + $msg .= "\n"; + $msg =~ tr/\0//d; + return $msg; + } + } + continue { + $prevpack = $pack; + } + + # uh-oh! It looks like we crawled all the way up the stack and + # never found a candidate package. Oh well, let's call longmess + # to generate a full stack trace. We use the magical form of 'goto' + # so that this shortmess() function doesn't appear on the stack + # to further confuse longmess() about it's calling package. + goto &longmess_heavy; +} + +1; diff --git a/makedepend.SH b/makedepend.SH index e26c50e09f..e1c28468bd 100755 --- a/makedepend.SH +++ b/makedepend.SH @@ -26,14 +26,13 @@ $startsh # MAKE=$make trnl='$trnl' -src=$src !GROK!THIS! $spitshell >>makedepend <<'!NO!SUBS!' # This script should be called with -# sh ./makedepend MAKE=$(MAKE) [src=$(src)] +# sh ./makedepend MAKE=$(MAKE) case "$1" in - MAKE=*) eval $1 ; shift ;; + MAKE=*) eval $1 ;; esac export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$) @@ -52,10 +51,6 @@ case $CONFIGDOTSH in ;; esac -case "$1" in - src=*) eval $1 ; shift ;; -esac - # We need .. when we are in the x2p directory if we are using the # cppstdin wrapper script. # Put .. and . first so that we pick up the present cppstdin, not @@ -100,18 +95,9 @@ esac : might be identical $test -d UU || mkdir UU -$MAKE clist || (cd $src; $echo "Searching for .c files..."; \ - $echo *.c | $tr ' ' $trnl | $egrep -v '\*') >.clist -for base in `$cat .clist`; do - case "$src" in - .) file="$base" ;; - *) if test -f "$base"; then - file="$base" - elif test -f "$src/$base"; then - file="$src/$base" - fi - ;; - esac +$MAKE clist || ($echo "Searching for .c files..."; \ + $echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist) +for file in `$cat .clist`; do # for file in `cat /dev/null`; do if [ "$osname" = uwin ]; then uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" @@ -127,15 +113,14 @@ for base in `$cat .clist`; do fi fi case "$file" in + *.c) filebase=`basename $file .c` ;; + *.y) filebase=`basename $file .y` ;; + esac + case "$file" in */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;; *) finc= ;; esac - case "$src" in - '') ;; - *) finc="-I$src" ;; - esac - basebase=`basename $base .c` - $echo "Finding dependencies for $basebase$_o." + $echo "Finding dependencies for $filebase$_o." ( $echo "#line 1 \"$file\""; \ $sed -n <$file \ -e "/^${filebase}_init(/q" \ @@ -144,16 +129,16 @@ for base in `$cat .clist`; do -e 's|/\*.*$||' \ -e 's|\\$||' \ -e p \ - -e '}' ) >UU/$base.c - $cppstdin $finc -I. $cppflags $cppminus <UU/$base.c | + -e '}' ) >UU/$file.c + $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c | $sed \ -e '/^#.*<stdin>/d' \ -e '/^#.*"-"/d' \ -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ -e 's/^[ ]*#[ ]*line/#/' \ -e '/^# *[0-9][0-9]* *[".\/]/!d' \ - -e 's/^.*"\(.*\)".*$/'$base'\$(OBJ_EXT): \1/' \ - -e 's/^# *[0-9][0-9]* \(.*\)$/'$base'\$(OBJ_EXT): \1/' \ + -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \ + -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \ -e 's|: \./|: |' \ -e 's|\.c\.c|.c|' $uwinfix | \ $uniq | $sort | $uniq >> .deptmp @@ -161,8 +146,8 @@ done $sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d' -$MAKE shlist || (cd $src; $echo "Searching for .SH files..."; \ - $echo *.SH | $tr ' ' $trnl | $egrep -v '\*') >.shlist +$MAKE shlist || ($echo "Searching for .SH files..."; \ + $echo *.SH | $tr ' ' $trnl | $egrep -v '\*' >.shlist) # Now extract the dependencies on makedepend.SH and Makefile.SH # (they should reside in the main Makefile): @@ -191,8 +176,8 @@ if $test -s .deptmp; then $sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \ >>$mf.new else - $MAKE hlist || (cd $src; $echo "Searching for .h files..."; \ - $echo *.h | $tr ' ' $trnl | $egrep -v '\*') >.hlist + $MAKE hlist || ($echo "Searching for .h files..."; \ + $echo *.h | $tr ' ' $trnl | $egrep -v '\*' >.hlist) $echo "You don't seem to have a proper C preprocessor. Using grep instead." $egrep '^#include ' `cat .clist` `cat .hlist` >.deptmp $echo "Updating $mf..." diff --git a/pod/pod2html.PL b/pod/pod2html.PL index 746e101e49..366dc163bf 100644 --- a/pod/pod2html.PL +++ b/pod/pod2html.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -10,11 +11,13 @@ use File::Basename qw(&basename &dirname); # $startperl # to ensure Configure will look for $Config{startperl}. -$file = basename($0); -$file =~ s/\.PL$//i; +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir dirname($0); +$file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; -chdir("pod") or die "Can't chdir to pod: $!"; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; @@ -177,4 +180,4 @@ pod2html @ARGV; close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; - +chdir $origdir; diff --git a/pod/pod2latex.PL b/pod/pod2latex.PL index 01cdf1bd76..feed98e923 100644 --- a/pod/pod2latex.PL +++ b/pod/pod2latex.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -10,11 +11,13 @@ use File::Basename qw(&basename &dirname); # $startperl # to ensure Configure will look for $Config{startperl}. -$file = basename($0); -$file =~ s/\.PL$//i; +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir dirname($0); +$file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; -chdir("pod") or die "Can't chdir to pod: $!"; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; @@ -702,3 +705,4 @@ BEGIN { close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 37557bf560..20610a84c3 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -11,11 +12,13 @@ use File::Basename qw(&basename &dirname); # $man3ext # to ensure Configure will look for $Config{startperl}. -$file = basename($0); -$file =~ s/\.PL$//i; +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir dirname($0); +$file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; -chdir("pod") or die "Can't chdir to pod: $!"; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; @@ -1231,3 +1234,4 @@ BEGIN { close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/pod/pod2text.PL b/pod/pod2text.PL index a1a38751b8..94516c3997 100644 --- a/pod/pod2text.PL +++ b/pod/pod2text.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -10,11 +11,13 @@ use File::Basename qw(&basename &dirname); # $startperl # to ensure Configure will look for $Config{startperl}. -$file = basename($0); +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir dirname($0); $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; -chdir("pod") or die "Can't chdir to pod: $!"; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; @@ -45,3 +48,4 @@ if(@ARGV) { close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/pod/pod2usage.PL b/pod/pod2usage.PL index f534252e3e..fdaa955c69 100644 --- a/pod/pod2usage.PL +++ b/pod/pod2usage.PL @@ -10,11 +10,13 @@ use File::Basename qw(&basename &dirname); # $startperl # to ensure Configure will look for $Config{startperl}. -$file = basename($0); -$file =~ s/\.PL$//i; -$file .= '.com' if $^O eq 'VMS'; +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" -chdir("pod") or die "Can't chdir to pod: $!"; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; diff --git a/pod/podchecker.PL b/pod/podchecker.PL index 24dcfb88c2..1ca0d79eda 100644 --- a/pod/podchecker.PL +++ b/pod/podchecker.PL @@ -10,11 +10,13 @@ use File::Basename qw(&basename &dirname); # $startperl # to ensure Configure will look for $Config{startperl}. -$file = basename($0); -$file =~ s/\.PL$//i; -$file .= '.com' if $^O eq 'VMS'; +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" -chdir("pod") or die "Can't chdir to pod: $!"; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; diff --git a/pod/podselect.PL b/pod/podselect.PL index 7cff6915bb..0df830406e 100644 --- a/pod/podselect.PL +++ b/pod/podselect.PL @@ -10,11 +10,13 @@ use File::Basename qw(&basename &dirname); # $startperl # to ensure Configure will look for $Config{startperl}. -$file = basename($0); -$file =~ s/\.PL$//i; -$file .= '.com' if $^O eq 'VMS'; +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" -chdir("pod") or die "Can't chdir to pod: $!"; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; diff --git a/writemain.SH b/writemain.SH index 6c53602472..18544c1f81 100644 --- a/writemain.SH +++ b/writemain.SH @@ -24,7 +24,6 @@ echo "Extracting writemain (with variable substitutions)" rm -f writemain $spitshell >writemain <<!GROK!THIS! $startsh -src=$src !GROK!THIS! : In the following dollars and backticks do not need the extra backslash. @@ -56,7 +55,7 @@ for file in $orig ; do done -sed '/Do not delete this line--writemain depends on it/q' $src/miniperlmain.c +sed '/Do not delete this line--writemain depends on it/q' miniperlmain.c if test X"$args" != "X" ; then diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index 240725a805..8ed7d315a1 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -63,12 +63,6 @@ TRNL = '$trnl' .SUFFIXES: .c \$(OBJ_EXT) -# this is where the sources are -src = $src - -# nice makes grok this -#VPATH = .:$src - !GROK!THIS! cat >>Makefile <<'!NO!SUBS!' @@ -95,9 +89,9 @@ plm = a2p.loadmap addedbyconf = $(shextract) $(plextract) -h = EXTERN.h INTERN.h ../config.h handy.h hash.h a2p.h str.h util.h +h = EXTERN.h INTERN.h ../config.h ../handy.h hash.h a2p.h str.h util.h -c = hash.c str.c util.c walk.c +c = hash.c $(mallocsrc) str.c util.c walk.c obj = hash$(OBJ_EXT) $(mallocobj) str$(OBJ_EXT) util$(OBJ_EXT) walk$(OBJ_EXT) @@ -153,7 +147,7 @@ lint: lint $(lintflags) $(defs) $(c) > a2p.fuzz depend: $(mallocsrc) ../makedepend - sh ../makedepend MAKE=$(MAKE) src=$(src)/x2p + sh ../makedepend MAKE=$(MAKE) clist: echo $(c) | tr ' ' $(TRNL) >.clist |