diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | Makefile.SH | 2 | ||||
| -rw-r--r-- | ext/B/B/Xref.pm | 17 | ||||
| -rw-r--r-- | ext/B/t/xref.t | 102 | ||||
| -rwxr-xr-x | ext/Safe/safe2.t | 22 | ||||
| -rw-r--r-- | lib/Benchmark.t | 2 | ||||
| -rw-r--r-- | lib/Exporter.pm | 32 | ||||
| -rw-r--r-- | lib/Pod/Html.pm | 10 | ||||
| -rwxr-xr-x | makedepend.SH | 8 | ||||
| -rw-r--r-- | perl.c | 1 | ||||
| -rwxr-xr-x | t/op/arith.t | 29 |
11 files changed, 185 insertions, 41 deletions
@@ -106,6 +106,7 @@ ext/B/t/lint.t See if B::Lint works ext/B/t/showlex.t See if B::ShowLex works ext/B/t/stash.t See if B::Stash works ext/B/t/terse.t See if B::Terse works +ext/B/t/xref.t See if B::Xref works ext/B/TESTS Compiler backend test data ext/B/Todo Compiler backend Todo list ext/B/typemap Compiler backend interface types diff --git a/Makefile.SH b/Makefile.SH index 091b154a38..0410bb6ee3 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -100,7 +100,7 @@ true) ;; esac -case "`pwd`" in +case "$ldlibpth" in # Protect any spaces *" "*) ldlibpth=`echo $ldlibpth|sed 's/ /\\\\ /g'` ;; esac diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm index 5ae19beba0..f727dc766b 100644 --- a/ext/B/B/Xref.pm +++ b/ext/B/B/Xref.pm @@ -1,6 +1,6 @@ package B::Xref; -our $VERSION = '1.00'; +our $VERSION = '1.01'; =head1 NAME @@ -21,8 +21,8 @@ The report generated is in the following format: File filename1 Subroutine subname1 Package package1 - object1 C<line numbers> - object2 C<line numbers> + object1 line numbers + object2 line numbers ... Package package2 ... @@ -64,6 +64,10 @@ Directs output to C<FILENAME> instead of standard output. Raw output. Instead of producing a human-readable report, outputs a line in machine-readable form for each definition/use of a variable/sub/format. +=item C<-d> + +Don't output the "(definitions)" sections. + =item C<-D[tO]> (Internal) debug options, probably only useful if C<-r> included. @@ -89,7 +93,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. use strict; use Config; use B qw(peekop class comppadlist main_start svref_2object walksymtable - OPpLVAL_INTRO SVf_POK OPpOUR_INTRO + OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring ); sub UNKNOWN { ["?", "?", "?"] } @@ -145,7 +149,7 @@ sub load_pad { my $namesv = $namelist[$ix]; next if class($namesv) eq "SPECIAL"; my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; - $pad[$ix] = ["(lexical)", $type, $name]; + $pad[$ix] = ["(lexical)", $type || '?', $name || '?']; } if ($Config{useithreads}) { my (@vallist); @@ -278,7 +282,8 @@ sub pp_const { # constant could be in the pad (under useithreads) if ($$sv) { $top = ["?", "", - (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; + (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) + ? cstring($sv->PV) : "?"]; } else { $top = $pad[$op->targ]; diff --git a/ext/B/t/xref.t b/ext/B/t/xref.t new file mode 100644 index 0000000000..8268e3f898 --- /dev/null +++ b/ext/B/t/xref.t @@ -0,0 +1,102 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = qw(../lib); +} + +use strict; +use Test::More tests => 14; + +# line 50 +use_ok( 'B::Xref' ); + +my $file = 'xreftest.out'; + +# line 100 +our $compilesub = B::Xref::compile("-o$file"); +ok( ref $compilesub eq 'CODE', "compile() returns a coderef ($compilesub)" ); +$compilesub->(); # Compile this test script + +#END { unlink $file or diag "END block failed: $!" } + +# Now parse the output +# line 200 +my ($curfile, $cursub, $curpack) = ('') x 3; +our %xreftable = (); +open XREF, $file or die "# Can't open $file: $!\n"; +while (<XREF>) { + chomp; + if (/^File (.*)/) { + $curfile = $1; + } elsif (/^ Subroutine (.*)/) { + $cursub = $1; + } elsif (/^ Package (.*)/) { + $curpack = $1; + } elsif ($curpack eq '?' && /^ (".*") +(.*)/ + or /^ (\S+)\s+(.*)/) { + $xreftable{$curfile}{$cursub}{$curpack}{$1} = $2; + } +} +close XREF; +my $thisfile = __FILE__; + +ok( + defined $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'}, + '$compilesub present in main program' +); +like( + $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'}, + qr/\bi100\b/, + '$compilesub introduced at line 100' +); +like( + $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'}, + qr/&102\b/, + '$compilesub coderef called at line 102' +); +ok( + defined $xreftable{$thisfile}{'(main)'}{'(lexical)'}{'$curfile'}, + '$curfile present in main program' +); +like( + $xreftable{$thisfile}{'(main)'}{'(lexical)'}{'$curfile'}, + qr/\bi200\b/, + '$curfile introduced at line 200' +); +ok( + defined $xreftable{$thisfile}{'(main)'}{main}{'%xreftable'}, + '$xreftable present in main program' +); +ok( + defined $xreftable{$thisfile}{'Testing::Xref::foo'}{main}{'%xreftable'}, + '$xreftable used in subroutine bar' +); +is( + $xreftable{$thisfile}{'(main)'}{main}{'&use_ok'}, '&50', + 'use_ok called at line 50' +); +is( + $xreftable{$thisfile}{'(definitions)'}{'Testing::Xref'}{'&foo'}, 's1001', + 'subroutine foo defined at line 1001' +); +is( + $xreftable{$thisfile}{'(definitions)'}{'Testing::Xref'}{'&bar'}, 's1002', + 'subroutine bar defined at line 1002' +); +is( + $xreftable{$thisfile}{'Testing::Xref::bar'}{'Testing::Xref'}{'&foo'}, + '&1002', 'subroutine foo called at line 1002 by bar' +); +is( + $xreftable{$thisfile}{'Testing::Xref::foo'}{'Testing::Xref'}{'*FOO'}, + '1001', 'glob FOO used in subroutine foo' +); + +# End of tests. +# Now some stuff to feed B::Xref + +# line 1000 +package Testing::Xref; +sub foo { print FOO %::xreftable; } +sub bar { print FOO foo; } diff --git a/ext/Safe/safe2.t b/ext/Safe/safe2.t index 4d6c84a692..d967b19634 100755 --- a/ext/Safe/safe2.t +++ b/ext/Safe/safe2.t @@ -8,9 +8,6 @@ BEGIN { print "1..0\n"; exit 0; } - # test 30 rather naughtily expects English error messages - $ENV{'LC_ALL'} = 'C'; - $ENV{LANGUAGE} = 'C'; # GNU locale extension } # Tests Todo: @@ -122,11 +119,22 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; # --- rdo my $t = 30; -$cpt->rdo('/non/existant/file.name'); -# The regexp is getting rather baroque. -print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; +$! = 0; +my $nosuch = '/non/existant/file.name'; +open(NOSUCH, $nosuch); +if ($@) { + my $errno = $!; + die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!; + $! = 0; + $cpt->rdo($nosuch); + print $! == $errno ? "ok $t\n" : sprintf "not ok $t # \"$!\" is %d (expected %d)\n", $!, $errno; $t++; +} else { + die "Eek! Didn't expect $nosuch to be there."; +} +close(NOSUCH); + # test #31 is gone. -print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; +print "ok $t\n"; $t++; #my $rdo_file = "tmp_rdo.tpl"; #if (open X,">$rdo_file") { diff --git a/lib/Benchmark.t b/lib/Benchmark.t index 503463329e..53d4efcb67 100644 --- a/lib/Benchmark.t +++ b/lib/Benchmark.t @@ -319,7 +319,7 @@ sub check_graph { { select(OUT); my $start = times; - my $chart = cmpthese( -0.1, { a => "++\$i", b => "\$i *= 2" } ) ; + my $chart = cmpthese( -0.1, { a => "++\$i", b => "\$i = sqrt(\$i++)" } ) ; my $end = times; select(STDOUT); ok (($end - $start) > 0.05, "benchmarked code ran for over 0.05 seconds"); diff --git a/lib/Exporter.pm b/lib/Exporter.pm index a986fb33d3..8b8d4c4939 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -247,7 +247,7 @@ Exporter has a special method, 'export_to_level' which is used in situations where you can't directly call Exporter's import method. The export_to_level method looks like: -MyPackage->export_to_level($where_to_export, $package, @what_to_export); + MyPackage->export_to_level($where_to_export, $package, @what_to_export); where $where_to_export is an integer telling how far up the calling stack to export your symbols, and @what_to_export is an array telling what @@ -257,30 +257,30 @@ currently unused. For example, suppose that you have a module, A, which already has an import function: -package A; + package A; -@ISA = qw(Exporter); -@EXPORT_OK = qw ($b); + @ISA = qw(Exporter); + @EXPORT_OK = qw ($b); -sub import -{ - $A::b = 1; # not a very useful import method -} + sub import + { + $A::b = 1; # not a very useful import method + } and you want to Export symbol $A::b back to the module that called package A. Since Exporter relies on the import method to work, via inheritance, as it stands Exporter::import() will never get called. Instead, say the following: -package A; -@ISA = qw(Exporter); -@EXPORT_OK = qw ($b); + package A; + @ISA = qw(Exporter); + @EXPORT_OK = qw ($b); -sub import -{ - $A::b = 1; - A->export_to_level(1, @_); -} + sub import + { + $A::b = 1; + A->export_to_level(1, @_); + } This will export the symbols one level 'above' the current package - ie: to the program or module that used package A. diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 91f78f6e03..362b054e3f 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -407,7 +407,7 @@ sub pod2html { if ($title) { $title =~ s/\s*\(.*\)//; } else { - warn "$0: no title for $podfile" unless $quiet; + warn "$0: no title for $podfile.\n" unless $quiet; $podfile =~ /^(.*)(\.[^.\/]+)?\z/s; $title = ($podfile eq "-" ? 'No Title' : $1); warn "using $title" if $verbose; @@ -1595,7 +1595,7 @@ sub process_text1($$;$$){ # warning; show some text. $linktext = $opar unless defined $linktext; - warn "$0: $podfile: cannot resolve L<$opar> in paragraph $paragraph."; + warn "$0: $podfile: cannot resolve L<$opar> in paragraph $paragraph.\n"; } # now we have a URL or just plain code @@ -1617,7 +1617,7 @@ sub process_text1($$;$$){ } elsif( $func eq 'Z' ){ # Z<> - empty - warn "$0: $podfile: invalid X<> in paragraph $paragraph." + warn "$0: $podfile: invalid X<> in paragraph $paragraph.\n" unless $$rstr =~ s/^>//; } else { @@ -1636,7 +1636,7 @@ sub process_text1($$;$$){ if( $lev == 1 ){ $res .= pure_text( $$rstr ); } else { - warn "$0: $podfile: undelimited $func<> in paragraph $paragraph."; + warn "$0: $podfile: undelimited $func<> in paragraph $paragraph.\n"; } } return $res; @@ -1660,7 +1660,7 @@ sub go_ahead($$$){ } $res .= $2; } - warn "$0: $podfile: undelimited $func<> in paragraph $paragraph."; + warn "$0: $podfile: undelimited $func<> in paragraph $paragraph.\n"; return $res; } diff --git a/makedepend.SH b/makedepend.SH index d18138d773..0806021da8 100755 --- a/makedepend.SH +++ b/makedepend.SH @@ -18,10 +18,6 @@ case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac -case "$osname" in -amigaos) cat=/bin/cat ;; # must be absolute -esac - echo "Extracting makedepend (with variable substitutions)" rm -f makedepend $spitshell >makedepend <<!GROK!THIS! @@ -62,6 +58,10 @@ esac PATH=".$path_sep..$path_sep$PATH" export PATH +case "$osname" in +amigaos) cat=/bin/cat ;; # must be absolute +esac + $cat /dev/null >.deptmp $rm -f *.c.c c/*.c.c if test -f Makefile; then @@ -2161,6 +2161,7 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */ "-s enable rudimentary parsing for switches after programfile", "-S look for programfile using PATH environment variable", "-T enable tainting checks", +"-t enable tainting warnings", "-u dump core after parsing program", "-U allow unsafe operations", "-v print version, subversion (includes VERY IMPORTANT perl info)", diff --git a/t/op/arith.t b/t/op/arith.t index 4205345a7e..55a5e48084 100755 --- a/t/op/arith.t +++ b/t/op/arith.t @@ -1,6 +1,11 @@ #!./perl -w -print "1..133\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..134\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; @@ -269,3 +274,25 @@ tryeq 130, 18446744073709551616/9223372036854775808, 2; my $t1000 = time() * 1000; try 133, abs($t1000 -1000 * $t) <= 2000; } + +if ($^O eq 'vos') { + print "not ok 134 # TODO VOS raises SIGFPE instead of producing infinity.\n"; +} else { + # The computation of $v should overflow and produce "infinity" + # on any system whose max exponent is less than 10**1506. + # The exact string used to represent infinity varies by OS, + # so we don't test for it; all we care is that we don't die. + # + # Perl considers it to be an error if SIGFPE is raised. + # Chances are the interpreter will die, since it doesn't set + # up a handler for SIGFPE. That's why this test is last; to + # minimize the number of test failures. --PG + + my $n = 5000; + my $v = 2; + while (--$n) + { + $v *= 2; + } + print "ok 134\n"; +} |