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