From: Gurusamy Sarathy Date: Sun, 19 Mar 2000 03:59:29 +0000 (+0000) Subject: fixes for alias handling in debugger (from Tom Christiansen) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3dcd9d33ba0f5c25b8e7a1285e47073c4ec85071;p=p5sagit%2Fp5-mst-13.2.git fixes for alias handling in debugger (from Tom Christiansen) p4raw-id: //depot/perl@5814 --- diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 50844d2..23fcb1c 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -604,16 +604,19 @@ EOP $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 =~ /^h$/ && do { print_help($help); @@ -1211,6 +1214,9 @@ EOP $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 "$@"; @@ -1240,9 +1246,12 @@ EOP $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; @@ -1308,19 +1317,39 @@ EOP 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}) =~ ss\a$k\a(.*)\a$1) { + 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 =~ /^\|/) { @@ -1716,7 +1745,7 @@ sub setterm { $| = 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;