structure and services provided by C<perl5db.pl>, and to describe how you
can use them.
+See L<perldebug> for an overview of how to use the debugger.
+
=head1 GENERAL NOTES
The debugger can look pretty forbidding to many Perl programmers. There are
use vars qw($VERSION $header);
# bump to X.XX in blead, only use X.XX_XX in maint
-$VERSION = '1.58';
+$VERSION = '1.59';
$header = "perl5db.pl version $VERSION";
share($pre);
share($post);
share($pretype);
-share($rl);
share($CreateTTY);
share($CommandSet);
# A single-character debugger command can be immediately followed by its
# argument if they aren't both alphanumeric; otherwise require space
# between commands and arguments:
- my ($verb, $args) = $cmd =~ m{\A(.\b|\S*)\s*(.*)}s;
+ my ($verb, $args) = $cmd =~ m{\A([^\.-]\b|\S*)\s*(.*)}s;
$obj->cmd_verb($verb);
$obj->cmd_args($args);
return;
}
-# 't' is type.
-# 'm' is method.
-# 'v' is the value (i.e: method name or subroutine ref).
-# 's' is subroutine.
-my %cmd_lookup;
+=head3 C<_DB__handle_i_command> - inheritance display
-BEGIN
-{
- %cmd_lookup =
-(
- '-' => { t => 'm', v => '_handle_dash_command', },
- '.' => { t => 's', v => \&_DB__handle_dot_command, },
- '=' => { t => 'm', v => '_handle_equal_sign_command', },
- 'H' => { t => 'm', v => '_handle_H_command', },
- 'S' => { t => 'm', v => '_handle_S_command', },
- 'T' => { t => 'm', v => '_handle_T_command', },
- 'W' => { t => 'm', v => '_handle_W_command', },
- 'c' => { t => 's', v => \&_DB__handle_c_command, },
- 'f' => { t => 's', v => \&_DB__handle_f_command, },
- 'm' => { t => 's', v => \&_DB__handle_m_command, },
- 'n' => { t => 'm', v => '_handle_n_command', },
- 'p' => { t => 'm', v => '_handle_p_command', },
- 'q' => { t => 'm', v => '_handle_q_command', },
- 'r' => { t => 'm', v => '_handle_r_command', },
- 's' => { t => 'm', v => '_handle_s_command', },
- 'save' => { t => 'm', v => '_handle_save_command', },
- 'source' => { t => 'm', v => '_handle_source_command', },
- 't' => { t => 'm', v => '_handle_t_command', },
- 'w' => { t => 'm', v => '_handle_w_command', },
- 'x' => { t => 'm', v => '_handle_x_command', },
- 'y' => { t => 's', v => \&_DB__handle_y_command, },
- (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, }
- ('X', 'V')),
- (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, }
- qw(enable disable)),
- (map { $_ =>
- { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
- } qw(R rerun)),
- (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
- qw(a A b B e E h i l L M o O v w W)),
-);
-};
+Display the (nested) parentage of the module or object given.
-sub DB {
+=cut
- # lock the debugger and get the thread id for the prompt
- lock($DBGR);
- my $tid;
- my $position;
- my ($prefix, $after, $infix);
- my $pat;
- my $explicit_stop;
- my $piped;
- my $selected;
+sub _DB__handle_i_command {
+ my $self = shift;
- if ($ENV{PERL5DB_THREADED}) {
- $tid = eval { "[".threads->tid."]" };
+ my $line = $self->cmd_args;
+ require mro;
+ foreach my $isa ( split( /\s+/, $line ) ) {
+ $evalarg = "$isa";
+ # The &-call is here to ascertain the mutability of @_.
+ ($isa) = &DB::eval;
+ no strict 'refs';
+ print join(
+ ', ',
+ map {
+ "$_"
+ . (
+ defined( ${"$_\::VERSION"} )
+ ? ' ' . ${"$_\::VERSION"}
+ : undef )
+ } @{mro::get_linear_isa(ref($isa) || $isa)}
+ );
+ print "\n";
}
+ next CMD;
+}
- my $cmd_verb;
- my $cmd_args;
+=head3 C<cmd_l> - list lines (command)
- my $obj = DB::Obj->new(
- {
- position => \$position,
- prefix => \$prefix,
- after => \$after,
- explicit_stop => \$explicit_stop,
- infix => \$infix,
- cmd_args => \$cmd_args,
- cmd_verb => \$cmd_verb,
- pat => \$pat,
- piped => \$piped,
- selected => \$selected,
- },
- );
+Most of the command is taken up with transforming all the different line
+specification syntaxes into 'start-stop'. After that is done, the command
+runs a loop over C<@dbline> for the specified range of lines. It handles
+the printing of each line and any markers (C<==E<gt>> for current line,
+C<b> for break on this line, C<a> for action on this line, C<:> for this
+line breakable).
- $obj->_DB_on_init__initialize_globals(@_);
+We save the last line listed in the C<$start> global for further listing
+later.
- # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
- # The code being debugged may have altered them.
- DB::save();
+=cut
- # Since DB::DB gets called after every line, we can use caller() to
- # figure out where we last were executing. Sneaky, eh? This works because
- # caller is returning all the extra information when called from the
- # debugger.
- local ( $package, $filename, $line ) = caller;
- $filename_ini = $filename;
+sub _min {
+ my $min = shift;
+ foreach my $v (@_) {
+ if ($min > $v) {
+ $min = $v;
+ }
+ }
+ return $min;
+}
- # set up the context for DB::eval, so it can properly execute
- # code on behalf of the user. We add the package in so that the
- # code is eval'ed in the proper package (not in the debugger!).
- local $usercontext = _calc_usercontext($package);
+sub _max {
+ my $max = shift;
+ foreach my $v (@_) {
+ if ($max < $v) {
+ $max = $v;
+ }
+ }
+ return $max;
+}
- # Create an alias to the active file magical array to simplify
- # the code here.
- local (*dbline) = $main::{ '_<' . $filename };
+sub _minify_to_max {
+ my $ref = shift;
- # Last line in the program.
- $max = $#dbline;
+ $$ref = _min($$ref, $max);
- # The &-call is here to ascertain the mutability of @_.
- &_DB__determine_if_we_should_break;
+ return;
+}
- # Preserve the current stop-or-not, and see if any of the W
- # (watch expressions) has changed.
- my $was_signal = $signal;
+sub _cmd_l_handle_var_name {
+ my $var_name = shift;
- # If we have any watch expressions ...
- _DB__handle_watch_expressions($obj);
+ $evalarg = $var_name;
-=head2 C<watchfunction()>
+ my ($s) = DB::eval();
-C<watchfunction()> is a function that can be defined by the user; it is a
-function which will be run on each entry to C<DB::DB>; it gets the
-current package, filename, and line as its parameters.
+ # Ooops. Bad scalar.
+ if ($@) {
+ print {$OUT} "Error: $@\n";
+ next CMD;
+ }
-The watchfunction can do anything it likes; it is executing in the
-debugger's context, so it has access to all of the debugger's internal
-data structures and functions.
+ # Good scalar. If it's a reference, find what it points to.
+ $s = CvGV_name($s);
+ print {$OUT} "Interpreted as: $1 $s\n";
+ $line = "$1 $s";
-C<watchfunction()> can control the debugger's actions. Any of the following
-will cause the debugger to return control to the user's program after
-C<watchfunction()> executes:
+ # Call self recursively to really do the command.
+ return _cmd_l_main( $s );
+}
-=over 4
+sub _cmd_l_handle_subname {
-=item *
+ my $s = $subname;
-Returning a false value from the C<watchfunction()> itself.
+ # De-Perl4.
+ $subname =~ s/\'/::/;
-=item *
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
-Altering C<$single> to a false value.
+ # Put it in CORE::GLOBAL if t doesn't start with :: and
+ # it doesn't live in this package and it lives in CORE::GLOBAL.
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname
+ and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
-=item *
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
-Altering C<$signal> to a false value.
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
-=item *
+ # Pull off start-stop.
+ my $subrange = pop @pieces;
-Turning off the C<4> bit in C<$trace> (this also disables the
-check for C<watchfunction()>. This can be done with
+ # If the name contained colons, the split broke it up.
+ # Put it back together.
+ $file = join( ':', @pieces );
- $trace &= ~4;
+ # If we're not in that file, switch over to it.
+ if ( $file ne $filename ) {
+ if (! $slave_editor) {
+ print {$OUT} "Switching to file '$file'.\n";
+ }
-=back
+ # Switch debugger's magic structures.
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ } ## end if ($file ne $filename)
-=cut
+ # Subrange is 'start-stop'. If this is less than a window full,
+ # swap it to 'start+', which will list a window from the start point.
+ if ($subrange) {
+ if ( eval($subrange) < -$window ) {
+ $subrange =~ s/-.*/+/;
+ }
- # If there's a user-defined DB::watchfunction, call it with the
- # current package, filename, and line. The function executes in
- # the DB:: package.
- if ( $trace & 4 ) { # User-installed watch
- return
- if watchfunction( $package, $filename, $line )
- and not $single
- and not $was_signal
- and not( $trace & ~4 );
- } ## end if ($trace & 4)
+ # Call self recursively to list the range.
+ return _cmd_l_main( $subrange );
+ } ## end if ($subrange)
- # Pick up any alteration to $signal in the watchfunction, and
- # turn off the signal now.
- $was_signal = $signal;
- $signal = 0;
+ # Couldn't find it.
+ else {
+ print {$OUT} "Subroutine $subname not found.\n";
+ return;
+ }
+}
-=head2 GETTING READY TO EXECUTE COMMANDS
+sub _cmd_l_empty {
+ # Compute new range to list.
+ $incr = $window - 1;
-The debugger decides to take control if single-step mode is on, the
-C<t> command was entered, or the user generated a signal. If the program
+ # Recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
+
+sub _cmd_l_plus {
+ my ($new_start, $new_incr) = @_;
+
+ # Don't reset start for 'l +nnn'.
+ $start = $new_start if $new_start;
+
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $new_incr || ($window - 1);
+
+ # Create a line range we'll understand, and recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
+
+sub _cmd_l_calc_initial_end_and_i {
+ my ($spec, $start_match, $end_match) = @_;
+
+ # Determine end point; use end of file if not specified.
+ my $end = ( !defined $start_match ) ? $max :
+ ( $end_match ? $end_match : $start_match );
+
+ # Go on to the end, and then stop.
+ _minify_to_max(\$end);
+
+ # Determine start line.
+ my $i = $start_match;
+
+ if ($i eq '.') {
+ $i = $spec;
+ }
+
+ $i = _max($i, 1);
+
+ $incr = $end - $i;
+
+ return ($end, $i);
+}
+
+sub _cmd_l_range {
+ my ($spec, $current_line, $start_match, $end_match) = @_;
+
+ my ($end, $i) =
+ _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
+
+ # If we're running under a slave editor, force it to show the lines.
+ if ($slave_editor) {
+ print {$OUT} "\032\032$filename:$i:0\n";
+ $i = $end;
+ }
+ # We're doing it ourselves. We want to show the line and special
+ # markers for:
+ # - the current line in execution
+ # - whether a line is breakable or not
+ # - whether a line has a break or not
+ # - whether a line has an action or not
+ else {
+ I_TO_END:
+ for ( ; $i <= $end ; $i++ ) {
+
+ # Check for breakpoints and actions.
+ my ( $stop, $action );
+ if ($dbline{$i}) {
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ }
+
+ # ==> if this is the current line in execution,
+ # : if it's breakable.
+ my $arrow =
+ ( $i == $current_line and $filename eq $filename_ini )
+ ? '==>'
+ : ( $dbline[$i] + 0 ? ':' : ' ' );
+
+ # Add break and action indicators.
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
+
+ # Print the line.
+ print {$OUT} "$i$arrow\t", $dbline[$i];
+
+ # Move on to the next line. Drop out on an interrupt.
+ if ($signal) {
+ $i++;
+ last I_TO_END;
+ }
+ } ## end for (; $i <= $end ; $i++)
+
+ # Line the prompt up; print a newline if the last line listed
+ # didn't have a newline.
+ if ($dbline[ $i - 1 ] !~ /\n\z/) {
+ print {$OUT} "\n";
+ }
+ } ## end else [ if ($slave_editor)
+
+ # Save the point we last listed to in case another relative 'l'
+ # command is desired. Don't let it run off the end.
+ $start = $i;
+ _minify_to_max(\$start);
+
+ return;
+}
+
+sub _cmd_l_main {
+ my $spec = shift;
+
+ # If this is '-something', delete any spaces after the dash.
+ $spec =~ s/\A-\s*\z/-/;
+
+ # If the line is '$something', assume this is a scalar containing a
+ # line number.
+ # Set up for DB::eval() - evaluate in *user* context.
+ if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
+ return _cmd_l_handle_var_name($var_name);
+ }
+ # l name. Try to find a sub by that name.
+ elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
+ return _cmd_l_handle_subname();
+ }
+ # Bare 'l' command.
+ elsif ( $spec !~ /\S/ ) {
+ return _cmd_l_empty();
+ }
+ # l [start]+number_of_lines
+ elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
+ return _cmd_l_plus($new_start, $new_incr);
+ }
+ # l start-stop or l start,stop
+ elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
+ return _cmd_l_range($spec, $line, $s, $e);
+ }
+
+ return;
+} ## end sub cmd_l
+
+sub _DB__handle_l_command {
+ my $self = shift;
+
+ _cmd_l_main($self->cmd_args);
+ next CMD;
+}
+
+
+# 't' is type.
+# 'm' is method.
+# 'v' is the value (i.e: method name or subroutine ref).
+# 's' is subroutine.
+my %cmd_lookup;
+
+BEGIN
+{
+ %cmd_lookup =
+(
+ '-' => { t => 'm', v => '_handle_dash_command', },
+ '.' => { t => 's', v => \&_DB__handle_dot_command, },
+ '=' => { t => 'm', v => '_handle_equal_sign_command', },
+ 'H' => { t => 'm', v => '_handle_H_command', },
+ 'S' => { t => 'm', v => '_handle_S_command', },
+ 'T' => { t => 'm', v => '_handle_T_command', },
+ 'W' => { t => 'm', v => '_handle_W_command', },
+ 'c' => { t => 's', v => \&_DB__handle_c_command, },
+ 'f' => { t => 's', v => \&_DB__handle_f_command, },
+ 'i' => { t => 's', v => \&_DB__handle_i_command, },
+ 'l' => { t => 's', v => \&_DB__handle_l_command, },
+ 'm' => { t => 's', v => \&_DB__handle_m_command, },
+ 'n' => { t => 'm', v => '_handle_n_command', },
+ 'p' => { t => 'm', v => '_handle_p_command', },
+ 'q' => { t => 'm', v => '_handle_q_command', },
+ 'r' => { t => 'm', v => '_handle_r_command', },
+ 's' => { t => 'm', v => '_handle_s_command', },
+ 'save' => { t => 'm', v => '_handle_save_command', },
+ 'source' => { t => 'm', v => '_handle_source_command', },
+ 't' => { t => 'm', v => '_handle_t_command', },
+ 'w' => { t => 'm', v => '_handle_w_command', },
+ 'x' => { t => 'm', v => '_handle_x_command', },
+ 'y' => { t => 's', v => \&_DB__handle_y_command, },
+ (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, }
+ ('X', 'V')),
+ (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, }
+ qw(enable disable)),
+ (map { $_ =>
+ { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
+ } qw(R rerun)),
+ (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
+ qw(a A b B e E h L M o O v w W)),
+);
+};
+
+sub DB {
+
+ # lock the debugger and get the thread id for the prompt
+ lock($DBGR);
+ my $tid;
+ my $position;
+ my ($prefix, $after, $infix);
+ my $pat;
+ my $explicit_stop;
+ my $piped;
+ my $selected;
+
+ if ($ENV{PERL5DB_THREADED}) {
+ $tid = eval { "[".threads->tid."]" };
+ }
+
+ my $cmd_verb;
+ my $cmd_args;
+
+ my $obj = DB::Obj->new(
+ {
+ position => \$position,
+ prefix => \$prefix,
+ after => \$after,
+ explicit_stop => \$explicit_stop,
+ infix => \$infix,
+ cmd_args => \$cmd_args,
+ cmd_verb => \$cmd_verb,
+ pat => \$pat,
+ piped => \$piped,
+ selected => \$selected,
+ },
+ );
+
+ $obj->_DB_on_init__initialize_globals(@_);
+
+ # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
+ # The code being debugged may have altered them.
+ DB::save();
+
+ # Since DB::DB gets called after every line, we can use caller() to
+ # figure out where we last were executing. Sneaky, eh? This works because
+ # caller is returning all the extra information when called from the
+ # debugger.
+ local ( $package, $filename, $line ) = caller;
+ $filename_ini = $filename;
+
+ # set up the context for DB::eval, so it can properly execute
+ # code on behalf of the user. We add the package in so that the
+ # code is eval'ed in the proper package (not in the debugger!).
+ local $usercontext = _calc_usercontext($package);
+
+ # Create an alias to the active file magical array to simplify
+ # the code here.
+ local (*dbline) = $main::{ '_<' . $filename };
+
+ # Last line in the program.
+ $max = $#dbline;
+
+ # The &-call is here to ascertain the mutability of @_.
+ &_DB__determine_if_we_should_break;
+
+ # Preserve the current stop-or-not, and see if any of the W
+ # (watch expressions) has changed.
+ my $was_signal = $signal;
+
+ # If we have any watch expressions ...
+ _DB__handle_watch_expressions($obj);
+
+=head2 C<watchfunction()>
+
+C<watchfunction()> is a function that can be defined by the user; it is a
+function which will be run on each entry to C<DB::DB>; it gets the
+current package, filename, and line as its parameters.
+
+The watchfunction can do anything it likes; it is executing in the
+debugger's context, so it has access to all of the debugger's internal
+data structures and functions.
+
+C<watchfunction()> can control the debugger's actions. Any of the following
+will cause the debugger to return control to the user's program after
+C<watchfunction()> executes:
+
+=over 4
+
+=item *
+
+Returning a false value from the C<watchfunction()> itself.
+
+=item *
+
+Altering C<$single> to a false value.
+
+=item *
+
+Altering C<$signal> to a false value.
+
+=item *
+
+Turning off the C<4> bit in C<$trace> (this also disables the
+check for C<watchfunction()>. This can be done with
+
+ $trace &= ~4;
+
+=back
+
+=cut
+
+ # If there's a user-defined DB::watchfunction, call it with the
+ # current package, filename, and line. The function executes in
+ # the DB:: package.
+ if ( $trace & 4 ) { # User-installed watch
+ return
+ if watchfunction( $package, $filename, $line )
+ and not $single
+ and not $was_signal
+ and not( $trace & ~4 );
+ } ## end if ($trace & 4)
+
+ # Pick up any alteration to $signal in the watchfunction, and
+ # turn off the signal now.
+ $was_signal = $signal;
+ $signal = 0;
+
+=head2 GETTING READY TO EXECUTE COMMANDS
+
+The debugger decides to take control if single-step mode is on, the
+C<t> command was entered, or the user generated a signal. If the program
has fallen off the end, we set things up so that entering further commands
won't cause trouble, and we say that the program is over.
$had_breakpoints{$filename} |= 1;
# If there is an action or condition here already ...
- if ( $dbline{$i} ) {
-
- # ... swap this condition for the existing one.
- $dbline{$i} =~ s/^[^\0]*/$cond/;
- }
- else {
-
- # Nothing here - just add the condition.
- $dbline{$i} = $cond;
-
- _set_breakpoint_enabled_status($filename, $i, 1);
- }
-
- return;
-} ## end sub break_on_line
-
-=head3 cmd_b_line(line, [condition]) (command)
-
-Wrapper for C<break_on_line>. Prints the failure message if it
-doesn't work.
-
-=cut
-
-sub cmd_b_line {
- if (not eval { break_on_line(@_); 1 }) {
- local $\ = '';
- print $OUT $@ and return;
- }
-
- return;
-} ## end sub cmd_b_line
-
-=head3 cmd_b_filename_line(line, [condition]) (command)
-
-Wrapper for C<break_on_filename_line>. Prints the failure message if it
-doesn't work.
-
-=cut
-
-sub cmd_b_filename_line {
- if (not eval { break_on_filename_line(@_); 1 }) {
- local $\ = '';
- print $OUT $@ and return;
- }
-
- return;
-}
-
-=head3 break_on_filename_line(file, line, [condition]) (API)
-
-Switches to the file specified and then calls C<break_on_line> to set
-the breakpoint.
-
-=cut
-
-sub break_on_filename_line {
- my $f = shift;
- my $i = shift;
- my $cond = @_ ? shift(@_) : 1;
-
- # Switch the magical hash temporarily.
- local *dbline = $main::{ '_<' . $f };
-
- # Localize the variables that break_on_line uses to make its message.
- local $filename_error = " of '$f'";
- local $filename = $f;
-
- # Add the breakpoint.
- break_on_line( $i, $cond );
-
- return;
-} ## end sub break_on_filename_line
-
-=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
-
-Switch to another file, search the range of lines specified for an
-executable one, and put a breakpoint on the first one you find.
-
-=cut
-
-sub break_on_filename_line_range {
- my $f = shift;
- my $from = shift;
- my $to = shift;
- my $cond = @_ ? shift(@_) : 1;
-
- # Find a breakable line if there is one.
- my $i = breakable_line_in_filename( $f, $from, $to );
-
- # Add the breakpoint.
- break_on_filename_line( $f, $i, $cond );
-
- return;
-} ## end sub break_on_filename_line_range
-
-=head3 subroutine_filename_lines(subname, [condition]) (API)
-
-Search for a subroutine within a given file. The condition is ignored.
-Uses C<find_sub> to locate the desired subroutine.
-
-=cut
-
-sub subroutine_filename_lines {
- my ( $subname ) = @_;
-
- # Returned value from find_sub() is fullpathname:startline-endline.
- # The match creates the list (fullpathname, start, end).
- return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
-} ## end sub subroutine_filename_lines
-
-=head3 break_subroutine(subname) (API)
-
-Places a break on the first line possible in the specified subroutine. Uses
-C<subroutine_filename_lines> to find the subroutine, and
-C<break_on_filename_line_range> to place the break.
-
-=cut
-
-sub break_subroutine {
- my $subname = shift;
-
- # Get filename, start, and end.
- my ( $file, $s, $e ) = subroutine_filename_lines($subname)
- or die "Subroutine $subname not found.\n";
-
-
- # Null condition changes to '1' (always true).
- my $cond = @_ ? shift(@_) : 1;
-
- # Put a break the first place possible in the range of lines
- # that make up this subroutine.
- break_on_filename_line_range( $file, $s, $e, $cond );
-
- return;
-} ## end sub break_subroutine
-
-=head3 cmd_b_sub(subname, [condition]) (command)
-
-We take the incoming subroutine name and fully-qualify it as best we can.
-
-=over 4
-
-=item 1. If it's already fully-qualified, leave it alone.
-
-=item 2. Try putting it in the current package.
-
-=item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
-
-=item 4. If it starts with '::', put it in 'main::'.
-
-=back
-
-After all this cleanup, we call C<break_subroutine> to try to set the
-breakpoint.
-
-=cut
-
-sub cmd_b_sub {
- my $subname = shift;
- my $cond = @_ ? shift : 1;
-
- # If the subname isn't a code reference, qualify it so that
- # break_subroutine() will work right.
- if ( ref($subname) ne 'CODE' ) {
-
- # Not Perl 4.
- $subname =~ s/'/::/g;
- my $s = $subname;
-
- # Put it in this package unless it's already qualified.
- if ($subname !~ /::/)
- {
- $subname = $package . '::' . $subname;
- };
-
- # Requalify it into CORE::GLOBAL if qualifying it into this
- # package resulted in its not being defined, but only do so
- # if it really is in CORE::GLOBAL.
- my $core_name = "CORE::GLOBAL::$s";
- if ((!defined(&$subname))
- and ($s !~ /::/)
- and (defined &{$core_name}))
- {
- $subname = $core_name;
- }
-
- # Put it in package 'main' if it has a leading ::.
- if ($subname =~ /\A::/)
- {
- $subname = "main" . $subname;
- }
- } ## end if ( ref($subname) ne 'CODE' ) {
-
- # Try to set the breakpoint.
- if (not eval { break_subroutine( $subname, $cond ); 1 }) {
- local $\ = '';
- print {$OUT} $@;
- return;
- }
-
- return;
-} ## end sub cmd_b_sub
-
-=head3 C<cmd_B> - delete breakpoint(s) (command)
-
-The command mostly parses the command line and tries to turn the argument
-into a line spec. If it can't, it uses the current line. It then calls
-C<delete_breakpoint> to actually do the work.
-
-If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
-thereby deleting all the breakpoints.
-
-=cut
-
-sub cmd_B {
- my $cmd = shift;
-
- # No line spec? Use dbline.
- # If there is one, use it if it's non-zero, or wipe it out if it is.
- my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || '');
- my $dbline = shift;
-
- # If the line was dot, make the line the current one.
- $line =~ s/^\./$dbline/;
+ if ( $dbline{$i} ) {
- # If it's * we're deleting all the breakpoints.
- if ( $line eq '*' ) {
- if (not eval { delete_breakpoint(); 1 }) {
- print {$OUT} $@;
- }
+ # ... swap this condition for the existing one.
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
}
+ else {
- # If there is a line spec, delete the breakpoint on that line.
- elsif ( $line =~ /\A(\S.*)/ ) {
- if (not eval { delete_breakpoint( $line || $dbline ); 1 }) {
- local $\ = '';
- print {$OUT} $@;
- }
- } ## end elsif ($line =~ /^(\S.*)/)
+ # Nothing here - just add the condition.
+ $dbline{$i} = $cond;
- # No line spec.
- else {
- print {$OUT}
- "Deleting a breakpoint requires a line number, or '*' for all\n"
- ; # hint
+ _set_breakpoint_enabled_status($filename, $i, 1);
}
return;
-} ## end sub cmd_B
+} ## end sub break_on_line
-=head3 delete_breakpoint([line]) (API)
+=head3 cmd_b_line(line, [condition]) (command)
-This actually does the work of deleting either a single breakpoint, or all
-of them.
+Wrapper for C<break_on_line>. Prints the failure message if it
+doesn't work.
-For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
-just drop out with a message saying so. If it is, we remove the condition
-part of the 'condition\0action' that says there's a breakpoint here. If,
-after we've done that, there's nothing left, we delete the corresponding
-line in C<%dbline> to signal that no action needs to be taken for this line.
+=cut
-For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
-which lists all currently-loaded files which have breakpoints. We then look
-at each line in each of these files, temporarily switching the C<%dbline>
-and C<@dbline> structures to point to the files in question, and do what
-we did in the single line case: delete the condition in C<@dbline>, and
-delete the key in C<%dbline> if nothing's left.
+sub cmd_b_line {
+ if (not eval { break_on_line(@_); 1 }) {
+ local $\ = '';
+ print $OUT $@ and return;
+ }
-We then wholesale delete C<%postponed>, C<%postponed_file>, and
-C<%break_on_load>, because these structures contain breakpoints for files
-and code that haven't been loaded yet. We can just kill these off because there
-are no magical debugger structures associated with them.
+ return;
+} ## end sub cmd_b_line
-=cut
+=head3 cmd_b_filename_line(line, [condition]) (command)
-sub _remove_breakpoint_entry {
- my ($fn, $i) = @_;
+Wrapper for C<break_on_filename_line>. Prints the failure message if it
+doesn't work.
- delete $dbline{$i};
- _delete_breakpoint_data_ref($fn, $i);
+=cut
+
+sub cmd_b_filename_line {
+ if (not eval { break_on_filename_line(@_); 1 }) {
+ local $\ = '';
+ print $OUT $@ and return;
+ }
return;
}
-sub _delete_all_breakpoints {
- print {$OUT} "Deleting all breakpoints...\n";
-
- # %had_breakpoints lists every file that had at least one
- # breakpoint in it.
- for my $fn ( keys %had_breakpoints ) {
-
- # Switch to the desired file temporarily.
- local *dbline = $main::{ '_<' . $fn };
+=head3 break_on_filename_line(file, line, [condition]) (API)
- $max = $#dbline;
+Switches to the file specified and then calls C<break_on_line> to set
+the breakpoint.
- # For all lines in this file ...
- for my $i (1 .. $max) {
+=cut
- # If there's a breakpoint or action on this line ...
- if ( defined $dbline{$i} ) {
+sub break_on_filename_line {
+ my $f = shift;
+ my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
- # ... remove the breakpoint.
- $dbline{$i} =~ s/\A[^\0]+//;
- if ( $dbline{$i} =~ s/\A\0?\z// ) {
- # Remove the entry altogether if no action is there.
- _remove_breakpoint_entry($fn, $i);
- }
- } ## end if (defined $dbline{$i...
- } ## end for $i (1 .. $max)
+ # Switch the magical hash temporarily.
+ local *dbline = $main::{ '_<' . $f };
- # If, after we turn off the "there were breakpoints in this file"
- # bit, the entry in %had_breakpoints for this file is zero,
- # we should remove this file from the hash.
- if ( not $had_breakpoints{$fn} &= (~1) ) {
- delete $had_breakpoints{$fn};
- }
- } ## end for my $fn (keys %had_breakpoints)
+ # Localize the variables that break_on_line uses to make its message.
+ local $filename_error = " of '$f'";
+ local $filename = $f;
- # Kill off all the other breakpoints that are waiting for files that
- # haven't been loaded yet.
- undef %postponed;
- undef %postponed_file;
- undef %break_on_load;
+ # Add the breakpoint.
+ break_on_line( $i, $cond );
return;
-}
-
-sub _delete_breakpoint_from_line {
- my ($i) = @_;
+} ## end sub break_on_filename_line
- # Woops. This line wasn't breakable at all.
- die "Line $i not breakable.\n" if $dbline[$i] == 0;
+=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
- # Kill the condition, but leave any action.
- $dbline{$i} =~ s/\A[^\0]*//;
+Switch to another file, search the range of lines specified for an
+executable one, and put a breakpoint on the first one you find.
- # Remove the entry entirely if there's no action left.
- if ($dbline{$i} eq '') {
- _remove_breakpoint_entry($filename, $i);
- }
+=cut
- return;
-}
+sub break_on_filename_line_range {
+ my $f = shift;
+ my $from = shift;
+ my $to = shift;
+ my $cond = @_ ? shift(@_) : 1;
-sub delete_breakpoint {
- my $i = shift;
+ # Find a breakable line if there is one.
+ my $i = breakable_line_in_filename( $f, $from, $to );
- # If we got a line, delete just that one.
- if ( defined($i) ) {
- _delete_breakpoint_from_line($i);
- }
- # No line; delete them all.
- else {
- _delete_all_breakpoints();
- }
+ # Add the breakpoint.
+ break_on_filename_line( $f, $i, $cond );
return;
-}
+} ## end sub break_on_filename_line_range
-=head3 cmd_stop (command)
+=head3 subroutine_filename_lines(subname, [condition]) (API)
-This is meant to be part of the new command API, but it isn't called or used
-anywhere else in the debugger. XXX It is probably meant for use in development
-of new commands.
+Search for a subroutine within a given file. The condition is ignored.
+Uses C<find_sub> to locate the desired subroutine.
=cut
-sub cmd_stop { # As on ^C, but not signal-safy.
- $signal = 1;
-}
-
-=head3 C<cmd_e> - threads
+sub subroutine_filename_lines {
+ my ( $subname ) = @_;
-Display the current thread id:
+ # Returned value from find_sub() is fullpathname:startline-endline.
+ # The match creates the list (fullpathname, start, end).
+ return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
+} ## end sub subroutine_filename_lines
- e
+=head3 break_subroutine(subname) (API)
-This could be how (when implemented) to send commands to this thread id (e cmd)
-or that thread id (e tid cmd).
+Places a break on the first line possible in the specified subroutine. Uses
+C<subroutine_filename_lines> to find the subroutine, and
+C<break_on_filename_line_range> to place the break.
=cut
-sub cmd_e {
- my $cmd = shift;
- my $line = shift;
- unless (exists($INC{'threads.pm'})) {
- print "threads not loaded($ENV{PERL5DB_THREADED})
- please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
- } else {
- my $tid = threads->tid;
- print "thread id: $tid\n";
- }
-} ## end sub cmd_e
-
-=head3 C<cmd_E> - list of thread ids
+sub break_subroutine {
+ my $subname = shift;
-Display the list of available thread ids:
+ # Get filename, start, and end.
+ my ( $file, $s, $e ) = subroutine_filename_lines($subname)
+ or die "Subroutine $subname not found.\n";
- E
-This could be used (when implemented) to send commands to all threads (E cmd).
+ # Null condition changes to '1' (always true).
+ my $cond = @_ ? shift(@_) : 1;
-=cut
+ # Put a break the first place possible in the range of lines
+ # that make up this subroutine.
+ break_on_filename_line_range( $file, $s, $e, $cond );
-sub cmd_E {
- my $cmd = shift;
- my $line = shift;
- unless (exists($INC{'threads.pm'})) {
- print "threads not loaded($ENV{PERL5DB_THREADED})
- please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
- } else {
- my $tid = threads->tid;
- print "thread ids: ".join(', ',
- map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list
- )."\n";
- }
-} ## end sub cmd_E
+ return;
+} ## end sub break_subroutine
-=head3 C<cmd_h> - help command (command)
+=head3 cmd_b_sub(subname, [condition]) (command)
-Does the work of either
+We take the incoming subroutine name and fully-qualify it as best we can.
=over 4
-=item *
+=item 1. If it's already fully-qualified, leave it alone.
-Showing all the debugger help
+=item 2. Try putting it in the current package.
-=item *
+=item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
-Showing help for a specific command
+=item 4. If it starts with '::', put it in 'main::'.
=back
-=cut
-
-use vars qw($help);
-use vars qw($summary);
-
-sub cmd_h {
- my $cmd = shift;
+After all this cleanup, we call C<break_subroutine> to try to set the
+breakpoint.
- # If we have no operand, assume null.
- my $line = shift || '';
+=cut
- # 'h h'. Print the long-format help.
- if ( $line =~ /\Ah\s*\z/ ) {
- print_help($help);
- }
+sub cmd_b_sub {
+ my $subname = shift;
+ my $cond = @_ ? shift : 1;
- # 'h <something>'. Search for the command and print only its help.
- elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) {
+ # If the subname isn't a code reference, qualify it so that
+ # break_subroutine() will work right.
+ if ( ref($subname) ne 'CODE' ) {
- # support long commands; otherwise bogus errors
- # happen when you ask for h on <CR> for example
- my $qasked = quotemeta($asked); # for searching; we don't
- # want to use it as a pattern.
- # XXX: finds CR but not <CR>
+ # Not Perl 4.
+ $subname =~ s/'/::/g;
+ my $s = $subname;
- # Search the help string for the command.
- if (
- $help =~ /^ # Start of a line
- <? # Optional '<'
- (?:[IB]<) # Optional markup
- $qasked # The requested command
- /mx
- )
+ # Put it in this package unless it's already qualified.
+ if ($subname !~ /::/)
{
+ $subname = $package . '::' . $subname;
+ };
- # It's there; pull it out and print it.
- while (
- $help =~ /^
- (<? # Optional '<'
- (?:[IB]<) # Optional markup
- $qasked # The command
- ([\s\S]*?) # Description line(s)
- \n) # End of last description line
- (?!\s) # Next line not starting with
- # whitespace
- /mgx
- )
- {
- print_help($1);
- }
+ # Requalify it into CORE::GLOBAL if qualifying it into this
+ # package resulted in its not being defined, but only do so
+ # if it really is in CORE::GLOBAL.
+ my $core_name = "CORE::GLOBAL::$s";
+ if ((!defined(&$subname))
+ and ($s !~ /::/)
+ and (defined &{$core_name}))
+ {
+ $subname = $core_name;
}
- # Not found; not a debugger command.
- else {
- print_help("B<$asked> is not a debugger command.\n");
+ # Put it in package 'main' if it has a leading ::.
+ if ($subname =~ /\A::/)
+ {
+ $subname = "main" . $subname;
}
- } ## end elsif ($line =~ /^(\S.*)$/)
+ } ## end if ( ref($subname) ne 'CODE' ) {
- # 'h' - print the summary help.
- else {
- print_help($summary);
+ # Try to set the breakpoint.
+ if (not eval { break_subroutine( $subname, $cond ); 1 }) {
+ local $\ = '';
+ print {$OUT} $@;
+ return;
}
-} ## end sub cmd_h
-
-=head3 C<cmd_i> - inheritance display
-
-Display the (nested) parentage of the module or object given.
-=cut
+ return;
+} ## end sub cmd_b_sub
-sub cmd_i {
- my $cmd = shift;
- my $line = shift;
+=head3 C<cmd_B> - delete breakpoint(s) (command)
- require mro;
+The command mostly parses the command line and tries to turn the argument
+into a line spec. If it can't, it uses the current line. It then calls
+C<delete_breakpoint> to actually do the work.
- foreach my $isa ( split( /\s+/, $line ) ) {
- $evalarg = $isa;
- # The &-call is here to ascertain the mutability of @_.
- ($isa) = &DB::eval;
- no strict 'refs';
- print join(
- ', ',
- map {
- "$_"
- . (
- defined( ${"$_\::VERSION"} )
- ? ' ' . ${"$_\::VERSION"}
- : undef )
- } @{mro::get_linear_isa(ref($isa) || $isa)}
- );
- print "\n";
- }
-} ## end sub cmd_i
+If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
+thereby deleting all the breakpoints.
-=head3 C<cmd_l> - list lines (command)
+=cut
-Most of the command is taken up with transforming all the different line
-specification syntaxes into 'start-stop'. After that is done, the command
-runs a loop over C<@dbline> for the specified range of lines. It handles
-the printing of each line and any markers (C<==E<gt>> for current line,
-C<b> for break on this line, C<a> for action on this line, C<:> for this
-line breakable).
+sub cmd_B {
+ my $cmd = shift;
-We save the last line listed in the C<$start> global for further listing
-later.
+ # No line spec? Use dbline.
+ # If there is one, use it if it's non-zero, or wipe it out if it is.
+ my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || '');
+ my $dbline = shift;
-=cut
+ # If the line was dot, make the line the current one.
+ $line =~ s/^\./$dbline/;
-sub _min {
- my $min = shift;
- foreach my $v (@_) {
- if ($min > $v) {
- $min = $v;
+ # If it's * we're deleting all the breakpoints.
+ if ( $line eq '*' ) {
+ if (not eval { delete_breakpoint(); 1 }) {
+ print {$OUT} $@;
}
}
- return $min;
-}
-sub _max {
- my $max = shift;
- foreach my $v (@_) {
- if ($max < $v) {
- $max = $v;
+ # If there is a line spec, delete the breakpoint on that line.
+ elsif ( $line =~ /\A(\S.*)/ ) {
+ if (not eval { delete_breakpoint( $line || $dbline ); 1 }) {
+ local $\ = '';
+ print {$OUT} $@;
}
+ } ## end elsif ($line =~ /^(\S.*)/)
+
+ # No line spec.
+ else {
+ print {$OUT}
+ "Deleting a breakpoint requires a line number, or '*' for all\n"
+ ; # hint
}
- return $max;
-}
-sub _minify_to_max {
- my $ref = shift;
+ return;
+} ## end sub cmd_B
- $$ref = _min($$ref, $max);
+=head3 delete_breakpoint([line]) (API)
- return;
-}
+This actually does the work of deleting either a single breakpoint, or all
+of them.
-sub _cmd_l_handle_var_name {
- my $var_name = shift;
+For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
+just drop out with a message saying so. If it is, we remove the condition
+part of the 'condition\0action' that says there's a breakpoint here. If,
+after we've done that, there's nothing left, we delete the corresponding
+line in C<%dbline> to signal that no action needs to be taken for this line.
- $evalarg = $var_name;
+For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
+which lists all currently-loaded files which have breakpoints. We then look
+at each line in each of these files, temporarily switching the C<%dbline>
+and C<@dbline> structures to point to the files in question, and do what
+we did in the single line case: delete the condition in C<@dbline>, and
+delete the key in C<%dbline> if nothing's left.
- my ($s) = DB::eval();
+We then wholesale delete C<%postponed>, C<%postponed_file>, and
+C<%break_on_load>, because these structures contain breakpoints for files
+and code that haven't been loaded yet. We can just kill these off because there
+are no magical debugger structures associated with them.
- # Ooops. Bad scalar.
- if ($@) {
- print {$OUT} "Error: $@\n";
- next CMD;
- }
+=cut
- # Good scalar. If it's a reference, find what it points to.
- $s = CvGV_name($s);
- print {$OUT} "Interpreted as: $1 $s\n";
- $line = "$1 $s";
+sub _remove_breakpoint_entry {
+ my ($fn, $i) = @_;
- # Call self recursively to really do the command.
- return _cmd_l_main( $s );
+ delete $dbline{$i};
+ _delete_breakpoint_data_ref($fn, $i);
+
+ return;
}
-sub _cmd_l_handle_subname {
+sub _delete_all_breakpoints {
+ print {$OUT} "Deleting all breakpoints...\n";
- my $s = $subname;
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ for my $fn ( keys %had_breakpoints ) {
- # De-Perl4.
- $subname =~ s/\'/::/;
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $fn };
- # Put it in this package unless it starts with ::.
- $subname = $package . "::" . $subname unless $subname =~ /::/;
+ $max = $#dbline;
- # Put it in CORE::GLOBAL if t doesn't start with :: and
- # it doesn't live in this package and it lives in CORE::GLOBAL.
- $subname = "CORE::GLOBAL::$s"
- if not defined &$subname
- and $s !~ /::/
- and defined &{"CORE::GLOBAL::$s"};
+ # For all lines in this file ...
+ for my $i (1 .. $max) {
- # Put leading '::' names into 'main::'.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+ # If there's a breakpoint or action on this line ...
+ if ( defined $dbline{$i} ) {
- # Get name:start-stop from find_sub, and break this up at
- # colons.
- my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/\A[^\0]+//;
+ if ( $dbline{$i} =~ s/\A\0?\z// ) {
+ # Remove the entry altogether if no action is there.
+ _remove_breakpoint_entry($fn, $i);
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for $i (1 .. $max)
- # Pull off start-stop.
- my $subrange = pop @pieces;
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if ( not $had_breakpoints{$fn} &= (~1) ) {
+ delete $had_breakpoints{$fn};
+ }
+ } ## end for my $fn (keys %had_breakpoints)
- # If the name contained colons, the split broke it up.
- # Put it back together.
- $file = join( ':', @pieces );
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
- # If we're not in that file, switch over to it.
- if ( $file ne $filename ) {
- if (! $slave_editor) {
- print {$OUT} "Switching to file '$file'.\n";
- }
+ return;
+}
- # Switch debugger's magic structures.
- *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- $filename = $file;
- } ## end if ($file ne $filename)
+sub _delete_breakpoint_from_line {
+ my ($i) = @_;
- # Subrange is 'start-stop'. If this is less than a window full,
- # swap it to 'start+', which will list a window from the start point.
- if ($subrange) {
- if ( eval($subrange) < -$window ) {
- $subrange =~ s/-.*/+/;
- }
+ # Woops. This line wasn't breakable at all.
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
- # Call self recursively to list the range.
- return _cmd_l_main( $subrange );
- } ## end if ($subrange)
+ # Kill the condition, but leave any action.
+ $dbline{$i} =~ s/\A[^\0]*//;
- # Couldn't find it.
- else {
- print {$OUT} "Subroutine $subname not found.\n";
- return;
+ # Remove the entry entirely if there's no action left.
+ if ($dbline{$i} eq '') {
+ _remove_breakpoint_entry($filename, $i);
}
+
+ return;
}
-sub _cmd_l_empty {
- # Compute new range to list.
- $incr = $window - 1;
+sub delete_breakpoint {
+ my $i = shift;
- # Recurse to do it.
- return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+ # If we got a line, delete just that one.
+ if ( defined($i) ) {
+ _delete_breakpoint_from_line($i);
+ }
+ # No line; delete them all.
+ else {
+ _delete_all_breakpoints();
+ }
+
+ return;
}
-sub _cmd_l_plus {
- my ($new_start, $new_incr) = @_;
+=head3 cmd_stop (command)
- # Don't reset start for 'l +nnn'.
- $start = $new_start if $new_start;
+This is meant to be part of the new command API, but it isn't called or used
+anywhere else in the debugger. XXX It is probably meant for use in development
+of new commands.
- # Increment for list. Use window size if not specified.
- # (Allows 'l +' to work.)
- $incr = $new_incr || ($window - 1);
+=cut
- # Create a line range we'll understand, and recurse to do it.
- return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+sub cmd_stop { # As on ^C, but not signal-safy.
+ $signal = 1;
}
-sub _cmd_l_calc_initial_end_and_i {
- my ($spec, $start_match, $end_match) = @_;
+=head3 C<cmd_e> - threads
- # Determine end point; use end of file if not specified.
- my $end = ( !defined $start_match ) ? $max :
- ( $end_match ? $end_match : $start_match );
+Display the current thread id:
- # Go on to the end, and then stop.
- _minify_to_max(\$end);
+ e
- # Determine start line.
- my $i = $start_match;
+This could be how (when implemented) to send commands to this thread id (e cmd)
+or that thread id (e tid cmd).
- if ($i eq '.') {
- $i = $spec;
+=cut
+
+sub cmd_e {
+ my $cmd = shift;
+ my $line = shift;
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread id: $tid\n";
}
+} ## end sub cmd_e
- $i = _max($i, 1);
+=head3 C<cmd_E> - list of thread ids
- $incr = $end - $i;
+Display the list of available thread ids:
- return ($end, $i);
-}
+ E
-sub _cmd_l_range {
- my ($spec, $current_line, $start_match, $end_match) = @_;
+This could be used (when implemented) to send commands to all threads (E cmd).
- my ($end, $i) =
- _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
+=cut
- # If we're running under a slave editor, force it to show the lines.
- if ($slave_editor) {
- print {$OUT} "\032\032$filename:$i:0\n";
- $i = $end;
+sub cmd_E {
+ my $cmd = shift;
+ my $line = shift;
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread ids: ".join(', ',
+ map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list
+ )."\n";
}
- # We're doing it ourselves. We want to show the line and special
- # markers for:
- # - the current line in execution
- # - whether a line is breakable or not
- # - whether a line has a break or not
- # - whether a line has an action or not
- else {
- I_TO_END:
- for ( ; $i <= $end ; $i++ ) {
+} ## end sub cmd_E
- # Check for breakpoints and actions.
- my ( $stop, $action );
- if ($dbline{$i}) {
- ( $stop, $action ) = split( /\0/, $dbline{$i} );
- }
+=head3 C<cmd_h> - help command (command)
- # ==> if this is the current line in execution,
- # : if it's breakable.
- my $arrow =
- ( $i == $current_line and $filename eq $filename_ini )
- ? '==>'
- : ( $dbline[$i] + 0 ? ':' : ' ' );
+Does the work of either
- # Add break and action indicators.
- $arrow .= 'b' if $stop;
- $arrow .= 'a' if $action;
+=over 4
- # Print the line.
- print {$OUT} "$i$arrow\t", $dbline[$i];
+=item *
- # Move on to the next line. Drop out on an interrupt.
- if ($signal) {
- $i++;
- last I_TO_END;
- }
- } ## end for (; $i <= $end ; $i++)
+Showing all the debugger help
- # Line the prompt up; print a newline if the last line listed
- # didn't have a newline.
- if ($dbline[ $i - 1 ] !~ /\n\z/) {
- print {$OUT} "\n";
- }
- } ## end else [ if ($slave_editor)
+=item *
- # Save the point we last listed to in case another relative 'l'
- # command is desired. Don't let it run off the end.
- $start = $i;
- _minify_to_max(\$start);
+Showing help for a specific command
- return;
-}
+=back
-sub _cmd_l_main {
- my $spec = shift;
+=cut
- # If this is '-something', delete any spaces after the dash.
- $spec =~ s/\A-\s*\z/-/;
+use vars qw($help);
+use vars qw($summary);
- # If the line is '$something', assume this is a scalar containing a
- # line number.
- # Set up for DB::eval() - evaluate in *user* context.
- if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
- return _cmd_l_handle_var_name($var_name);
- }
- # l name. Try to find a sub by that name.
- elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
- return _cmd_l_handle_subname();
- }
- # Bare 'l' command.
- elsif ( $spec !~ /\S/ ) {
- return _cmd_l_empty();
- }
- # l [start]+number_of_lines
- elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
- return _cmd_l_plus($new_start, $new_incr);
- }
- # l start-stop or l start,stop
- elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
- return _cmd_l_range($spec, $line, $s, $e);
+sub cmd_h {
+ my $cmd = shift;
+
+ # If we have no operand, assume null.
+ my $line = shift || '';
+
+ # 'h h'. Print the long-format help.
+ if ( $line =~ /\Ah\s*\z/ ) {
+ print_help($help);
}
- return;
-} ## end sub cmd_l
+ # 'h <something>'. Search for the command and print only its help.
+ elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) {
-sub cmd_l {
- my (undef, $line) = @_;
+ # support long commands; otherwise bogus errors
+ # happen when you ask for h on <CR> for example
+ my $qasked = quotemeta($asked); # for searching; we don't
+ # want to use it as a pattern.
+ # XXX: finds CR but not <CR>
- return _cmd_l_main($line);
-}
+ # Search the help string for the command.
+ if (
+ $help =~ /^ # Start of a line
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The requested command
+ /mx
+ )
+ {
+
+ # It's there; pull it out and print it.
+ while (
+ $help =~ /^
+ (<? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command
+ ([\s\S]*?) # Description line(s)
+ \n) # End of last description line
+ (?!\s) # Next line not starting with
+ # whitespace
+ /mgx
+ )
+ {
+ print_help($1);
+ }
+ }
+
+ # Not found; not a debugger command.
+ else {
+ print_help("B<$asked> is not a debugger command.\n");
+ }
+ } ## end elsif ($line =~ /^(\S.*)$/)
+
+ # 'h' - print the summary help.
+ else {
+ print_help($summary);
+ }
+} ## end sub cmd_h
=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
https://perl5.git.perl.org / perl5.git / blobdiff