--- lib/perl5db.pl.original 2004-10-13 07:50:47.000000000 +0200 +++ lib/perl5db.pl 2004-10-13 07:52:26.000000000 +0200 @@ -493,7 +493,7 @@ use IO::Handle; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.27; +$VERSION = 1.28; $header = "perl5db.pl version $VERSION"; @@ -680,7 +680,7 @@ # (for subroutines defined outside of the package DB). In fact the same is # true if $deep is not defined. # -# $Log: perl5db.pl.orig,v $ +# $Log: perl5db.pl.new,v $ # Revision 1.1 2004/10/12 15:43:41 perltut # threaded debugger # @@ -922,6 +922,8 @@ # + removed windowid restriction for forking into an xterm. # + more whitespace again. # + wrapped restart and enabled rerun [-n] (go back n steps) command. +# Changes: 1.28: Oct 12, 2004 Richard Foley +# + Added threads support (inc. e and E commands) #################################################################### =head1 DEBUGGER INITIALIZATION @@ -959,12 +961,55 @@ local ($^W) = 0; # Switch run-time warnings off during init. +=head2 THREADS SUPPORT + +If we are running under a threaded Perl, we use threads::shared by default. + +Each new thread will be announced and the debugger prompt will always inform +you of each new thread created. It will also indicate the thread id in which +we are currently running within the prompt like this: + + [tid] DB<$i> + +Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger +command prompt. The prompt will show: C<[0]> when running under threads, but +not actually in a thread. C<[tid]> is consistent with C usage. + +While running under threads, when you set or delete a breakpoint (etc.), this +will apply to all threads, not just the currently running one. When you are +in a currently executing thread, you will stay there until it completes. With +the current implementation it is not currently possible to hop from one thread +to another. + +The C and C commands are currently fairly minimal - see C and C. + +Note that threading support was built into the debugger as of Perl version +C<5.8.6> and debugger version C<1.2.8>. + +=cut + +BEGIN { + # ensure we can share our non-threaded variables or no-op + use Config; + if ($Config{useithreads}) { + use threads; + use threads::shared; + import threads::shared qw(share); + $DBGR; + share($DBGR); + lock($DBGR); + } else { + *lock = sub(*) {}; + *share = sub(*) {}; + } +} + # This would probably be better done with "use vars", but that wasn't around # when this code was originally written. (Neither was "use strict".) And on # the principle of not fiddling with something that was working, this was # left alone. warn( # Do not ;-) - # These variables control the execution of 'dumpvar.pl'. + # These variables control the execution of 'dumpvar.pl'. $dumpvar::hashDepth, $dumpvar::arrayDepth, $dumpvar::dumpDBFiles, @@ -990,6 +1035,10 @@ ) if 0; +foreach my $k (keys (%INC)) { + &share(\$main::{'_<'.$filename}); +}; + # Command-line + PERLLIB: # Save the contents of @INC before they are modified elsewhere. @ini_INC = @INC; @@ -1157,6 +1206,17 @@ $CreateTTY = 3 unless defined $CreateTTY; $CommandSet = '580' unless defined $CommandSet; +share($rl); +share($warnLevel); +share($dieLevel); +share($signalLevel); +share($pre); +share($post); +share($pretype); +share($rl); +share($CreateTTY); +share($CommandSet); + =pod The default C, C, and C handlers are set up. @@ -1432,6 +1492,11 @@ %break_on_load = get_list("PERLDB_ON_LOAD"); %postponed = get_list("PERLDB_POSTPONE"); + share(@hist); + share(@truehist); + share(%break_on_load); + share(%postponed); + # restore breakpoints/actions my @had_breakpoints = get_list("PERLDB_VISITED"); for ( 0 .. $#had_breakpoints ) { @@ -1468,6 +1533,7 @@ if ($notty) { $runnonstop = 1; + share($runnonstop); } =pod @@ -1681,6 +1747,8 @@ # and a I/O description to keep track of. $LINEINFO = $OUT unless defined $LINEINFO; $lineinfo = $console unless defined $lineinfo; + # share($LINEINFO); # <- unable to share globs + share($lineinfo); # =pod @@ -1749,6 +1817,12 @@ sub DB { + # lock the debugger and get the thread id for the prompt + lock($DBGR); + my $tid = eval { + "[".threads->self->tid."]" || 'notid'; + }; + # Check for whether we should be running continuously or not. # _After_ the perl program is compiled, $single is set to 1: if ( $single and not $second_time++ ) { @@ -2117,7 +2191,7 @@ # ... and we got a line of command input ... defined( $cmd = &readline( - "$pidprompt DB" + "$pidprompt $tid DB" . ( '<' x $level ) . ( $#hist + 1 ) . ( '>' x $level ) . " " @@ -2126,6 +2200,7 @@ ) { + share($cmd); # ... try to execute the input as debugger commands. # Don't stop running. @@ -2156,6 +2231,8 @@ chomp($cmd); # get rid of the annoying extra newline push( @hist, $cmd ) if length($cmd) > 1; push( @truehist, $cmd ); + share(@hist); + share(@truehist); # This is a restart point for commands that didn't arrive # via direct user input. It allows us to 'redo PIPE' to @@ -2464,7 +2541,7 @@ # All of these commands were remapped in perl 5.8.0; # we send them off to the secondary dispatcher (see below). - $cmd =~ /^([aAbBhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do { + $cmd =~ /^([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do { &cmd_wrapper( $1, $2, $line ); next CMD; }; @@ -3485,10 +3562,16 @@ sub sub { + # lock ourselves + lock($DBGR); + # Whether or not the autoloader was running, a scalar to put the # sub's return value in (if needed), and an array to put the sub's # return value in (if needed). my ( $al, $ret, @ret ) = ""; + if ($sub =~ /^threads::new$/) { + print "creating new thread\n"; + } # If the last ten characters are C'::AUTOLOAD', note we've traced # into AUTOLOAD for $sub. @@ -4491,6 +4574,48 @@ $signal = 1; } +=head3 C - threads + +Display the current thread id: + + e + +=cut + +sub cmd_e { + my $cmd = shift; + my $line = shift; + eval { require threads }; + if ($@) { + &warn($@ =~ /locate/ ? "threads pragma not found - please install\n" : $@); + } else { + my $tid = threads->self->tid; + print "thread id: $tid\n"; + } +} ## end sub cmd_e + +=head3 C - list of thread ids + +Display the list of available thread ids: + + E + +=cut + +sub cmd_E { + my $cmd = shift; + my $line = shift; + eval { require threads }; + if ($@) { + &warn($@ =~ /locate/ ? "threads pragma not found - please install\n" : $@); + } else { + my $tid = threads->self->tid; + print "thread ids: ".join(', ', + map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list + )."\n"; + } +} ## end sub cmd_E + =head3 C - help command (command) Does the work of either @@ -6944,6 +7069,8 @@ B I Prints methods callable via the given class. B Show versions of loaded modules. B I Prints nested parents of given class. +B Display current thread id. +B Display all thread ids the current one will be identified: . B [I [I]] List lexicals in higher scope . Vars same as B. B

Something to do with assertions... @@ -7061,6 +7188,7 @@ B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. B [I] Same as \"B I [I]\". B I inheritance tree. B [I [I]] List lexicals in higher scope . Vars same as B. + B Display thread id B Display all thread ids. For more help, type B I, or run B<$doccmd perldebug> for all docs. END_SUM