# interpreter, though the values used by perl5db.pl have the form
# "$break_condition\0$action". Values are magical in numeric context.
#
-# The scalar ${'_<'.$filename} contains "_<$filename".
+# The scalar ${'_<'.$filename} contains $filename.
#
# Note that no subroutine call is possible until &DB::sub is defined
# (for subroutines defined outside of the package DB). In fact the same is
);
# These guys may be defined in $ENV{PERL5DB} :
-$rl = 1 unless defined $rl;
-$warnLevel = 1 unless defined $warnLevel;
-$dieLevel = 1 unless defined $dieLevel;
-$signalLevel = 1 unless defined $signalLevel;
-$pre = [] unless defined $pre;
-$post = [] unless defined $post;
-$pretype = [] unless defined $pretype;
+$rl = 1 unless defined $rl;
+$warnLevel = 0 unless defined $warnLevel;
+$dieLevel = 0 unless defined $dieLevel;
+$signalLevel = 1 unless defined $signalLevel;
+$pre = [] unless defined $pre;
+$post = [] unless defined $post;
+$pretype = [] unless defined $pretype;
warnLevel($warnLevel);
dieLevel($dieLevel);
$cmd =~ /^$/ && ($cmd = $laststep);
push(@hist,$cmd) if length($cmd) > 1;
PIPE: {
+ $cmd =~ s/^\s+//s; # trim annoying leading whitespace
+ $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
($i) = split(/\s+/,$cmd);
- #eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
if ($alias{$i}) {
- print STDERR "ALIAS $cmd INTO ";
+ # squelch the sigmangler
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
eval "\$cmd =~ $alias{$i}";
- print "$cmd\n";
- print $OUT $@;
+ if ($@) {
+ print $OUT "Couldn't evaluate `$i' alias: $@";
+ next CMD;
+ }
}
- $cmd =~ s/^\s+//s; # trim annoying leading whitespace
- $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
- $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
+ $cmd =~ /^q$/ && ($exiting = 1) && exit $?;
$cmd =~ /^h$/ && do {
print_help($help);
next CMD; };
print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
next CMD; };
$cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
- my $cond = $3 || '1';
+ my $cond = length $3 ? $3 : '1';
my ($subname, $break) = ($2, $1 eq 'postpone');
- $subname =~ s/\'/::/;
+ $subname =~ s/\'/::/g;
$subname = "${'package'}::" . $subname
unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
next CMD; };
$cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
$subname = $1;
- $cond = $2 || '1';
- $subname =~ s/\'/::/;
+ $cond = length $2 ? $2 : '1';
+ $subname =~ s/\'/::/g;
$subname = "${'package'}::" . $subname
unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
next CMD; };
$cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
$i = $1 || $line;
- $cond = $2 || '1';
+ $cond = length $2 ? $2 : '1';
if ($dbline[$i] == 0) {
print $OUT "Line $i not breakable.\n";
} else {
next CMD; };
$cmd =~ /^d\b\s*(\d*)/ && do {
$i = $1 || $line;
- $dbline{$i} =~ s/^[^\0]*//;
- delete $dbline{$i} if $dbline{$i} eq '';
+ if ($dbline[$i] == 0) {
+ print $OUT "Line $i not breakable.\n";
+ } else {
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
next CMD; };
$cmd =~ /^A$/ && do {
print $OUT "Deleting all actions...\n";
next CMD; };
$cmd =~ /^<\s*(.*)/ && do {
unless ($1) {
- print OUT "All < actions cleared.\n";
+ print $OUT "All < actions cleared.\n";
$pre = [];
next CMD;
}
if ($1 eq '?') {
unless (@$pre) {
- print OUT "No pre-prompt Perl actions.\n";
+ print $OUT "No pre-prompt Perl actions.\n";
next CMD;
}
- print OUT "Perl commands run before each prompt:\n";
+ print $OUT "Perl commands run before each prompt:\n";
for my $action ( @$pre ) {
- print "\t< -- $action\n";
+ print $OUT "\t< -- $action\n";
}
next CMD;
}
next CMD; };
$cmd =~ /^>\s*(.*)/ && do {
unless ($1) {
- print OUT "All > actions cleared.\n";
+ print $OUT "All > actions cleared.\n";
$post = [];
next CMD;
}
if ($1 eq '?') {
unless (@$post) {
- print OUT "No post-prompt Perl actions.\n";
+ print $OUT "No post-prompt Perl actions.\n";
next CMD;
}
- print OUT "Perl commands run after each prompt:\n";
+ print $OUT "Perl commands run after each prompt:\n";
for my $action ( @$post ) {
- print "\t> -- $action\n";
+ print $OUT "\t> -- $action\n";
}
next CMD;
}
next CMD; };
$cmd =~ /^\{\{\s*(.*)/ && do {
if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
- print OUT "{{ is now a debugger command\n",
+ print $OUT "{{ is now a debugger command\n",
"use `;{{' if you mean Perl code\n";
$cmd = "h {{";
redo CMD;
next CMD; };
$cmd =~ /^\{\s*(.*)/ && do {
unless ($1) {
- print OUT "All { actions cleared.\n";
+ print $OUT "All { actions cleared.\n";
$pretype = [];
next CMD;
}
if ($1 eq '?') {
unless (@$pretype) {
- print OUT "No pre-prompt debugger actions.\n";
+ print $OUT "No pre-prompt debugger actions.\n";
next CMD;
}
- print OUT "Debugger commands run before each prompt:\n";
+ print $OUT "Debugger commands run before each prompt:\n";
for my $action ( @$pretype ) {
- print "\t{ -- $action\n";
+ print $OUT "\t{ -- $action\n";
}
next CMD;
}
if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
- print OUT "{ is now a debugger command\n",
+ print $OUT "{ is now a debugger command\n",
"use `;{' if you mean Perl code\n";
$cmd = "h {";
redo CMD;
$inpat = $1;
$inpat =~ s:([^\\])/$:$1:;
if ($inpat ne "") {
+ # squelch the sigmangler
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
eval '$inpat =~ m'."\a$inpat\a";
if ($@ ne "") {
print $OUT "$@";
$inpat = $1;
$inpat =~ s:([^\\])\?$:$1:;
if ($inpat ne "") {
+ # squelch the sigmangler
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
eval '$inpat =~ m'."\a$inpat\a";
if ($@ ne "") {
- print $OUT "$@";
+ print $OUT $@;
next CMD;
}
$pat = $inpat;
next CMD; };
$cmd =~ s/^p$/print {\$DB::OUT} \$_/;
$cmd =~ s/^p\b/print {\$DB::OUT} /;
- $cmd =~ /^=/ && do {
- if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
- $alias{$k}="s~$k~$v~";
- print $OUT "$k = $v\n";
- } elsif ($cmd =~ /^=\s*$/) {
- foreach $k (sort keys(%alias)) {
- if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
- print $OUT "$k = $v\n";
- } else {
+ $cmd =~ s/^=\s*// && do {
+ my @keys;
+ if (length $cmd == 0) {
+ @keys = sort keys %alias;
+ }
+ elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
+ # can't use $_ or kill //g state
+ for my $x ($k, $v) { $x =~ s/\a/\\a/g }
+ $alias{$k} = "s\a$k\a$v\a";
+ # squelch the sigmangler
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+ unless (eval "sub { s\a$k\a$v\a }; 1") {
+ print $OUT "Can't alias $k to $v: $@\n";
+ delete $alias{$k};
+ next CMD;
+ }
+ @keys = ($k);
+ }
+ else {
+ @keys = ($cmd);
+ }
+ for my $k (@keys) {
+ if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
+ print $OUT "$k\t= $1\n";
+ }
+ elsif (defined $alias{$k}) {
print $OUT "$k\t$alias{$k}\n";
- };
- };
- };
+ }
+ else {
+ print "No alias for $k\n";
+ }
+ }
next CMD; };
$cmd =~ /^\|\|?\s*[^|]/ && do {
if ($pager =~ /^\|/) {
local $otrace = $trace;
local $osingle = $single;
local $od = $^D;
+ { ($evalarg) = $evalarg =~ /(.*)/s; }
@res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
$trace = $otrace;
$single = $osingle;
}
sub gets {
- local($.);
- #<IN>;
&readline("cont: ");
}
$| = 1;
select($sel);
} else {
- eval "require Term::Rendezvous;" or die $@;
+ eval "require Term::Rendezvous;" or die;
my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
my $term_rv = new Term::Rendezvous $rv;
$IN = $term_rv->IN;
}
sub readline {
+ local $.;
if (@typeahead) {
my $left = @typeahead;
my $got = shift @typeahead;
local $frame = 0;
local $doret = -2;
if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
- print $OUT @_;
+ $OUT->write(join('', @_));
my $stuff;
$IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
$stuff;
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
+B<x> I<expr> Evals expression in list context, dumps the result.
+B<m> I<expr> Evals expression in list context, prints methods callable
on the first element of the result.
B<m> I<class> Prints methods callable via the given class.
B<|>[B<|>]I<db_cmd> 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<x>|B<m> I<expr> Evals expr in list 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.