package DB;
-$header = '$Header: perldb.pl,v 4.0 91/03/20 01:25:50 lwall Locked $';
+# modified Perl debugger, to be run from Emacs in perldb-mode
+# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
+# Johan Vromans -- upgrade to 4.0 pl 10
+
+$header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $';
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
#
# $Log: perldb.pl,v $
+# Revision 4.1 92/08/07 18:24:07 lwall
+#
+# Revision 4.0.1.3 92/06/08 13:43:57 lwall
+# patch20: support for MSDOS folded into perldb.pl
+# patch20: perldb couldn't debug file containing '-', such as STDIN designator
+#
+# Revision 4.0.1.2 91/11/05 17:55:58 lwall
+# patch11: perldb.pl modified to run within emacs in perldb-mode
+#
+# Revision 4.0.1.1 91/06/07 11:17:44 lwall
+# patch4: added $^P variable to control calling of perldb routines
+# patch4: debugger sometimes listed wrong number of lines for a statement
+#
# Revision 4.0 91/03/20 01:25:50 lwall
# 4.0 baseline.
#
#
#
-open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin
-open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
+if (-e "/dev/tty") {
+ $console = "/dev/tty";
+ $rcfile=".perldb";
+}
+else {
+ $console = "con";
+ $rcfile="perldb.ini";
+}
+
+open(IN, "<$console") || open(IN, "<&STDIN"); # so we don't dingle stdin
+open(OUT,">$console") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
select(OUT);
-$| = 1; # for DB'OUT
+$| = 1; # for DB::OUT
select(STDOUT);
$| = 1; # for real STDOUT
$sub = '';
+# Is Perl being run from Emacs?
+$emacs = $main::ARGV[$[] eq '-emacs';
+shift(@main::ARGV) if $emacs;
+
$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
-print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
+print OUT "\nLoading DB routines from $header\n";
+print OUT ("Emacs support ",
+ $emacs ? "enabled" : "available",
+ ".\n");
+print OUT "\nEnter h for help.\n\n";
sub DB {
&save;
($package, $filename, $line) = caller;
$usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
"package $package;"; # this won't let them modify, alas
- local(*dbline) = "_<$filename";
+ local($^P) = 0; # don't debug our own evals
+ local(*dbline) = "::_<$filename";
$max = $#dbline;
if (($stop,$action) = split(/\0/,$dbline{$line})) {
if ($stop eq '1') {
$signal |= 1;
}
else {
- $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
+ $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
$dbline{$line} =~ s/;9($|\0)/$1/;
}
}
if ($single || $trace || $signal) {
- print OUT "$package'" unless $sub =~ /'/;
- print OUT "$sub($filename:$line):\t",$dbline[$line];
- for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
- last if $dbline[$i] =~ /^\s*(}|#|\n)/;
- print OUT "$sub($filename:$i):\t",$dbline[$i];
+ if ($emacs) {
+ print OUT "\032\032$filename:$line:0\n";
+ } else {
+ print OUT "$package::" unless $sub =~ /'|::/;
+ print OUT "$sub($filename:$line):\t",$dbline[$line];
+ for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
+ last if $dbline[$i] =~ /^\s*(}|#|\n)/;
+ print OUT "$sub($filename:$i):\t",$dbline[$i];
+ }
}
}
$evalarg = $action, &eval if $action;
! -number Redo number\'th to last command.
H -number Display last number commands (default all).
q or ^D Quit.
-p expr Same as \"print DB'OUT expr\" in current package.
+p expr Same as \"print DB::OUT expr\" in current package.
= [alias value] Define a command alias, or list current aliases.
command Execute as a perl statement in current package.
next CMD; };
$cmd =~ s/^X\b/V $package/;
$cmd =~ /^V$/ && do {
- $cmd = 'V $package'; };
+ $cmd = "V $package"; };
$cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+ local ($savout) = select(OUT);
$packname = $1;
@vars = split(' ',$2);
- do 'dumpvar.pl' unless defined &main'dumpvar;
- if (defined &main'dumpvar) {
- &main'dumpvar($packname,@vars);
+ do 'dumpvar.pl' unless defined &main::dumpvar;
+ if (defined &main::dumpvar) {
+ &main::dumpvar($packname,@vars);
}
else {
- print DB'OUT "dumpvar.pl not available.\n";
+ print DB::OUT "dumpvar.pl not available.\n";
}
+ select ($savout);
next CMD; };
$cmd =~ /^f\b\s*(.*)/ && do {
$file = $1;
print OUT "The new f command switches filenames.\n";
next CMD;
}
- if (!defined $_main{'_<' . $file}) {
- if (($try) = grep(m#^_<.*$file#, keys %_main)) {
+ if (!defined $::_main{'_<' . $file}) {
+ if (($try) = grep(m#^_<.*$file#, keys %::_main)) {
$file = substr($try,2);
print "\n$file:\n";
}
}
- if (!defined $_main{'_<' . $file}) {
+ if (!defined $::_main{'_<' . $file}) {
print OUT "There's no code here anything matching $file.\n";
next CMD;
}
elsif ($file ne $filename) {
- *dbline = "_<$file";
+ *dbline = "::_<$file";
$max = $#dbline;
$filename = $file;
$start = 1;
$cmd = "l";
} };
- $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
+ $cmd =~ /^l\b\s*([':A-Za-z_][':\w]*)/ && do {
$subname = $1;
- $subname = "main'" . $subname unless $subname =~ /'/;
- $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ $subname = "main::" . $subname unless $subname =~ /'|::/;
+ $subname = "main" . $subname if substr($subname,0,1)eq "'";
+ $subname = "main" . $subname if substr($subname,0,2)eq "::";
($file,$subrange) = split(/:/,$sub{$subname});
if ($file ne $filename) {
- *dbline = "_<$file";
+ *dbline = "::_<$file";
$max = $#dbline;
$filename = $file;
}
$i = $2;
$i = $line if $i eq '.';
$i = 1 if $i < 1;
- for (; $i <= $end; $i++) {
- print OUT "$i:\t", $dbline[$i];
- last if $signal;
+ if ($emacs) {
+ print OUT "\032\032$filename:$i:0\n";
+ $i = $end;
+ } else {
+ for (; $i <= $end; $i++) {
+ print OUT "$i:\t", $dbline[$i];
+ last if $signal;
+ }
}
$start = $i; # remember in case they want more
$start = $max if $start > $max;
}
}
next CMD; };
- $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
+ $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
$subname = $1;
$cond = $2 || '1';
- $subname = "$package'" . $subname unless $subname =~ /'/;
+ $subname = "$package::" . $subname unless $subname =~ /'|::/;
$subname = "main" . $subname if substr($subname,0,1) eq "'";
- ($filename,$i) = split(/[:-]/, $sub{$subname});
+ $subname = "main" . $subname if substr($subname,0,2) eq "::";
+ ($filename,$i) = split(/:/, $sub{$subname});
+ $i += 0;
if ($i) {
- *dbline = "_<$filename";
+ *dbline = "::_<$filename";
++$i while $dbline[$i] == 0 && $i < $#dbline;
$dbline{$i} =~ s/^[^\0]*/$cond/;
} else {
for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
@a = @args;
for (@a) {
- if (/^StB\000/ && length($_) == length($_main{'_main'})) {
- $_ = sprintf("%s",$_);
- }
- else {
- s/'/\\'/g;
- s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
- s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
- s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
- }
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
$start = 1 if ($start > $max);
last if ($start == $end);
if ($dbline[$start] =~ m'."\n$pat\n".'i) {
- print OUT "$start:\t", $dbline[$start], "\n";
+ if ($emacs) {
+ print OUT "\032\032$filename:$start:0\n";
+ } else {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ }
last;
}
} ';
$start = $max if ($start <= 0);
last if ($start == $end);
if ($dbline[$start] =~ m'."\n$pat\n".'i) {
- print OUT "$start:\t", $dbline[$start], "\n";
+ if ($emacs) {
+ print OUT "\032\032$filename:$start:0\n";
+ } else {
+ print OUT "$start:\t", $dbline[$start], "\n";
+ }
last;
}
} ';
unless $hist[$i] =~ /^.?$/;
};
next CMD; };
- $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
+ $cmd =~ s/^p( .*)?$/print DB::OUT$1/;
$cmd =~ /^=/ && do {
if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
$alias{$k}="s~$k~$v~";
# The following takes its argument via $evalarg to preserve current @_
sub eval {
- eval "$usercontext $evalarg; &DB'save";
+ eval "$usercontext $evalarg; &DB::save";
print OUT $@;
}
$single = 1; # so it stops on first executable statement
@hist = ('?');
-$SIG{'INT'} = "DB'catch";
+$SIG{'INT'} = "DB::catch";
$deep = 100; # warning if stack gets this deep
$window = 10;
$preview = 3;
s/(.*)/'$1'/ unless /^-?[\d.]+$/;
}
-if (-f '.perldb') {
- do './.perldb';
+if (-f $rcfile) {
+ do "./$rcfile";
}
-elsif (-f "$ENV{'LOGDIR'}/.perldb") {
- do "$ENV{'LOGDIR'}/.perldb";
+elsif (-f "$ENV{'LOGDIR'}/$rcfile") {
+ do "$ENV{'LOGDIR'}/$rcfile";
}
-elsif (-f "$ENV{'HOME'}/.perldb") {
- do "$ENV{'HOME'}/.perldb";
+elsif (-f "$ENV{'HOME'}/$rcfile") {
+ do "$ENV{'HOME'}/$rcfile";
}
1;
https://perl5.git.perl.org / perl5.git / blobdiff