perl
view release on metacpan or search on metacpan
lib/perl5db.pl view on Meta::CPAN
}
} ## end if (($try) = grep(m#^_<.*$file#...
} ## end if (!defined $main::{ ...
# If not successfully switched now, we failed.
if ( !defined $main::{ '_<' . $file } ) {
print $OUT "No file matching '$file' is loaded.\n";
next CMD;
}
# We switched, so switch the debugger internals around.
elsif ( $file ne $filename ) {
*dbline = $main::{ '_<' . $file };
$max = $#dbline;
$filename = $file;
$start = 1;
$cmd = "l";
} ## end elsif ($file ne $filename)
# We didn't switch; say we didn't.
else {
print $OUT "Already in $file.\n";
next CMD;
}
}
return;
}
sub _DB__handle_dot_command {
my ($obj) = @_;
# . command.
if ($obj->_is_full('.')) {
$incr = -1; # stay at current line
# Reset everything to the old location.
$start = $line;
$filename = $filename_ini;
*dbline = $main::{ '_<' . $filename };
$max = $#dbline;
# Now where are we?
print_lineinfo($obj->position());
next CMD;
}
return;
}
sub _DB__handle_y_command {
my ($obj) = @_;
if (my ($match_level, $match_vars)
= $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
# See if we've got the necessary support.
if (!eval {
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
require PadWalker; PadWalker->VERSION(0.08) }) {
my $Err = $@;
_db_warn(
$Err =~ /locate/
? "PadWalker module not found - please install\n"
: $Err
);
next CMD;
}
# Load up dumpvar if we don't have it. If we can, that is.
do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
defined &main::dumpvar
or print $OUT "dumpvar.pl not available.\n"
and next CMD;
# Got all the modules we need. Find them and print them.
my @vars = split( ' ', $match_vars || '' );
# Find the pad.
my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) };
# Oops. Can't find it.
if (my $Err = $@) {
$Err =~ s/ at .*//;
_db_warn($Err);
next CMD;
}
# Show the desired vars with dumplex().
my $savout = select($OUT);
# Have dumplex dump the lexicals.
foreach my $key (sort keys %$h) {
dumpvar::dumplex( $key, $h->{$key},
defined $option{dumpDepth} ? $option{dumpDepth} : -1,
@vars );
}
select($savout);
next CMD;
}
}
sub _DB__handle_c_command {
my ($obj) = @_;
my $i = $obj->cmd_args;
if ($i =~ m#\A[\w:]*\z#) {
# Hey, show's over. The debugged program finished
# executing already.
next CMD if _DB__is_finished();
# Capture the place to put a one-time break.
$subname = $i;
# Probably not needed, since we finish an interactive
# sub-session anyway...
# local $filename = $filename;
# local *dbline = *dbline; # XXX Would this work?!
#
# The above question wonders if localizing the alias
# to the magic array works or not. Since it's commented
# out, we'll just leave that to speculation for now.
# If the "subname" isn't all digits, we'll assume it
# is a subroutine name, and try to find it.
if ( $subname =~ /\D/ ) { # subroutine name
# Qualify it to the current package unless it's
# already qualified.
$subname = $package . "::" . $subname
unless $subname =~ /::/;
my ($file, $line) = eval { subroutine_first_breakable_line($subname) };
# If we got a line number, we found the sub.
if ($line) {
# Switch all the debugger's internals around so
# we're actually working with that file.
lib/perl5db.pl view on Meta::CPAN
}
elsif ($type eq 's') {
$val->($obj);
}
}
=head4 C<t> - trace [n]
Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
If level is specified, set C<$trace_to_depth>.
=head4 C<S> - list subroutines matching/not matching a pattern
Walks through C<%sub>, checking to see whether or not to print the name.
=head4 C<X> - list variables in current package
Since the C<V> command actually processes this, just change this to the
appropriate C<V> command and fall through.
=head4 C<V> - list variables
Uses C<dumpvar.pl> to dump out the current values for selected variables.
=head4 C<x> - evaluate and print an expression
Hands the expression off to C<DB::eval>, setting it up to print the value
via C<dumpvar.pl> instead of just printing it directly.
=head4 C<m> - print methods
Just uses C<DB::methods> to determine what methods are available.
=head4 C<f> - switch files
Switch to a different filename.
=head4 C<.> - return to last-executed line
We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
and then we look up the line in the magical C<%dbline> hash.
=head4 C<-> - back one window
We change C<$start> to be one window back; if we go back past the first line,
we set it to be the first line. We set C<$incr> to put us back at the
currently-executing line, and then put a S<C<l $start +>> (list one window from
C<$start>) in C<$cmd> to be executed later.
=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, E<0x7B>, E<0x7B>E<0x7B>>
In Perl 5.8.0, a realignment of the commands was done to fix up a number of
problems, most notably that the default case of several commands destroying
the user's work in setting watchpoints, actions, etc. We wanted, however, to
retain the old commands for those who were used to using them or who preferred
them. At this point, we check for the new commands and call C<cmd_wrapper> to
deal with them instead of processing them in-line.
=head4 C<y> - List lexicals in higher scope
Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
above the current one and then displays them using F<dumpvar.pl>.
=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
All of the commands below this point don't work after the program being
debugged has ended. All of them check to see if the program has ended; this
allows the commands to be relocated without worrying about a 'line of
demarcation' above which commands can be entered anytime, and below which
they can't.
=head4 C<n> - single step, but don't trace down into subs
Done by setting C<$single> to 2, which forces subs to execute straight through
when entered (see C<DB::sub> in L</DEBUGGER INTERFACE VARIABLES>). We also
save the C<n> command in C<$laststep>,
so a null command knows what to re-execute.
=head4 C<s> - single-step, entering subs
Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
subs. Also saves C<s> as C<$lastcmd>.
=head4 C<c> - run continuously, setting an optional breakpoint
Most of the code for this command is taken up with locating the optional
breakpoint, which is either a subroutine name or a line number. We set
the appropriate one-time-break in C<@dbline> and then turn off single-stepping
in this and all call levels above this one.
=head4 C<r> - return from a subroutine
For C<r> to work properly, the debugger has to stop execution again
immediately after the return is executed. This is done by forcing
single-stepping to be on in the call level above the current one. If
we are printing return values when a C<r> is executed, set C<$doret>
appropriately, and force us out of the command loop.
=head4 C<T> - stack trace
Just calls C<DB::print_trace>.
=head4 C<w> - List window around current line
Just calls C<DB::cmd_w>.
=head4 C<W> - watch-expression processing
Just calls C<DB::cmd_W>.
=head4 C</> - search forward for a string in the source
We take the argument and treat it as a pattern. If it turns out to be a
bad one, we return the error we got from trying to C<eval> it and exit.
If not, we create some code to do the search and C<eval> it so it can't
mess us up.
=cut
_DB__handle_forward_slash_command($obj);
lib/perl5db.pl view on Meta::CPAN
map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/,
keys %$pack;
};
=pod
=item *
If there's only one hit, and it's a package qualifier, and it's not equal to the initial text, re-complete it using the symbol we actually found.
=cut
if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) {
return db_complete( $out[0], $line, $start );
}
# Return the list of possibles.
return sort @out;
} ## end if ($text =~ /^[\$@%](.*)::(.*)/)
=pod
=back
=head3 Symbol completion: current package or package C<main>
=cut
if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main)
=pod
=over 4
=item *
If it's C<main>, delete main to just get C<::> leading.
=cut
$pack = ( $package eq 'main' ? '' : $package ) . '::';
=pod
=item *
We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed.
=cut
$prefix = substr $text, 0, 1;
$text = substr $text, 1;
my @out;
=pod
=item *
We look for the lexical scope above DB::DB and auto-complete lexical variables
if PadWalker could be loaded.
=cut
if (not $text =~ /::/ and eval {
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
require PadWalker } ) {
my $level = 1;
while (1) {
my @info = caller($level);
$level++;
$level = -1, last
if not @info;
last if $info[3] eq 'DB::DB';
}
if ($level > 0) {
my $lexicals = PadWalker::peek_my($level);
push @out, grep /^\Q$prefix$text/, keys %$lexicals;
}
}
=pod
=item *
If the package is C<::> (C<main>), create an empty list; if it's something else, create a list of all the packages known. Append whichever list to a list of all the possible symbols in the current package. C<grep> out the matches to the text entered...
=cut
push @out, map "$prefix$_", grep /^\Q$text/,
( grep /^_?[a-zA-Z]/, do { no strict 'refs'; keys %$pack } ),
( $pack eq '::' ? () : ( grep /::$/, keys %:: ) );
=item *
If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol.
=back
=cut
if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) {
return db_complete( $out[0], $line, $start );
}
# Return the list of possibles.
return sort @out;
} ## end if ($text =~ /^[\$@%]/)
=head3 Options
We use C<option_val()> to look up the current value of the option. If there's
only a single value, we complete the command in such a way that it is a
complete command for setting the option in question. If there are multiple
possible values, we generate a command consisting of the option plus a trailing
question mark, which, if executed, will list the current value of the option.
=cut
if ( ( substr $line, 0, $start ) =~ /^\|*[oO]\b.*\s$/ )
{ # Options after space
# We look for the text to be matched in the list of possible options,
# and fetch the current value.
my @out = grep /^\Q$text/, @options;
my $val = option_val( $out[0], undef );
# Set up a 'query option's value' command.
my $out = '? ';
if ( not defined $val or $val =~ /[\n\r]/ ) {
# There's really nothing else we can do.
}
# We have a value. Create a proper option-setting command.
elsif ( $val =~ /\s/ ) {
# XXX This may be an extraneous variable.
( run in 0.734 second using v1.01-cache-2.11-cpan-98e64b0badf )