diff options
-rw-r--r-- | README.threads | 52 | ||||
-rw-r--r-- | hints/irix_6.sh | 6 | ||||
-rw-r--r-- | lib/Test/Harness.pm | 14 | ||||
-rw-r--r-- | lib/perl5db.pl | 299 | ||||
-rw-r--r-- | malloc.c | 2 | ||||
-rw-r--r-- | miniperlmain.c | 4 | ||||
-rw-r--r-- | perl.h | 19 | ||||
-rw-r--r-- | sv.c | 19 | ||||
-rwxr-xr-x | t/TEST | 2 | ||||
-rwxr-xr-x | t/lib/anydbm.t | 2 | ||||
-rwxr-xr-x | t/lib/db-btree.t | 2 | ||||
-rwxr-xr-x | t/lib/db-hash.t | 2 | ||||
-rwxr-xr-x | t/lib/db-recno.t | 2 | ||||
-rwxr-xr-x | t/lib/gdbm.t | 4 | ||||
-rwxr-xr-x | t/lib/ndbm.t | 4 | ||||
-rwxr-xr-x | t/lib/odbm.t | 4 | ||||
-rwxr-xr-x | t/lib/safe2.t | 1 | ||||
-rwxr-xr-x | t/lib/sdbm.t | 4 | ||||
-rwxr-xr-x | t/op/pat.t | 22 | ||||
-rwxr-xr-x | t/op/taint.t | 51 | ||||
-rw-r--r-- | win32/perllib.c | 4 |
21 files changed, 313 insertions, 206 deletions
diff --git a/README.threads b/README.threads index 653321af8a..427f38ad74 100644 --- a/README.threads +++ b/README.threads @@ -1,10 +1,19 @@ Building If you want to build with multi-threading support and you are -running Linux 2.x (with the LinuxThreads library installed: -that's the linuxthreads and linuxthreads-devel RPMs for RedHat) -or Digital UNIX 4.x or Solaris 2.x for recentish x (2.5 is OK) -or IRIX 6.2 or newer (6.2 will require a few os patches), +running one of the following: + * Linux 2.x (with the LinuxThreads library installed: that's + the linuxthreads and linuxthreads-devel RPMs for RedHat) + + * Digital UNIX 4.x + + * Solaris 2.x for recentish x (2.5 is OK) + + * IRIX 6.2 or newer. 6.2 will require a few os patches. + IMPORTANT: Without patch 2401, a kernel bug in IRIX 6.2 will + cause your machine to panic and crash when running threaded perl. + IRIX 6.3 and up should be OK. See lower down for patch details. + then you should be able to use ./Configure -Dusethreads -Doptimize=-g -ders make @@ -53,6 +62,11 @@ For IRIX: 1645 IRIX 6.2 & 6.3 POSIX header file updates 2000 Irix 6.2 Posix 1003.1b support modules 2254 Pthread library fixes + 2401 6.2 all platform kernel rollup + IMPORTANT: Without patch 2401, a kernel bug in IRIX 6.2 will + cause your machine to panic and crash when running threaded perl. + IRIX 6.3 and up should be OK. + For IRIX 6.3 and 6.4 the pthreads should work out of the box. Thanks to Hannu Napari <Hannu.Napari@hut.fi> for the IRIX pthreads patches information. @@ -68,9 +82,8 @@ while doing a sort() then the resulting longjmp() leaves the mutex locked so you get a deadlock the next time you try to sort(). LinuxThreads 0.5 has a bug which can cause file descriptor 0 to be -closed after a fork() leading to many strange symptoms. The -development version of LinuxThreads has this fixed but the following -patch can be applied to 0.5 for now: +closed after a fork() leading to many strange symptoms. Version 0.6 +has this fixed but the following patch can be applied to 0.5 for now: ----------------------------- cut here ----------------------------- --- linuxthreads-0.5/pthread.c.ORI Mon Oct 6 13:55:50 1997 @@ -99,28 +112,21 @@ the list of extensions automatically. You can try some of the tests with cd ext/Thread - perl -Mblib create.t - perl -Mblib join.t - perl -Mblib lock.t - perl -Mblib unsync.t - perl -Mblib unsync2.t - perl -Mblib unsync3.t - perl -Mblib io.t - perl -Mblib queue.t + perl create.t + perl join.t + perl lock.t + perl io.t +etc. The io one leaves a thread reading from the keyboard on stdin so as the ping messages appear you can type lines and see them echoed. Try running the main perl test suite too. There are known -failures for op/misc test 45 (tries to do local(@_) but @_ is -now lexical) and for some of the DBM/DB extensions (if there -underlying libraries were not compiled to be thread-aware). -may or may not work. +failures for some of the DBM/DB extensions (if their underlying +libraries were not compiled to be thread-aware). Bugs -* cond.t hasn't been redone since condition variable changed. - * FAKE_THREADS should produce a working perl but the Thread extension won't build with it yet. @@ -132,8 +138,6 @@ haven't tracked down yet) and there are very probably others too. * Need to document "lock", Thread.pm, Queue.pm, ... -* Plenty of others - Debugging @@ -248,4 +252,4 @@ ZOMBIE ----------------------------> DEAD Malcolm Beattie mbeattie@sable.ox.ac.uk -6 November 1997 +Last updated: 27 November 1997 diff --git a/hints/irix_6.sh b/hints/irix_6.sh index 1ae1ca5249..72cc2c61db 100644 --- a/hints/irix_6.sh +++ b/hints/irix_6.sh @@ -136,6 +136,12 @@ The following IRIX patches must, however, be installed: 1645 IRIX 6.2 & 6.3 POSIX header file updates 2000 Irix 6.2 Posix 1003.1b support modules 2254 Pthread library fixes + 2401 6.2 all platform kernel rollup +IMPORTANT: + Without patch 2401, a kernel bug in IRIX 6.2 will + cause your machine to panic and crash when running + threaded perl. IRIX 6.3 and up should be OK. + Cannot continue, aborting. EOF diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index f5fc3d8cc5..37f4a9fbde 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -73,6 +73,7 @@ sub runtests { $fh->open($cmd) or print "can't run $test. $!\n"; $ok = $next = $max = 0; @failed = (); + my $skipped = 0; while (<$fh>) { if( $verbose ){ print $_; @@ -87,10 +88,11 @@ sub runtests { if (/^not ok\s*(\d*)/){ $this = $1 if $1 > 0; push @failed, $this; - } elsif (/^ok\s*(\d*)/) { + } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip)?/) { $this = $1 if $1 > 0; $ok++; $totok++; + $skipped++ if defined $2; } if ($this > $next) { # warn "Test output counter mismatch [test $this]\n"; @@ -142,7 +144,10 @@ sub runtests { estat => $estatus, wstat => $wstatus, }; } elsif ($ok == $max && $next == $max+1) { - if ($max) { + if ($max and $skipped) { + my $ender = 's' x ($skipped > 1); + print "ok, $skipped subtest$ender skipped on this platform\n"; + } elsif ($max) { print "ok\n"; } else { print "skipping test on this platform\n"; @@ -328,6 +333,11 @@ The global variable $Test::Harness::switches is exportable and can be used to set perl command line options used for running the test script(s). The default value is C<-w>. +If the standard output line contains substring C< # Skip> (with +variations in spacing and case) after C<ok> or C<ok NUMBER>, it is +counted as a skipped test. If the whole testscript succeeds, the +count of skipped tests is included in the generated output. + =head1 EXPORT C<&runtests> is exported by Test::Harness per default. diff --git a/lib/perl5db.pl b/lib/perl5db.pl index d5dbfbdd68..df56723dee 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 = 1.01; +$VERSION = 1.02; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -381,8 +381,29 @@ sub DB { } } my $was_signal = $signal; + if ($trace & 2) { + for (my $n = 0; $n <= $#to_watch; $n++) { + $evalarg = $to_watch[$n]; + my ($val) = &eval; # Fix context (&eval is doing array)? + $val = ( (defined $val) ? "'$val'" : 'undef' ); + if ($val ne $old_watch[$n]) { + $signal = 1; + print $OUT <<EOP; +Watchpoint $n: $to_watch[$n] changed: +old value: $old_watch[$n] +new value: $val +EOP + $old_watch[$n] = $val; + } + } + } + if ($trace & 4) { # User-installed watch + return if watchfunction($package, $filename, $line) + and not $single and not $was_signal and not ($trace & ~4); + } + $was_signal = $signal; $signal = 0; - if ($single || $trace || $was_signal) { + if ($single || ($trace & 1) || $was_signal) { $term || &setterm; if ($emacs) { $position = "\032\032$filename:$line:0\n"; @@ -449,24 +470,25 @@ sub DB { eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i}; $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^h$/ && do { - print $OUT $help; + print_help($help); next CMD; }; $cmd =~ /^h\s+h$/ && do { - print $OUT $summary; + print_help($summary); next CMD; }; $cmd =~ /^h\s+(\S)$/ && do { my $asked = "\Q$1"; - if ($help =~ /^$asked/m) { - while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) { - print $OUT $1; + if ($help =~ /^(?:[IB]<)$asked/m) { + while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) { + print_help($1); } } else { - print $OUT "`$asked' is not a debugger command.\n"; + print_help("B<$asked> is not a debugger command.\n"); } next CMD; }; $cmd =~ /^t$/ && do { - $trace = !$trace; - print $OUT "Trace = ".($trace?"on":"off")."\n"; + ($trace & 1) ? ($trace &= ~1) : ($trace |= 1); + print $OUT "Trace = " . + (($trace & 1) ? "on" : "off" ) . "\n"; next CMD; }; $cmd =~ /^S(\s+(!)?(.+))?$/ && do { $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1; @@ -686,6 +708,14 @@ sub DB { last if $signal; } } + if ($trace & 2) { + print $OUT "Watch-expressions:\n"; + my $expr; + for $expr (@to_watch) { + print $OUT " $expr\n"; + last if $signal; + } + } next CMD; }; $cmd =~ /^b\b\s*load\b\s*(.*)/ && do { my $file = $1; $file =~ s/\s+$//; @@ -925,6 +955,18 @@ sub DB { $cmd =~ /^T$/ && do { print_trace($OUT, 1); # skip DB next CMD; }; + $cmd =~ /^W\s*$/ && do { + $trace &= ~2; + @to_watch = @old_watch = (); + next CMD; }; + $cmd =~ /^W\b\s*(.*)/s && do { + push @to_watch, $1; + $evalarg = $1; + my ($val) = &eval; + $val = (defined $val) ? "'$val'" : 'undef' ; + push @old_watch, $val; + $trace |= 2; + next CMD; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])/$:$1:; @@ -1062,7 +1104,7 @@ sub DB { $cmd =~ s/^\|+\s*//; redo PIPE; }; # XXX Local variants do not work! - $cmd =~ s/^t\s/\$DB::trace = 1;\n/; + $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'}; } # PIPE: @@ -1176,6 +1218,7 @@ sub eval { } elsif ($onetimeDump eq 'methods') { methods($res[0]); } + @res; } sub postponed_sub { @@ -1678,135 +1721,147 @@ sub list_versions { sub sethelp { $help = " -T Stack trace. -s [expr] Single step [in expr]. -n [expr] Next, steps over subroutine calls [in expr]. -<CR> Repeat last n or s command. -r Return from current subroutine. -c [line|sub] Continue; optionally inserts a one-time-only breakpoint +B<T> Stack trace. +B<s> [I<expr>] Single step [in I<expr>]. +B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. +<B<CR>> Repeat last B<n> or B<s> command. +B<r> Return from current subroutine. +B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint at the specified position. -l min+incr List incr+1 lines starting at min. -l min-max List lines min through max. -l line List single line. -l subname List first window of lines from subroutine. -l List next window of lines. -- List previous window of lines. -w [line] List window around line. -. Return to the executed line. -f filename Switch to viewing filename. Must be loaded. -/pattern/ Search forwards for pattern; final / is optional. -?pattern? Search backwards for pattern; final ? is optional. -L List all breakpoints and actions. -S [[!]pattern] List subroutine names [not] matching pattern. -t Toggle trace mode. -t expr Trace through execution of expr. -b [line] [condition] - Set breakpoint; line defaults to the current execution line; - condition breaks if it evaluates to true, defaults to '1'. -b subname [condition] +B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. +B<l> I<min>B<->I<max> List lines I<min> through I<max>. +B<l> I<line> List single I<line>. +B<l> I<subname> List first window of lines from subroutine. +B<l> List next window of lines. +B<-> List previous window of lines. +B<w> [I<line>] List window around I<line>. +B<.> Return to the executed line. +B<f> I<filename> Switch to viewing I<filename>. Must be loaded. +B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. +B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. +B<L> List all breakpoints and actions. +B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. +B<t> Toggle trace mode. +B<t> I<expr> Trace through execution of I<expr>. +B<b> [I<line>] [I<condition>] + Set breakpoint; I<line> defaults to the current execution line; + I<condition> breaks if it evaluates to true, defaults to '1'. +B<b> I<subname> [I<condition>] Set breakpoint at first line of subroutine. -b load filename Set breakpoint on `require'ing the given file. -b postpone subname [condition] +B<b> B<load> I<filename> Set breakpoint on `require'ing the given file. +B<b> B<postpone> I<subname> [I<condition>] Set breakpoint at first line of subroutine after it is compiled. -b compile subname +B<b> B<compile> I<subname> Stop after the subroutine is compiled. -d [line] Delete the breakpoint for line. -D Delete all breakpoints. -a [line] command - Set an action to be done before the line is executed. - Sequence is: check for breakpoint, print line if necessary, - do action, prompt user if breakpoint or step, evaluate line. -A Delete all actions. -V [pkg [vars]] List some (default all) variables in package (default current). - Use ~pattern and !pattern for positive and negative regexps. -X [vars] Same as \"V currentpackage [vars]\". -x expr Evals expression in array context, dumps the result. -m expr Evals expression in array context, prints methods callable +B<d> [I<line>] Delete the breakpoint for I<line>. +B<D> Delete all breakpoints. +B<a> [I<line>] I<command> + Set an action to be done before the I<line> is executed. + Sequence is: check for breakpoint/watchpoint, print line + if necessary, do action, prompt user if necessary, + execute expression. +B<A> Delete all actions. +B<W> I<expr> Add a global watch-expression. +B<W> Delete all watch-expressions. +B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). + Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. +B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". +B<x> I<expr> Evals expression in array context, dumps the result. +B<m> I<expr> Evals expression in array context, prints methods callable on the first element of the result. -m class Prints methods callable via the given class. -O [opt[=val]] [opt\"val\"] [opt?]... - Set or query values of options. val defaults to 1. opt can +B<m> I<class> Prints methods callable via the given class. +B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]... + Set or query values of options. I<val> defaults to 1. I<opt> can be abbreviated. Several options can be listed. - recallCommand, ShellBang: chars used to recall command or spawn shell; - pager: program for output of \"|cmd\"; - tkRunning: run Tk while prompting (with ReadLine); - signalLevel warnLevel dieLevel: level of verbosity; - inhibit_exit Allows stepping off the end of the script. - The following options affect what happens with V, X, and x commands: - arrayDepth, hashDepth: print only first N elements ('' for all); - compactDump, veryCompact: change style of array and hash dump; - globPrint: whether to print contents of globs; - DumpDBFiles: dump arrays holding debugged files; - DumpPackages: dump symbol tables of packages; - quote, HighBit, undefPrint: change style of string dump; - Option PrintRet affects printing of return value after r command, - frame affects printing messages on entry and exit from subroutines. - AutoTrace affects printing messages on every possible breaking point. - maxTraceLen gives maximal length of evals/args listed in stack trace. - ornaments affects screen appearance of the command line. + I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell; + I<pager>: program for output of \"|cmd\"; + I<tkRunning>: run Tk while prompting (with ReadLine); + I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity; + I<inhibit_exit> Allows stepping off the end of the script. + The following options affect what happens with B<V>, B<X>, and B<x> commands: + I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all); + I<compactDump>, I<veryCompact>: change style of array and hash dump; + I<globPrint>: whether to print contents of globs; + I<DumpDBFiles>: dump arrays holding debugged files; + I<DumpPackages>: dump symbol tables of packages; + I<quote>, I<HighBit>, I<undefPrint>: change style of string dump; + Option I<PrintRet> affects printing of return value after B<r> command, + I<frame> affects printing messages on entry and exit from subroutines. + I<AutoTrace> affects printing messages on every possible breaking point. + I<maxTraceLen> gives maximal length of evals/args listed in stack trace. + I<ornaments> affects screen appearance of the command line. During startup options are initialized from \$ENV{PERLDB_OPTS}. - You can put additional initialization options TTY, noTTY, - ReadLine, and NonStop there (or use `R' after you set them). -< command Define Perl command to run before each prompt. -<< command Add to the list of Perl commands to run before each prompt. -> command Define Perl command to run after each prompt. ->> command Add to the list of Perl commands to run after each prompt. -\{ commandline Define debugger command to run before each prompt. -\{{ commandline Add to the list of debugger commands to run before each prompt. -$prc number Redo a previous command (default previous command). -$prc -number Redo number'th-to-last command. -$prc pattern Redo last command that started with pattern. - See 'O recallCommand' too. -$psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" + You can put additional initialization options I<TTY>, I<noTTY>, + I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them). +B<<> I<expr> Define Perl command to run before each prompt. +B<<<> I<expr> Add to the list of Perl commands to run before each prompt. +B<>> I<expr> Define Perl command to run after each prompt. +B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. +B<{> I<db_command> Define debugger command to run before each prompt. +B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. +B<$prc> I<number> Redo a previous command (default previous command). +B<$prc> I<-number> Redo number'th-to-last command. +B<$prc> I<pattern> Redo last command that started with I<pattern>. + See 'B<O> I<recallCommand>' too. +B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" . ( $rc eq $sh ? "" : " -$psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " - See 'O shellBang' too. -H -number Display last number commands (default all). -p expr Same as \"print {DB::OUT} expr\" in current package. -|dbcmd Run debugger command, piping DB::OUT to current pager. -||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well. -\= [alias value] Define a command alias, or list current aliases. -command Execute as a perl statement in current package. -v Show versions of loaded modules. -R Pure-man-restart of debugger, some of debugger state +B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " + See 'B<O> I<shellBang>' too. +B<H> I<-number> Display last number commands (default all). +B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. +B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. +B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well. +B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. +I<command> Execute as a perl statement in current package. +B<v> Show versions of loaded modules. +B<R> Pure-man-restart of debugger, some of debugger state and command-line options may be lost. Currently the following setting are preserved: - history, breakpoints and actions, debugger Options - and the following command-line options: -w, -I, -e. -h [db_command] Get help [on a specific debugger command], enter |h to page. -h h Summary of debugger commands. -q or ^D Quit. Set \$DB::finished to 0 to debug global destruction. + history, breakpoints and actions, debugger B<O>ptions + and the following command-line options: I<-w>, I<-I>, I<-e>. +B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. +B<h h> Summary of debugger commands. +B<q> or B<^D> Quit. Set \$DB::finished to 0 to debug global destruction. "; $summary = <<"END_SUM"; -List/search source lines: Control script execution: - l [ln|sub] List source code T Stack trace - - or . List previous/current line s [expr] Single step [in expr] - w [line] List around line n [expr] Next, steps over subs - f filename View source in file <CR> Repeat last n or s - /pattern/ ?patt? Search forw/backw r Return from subroutine - v Show versions of modules c [ln|sub] Continue until position -Debugger controls: L List break pts & actions - O [...] Set debugger options t [expr] Toggle trace [trace expr] - <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint - >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub - $prc [N|pat] Redo a previous command d [line] Delete a breakpoint - H [-num] Display last num commands D Delete all breakpoints - = [a val] Define/list an alias a [ln] cmd Do cmd before line - h [db_cmd] Get help on command A Delete all actions - |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess - q or ^D Quit R Attempt a restart -Data Examination: expr Execute perl code, also see: s,n,t expr - x|m expr Evals expr in array context, dumps the result or lists methods. - p expr Print expression (uses script's current package). - S [[!]pat] List subroutine names [not] matching pattern - V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern. - X [Vars] Same as \"V current_package [Vars]\". +I<List/search source lines:> I<Control script execution:> + B<l> [I<ln>|I<sub>] List source code B<T> Stack trace + B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] + B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs + B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s> + B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine + B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position +I<Debugger controls:> B<L> List break/watch/actions + B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr] + B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint + B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub + B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints + B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line + B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression + B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch + B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess + B<q> or B<^D> Quit B<R> Attempt a restart +I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> + B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods. + B<p> I<expr> Print expression (uses script's current package). + B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern + B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. + B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". END_SUM # ')}}; # Fix balance of Emacs parsing } +sub print_help { + my $message = shift; + if (@Term::ReadLine::TermCap::rl_term_set) { + $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g; + $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g; + } + print $OUT $message; +} + sub diesignal { local $frame = 0; local $doret = -2; @@ -2,8 +2,6 @@ * */ -#define EMBEDMYMALLOC - #if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS) # define DEBUGGING_MSTATS #endif diff --git a/miniperlmain.c b/miniperlmain.c index 81e649344d..27ad541fb4 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -25,10 +25,6 @@ char **env; { int exitstatus; -#ifdef USE_THREADS - MUTEX_INIT(&malloc_mutex); -#endif - PERL_SYS_INIT(&argc,&argv); perl_init_i18nl10n(1); @@ -1359,6 +1359,14 @@ typedef Sighandler_t Sigsave_t; # define MALLOC_TERM #endif +#ifdef MYMALLOC +# define MALLOC_INIT MUTEX_INIT(&malloc_mutex) +# define MALLOC_TERM MUTEX_DESTROY(&malloc_mutex) +#else +# define MALLOC_INIT +# define MALLOC_TERM +#endif + /* * These need prototyping here because <proto.h> isn't * included until after runops is initialised. @@ -2022,6 +2030,17 @@ END_EXTERN_C #endif /* WIN32 */ +#if defined(HASATTRIBUTE) && defined(WIN32) +/* + * This provides a layer of functions and macros to ensure extensions will + * get to use the same RTL functions as the core. + * It has to go here or #define of printf messes up __attribute__ + * stuff in proto.h + */ +# include <win32iop.h> +#endif /* WIN32 */ + + #ifdef DOINIT EXT MGVTBL vtbl_sv = {magic_get, @@ -1889,10 +1889,6 @@ sv_setsv(SV *dstr, register SV *sstr) sv_upgrade(dstr, SVt_PVNV); break; - case SVt_PVLV: - sv_upgrade(dstr, SVt_PVLV); - break; - case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -3887,7 +3883,16 @@ newSVrv(SV *rv, char *classname) SvANY(sv) = 0; SvREFCNT(sv) = 0; SvFLAGS(sv) = 0; - sv_upgrade(rv, SVt_RV); + + sv_check_thinkfirst(rv); +#ifdef OVERLOAD + SvAMAGIC_off(rv); +#endif /* OVERLOAD */ + + if (SvTYPE(rv) < SVt_RV) + sv_upgrade(rv, SVt_RV); + + (void)SvOK_off(rv); SvRV(rv) = SvREFCNT_inc(sv); SvROK_on(rv); @@ -4094,14 +4099,14 @@ sv_catpvf(sv, pat, va_alist) } void -sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, char *used_locale) +sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) { sv_setpvn(sv, "", 0); sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale); } void -sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, char *used_locale) +sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) { dTHR; char *p; @@ -83,7 +83,7 @@ while ($test = shift) { $ok = 1; } else { $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; - if (/^ok (.*)/ && $1 == $next) { + if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) { $next = $next + 1; } else { $ok = 0; diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t index 6ddbf25e2d..cadbfd5658 100755 --- a/t/lib/anydbm.t +++ b/t/lib/anydbm.t @@ -23,7 +23,7 @@ if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { - print "ok 2\n"; + print "ok 2 # Skipped: different file permission semantics\n"; } else { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index bebb63df8d..c85c22f92c 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -601,6 +601,8 @@ EOM main::ok(101, $@ eq "") ; main::ok(102, $ret eq "[[11]]") ; + undef $X; + untie(%h); unlink "SubDB.pm", "dbbtree.tmp" ; } diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t index 9df918cce5..10c8d14fb8 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -407,6 +407,8 @@ EOM main::ok(61, $@ eq "") ; main::ok(62, $ret eq "[[11]]") ; + undef $X; + untie(%h); unlink "SubDB.pm", "dbhash.tmp" ; } diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t index 9950741ffe..b332c5eb6c 100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@ -378,6 +378,8 @@ EOM main::ok(65, $@ eq "") ; main::ok(66, $ret eq "[[11]]") ; + undef $X; + untie(@h); unlink "SubDB.pm", "recno.tmp" ; } diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t index 37660c26c6..ebc9f56bc0 100755 --- a/t/lib/gdbm.t +++ b/t/lib/gdbm.t @@ -25,7 +25,7 @@ if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { - print "ok 2\n"; + print "ok 2 # Skipped: different file permission semantics\n"; } else { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, @@ -201,6 +201,8 @@ EOM main::ok(19, $@ eq "") ; main::ok(20, $ret eq "[[5]]") ; + undef $X; + untie(%h); unlink "SubDB.pm", <dbhash.tmp*> ; } diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t index 27f3ec5066..db9846a8cb 100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@ -28,7 +28,7 @@ if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { - print "ok 2\n"; + print "ok 2 # Skipped: different file permission semantics\n"; } else { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, @@ -200,6 +200,8 @@ EOM main::ok(17, $@ eq "") ; main::ok(18, $ret eq "[[5]]") ; + undef $X; + untie(%h); unlink "SubDB.pm", <dbhash.tmp*> ; } diff --git a/t/lib/odbm.t b/t/lib/odbm.t index 6cfefdaee5..65c9870a02 100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@ -28,7 +28,7 @@ if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { - print "ok 2\n"; + print "ok 2 # Skipped: different file permission semantics\n"; } else { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, @@ -200,6 +200,8 @@ EOM main::ok(17, $@ eq "") ; main::ok(18, $ret eq "[[5]]") ; + undef $X; + untie(%h); unlink "SubDB.pm", <dbhash.tmp*> ; } diff --git a/t/lib/safe2.t b/t/lib/safe2.t index a9d24051ea..c9e38808b3 100755 --- a/t/lib/safe2.t +++ b/t/lib/safe2.t @@ -124,6 +124,7 @@ my $t = 30; $cpt->rdo('/non/existant/file.name'); print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || $! =~ /A file or directory in the path name does not exist/ || + $! =~ /Invalid argument/ || $! =~ /Device not configured/ ? "ok $t\n" : "not ok $t # $!\n"); $t++; print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t index c8ae09285b..ad25011d76 100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@ -28,7 +28,7 @@ if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { - print "ok 2\n"; + print "ok 2 # Skipped: different file permission semantics\n"; } else { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, @@ -200,6 +200,8 @@ EOM main::ok(17, $@ eq "") ; main::ok(18, $ret eq "[[5]]") ; + undef $X; + untie(%h); unlink "SubDB.pm", <dbhash.tmp*> ; } diff --git a/t/op/pat.t b/t/op/pat.t index 03af1227ca..a9e6869a4a 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -2,7 +2,7 @@ # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $ -print "1..97\n"; +print "1..100\n"; $x = "abc\ndef\n"; @@ -328,3 +328,23 @@ print "not " if $blah != 45; print "ok $test\n"; $test++; +$x = 'banana'; +$x =~ /.a/g; +print "not " unless pos($x) == 2; +print "ok $test\n"; +$test++; + +$x =~ /.z/gc; +print "not " unless pos($x) == 2; +print "ok $test\n"; +$test++; + +sub f { + my $p = $_[0]; + return $p; +} + +$x =~ /.a/g; +print "not " unless f(pos($x)) == 4; +print "ok $test\n"; +$test++; diff --git a/t/op/taint.t b/t/op/taint.t index 8437c43c45..22bb574a09 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -120,10 +120,7 @@ print "1..140\n"; } my $tmp; - if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32) { - print "# all directories are writeable\n"; - } - else { + unless ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32) { $tmp = (grep { defined and -d and (stat _)[2] & 2 } qw(/tmp /var/tmp /usr/tmp /sys$scratch), @ENV{qw(TMP TEMP)})[0] @@ -136,7 +133,7 @@ print "1..140\n"; test 7, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; } else { - for (6..7) { print "ok $_\n" } + for (6..7) { print "ok $_ # Skipped: all directories are writeable\n" } } if ($Is_VMS) { @@ -149,14 +146,12 @@ print "1..140\n"; test 11, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; } else { - print "# can't find world-writeable directory to test DCL\$PATH\n"; - for (10..11) { print "ok $_\n" } + for (10..11) { print "ok $_ # Skipped: can't find world-writeable directory to test DCL\$PATH\n" } } $ENV{'DCL$PATH'} = ''; } else { - print "# This is not VMS\n"; - for (8..11) { print "ok $_\n"; } + for (8..11) { print "ok $_ # Skipped: This is not VMS\n"; } } } @@ -292,8 +287,7 @@ else { test 50, $@ =~ /^Insecure dependency/, $@; } else { - print "# chown() is not available\n"; - for (49..50) { print "ok $_\n" } + for (49..50) { print "ok $_ # Skipped: chown() is not available\n" } } if ($Config{d_link}) { @@ -301,8 +295,7 @@ else { test 52, $@ =~ /^Insecure dependency/, $@; } else { - print "# link() is not available\n"; - for (51..52) { print "ok $_\n" } + for (51..52) { print "ok $_ # Skipped: link() is not available\n" } } if ($Config{d_symlink}) { @@ -310,8 +303,7 @@ else { test 54, $@ =~ /^Insecure dependency/, $@; } else { - print "# symlink() is not available\n"; - for (53..54) { print "ok $_\n" } + for (53..54) { print "ok $_ # Skipped: symlink() is not available\n" } } } @@ -331,8 +323,7 @@ else { test 62, $@ =~ /^Insecure dependency/, $@; } else { - print "# chroot() is not available\n"; - for (61..62) { print "ok $_\n" } + for (61..62) { print "ok $_ # Skipped: chroot() is not available\n" } } } @@ -360,8 +351,7 @@ else { my $foo = $TAINT; if ($^O eq 'amigaos') { - print "# open(\"|\") is not available\n"; - for (70..73) { print "ok $_\n" } + for (70..73) { print "ok $_ # Skipped: open('|') is not available\n" } } else { test 70, eval { open FOO, "| $foo" } eq '', 'popen to'; @@ -388,7 +378,7 @@ else { test 81, $@ eq '', $@; } else { - for (80..81) { print "ok $_\n"; } + for (80..81) { print "ok $_ # Skipped: this is not VMS\n"; } } } @@ -402,8 +392,7 @@ else { test 85, $@ =~ /^Insecure dependency/, $@; } else { - print "# setpgrp() is not available\n"; - for (84..85) { print "ok $_\n" } + for (84..85) { print "ok $_ # Skipped: setpgrp() is not available\n" } } if ($Config{d_setprior}) { @@ -411,8 +400,7 @@ else { test 87, $@ =~ /^Insecure dependency/, $@; } else { - print "# setpriority() is not available\n"; - for (86..87) { print "ok $_\n" } + for (86..87) { print "ok $_ # Skipped: setpriority() is not available\n" } } } @@ -423,8 +411,7 @@ else { test 89, $@ =~ /^Insecure dependency/, $@; } else { - print "# syscall() is not available\n"; - for (88..89) { print "ok $_\n" } + for (88..89) { print "ok $_ # Skipped: syscall() is not available\n" } } { @@ -443,8 +430,7 @@ else { test 94, $@ =~ /^Insecure dependency/, $@; } else { - print "# fcntl() is not available\n"; - for (93..94) { print "ok $_\n" } + for (93..94) { print "ok $_ # Skipped: fcntl() is not available\n" } } close FOO; @@ -534,8 +520,7 @@ else { and not tainted $getpwent[8]); endpwent(); } else { - print "# getpwent() is not available\n"; - print "ok 136\n"; + print "ok 136 # Skipped: getpwent() is not available\n"; } if ($Config{d_readdir}) { # pretty hard to imagine not @@ -545,8 +530,7 @@ else { test 137, tainted $readdir; closedir(OP); } else { - print "# readdir() is not available\n"; - print "ok 137\n"; + print "ok 137 # Skipped: readdir() is not available\n"; } if ($Config{d_readlink} && $Config{d_symlink}) { @@ -557,8 +541,7 @@ else { test 138, tainted $readlink; unlink($symlink); } else { - print "# readlink() or symlink() is not available\n"; - print "ok 138\n"; + print "ok 138 # Skipped: readlink() or symlink() is not available\n"; } } diff --git a/win32/perllib.c b/win32/perllib.c index c24941f111..848360698b 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -15,10 +15,6 @@ RunPerl(int argc, char **argv, char **env, void *iosubsystem) int exitstatus; PerlInterpreter *my_perl; -#ifdef USE_THREADS - MUTEX_INIT(&malloc_mutex); -#endif - PERL_SYS_INIT(&argc,&argv); perl_init_i18nl10n(1); |