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