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