# Debugger for Perl 5.00x; perl5db.pl patch level:
use vars qw($VERSION $header);
-$VERSION = '1.39_05';
+$VERSION = '1.39_06';
$header = "perl5db.pl version $VERSION";
Several other systems don't use a specific console. We C<undef $console>
for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
-with a slave editor, Epoc).
+with a slave editor).
=cut
$console = undef;
}
- # EPOC also falls into the 'got to use STDIN' camp.
- if ( $^O eq 'epoc' ) {
- $console = undef;
- }
-
=pod
If there is a TTY hanging around from a parent, we use that as the console.
# Oops. Bad pattern. No biscuit.
# Print the eval error and go back for more
# commands.
- print $OUT "$@";
+ print {$OUT} "$@";
next CMD;
}
$obj->pat($inpat);
++$start;
# Wrap if we pass the last line.
- $start = 1 if ($start > $max);
+ if ($start > $max) {
+ $start = 1;
+ }
# Stop if we have gotten back to this line again,
last if ($start == $end);
if ($dbline[$start] =~ m/$pat/i) {
if ($slave_editor) {
# Handle proper escaping in the slave.
- print $OUT "\032\032$filename:$start:0\n";
+ print {$OUT} "\032\032$filename:$start:0\n";
}
else {
# Just print the line normally.
- print $OUT "$start:\t",$dbline[$start],"\n";
+ print {$OUT} "$start:\t",$dbline[$start],"\n";
}
# And quit since we found something.
last;
} # PIPE:
+ # trace an expression
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+
# Make sure the flag that says "the debugger's running" is
# still on, to make sure we get control again.
$evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
# We need to fully qualify the name ("DB::sub") to make "use strict;"
# happy. -- Shlomi Fish
+
+sub _indent_print_line_info {
+ my ($offset, $str) = @_;
+
+ print_lineinfo( ' ' x ($stack_depth - $offset), $str);
+
+ return;
+}
+
+sub _print_frame_message {
+ my ($al) = @_;
+
+ if ($frame) {
+ if ($frame & 4) { # Extended frame entry message
+ _indent_print_line_info(-1, "in ");
+
+ # Why -1? But it works! :-(
+ # Because print_trace will call add 1 to it and then call
+ # dump_trace; this results in our skipping -1+1 = 0 stack frames
+ # in dump_trace.
+ #
+ # Now it's 0 because we extracted a function.
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else {
+ _indent_print_line_info(-1, "entering $sub$al\n" );
+ }
+ }
+
+ return;
+}
+
sub DB::sub {
# Do not use a regex in this subroutine -> results in corrupted memory
# See: [perl #66110]
$single |= 4 if $stack_depth == $deep;
# If frame messages are on ...
- (
- $frame & 4 # Extended frame entry message
- ? (
- print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ),
- # Why -1? But it works! :-(
- # Because print_trace will call add 1 to it and then call
- # dump_trace; this results in our skipping -1+1 = 0 stack frames
- # in dump_trace.
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
+ _print_frame_message($al);
+ # standard frame entry message
- # standard frame entry message
- )
- if $frame;
+ my $print_exit_msg = sub {
+ # Check for exit trace messages...
+ if ($frame & 2)
+ {
+ if ($frame & 4) # Extended exit message
+ {
+ _indent_print_line_info(0, "out ");
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else
+ {
+ _indent_print_line_info(0, "exited $sub$al\n" );
+ }
+ }
+ return;
+ };
# Determine the sub's return type, and capture appropriately.
if (wantarray) {
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
- # Check for exit trace messages...
- (
- $frame & 4 # Extended exit message
- ? (
- print_lineinfo( ' ' x $stack_depth, "out " ),
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" )
-
- # Standard exit message
- )
- if $frame & 2;
+ $print_exit_msg->();
# Print the return info if we need to.
if ( $doret eq $stack_depth or $frame & 16 ) {
my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
# Indent if we're printing because of $frame tracing.
- print $fh ' ' x $stack_depth if $frame & 16;
+ if ($frame & 16)
+ {
+ print {$fh} ' ' x $stack_depth;
+ }
# Print the return value.
- print $fh "list context return from $sub:\n";
+ print {$fh} "list context return from $sub:\n";
dumpit( $fh, \@ret );
# And don't print it again.
$single |= $stack[ $stack_depth-- ];
# If we're doing exit messages...
- (
- $frame & 4 # Extended messages
- ? (
- print_lineinfo( ' ' x $stack_depth, "out " ),
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" )
-
- # Standard messages
- )
- if $frame & 2;
+ $print_exit_msg->();
# If we are supposed to show the return value... same as before.
if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
$single |= 4 if $stack_depth == $deep;
# If frame messages are on ...
- (
- $frame & 4 # Extended frame entry message
- ? (
- print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ),
-
- # Why -1? But it works! :-(
- # Because print_trace will call add 1 to it and then call
- # dump_trace; this results in our skipping -1+1 = 0 stack frames
- # in dump_trace.
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
-
- # standard frame entry message
- )
- if $frame;
+ _print_frame_message($al);
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
=cut
sub cmd_b_sub {
- my ( $subname, $cond ) = @_;
-
- # Add always-true condition if we have none.
- $cond = 1 unless @_ >= 2;
+ my $subname = shift;
+ my $cond = @_ ? shift : 1;
# If the subname isn't a code reference, qualify it so that
# break_subroutine() will work right.
- unless ( ref $subname eq 'CODE' ) {
+ if ( ref($subname) ne 'CODE' ) {
- # Not Perl4.
- $subname =~ s/\'/::/g;
+ # Not Perl 4.
+ $subname =~ s/'/::/g;
my $s = $subname;
# Put it in this package unless it's already qualified.
- $subname = "${package}::" . $subname
- unless $subname =~ /::/;
+ 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.
- $subname = "CORE::GLOBAL::$s"
- if not defined &$subname
- and $s !~ /::/
- and defined &{"CORE::GLOBAL::$s"};
+ 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 ::.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
-
- } ## end unless (ref $subname eq 'CODE')
+ 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 $@ and return;
+ print {$OUT} $@;
+ return;
}
return;
=cut
-sub cmd_l {
- my $current_line = $line;
+sub _min {
+ my $min = shift;
+ foreach my $v (@_) {
+ if ($v < $min) {
+ $v = $min;
+ }
+ }
+ return $min;
+}
+
+sub _minify_to_max {
+ my $ref = shift;
+
+ $$ref = _min($$ref, $max);
+
+ return;
+}
+
+sub _cmd_l_handle_var_name {
+ my $var_name = shift;
+
+ $evalarg = $var_name;
+
+ my ($s) = DB::eval();
+
+ # Ooops. Bad scalar.
+ if ($@) {
+ print {$OUT} "Error: $@\n";
+ next CMD;
+ }
+
+ # 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";
+
+ # Call self recursively to really do the command.
+ return cmd_l( 'l', $s );
+}
+
+sub _cmd_l_handle_subname {
my $cmd = shift;
my $line = shift;
- # If this is '-something', delete any spaces after the dash.
- $line =~ s/^-\s*$/-/;
+ my $s = $subname;
- # If the line is '$something', assume this is a scalar containing a
- # line number.
- if ( $line =~ /^(\$.*)/s ) {
+ # De-Perl4.
+ $subname =~ s/\'/::/;
- # Set up for DB::eval() - evaluate in *user* context.
- $evalarg = $1;
- # $evalarg = $2;
- my ($s) = DB::eval();
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
- # Ooops. Bad scalar.
- if ($@) {
- print {$OUT} "Error: $@\n";
- next CMD;
- }
+ # 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"};
- # 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";
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
- # Call self recursively to really do the command.
- cmd_l( 'l', $s );
- } ## end if ($line =~ /^(\$.*)/s)
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
- # l name. Try to find a sub by that name.
- elsif ( ($subname) = $line =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
- my $s = $subname;
+ # Pull off start-stop.
+ my $subrange = pop @pieces;
- # De-Perl4.
- $subname =~ s/\'/::/;
+ # If the name contained colons, the split broke it up.
+ # Put it back together.
+ $file = join( ':', @pieces );
- # Put it in this package unless it starts with ::.
- $subname = $package . "::" . $subname unless $subname =~ /::/;
+ # 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";
+ }
- # 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"};
+ # Switch debugger's magic structures.
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ } ## end if ($file ne $filename)
+
+ # 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/-.*/+/;
+ }
- # Put leading '::' names into 'main::'.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+ # Call self recursively to list the range.
+ $line = $subrange;
+ return cmd_l( 'l', $subrange );
+ } ## end if ($subrange)
- # Get name:start-stop from find_sub, and break this up at
- # colons.
- my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+ # Couldn't find it.
+ else {
+ print {$OUT} "Subroutine $subname not found.\n";
+ return;
+ }
+}
- # Pull off start-stop.
- my $subrange = pop @pieces;
+sub _cmd_l_empty {
+ # Compute new range to list.
+ $incr = $window - 1;
- # If the name contained colons, the split broke it up.
- # Put it back together.
- $file = join( ':', @pieces );
+ # Recurse to do it.
+ return cmd_l( 'l', $start . '-' . ( $start + $incr ) );
+}
- # If we're not in that file, switch over to it.
- if ( $file ne $filename ) {
- print $OUT "Switching to file '$file'.\n"
- unless $slave_editor;
+sub _cmd_l_plus {
+ my ($new_start, $new_incr) = @_;
- # Switch debugger's magic structures.
- *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- $filename = $file;
- } ## end if ($file ne $filename)
+ # Don't reset start for 'l +nnn'.
+ $start = $new_start if $new_start;
- # 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/-.*/+/;
- }
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $new_incr || ($window - 1);
- # Call self recursively to list the range.
- $line = $subrange;
- cmd_l( 'l', $subrange );
- } ## end if ($subrange)
+ # Create a line range we'll understand, and recurse to do it.
+ my $line = $start . '-' . ( $start + $incr );
+ return cmd_l( 'l', $line );
+}
- # Couldn't find it.
- else {
- print $OUT "Subroutine $subname not found.\n";
- }
+sub cmd_l {
+ my $current_line = $line;
+ my $cmd = shift;
+ my $line = shift;
+
+ # If this is '-something', delete any spaces after the dash.
+ $line =~ s/^-\s*$/-/;
+
+ # 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) = $line =~ /\A(\$.*)/s ) {
+ return _cmd_l_handle_var_name($var_name);
+ } ## end if ($line =~ /^(\$.*)/s)
+
+ # l name. Try to find a sub by that name.
+ elsif ( ($subname) = $line =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
+ return _cmd_l_handle_subname($cmd, $line);
} ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s)
# Bare 'l' command.
elsif ( $line !~ /\S/ ) {
-
- # Compute new range to list.
- $incr = $window - 1;
- $line = $start . '-' . ( $start + $incr );
-
- # Recurse to do it.
- cmd_l( 'l', $line );
+ return _cmd_l_empty();
}
# l [start]+number_of_lines
elsif ( my ($new_start, $new_incr) = $line =~ /\A(\d*)\+(\d*)\z/ ) {
- # 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;
- $incr = $window - 1 unless $incr;
-
- # Create a line range we'll understand, and recurse to do it.
- $line = $start . '-' . ( $start + $incr );
- cmd_l( 'l', $line );
+ return _cmd_l_plus($new_start, $new_incr);
} ## end elsif ($line =~ /^(\d*)\+(\d*)$/)
# l start-stop or l start,stop
my $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 );
# Go on to the end, and then stop.
- $end = $max if $end > $max;
+ _minify_to_max(\$end);
# Determine start line.
my $i = $2;
# - 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 );
- ( $stop, $action ) = split( /\0/, $dbline{$i} )
- if $dbline{$i};
+ if ($dbline{$i}) {
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ }
# ==> if this is the current line in execution,
# : if it's breakable.
$arrow .= 'a' if $action;
# Print the line.
- print $OUT "$i$arrow\t", $dbline[$i];
+ print {$OUT} "$i$arrow\t", $dbline[$i];
# Move on to the next line. Drop out on an interrupt.
- $i++, last if $signal;
+ 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.
- print $OUT "\n" unless $dbline[ $i - 1 ] =~ /\n$/;
+ 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;
- $start = $max if $start > $max;
+ _minify_to_max(\$start);
+
+ return;
} ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/)
} ## end sub cmd_l
# If no argument, list everything. Pre-5.8.0 version always lists
# everything
my $arg = shift || 'abw';
- $arg = 'abw' unless $CommandSet eq '580'; # sigh...
+ if ($CommandSet ne '580')
+ {
+ $arg = 'abw';
+ }
# See what is wanted.
my $action_wanted = ( $arg =~ /a/ ) ? 1 : 0;
}
# If this is a subroutine, let postponed_sub() deal with it.
- return postponed_sub(@_) unless ref \$_[0] eq 'GLOB';
+ if (ref(\$_[0]) ne 'GLOB') {
+ return postponed_sub(@_);
+ }
# Not a subroutine. Deal with the file.
local *dbline = shift;
if ( defined $term ) {
# We don't want to show warning backtraces, but we do want die() ones.
- local ( $warnLevel, $dieLevel ) = ( 0, 1 );
+ local $warnLevel = 0;
+ local $dieLevel = 1;
# No ornaments if the terminal doesn't support them.
- return '' unless $term->Features->{ornaments};
- eval { $term->ornaments(@_) } || '';
+ if (not $term->Features->{ornaments}) {
+ return '';
+ }
+
+ return (eval { $term->ornaments(@_) } || '');
}
# Use what was passed in if we can't determine it ourselves.
else {
$ornaments = shift;
+
+ return $ornaments;
}
+
} ## end sub ornaments
=head2 C<recallCommand>
}
# Build it into a printable version.
- $prc = $rc; # Copy it
+ $prc = $rc; # Copy it
$prc =~ s/\\b$//; # Remove trailing \b
$prc =~ s/\\(.)/$1/g; # Remove escapes
- $prc; # Return the printable version
+ return $prc; # Return the printable version
} ## end sub recallCommand
=head2 C<LineInfo> - where the line number information goes
# If this is a pipe, the stream points to a slave editor.
$slave_editor = ( $stream =~ /^\|/ );
+ my $new_lineinfo_fh;
# Open it up and unbuffer it.
- open( LINEINFO, $stream ) || _db_warn("Cannot open '$stream' for write");
- $LINEINFO = \*LINEINFO;
+ open ($new_lineinfo_fh , $stream )
+ or _db_warn("Cannot open '$stream' for write");
+ $LINEINFO = $new_lineinfo_fh;
$LINEINFO->autoflush(1);
}
apio
api
artistic
- beos
book
boot
bot
dsc
ebcdic
embed
- epoc
faq1
faq2
faq3
# this way user can override, like with $doccmd="man -Mwhatever"
# or even just "man " to disable the path check.
- unless ( $doccmd eq 'man' ) {
+ if ( $doccmd ne 'man' ) {
_db_system("$doccmd $page");
return;
}
https://perl5.git.perl.org / perl5.git / blobdiff