home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl502b.zip / lib / perl5db.pl < prev    next >
Perl Script  |  1996-01-29  |  38KB  |  1,296 lines
  1. package DB;
  2.  
  3. # Debugger for Perl 5.001m; perl5db.pl patch level:
  4.  
  5. $header = 'perl5db.pl patch level 0.93';
  6.  
  7. # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
  8. # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
  9.  
  10. # modified Perl debugger, to be run from Emacs in perldb-mode
  11. # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  12. # Johan Vromans -- upgrade to 4.0 pl 10
  13. # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  14.  
  15. #
  16. # This file is automatically included if you do perl -d.
  17. # It's probably not useful to include this yourself.
  18. #
  19. # Perl supplies the values for @line and %sub.  It effectively inserts
  20. # a &DB'DB(<linenum>); in front of every place that can have a
  21. # breakpoint. Instead of a subroutine call it calls &DB::sub with
  22. # $DB::sub being the called subroutine. It also inserts a BEGIN
  23. # {require 'perl5db.pl'} before the first line.
  24. #
  25. # Note that no subroutine call is possible until &DB::sub is defined
  26. # (for subroutines defined outside this file). In fact the same is
  27. # true if $deep is not defined.
  28. #
  29. # $Log:    perldb.pl,v $
  30.  
  31. #
  32. # At start reads $rcfile that may set important options.  This file
  33. # may define a subroutine &afterinit that will be executed after the
  34. # debugger is initialized.
  35. #
  36. # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  37. # it as a rest of `O ...' line in debugger prompt.
  38. #
  39. # The options that can be specified only at startup:
  40. # [To set in $rcfile, call &parse_options("optionName=new_value").]
  41. #
  42. # TTY  - the TTY to use for debugging i/o.
  43. #
  44. # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  45. # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  46. # Term::Rendezvous.  Current variant is to have the name of TTY in this
  47. # file.
  48. #
  49. # ReadLine - If false, dummy ReadLine is used, so you can debug
  50. # ReadLine applications.
  51. #
  52. # NonStop - if true, no i/o is performed until interrupt.
  53. #
  54. # LineInfo - file or pipe to print line number info to.  If it is a
  55. # pipe, a short "emacs like" message is used.
  56. #
  57. # Example $rcfile: (delete leading hashes!)
  58. #
  59. # &parse_options("NonStop=1 LineInfo=db.out");
  60. # sub afterinit { $trace = 1; }
  61. #
  62. # The script will run without human intervention, putting trace
  63. # information into db.out.  (If you interrupt it, you would better
  64. # reset LineInfo to something "interactive"!)
  65. #
  66.  
  67.  
  68. local($^W) = 0;
  69. warn (            # Do not ;-)
  70.       $dumpvar::hashDepth,     
  71.       $dumpvar::arrayDepth,    
  72.       $dumpvar::dumpDBFiles,   
  73.       $dumpvar::dumpPackages,  
  74.       $dumpvar::quoteHighBit,  
  75.       $dumpvar::printUndef,    
  76.       $dumpvar::globPrint,     
  77.       $readline::Tk_toloop,    
  78.       $dumpvar::usageOnly,
  79.       @ARGS,
  80.       $Carp::CarpLevel,
  81.      ) if 0;
  82.  
  83. # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
  84.  
  85. $trace = $signal = $single = 0;    # Uninitialized warning suppression
  86.                                 # (local $^W cannot help - other packages!).
  87. @stack = (0);
  88.  
  89. $option{PrintRet} = 1;
  90.  
  91. @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages 
  92.           compactDump veryCompact quote HighBit undefPrint
  93.           globPrint PrintRet UsageOnly frame
  94.           TTY noTTY ReadLine NonStop LineInfo
  95.           recallCommand ShellBang pager tkRunning
  96.           signalLevel warnLevel dieLevel);
  97.  
  98. %optionVars    = (
  99.          hashDepth    => \$dumpvar::hashDepth,
  100.          arrayDepth    => \$dumpvar::arrayDepth,
  101.          DumpDBFiles    => \$dumpvar::dumpDBFiles,
  102.          DumpPackages    => \$dumpvar::dumpPackages,
  103.          HighBit    => \$dumpvar::quoteHighBit,
  104.          undefPrint    => \$dumpvar::printUndef,
  105.          globPrint    => \$dumpvar::globPrint,
  106.          tkRunning    => \$readline::Tk_toloop,
  107.          UsageOnly    => \$dumpvar::usageOnly,     
  108.           frame           => \$frame,
  109. );
  110.  
  111. %optionAction  = (
  112.           compactDump    => \&dumpvar::compactDump,
  113.           veryCompact    => \&dumpvar::veryCompact,
  114.           quote        => \&dumpvar::quote,
  115.           TTY        => \&TTY,
  116.           noTTY        => \&noTTY,
  117.           ReadLine    => \&ReadLine,
  118.           NonStop    => \&NonStop,
  119.           LineInfo    => \&LineInfo,
  120.           recallCommand    => \&recallCommand,
  121.           ShellBang    => \&shellBang,
  122.           pager        => \&pager,
  123.           signalLevel    => \&signalLevel,
  124.           warnLevel    => \&warnLevel,
  125.           dieLevel    => \&dieLevel,
  126.          );
  127.  
  128. %optionRequire = (
  129.           compactDump    => 'dumpvar.pl',
  130.           veryCompact    => 'dumpvar.pl',
  131.           quote        => 'dumpvar.pl',
  132.          );
  133.  
  134. # These guys may be defined in $ENV{PERL5DB} :
  135. $rl = 1 unless defined $rl;
  136. warnLevel($warnLevel);
  137. dieLevel($dieLevel);
  138. signalLevel($signalLevel);
  139. &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
  140. &recallCommand("!") unless defined $prc;
  141. &shellBang("!") unless defined $psh;
  142.  
  143. if (-e "/dev/tty") {
  144.   $rcfile=".perldb";
  145. } else {
  146.   $rcfile="perldb.ini";
  147. }
  148.  
  149. if (-f $rcfile) {
  150.     do "./$rcfile";
  151. } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
  152.     do "$ENV{LOGDIR}/$rcfile";
  153. } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
  154.     do "$ENV{HOME}/$rcfile";
  155. }
  156.  
  157. if (defined $ENV{PERLDB_OPTS}) {
  158.   parse_options($ENV{PERLDB_OPTS});
  159. }
  160.  
  161. if ($notty) {
  162.   $runnonstop = 1;
  163. } else {
  164.   # Is Perl being run from Emacs?
  165.   $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
  166.   $rl = 0, shift(@main::ARGV) if $emacs;
  167.  
  168.   #require Term::ReadLine;
  169.  
  170.   if (-e "/dev/tty") {
  171.     $console = "/dev/tty";
  172.   } elsif (-e "con") {
  173.     $console = "con";
  174.   } else {
  175.     $console = "sys\$command";
  176.   }
  177.  
  178.   # Around a bug:
  179.   if (defined $ENV{OS2_SHELL} and $emacs) { # In OS/2
  180.     $console = undef;
  181.   }
  182.  
  183.   $console = $tty if defined $tty;
  184.  
  185.   if (defined $console) {
  186.     open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
  187.     open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
  188.       || open(OUT,">&STDOUT");    # so we don't dongle stdout
  189.   } else {
  190.     open(IN,"<&STDIN");
  191.     open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
  192.     $console = 'STDIN/OUT';
  193.   }
  194.   # so open("|more") can read from STDOUT and so we don't dingle stdin
  195.   $IN = \*IN;
  196.  
  197.   $OUT = \*OUT;
  198.   select($OUT);
  199.   $| = 1;            # for DB::OUT
  200.   select(STDOUT);
  201.  
  202.   $LINEINFO = $OUT unless defined $LINEINFO;
  203.   $lineinfo = $console unless defined $lineinfo;
  204.  
  205.   $| = 1;            # for real STDOUT
  206.  
  207.   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  208.   unless ($runnonstop) {
  209.     print $OUT "\nLoading DB routines from $header\n";
  210.     print $OUT ("Emacs support ",
  211.         $emacs ? "enabled" : "available",
  212.         ".\n");
  213.     print $OUT "\nEnter h or `h h' for help.\n\n";
  214.   }
  215. }
  216.  
  217. @ARGS = @ARGV;
  218. for (@args) {
  219.     s/\'/\\\'/g;
  220.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  221. }
  222.  
  223. if (defined &afterinit) {    # May be defined in $rcfile
  224.   &afterinit();
  225. }
  226.  
  227. ############################################################ Subroutines
  228.  
  229. # The following code may be executed now, but gives FPE later:
  230. # BEGIN {warn 5}
  231.  
  232. sub DB {
  233.     if ($runnonstop) {        # Disable until signal
  234.     for ($i=0; $i <= $#stack; ) {
  235.         $stack[$i++] &= ~1;
  236.     }
  237.     $single = $runnonstop = 0; # Once only
  238.     return;
  239.     }
  240.     &save;
  241.     if ($doret) {
  242.     $doret = 0;
  243.     if ($option{PrintRet}) {
  244.         print $OUT "$retctx context return from $lastsub:", 
  245.           ($retctx eq 'list') ? "\n" : " " ;
  246.         dumpit( ($retctx eq 'list') ? \@ret : $ret );
  247.     }
  248.     }
  249.     ($package, $filename, $line) = caller;
  250.     $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
  251.       "package $package;";    # this won't let them modify, alas
  252.     local(*dbline) = "::_<$filename";
  253.     $max = $#dbline;
  254.     if (($stop,$action) = split(/\0/,$dbline{$line})) {
  255.     if ($stop eq '1') {
  256.         $signal |= 1;
  257.     } else {
  258.         $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
  259.         $dbline{$line} =~ s/;9($|\0)/$1/;
  260.     }
  261.     }
  262.     if ($single || $trace || $signal) {
  263.     $term || &setterm;
  264.     if ($emacs) {
  265.         print $LINEINFO "\032\032$filename:$line:0\n";
  266.     } else {
  267.         $sub =~ s/\'/::/;
  268.         $prefix = $sub =~ /::/ ? "" : "${'package'}::";
  269.         $prefix .= "$sub($filename:";
  270.         $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
  271.         if (length($prefix) > 30) {
  272.         print $LINEINFO "$prefix$line):\n$line:\t", $dbline[$line], $after;
  273.         $prefix = "";
  274.         $infix = ":\t";
  275.         } else {
  276.         $infix = "):\t";
  277.         print $LINEINFO "$prefix$line$infix",$dbline[$line], $after;
  278.         }
  279.         for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
  280.         last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
  281.         $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
  282.         print $LINEINFO "$prefix$i$infix", $dbline[$i], $after;
  283.         }
  284.     }
  285.     }
  286.     $evalarg = $action, &eval if $action;
  287.     if ($single || $signal) {
  288.     local $level = $level + 1;
  289.     $evalarg = $pre, &eval if $pre;
  290.     print $OUT $#stack . " levels deep in subroutine calls!\n"
  291.       if $single & 4;
  292.     $start = $line;
  293.       CMD:
  294.     while (($term || &setterm),
  295.            defined ($cmd=$term->readline("  DB" . ('<' x $level) .
  296.                          ($#hist+1) . ('>' x $level) .
  297.                          " "))) {
  298.         {            # <-- Do we know what this brace is for?
  299.         $single = 0;
  300.         $signal = 0;
  301.         $cmd =~ s/\\$/\n/ && do {
  302.             $cmd .= $term->readline("  cont: ");
  303.             redo CMD;
  304.         };
  305.         $cmd =~ /^q$/ && exit 0;
  306.         $cmd =~ /^$/ && ($cmd = $laststep);
  307.         push(@hist,$cmd) if length($cmd) > 1;
  308.           PIPE: {
  309.             ($i) = split(/\s+/,$cmd);
  310.             eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
  311.             $cmd =~ /^h$/ && do {
  312.             print $OUT $help;
  313.             next CMD; };
  314.             $cmd =~ /^h\s+h$/ && do {
  315.             print $OUT $summary;
  316.             next CMD; };
  317.             $cmd =~ /^h\s+(\S)$/ && do {
  318.             my $asked = "\Q$1";
  319.             if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) {
  320.                 print $OUT $1;
  321.             } else {
  322.                 print $OUT "`$asked' is not a debugger command.\n";
  323.             }
  324.             next CMD; };
  325.             $cmd =~ /^t$/ && do {
  326.             $trace = !$trace;
  327.             print $OUT "Trace = ".($trace?"on":"off")."\n";
  328.             next CMD; };
  329.             $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
  330.             $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
  331.             foreach $subname (sort(keys %sub)) {
  332.                 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
  333.                 print $OUT $subname,"\n";
  334.                 }
  335.             }
  336.             next CMD; };
  337.             $cmd =~ s/^X\b/V $package/;
  338.             $cmd =~ /^V$/ && do {
  339.             $cmd = "V $package"; };
  340.             $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
  341.             local ($savout) = select($OUT);
  342.             $packname = $1;
  343.             @vars = split(' ',$2);
  344.             do 'dumpvar.pl' unless defined &main::dumpvar;
  345.             if (defined &main::dumpvar) {
  346.                 &main::dumpvar($packname,@vars);
  347.             } else {
  348.                 print $OUT "dumpvar.pl not available.\n";
  349.             }
  350.             select ($savout);
  351.             next CMD; };
  352.             $cmd =~ s/^x\b/ / && do { # So that will be evaled
  353.             $onetimeDump = 1; };
  354.             $cmd =~ /^f\b\s*(.*)/ && do {
  355.             $file = $1;
  356.             if (!$file) {
  357.                 print $OUT "The old f command is now the r command.\n";
  358.                 print $OUT "The new f command switches filenames.\n";
  359.                 next CMD;
  360.             }
  361.             if (!defined $main::{'_<' . $file}) {
  362.                 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
  363.                           $file = substr($try,2);
  364.                           print "\n$file:\n";
  365.                       }}
  366.             }
  367.             if (!defined $main::{'_<' . $file}) {
  368.                 print $OUT "There's no code here matching $file.\n";
  369.                 next CMD;
  370.             } elsif ($file ne $filename) {
  371.                 *dbline = "::_<$file";
  372.                 $max = $#dbline;
  373.                 $filename = $file;
  374.                 $start = 1;
  375.                 $cmd = "l";
  376.             } };
  377.             $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
  378.             $subname = $1;
  379.             $subname =~ s/\'/::/;
  380.             $subname = "main::".$subname unless $subname =~ /::/;
  381.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  382.             @pieces = split(/:/,$sub{$subname});
  383.             $subrange = pop @pieces;
  384.             $file = join(':', @pieces);
  385.             if ($file ne $filename) {
  386.                 *dbline = "::_<$file";
  387.                 $max = $#dbline;
  388.                 $filename = $file;
  389.             }
  390.             if ($subrange) {
  391.                 if (eval($subrange) < -$window) {
  392.                 $subrange =~ s/-.*/+/;
  393.                 }
  394.                 $cmd = "l $subrange";
  395.             } else {
  396.                 print $OUT "Subroutine $subname not found.\n";
  397.                 next CMD;
  398.             } };
  399.             $cmd =~ /^w\b\s*(\d*)$/ && do {
  400.             $incr = $window - 1;
  401.             $start = $1 if $1;
  402.             $start -= $preview;
  403.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  404.             $cmd =~ /^-$/ && do {
  405.             $incr = $window - 1;
  406.             $cmd = 'l ' . ($start-$window*2) . '+'; };
  407.             $cmd =~ /^l$/ && do {
  408.             $incr = $window - 1;
  409.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  410.             $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
  411.             $start = $1 if $1;
  412.             $incr = $2;
  413.             $incr = $window - 1 unless $incr;
  414.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  415.             $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  416.             $end = (!$2) ? $max : ($4 ? $4 : $2);
  417.             $end = $max if $end > $max;
  418.             $i = $2;
  419.             $i = $line if $i eq '.';
  420.             $i = 1 if $i < 1;
  421.             if ($emacs) {
  422.                 print $OUT "\032\032$filename:$i:0\n";
  423.                 $i = $end;
  424.             } else {
  425.                 for (; $i <= $end; $i++) {
  426.                 print $OUT "$i:\t", $dbline[$i];
  427.                 last if $signal;
  428.                 }
  429.             }
  430.             $start = $i; # remember in case they want more
  431.             $start = $max if $start > $max;
  432.             next CMD; };
  433.             $cmd =~ /^D$/ && do {
  434.             print $OUT "Deleting all breakpoints...\n";
  435.             for ($i = 1; $i <= $max ; $i++) {
  436.                 if (defined $dbline{$i}) {
  437.                 $dbline{$i} =~ s/^[^\0]+//;
  438.                 if ($dbline{$i} =~ s/^\0?$//) {
  439.                     delete $dbline{$i};
  440.                 }
  441.                 }
  442.             }
  443.             next CMD; };
  444.             $cmd =~ /^L$/ && do {
  445.             for ($i = 1; $i <= $max; $i++) {
  446.                 if (defined $dbline{$i}) {
  447.                 print $OUT "$i:\t", $dbline[$i];
  448.                 ($stop,$action) = split(/\0/, $dbline{$i});
  449.                 print $OUT "  break if (", $stop, ")\n"
  450.                   if $stop;
  451.                 print $OUT "  action:  ", $action, "\n"
  452.                   if $action;
  453.                 last if $signal;
  454.                 }
  455.             }
  456.             next CMD; };
  457.             $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
  458.             $subname = $1;
  459.             $cond = $2 || '1';
  460.             $subname =~ s/\'/::/;
  461.             $subname = "${'package'}::" . $subname
  462.               unless $subname =~ /::/;
  463.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  464.             # Filename below can contain ':'
  465.             ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/);
  466.             $i += 0;
  467.             if ($i) {
  468.                 $filename = $file;
  469.                 *dbline = "::_<$filename";
  470.                 $max = $#dbline;
  471.                 ++$i while $dbline[$i] == 0 && $i < $max;
  472.                 $dbline{$i} =~ s/^[^\0]*/$cond/;
  473.             } else {
  474.                 print $OUT "Subroutine $subname not found.\n";
  475.             }
  476.             next CMD; };
  477.             $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
  478.             $i = ($1?$1:$line);
  479.             $cond = $2 || '1';
  480.             if ($dbline[$i] == 0) {
  481.                 print $OUT "Line $i not breakable.\n";
  482.             } else {
  483.                 $dbline{$i} =~ s/^[^\0]*/$cond/;
  484.             }
  485.             next CMD; };
  486.             $cmd =~ /^d\b\s*(\d+)?/ && do {
  487.             $i = ($1?$1:$line);
  488.             $dbline{$i} =~ s/^[^\0]*//;
  489.             delete $dbline{$i} if $dbline{$i} eq '';
  490.             next CMD; };
  491.             $cmd =~ /^A$/ && do {
  492.             for ($i = 1; $i <= $max ; $i++) {
  493.                 if (defined $dbline{$i}) {
  494.                 $dbline{$i} =~ s/\0[^\0]*//;
  495.                 delete $dbline{$i} if $dbline{$i} eq '';
  496.                 }
  497.             }
  498.             next CMD; };
  499.             $cmd =~ /^O\s*$/ && do {
  500.             for (@options) {
  501.                 &dump_option($_);
  502.             }
  503.             next CMD; };
  504.             $cmd =~ /^O\s*(\S.*)/ && do {
  505.             parse_options($1);
  506.             next CMD; };
  507.             $cmd =~ /^<\s*(.*)/ && do {
  508.             $pre = action($1);
  509.             next CMD; };
  510.             $cmd =~ /^>\s*(.*)/ && do {
  511.             $post = action($1);
  512.             next CMD; };
  513.             $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
  514.             $i = $1; $j = $3;
  515.             if ($dbline[$i] == 0) {
  516.                 print $OUT "Line $i may not have an action.\n";
  517.             } else {
  518.                 $dbline{$i} =~ s/\0[^\0]*//;
  519.                 $dbline{$i} .= "\0" . action($j);
  520.             }
  521.             next CMD; };
  522.             $cmd =~ /^n$/ && do {
  523.             $single = 2;
  524.             $laststep = $cmd;
  525.             last CMD; };
  526.             $cmd =~ /^s$/ && do {
  527.             $single = 1;
  528.             $laststep = $cmd;
  529.             last CMD; };
  530.             $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
  531.             $i = $1;
  532.             if ($i) {
  533.                 if ($dbline[$i] == 0) {
  534.                 print $OUT "Line $i not breakable.\n";
  535.                 next CMD;
  536.                 }
  537.                 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
  538.             }
  539.             for ($i=0; $i <= $#stack; ) {
  540.                 $stack[$i++] &= ~1;
  541.             }
  542.             last CMD; };
  543.             $cmd =~ /^r$/ && do {
  544.             $stack[$#stack] |= 1;
  545.             $doret = 1;
  546.             last CMD; };
  547.             $cmd =~ /^T$/ && do {
  548.             local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub);
  549.             for ($i = 1; 
  550.                  ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); 
  551.                  $i++) {
  552.                 @a = ();
  553.                 for $arg (@args) {
  554.                 $_ = "$arg";
  555.                 s/([\'\\])/\\$1/g;
  556.                 s/([^\0]*)/'$1'/
  557.                   unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
  558.                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  559.                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  560.                 push(@a, $_);
  561.                 }
  562.                 $w = $w ? '@ = ' : '$ = ';
  563.                 $a = $h ? '(' . join(', ', @a) . ')' : '';
  564.                 $e =~ s/\n\s*\;\s*\Z// if $e;
  565.                 $e =~ s/[\\\']/\\$1/g if $e;
  566.                 if ($r) {
  567.                   $s = "require '$e'";
  568.                 } elsif (defined $r) {
  569.                   $s = "eval '$e'";
  570.                 } elsif ($s eq '(eval)') {
  571.                   $s = "eval {...}";
  572.                 }
  573.                 $f = "file `$f'" unless $f eq '-e';
  574.                 push(@sub, "$w$s$a called from $f line $l\n");
  575.                 last if $signal;
  576.             }
  577.             for ($i=0; $i <= $#sub; $i++) {
  578.                 last if $signal;
  579.                 print $OUT $sub[$i];
  580.             }
  581.             next CMD; };
  582.             $cmd =~ /^\/(.*)$/ && do {
  583.             $inpat = $1;
  584.             $inpat =~ s:([^\\])/$:$1:;
  585.             if ($inpat ne "") {
  586.                 eval '$inpat =~ m'."\a$inpat\a";    
  587.                 if ($@ ne "") {
  588.                 print $OUT "$@";
  589.                 next CMD;
  590.                 }
  591.                 $pat = $inpat;
  592.             }
  593.             $end = $start;
  594.             eval '
  595.                 for (;;) {
  596.                 ++$start;
  597.                 $start = 1 if ($start > $max);
  598.                 last if ($start == $end);
  599.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  600.                     if ($emacs) {
  601.                     print $OUT "\032\032$filename:$start:0\n";
  602.                     } else {
  603.                     print $OUT "$start:\t", $dbline[$start], "\n";
  604.                     }
  605.                     last;
  606.                 }
  607.                 } ';
  608.             print $OUT "/$pat/: not found\n" if ($start == $end);
  609.             next CMD; };
  610.             $cmd =~ /^\?(.*)$/ && do {
  611.             $inpat = $1;
  612.             $inpat =~ s:([^\\])\?$:$1:;
  613.             if ($inpat ne "") {
  614.                 eval '$inpat =~ m'."\a$inpat\a";    
  615.                 if ($@ ne "") {
  616.                 print $OUT "$@";
  617.                 next CMD;
  618.                 }
  619.                 $pat = $inpat;
  620.             }
  621.             $end = $start;
  622.             eval '
  623.                 for (;;) {
  624.                 --$start;
  625.                 $start = $max if ($start <= 0);
  626.                 last if ($start == $end);
  627.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  628.                     if ($emacs) {
  629.                     print $OUT "\032\032$filename:$start:0\n";
  630.                     } else {
  631.                     print $OUT "$start:\t", $dbline[$start], "\n";
  632.                     }
  633.                     last;
  634.                 }
  635.                 } ';
  636.             print $OUT "?$pat?: not found\n" if ($start == $end);
  637.             next CMD; };
  638.             $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
  639.             pop(@hist) if length($cmd) > 1;
  640.             $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
  641.             $cmd = $hist[$i] . "\n";
  642.             print $OUT $cmd;
  643.             redo CMD; };
  644.             $cmd =~ /^$sh$sh\s*/ && do {
  645.             &system($');
  646.             next CMD; };
  647.             $cmd =~ /^$rc([^$rc].*)$/ && do {
  648.             $pat = "^$1";
  649.             pop(@hist) if length($cmd) > 1;
  650.             for ($i = $#hist; $i; --$i) {
  651.                 last if $hist[$i] =~ /$pat/;
  652.             }
  653.             if (!$i) {
  654.                 print $OUT "No such command!\n\n";
  655.                 next CMD;
  656.             }
  657.             $cmd = $hist[$i] . "\n";
  658.             print $OUT $cmd;
  659.             redo CMD; };
  660.             $cmd =~ /^$sh$/ && do {
  661.             &system($ENV{SHELL}||"/bin/sh");
  662.             next CMD; };
  663.             $cmd =~ /^$sh\s*/ && do {
  664.             &system($ENV{SHELL}||"/bin/sh","-c",$');
  665.             next CMD; };
  666.             $cmd =~ /^H\b\s*(-(\d+))?/ && do {
  667.             $end = $2?($#hist-$2):0;
  668.             $hist = 0 if $hist < 0;
  669.             for ($i=$#hist; $i>$end; $i--) {
  670.                 print $OUT "$i: ",$hist[$i],"\n"
  671.                   unless $hist[$i] =~ /^.?$/;
  672.             };
  673.             next CMD; };
  674.             $cmd =~ s/^p$/print \$DB::OUT \$_/;
  675.             $cmd =~ s/^p\b/print \$DB::OUT /;
  676.             $cmd =~ /^=/ && do {
  677.             if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
  678.                 $alias{$k}="s~$k~$v~";
  679.                 print $OUT "$k = $v\n";
  680.             } elsif ($cmd =~ /^=\s*$/) {
  681.                 foreach $k (sort keys(%alias)) {
  682.                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
  683.                     print $OUT "$k = $v\n";
  684.                 } else {
  685.                     print $OUT "$k\t$alias{$k}\n";
  686.                 };
  687.                 };
  688.             };
  689.             next CMD; };
  690.             $cmd =~ /^\|\|?\s*[^|]/ && do {
  691.             if ($pager =~ /^\|/) {
  692.                 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
  693.                 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  694.             } else {
  695.                 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
  696.             }
  697.             unless ($piped=open(OUT,$pager)) {
  698.                 &warn("Can't pipe output to `$pager'");
  699.                 if ($pager =~ /^\|/) {
  700.                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  701.                 open(STDOUT,">&SAVEOUT")
  702.                   || &warn("Can't restore STDOUT");
  703.                 close(SAVEOUT);
  704.                 } else {
  705.                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  706.                 }
  707.                 next CMD;
  708.             }
  709.             $SIG{PIPE}= "DB::catch" if $pager =~ /^\|/
  710.               && "" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE};
  711.             $selected= select(OUT);
  712.             $|= 1;
  713.             select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
  714.             $cmd =~ s/^\|+\s*//;
  715.             redo PIPE; };
  716.             # XXX Local variants do not work!
  717.             $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
  718.             $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
  719.             $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
  720.         }        # PIPE:
  721.         }            # <-- Do we know what this brace is for?
  722.         $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
  723.         if ($onetimeDump) {
  724.         $onetimeDump = undef;
  725.         } else {
  726.         print $OUT "\n";
  727.         }
  728.     } continue {        # CMD:
  729.         if ($piped) {
  730.         if ($pager =~ /^\|/) {
  731.             $?= 0;  close(OUT) || &warn("Can't close DB::OUT");
  732.             &warn( "Pager `$pager' failed: ",
  733.               ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
  734.               ( $? & 128 ) ? " (core dumped)" : "",
  735.               ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
  736.             open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  737.             open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  738.             $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq "DB::catch";
  739.             # Will stop ignoring SIGPIPE if done like nohup(1)
  740.             # does SIGINT but Perl doesn't give us a choice.
  741.         } else {
  742.             open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
  743.         }
  744.         close(SAVEOUT);
  745.         select($selected), $selected= "" unless $selected eq "";
  746.         $piped= "";
  747.         }
  748.     }            # CMD:
  749.     if ($post) {
  750.         $evalarg = $post; &eval;
  751.     }
  752.     }                # if ($single || $signal)
  753.     ($@, $!, $,, $/, $\, $^W) = @saved;
  754.     ();
  755. }
  756.  
  757. # The following code may be executed now:
  758. # BEGIN {warn 4}
  759.  
  760. sub sub {
  761.     print $LINEINFO ' ' x $#stack, "entering $sub\n" if $frame;
  762.     push(@stack, $single);
  763.     $single &= 1;
  764.     $single |= 4 if $#stack == $deep;
  765.     if (wantarray) {
  766.     @ret = &$sub;
  767.     $single |= pop(@stack);
  768.     $retctx = "list";
  769.     $lastsub = $sub;
  770. print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
  771.     @ret;
  772.     } else {
  773.     $ret = &$sub;
  774.     $single |= pop(@stack);
  775.     $retctx = "scalar";
  776.     $lastsub = $sub;
  777. print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
  778.     $ret;
  779.     }
  780. }
  781.  
  782. sub save {
  783.     @saved = ($@, $!, $,, $/, $\, $^W);
  784.     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
  785. }
  786.  
  787. # The following takes its argument via $evalarg to preserve current @_
  788.  
  789. sub eval {
  790.     my @res;
  791.     {
  792.     local (@stack) = @stack; # guard against recursive debugging
  793.     my $otrace = $trace;
  794.     my $osingle = $single;
  795.     my $od = $^D;
  796.     @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
  797.     $trace = $otrace;
  798.     $single = $osingle;
  799.     $^D = $od;
  800.     }
  801.     my $at = $@;
  802.     eval "&DB::save";
  803.     if ($at) {
  804.     print $OUT $at;
  805.     } elsif ($onetimeDump) {
  806.     dumpit(\@res);
  807.     }
  808. }
  809.  
  810. sub dumpit {
  811.     local ($savout) = select($OUT);
  812.     do 'dumpvar.pl' unless defined &main::dumpValue;
  813.     if (defined &main::dumpValue) {
  814.     &main::dumpValue(shift);
  815.     } else {
  816.     print $OUT "dumpvar.pl not available.\n";
  817.     }
  818.     select ($savout);    
  819. }
  820.  
  821. sub action {
  822.     my $action = shift;
  823.     while ($action =~ s/\\$//) {
  824.     #print $OUT "+ ";
  825.     #$action .= "\n";
  826.     $action .= &gets;
  827.     }
  828.     $action;
  829. }
  830.  
  831. sub gets {
  832.     local($.);
  833.     #<IN>;
  834.     &readline("cont: ");
  835. }
  836.  
  837. sub system {
  838.     # We save, change, then restore STDIN and STDOUT to avoid fork() since
  839.     # many non-Unix systems can do system() but have problems with fork().
  840.     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
  841.     open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
  842.     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
  843.     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  844.     system(@_);
  845.     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
  846.     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  847.     close(SAVEIN); close(SAVEOUT);
  848.     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
  849.       ( $? & 128 ) ? " (core dumped)" : "",
  850.       ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
  851.     $?;
  852. }
  853.  
  854. sub setterm {
  855.     eval "require Term::ReadLine;" or die $@;
  856.     if ($notty) {
  857.     if ($tty) {
  858.         open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
  859.         open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
  860.         $IN = \*IN;
  861.         $OUT = \*OUT;
  862.         my $sel = select($OUT);
  863.         $| = 1;
  864.         select($sel);
  865.     } else {
  866.         eval "require Term::Rendezvous;" or die $@;
  867.         my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
  868.         my $term_rv = new Term::Rendezvous $rv;
  869.         $IN = $term_rv->IN;
  870.         $OUT = $term_rv->OUT;
  871.     }
  872.     }
  873.     if (!$rl) {
  874.     $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
  875.     } else {
  876.     $term = new Term::ReadLine 'perldb', $IN, $OUT;
  877.  
  878.     $readline::rl_basic_word_break_characters .= "[:" 
  879.       if defined $readline::rl_basic_word_break_characters 
  880.         and index($readline::rl_basic_word_break_characters, ":") == -1;
  881.     }
  882.     $LINEINFO = $OUT unless defined $LINEINFO;
  883.     $lineinfo = $console unless defined $lineinfo;
  884.     $term->MinLine(2);
  885. }
  886.  
  887. sub readline {
  888.   local $frame = 0;
  889.   $term->readline(@_);
  890. }
  891.  
  892. sub dump_option {
  893.     my ($opt, $val)= @_;
  894.     if (defined $optionVars{$opt}
  895.     and defined $ {$optionVars{$opt}}) {
  896.     $val = $ {$optionVars{$opt}};
  897.     } elsif (defined $optionAction{$opt}
  898.     and defined &{$optionAction{$opt}}) {
  899.     $val = &{$optionAction{$opt}}();
  900.     } elsif (defined $optionAction{$opt}
  901.          and not defined $option{$opt}
  902.          or defined $optionVars{$opt}
  903.          and not defined $ {$optionVars{$opt}}) {
  904.     $val = 'N/A';
  905.     } else {
  906.     $val = $option{$opt};
  907.     }
  908.     $val =~ s/[\\\']/\\$&/g;
  909.     printf $OUT "%20s = '%s'\n", $opt, $val;
  910. }
  911.  
  912. sub parse_options {
  913.     local($_)= @_;
  914.     while ($_ ne "") {
  915.     s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
  916.     my ($opt,$sep) = ($1,$2);
  917.     my $val;
  918.     if ("?" eq $sep) {
  919.         print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
  920.           if /^\S/;
  921.         #&dump_option($opt);
  922.     } elsif ($sep !~ /\S/) {
  923.         $val = "1";
  924.     } elsif ($sep eq "=") {
  925.         s/^(\S*)($|\s+)//;
  926.         $val = $1;
  927.     } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
  928.         my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
  929.         s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
  930.           print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
  931.         $val = $1;
  932.         $val =~ s/\\([\\$end])/$1/g;
  933.     }
  934.     my ($option);
  935.     my $matches =
  936.       grep(  /^\Q$opt/ && ($option = $_),  @options  );
  937.     $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
  938.       unless $matches;
  939.     print $OUT "Unknown option `$opt'\n" unless $matches;
  940.     print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
  941.     $option{$option} = $val if $matches == 1 and defined $val;
  942.     eval "require '$optionRequire{$option}'"
  943.       if $matches == 1 and defined $optionRequire{$option} and defined $val;
  944.     $ {$optionVars{$option}} = $val 
  945.       if $matches == 1
  946.         and defined $optionVars{$option} and defined $val;
  947.     & {$optionAction{$option}} ($val) 
  948.       if $matches == 1
  949.         and defined $optionAction{$option}
  950.           and defined &{$optionAction{$option}} and defined $val;
  951.     &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
  952.         s/^\s+//;
  953.     }
  954. }
  955.  
  956. sub catch {
  957.     $signal = 1;
  958. }
  959.  
  960. sub warn {
  961.     my($msg)= join("",@_);
  962.     $msg .= ": $!\n" unless $msg =~ /\n$/;
  963.     print $OUT $msg;
  964. }
  965.  
  966. sub TTY {
  967.     if ($term) {
  968.     &warn("Too late to set TTY!\n") if @_;
  969.     } else {
  970.     $tty = shift if @_;
  971.     }
  972.     $tty or $console;
  973. }
  974.  
  975. sub noTTY {
  976.     if ($term) {
  977.     &warn("Too late to set noTTY!\n") if @_;
  978.     } else {
  979.     $notty = shift if @_;
  980.     }
  981.     $notty;
  982. }
  983.  
  984. sub ReadLine {
  985.     if ($term) {
  986.     &warn("Too late to set ReadLine!\n") if @_;
  987.     } else {
  988.     $rl = shift if @_;
  989.     }
  990.     $rl;
  991. }
  992.  
  993. sub NonStop {
  994.     if ($term) {
  995.     &warn("Too late to set up NonStop mode!\n") if @_;
  996.     } else {
  997.     $runnonstop = shift if @_;
  998.     }
  999.     $runnonstop;
  1000. }
  1001.  
  1002. sub pager {
  1003.     if (@_) {
  1004.     $pager = shift;
  1005.     $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
  1006.     }
  1007.     $pager;
  1008. }
  1009.  
  1010. sub shellBang {
  1011.     if (@_) {
  1012.     $sh = quotemeta shift;
  1013.     $sh .= "\\b" if $sh =~ /\w$/;
  1014.     }
  1015.     $psh = $sh;
  1016.     $psh =~ s/\\b$//;
  1017.     $psh =~ s/\\(.)/$1/g;
  1018.     &sethelp;
  1019.     $psh;
  1020. }
  1021.  
  1022. sub recallCommand {
  1023.     if (@_) {
  1024.     $rc = quotemeta shift;
  1025.     $rc .= "\\b" if $rc =~ /\w$/;
  1026.     }
  1027.     $prc = $rc;
  1028.     $prc =~ s/\\b$//;
  1029.     $prc =~ s/\\(.)/$1/g;
  1030.     &sethelp;
  1031.     $prc;
  1032. }
  1033.  
  1034. sub LineInfo {
  1035.     return $lineinfo unless @_;
  1036.     $lineinfo = shift;
  1037.     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
  1038.     $emacs = ($stream =~ /^\|/);
  1039.     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
  1040.     $LINEINFO = \*LINEINFO;
  1041.     my $save = select($LINEINFO);
  1042.     $| = 1;
  1043.     select($save);
  1044.     $lineinfo;
  1045. }
  1046.  
  1047. sub sethelp {
  1048.     $help = "
  1049. T        Stack trace.
  1050. s [expr]    Single step [in expr].
  1051. n [expr]    Next, steps over subroutine calls [in expr].
  1052. <CR>        Repeat last n or s command.
  1053. r        Return from current subroutine.
  1054. c [line]    Continue; optionally inserts a one-time-only breakpoint
  1055.         at the specified line.
  1056. l min+incr    List incr+1 lines starting at min.
  1057. l min-max    List lines min through max.
  1058. l line        List single line.
  1059. l subname    List first window of lines from subroutine.
  1060. l        List next window of lines.
  1061. -        List previous window of lines.
  1062. w [line]    List window around line.
  1063. f filename    Switch to viewing filename.
  1064. /pattern/    Search forwards for pattern; final / is optional.
  1065. ?pattern?    Search backwards for pattern; final ? is optional.
  1066. L        List all breakpoints and actions.
  1067. S [[!]pattern]    List subroutine names [not] matching pattern.
  1068. t        Toggle trace mode.
  1069. t expr        Trace through execution of expr.
  1070. b [line] [condition]
  1071.         Set breakpoint; line defaults to the current execution line;
  1072.         condition breaks if it evaluates to true, defaults to '1'.
  1073. b subname [condition]
  1074.         Set breakpoint at first line of subroutine.
  1075. d [line]    Delete the breakpoint for line.
  1076. D        Delete all breakpoints.
  1077. a [line] command
  1078.         Set an action to be done before the line is executed.
  1079.         Sequence is: check for breakpoint, print line if necessary,
  1080.         do action, prompt user if breakpoint or step, evaluate line.
  1081. A        Delete all actions.
  1082. V [pkg [vars]]    List some (default all) variables in package (default current).
  1083.         Use ~pattern and !pattern for positive and negative regexps.
  1084. X [vars]    Same as \"V currentpackage [vars]\".
  1085. x expr        Evals expression in array context, dumps the result.
  1086. O [opt[=val]] [opt\"val\"] [opt?]...
  1087.         Set or query values of options.  val defaults to 1.  opt can
  1088.         be abbreviated.  Several options can be listed.
  1089.     recallCommand, ShellBang:    chars used to recall command or spawn shell;
  1090.     pager:            program for output of \"|cmd\";
  1091.   The following options affect what happens with V, X, and x commands:
  1092.     arrayDepth, hashDepth:    print only first N elements ('' for all);
  1093.     compactDump, veryCompact:    change style of array and hash dump;
  1094.     globPrint:            whether to print contents of globs;
  1095.     DumpDBFiles:        dump arrays holding debugged files;
  1096.     DumpPackages:        dump symbol tables of packages;
  1097.     quote, HighBit, undefPrint:    change style of string dump;
  1098.     tkRunning:            run Tk while prompting (with ReadLine);
  1099.     signalLevel warnLevel dieLevel:    level of verbosity;
  1100.   Option PrintRet affects printing of return value after r command,
  1101.          frame    affects printing messages on entry and exit from subroutines.
  1102.         During startup options are initialized from \$ENV{PERLDB_OPTS}.
  1103.         You can put additional initialization options TTY, noTTY,
  1104.         ReadLine, and NonStop there.
  1105. < command    Define command to run before each prompt.
  1106. > command    Define command to run after each prompt.
  1107. $prc number    Redo a previous command (default previous command).
  1108. $prc -number    Redo number'th-to-last command.
  1109. $prc pattern    Redo last command that started with pattern.
  1110.         See 'O recallCommand' too.
  1111. $psh$psh cmd      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
  1112.   . ( $rc eq $sh ? "" : "
  1113. $psh [cmd]     Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
  1114.         See 'O shellBang' too.
  1115. H -number    Display last number commands (default all).
  1116. p expr        Same as \"print DB::OUT expr\" in current package.
  1117. |dbcmd        Run debugger command, piping DB::OUT to current pager.
  1118. ||dbcmd        Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
  1119. \= [alias value]    Define a command alias, or list current aliases.
  1120. command        Execute as a perl statement in current package.
  1121. h [db_command]    Get help [on a specific debugger command], enter |h to page.
  1122. h h        Summary of debugger commands.
  1123. q or ^D        Quit.
  1124.  
  1125. ";
  1126.     $summary = <<"END_SUM";
  1127. List/search source lines:               Control script execution:
  1128.   l [ln|sub]  List source code            T           Stack trace
  1129.   -           List previous lines         s [expr]    Single step [in expr]
  1130.   w [line]    List around line            n [expr]    Next, steps over subs
  1131.   f filename  View source in file         <CR>        Repeat last n or s
  1132.   /pattern/   Search forward              r           Return from subroutine
  1133.   ?pattern?   Search backward             c [line]    Continue until line
  1134. Debugger controls:                        L           List break pts & actions
  1135.   O [...]     Set debugger options        t [expr]    Toggle trace [trace expr]
  1136.   < command   Command for before prompt   b [ln] [c]  Set breakpoint
  1137.   > command   Command for after prompt    b sub [c]   Set breakpoint for sub
  1138.   $prc [N|pat]   Redo a previous command     d [line]    Delete a breakpoint
  1139.   H [-num]    Display last num commands   D           Delete all breakpoints
  1140.   = [a val]   Define/list an alias        a [ln] cmd  Do cmd before line
  1141.   h [db_cmd]  Get help on command         A           Delete all actions
  1142.   |[|]dbcmd   Send output to pager        $psh\[$psh\] syscmd Run cmd in a subprocess
  1143.   q or ^D     Quit
  1144. Data Examination:          expr     Execute perl code, also see: s,n,t expr
  1145.   S [[!]pat]    List subroutine names [not] matching pattern
  1146.   V [Pk [Vars]]    List Variables in Package.  Vars can be ~pattern or !pattern.
  1147.   X [Vars]    Same as \"V current_package [Vars]\".
  1148.   x expr    Evals expression in array context, dumps the result.
  1149.   p expr    Print expression (uses script's current package).
  1150. END_SUM
  1151.                 # '); # Fix balance of Emacs parsing
  1152. }
  1153.  
  1154.  
  1155. sub diesignal {
  1156.     $SIG{'ABRT'} = DEFAULT;
  1157.     kill 'ABRT', $$ if $panic++;
  1158.     print $DB::OUT "Got $_[0]!\n";    # in the case cannot continue
  1159.     local $SIG{__WARN__} = '';
  1160.     require Carp; 
  1161.     local $Carp::CarpLevel = 2;        # mydie + confess
  1162.     &warn(Carp::longmess("Signal @_"));
  1163.     kill 'ABRT', $$;
  1164. }
  1165.  
  1166. sub dbwarn { 
  1167.   local $SIG{__WARN__} = '';
  1168.   require Carp; 
  1169.   #&warn("Entering dbwarn\n");
  1170.   my ($mysingle,$mytrace) = ($single,$trace);
  1171.   $single = 0; $trace = 0;
  1172.   my $mess = Carp::longmess(@_);
  1173.   ($single,$trace) = ($mysingle,$mytrace);
  1174.   #&warn("Warning in dbwarn\n");
  1175.   &warn($mess); 
  1176.   #&warn("Exiting dbwarn\n");
  1177. }
  1178.  
  1179. sub dbdie {
  1180.   local $SIG{__DIE__} = '';
  1181.   local $SIG{__WARN__} = '';
  1182.   my $i = 0; my $ineval = 0; my $sub;
  1183.   #&warn("Entering dbdie\n");
  1184.   if ($dieLevel != 2) {
  1185.     while ((undef,undef,undef,$sub) = caller(++$i)) {
  1186.       $ineval = 1, last if $sub eq '(eval)';
  1187.     }
  1188.     {
  1189.       local $SIG{__WARN__} = \&dbwarn;
  1190.       &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
  1191.     }
  1192.     #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
  1193.     die @_ if $ineval and $dieLevel < 2;
  1194.   }
  1195.   require Carp; 
  1196.   # We do not want to debug this chunk (automatic disabling works
  1197.   # inside DB::DB, but not in Carp).
  1198.   my ($mysingle,$mytrace) = ($single,$trace);
  1199.   $single = 0; $trace = 0;
  1200.   my $mess = Carp::longmess(@_);
  1201.   ($single,$trace) = ($mysingle,$mytrace);
  1202.   #&warn("dieing loudly in dbdie\n");
  1203.   die $mess;
  1204. }
  1205.  
  1206. # sub diehard {            # Always dump, useful if fatal is
  1207. #                                 # deeply in evals.
  1208. #   local $SIG{__DIE__} = '';
  1209. #   require Carp; 
  1210. #   # We do not want to debug this (automatic disabling works inside DB::DB)
  1211. #   my ($mysingle,$mytrace) = ($single,$trace);
  1212. #   $single = 0; $trace = 0;
  1213. #   my $mess = Carp::longmess(@_);
  1214. #   ($single,$trace) = ($mysingle,$mytrace);
  1215. #   die $mess;
  1216. # }
  1217.  
  1218. sub warnLevel {
  1219.   if (@_) {
  1220.     $prevwarn = $SIG{__WARN__} unless $warnLevel;
  1221.     $warnLevel = shift;
  1222.     if ($warnLevel) {
  1223.       $SIG{__WARN__} = 'DB::dbwarn';
  1224.     } else {
  1225.       $SIG{__WARN__} = $prevwarn;
  1226.     }
  1227.   }
  1228.   $warnLevel;
  1229. }
  1230.  
  1231. sub dieLevel {
  1232.   if (@_) {
  1233.     $prevdie = $SIG{__DIE__} unless $dieLevel;
  1234.     $dieLevel = shift;
  1235.     if ($dieLevel) {
  1236.       $SIG{__DIE__} = 'DB::dbdie'; # if $dieLevel < 2;
  1237.       #$SIG{__DIE__} = 'DB::diehard' if $dieLevel >= 2;
  1238.       print $OUT "Stack dump during die enabled", 
  1239.         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
  1240.       print $OUT "Dump printed too.\n" if $dieLevel > 2;
  1241.     } else {
  1242.       $SIG{__DIE__} = $prevdie;
  1243.       print $OUT "Default die handler restored.\n";
  1244.     }
  1245.   }
  1246.   $dieLevel;
  1247. }
  1248.  
  1249. sub signalLevel {
  1250.   if (@_) {
  1251.     $prevsegv = $SIG{SEGV} unless $signalLevel;
  1252.     $prevbus = $SIG{BUS} unless $signalLevel;
  1253.     $signalLevel = shift;
  1254.     if ($signalLevel) {
  1255.       $SIG{SEGV} = 'DB::diesignal';
  1256.       $SIG{BUS} = 'DB::diesignal';
  1257.     } else {
  1258.       $SIG{SEGV} = $prevsegv;
  1259.       $SIG{BUS} = $prevbus;
  1260.     }
  1261.   }
  1262.   $signalLevel;
  1263. }
  1264.  
  1265. # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
  1266.  
  1267. BEGIN {            # This does not compile, alas.
  1268.   $IN = \*STDIN;        # For bugs before DB::OUT has been opened
  1269.   $OUT = \*STDERR;        # For errors before DB::OUT has been opened
  1270.   $sh = '!';
  1271.   $rc = ',';
  1272.   @hist = ('?');
  1273.   $deep = 100;            # warning if stack gets this deep
  1274.   $window = 10;
  1275.   $preview = 3;
  1276.   $sub = '';
  1277.   #$SIG{__WARN__} = "DB::dbwarn";
  1278.   #$SIG{__DIE__} = 'DB::dbdie';
  1279.   #$SIG{SEGV} = "DB::diesignal";
  1280.   #$SIG{BUS} = "DB::diesignal";
  1281.   $SIG{INT} = "DB::catch";
  1282.   #$SIG{FPE} = "DB::catch";
  1283.   #warn "SIGFPE installed";
  1284.   $warnLevel = 1 unless defined $warnLevel;
  1285.   $dieLevel = 1 unless defined $dieLevel;
  1286.   $signalLevel = 1 unless defined $signalLevel;
  1287.  
  1288.   $db_stop = 0;            # Compiler warning
  1289.   $db_stop = 1 << 30;
  1290.   $level = 0;            # Level of recursive debugging
  1291. }
  1292.  
  1293. #use Carp;            # This did break, left for debuggin
  1294.  
  1295. 1;
  1296.