home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_mlb.zip / perl5db.pl < prev    next >
Perl Script  |  1997-11-26  |  67KB  |  2,144 lines
  1. package DB;
  2.  
  3. # Debugger for Perl 5.00x; perl5db.pl patch level:
  4.  
  5. $VERSION = 1.02;
  6. $header = "perl5db.pl version $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 %sub.  It effectively inserts
  21. # a &DB'DB(); 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. # After each `require'd file is compiled, but before it is executed, a
  27. # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
  28. # $filename is the expanded name of the `require'd file (as found as
  29. # value of %INC).
  30. #
  31. # Additional services from Perl interpreter:
  32. #
  33. # if caller() is called from the package DB, it provides some
  34. # additional data.
  35. #
  36. # The array @{$main::{'_<'.$filename} is the line-by-line contents of
  37. # $filename.
  38. #
  39. # The hash %{'_<'.$filename} contains breakpoints and action (it is
  40. # keyed by line number), and individual entries are settable (as
  41. # opposed to the whole hash). Only true/false is important to the
  42. # interpreter, though the values used by perl5db.pl have the form
  43. # "$break_condition\0$action". Values are magical in numeric context.
  44. #
  45. # The scalar ${'_<'.$filename} contains "_<$filename".
  46. #
  47. # Note that no subroutine call is possible until &DB::sub is defined
  48. # (for subroutines defined outside of the package DB). In fact the same is
  49. # true if $deep is not defined.
  50. #
  51. # $Log:    perldb.pl,v $
  52.  
  53. #
  54. # At start reads $rcfile that may set important options.  This file
  55. # may define a subroutine &afterinit that will be executed after the
  56. # debugger is initialized.
  57. #
  58. # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  59. # it as a rest of `O ...' line in debugger prompt.
  60. #
  61. # The options that can be specified only at startup:
  62. # [To set in $rcfile, call &parse_options("optionName=new_value").]
  63. #
  64. # TTY  - the TTY to use for debugging i/o.
  65. #
  66. # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  67. # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  68. # Term::Rendezvous.  Current variant is to have the name of TTY in this
  69. # file.
  70. #
  71. # ReadLine - If false, dummy ReadLine is used, so you can debug
  72. # ReadLine applications.
  73. #
  74. # NonStop - if true, no i/o is performed until interrupt.
  75. #
  76. # LineInfo - file or pipe to print line number info to.  If it is a
  77. # pipe, a short "emacs like" message is used.
  78. #
  79. # Example $rcfile: (delete leading hashes!)
  80. #
  81. # &parse_options("NonStop=1 LineInfo=db.out");
  82. # sub afterinit { $trace = 1; }
  83. #
  84. # The script will run without human intervention, putting trace
  85. # information into db.out.  (If you interrupt it, you would better
  86. # reset LineInfo to something "interactive"!)
  87. #
  88. ##################################################################
  89. # Changelog:
  90.  
  91. # A lot of things changed after 0.94. First of all, core now informs
  92. # debugger about entry into XSUBs, overloaded operators, tied operations,
  93. # BEGIN and END. Handy with `O f=2'.
  94.  
  95. # This can make debugger a little bit too verbose, please be patient
  96. # and report your problems promptly.
  97.  
  98. # Now the option frame has 3 values: 0,1,2.
  99.  
  100. # Note that if DESTROY returns a reference to the object (or object),
  101. # the deletion of data may be postponed until the next function call,
  102. # due to the need to examine the return value.
  103.  
  104. # Changes: 0.95: `v' command shows versions.
  105. # Changes: 0.96: `v' command shows version of readline.
  106. #    primitive completion works (dynamic variables, subs for `b' and `l',
  107. #        options). Can `p %var'
  108. #    Better help (`h <' now works). New commands <<, >>, {, {{.
  109. #    {dump|print}_trace() coded (to be able to do it from <<cmd).
  110. #    `c sub' documented.
  111. #    At last enough magic combined to stop after the end of debuggee.
  112. #    !! should work now (thanks to Emacs bracket matching an extra
  113. #    `]' in a regexp is caught).
  114. #    `L', `D' and `A' span files now (as documented).
  115. #    Breakpoints in `require'd code are possible (used in `R').
  116. #    Some additional words on internal work of debugger.
  117. #    `b load filename' implemented.
  118. #    `b postpone subr' implemented.
  119. #    now only `q' exits debugger (overwriteable on $inhibit_exit).
  120. #    When restarting debugger breakpoints/actions persist.
  121. #     Buglet: When restarting debugger only one breakpoint/action per 
  122. #        autoloaded function persists.
  123. # Changes: 0.97: NonStop will not stop in at_exit().
  124. #    Option AutoTrace implemented.
  125. #    Trace printed differently if frames are printed too.
  126. #    new `inhibitExit' option.
  127. #    printing of a very long statement interruptible.
  128. # Changes: 0.98: New command `m' for printing possible methods
  129. #    'l -' is a synonim for `-'.
  130. #    Cosmetic bugs in printing stack trace.
  131. #    `frame' & 8 to print "expanded args" in stack trace.
  132. #    Can list/break in imported subs.
  133. #    new `maxTraceLen' option.
  134. #    frame & 4 and frame & 8 granted.
  135. #    new command `m'
  136. #    nonstoppable lines do not have `:' near the line number.
  137. #    `b compile subname' implemented.
  138. #    Will not use $` any more.
  139. #    `-' behaves sane now.
  140. # Changes: 0.99: Completion for `f', `m'.
  141. #    `m' will remove duplicate names instead of duplicate functions.
  142. #    `b load' strips trailing whitespace.
  143. #    completion ignores leading `|'; takes into account current package
  144. #    when completing a subroutine name (same for `l').
  145.  
  146. ####################################################################
  147.  
  148. # Needed for the statement after exec():
  149.  
  150. BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
  151. local($^W) = 0;            # Switch run-time warnings off during init.
  152. warn (            # Do not ;-)
  153.       $dumpvar::hashDepth,     
  154.       $dumpvar::arrayDepth,    
  155.       $dumpvar::dumpDBFiles,   
  156.       $dumpvar::dumpPackages,  
  157.       $dumpvar::quoteHighBit,  
  158.       $dumpvar::printUndef,    
  159.       $dumpvar::globPrint,     
  160.       $dumpvar::usageOnly,
  161.       @ARGS,
  162.       $Carp::CarpLevel,
  163.       $panic,
  164.       $second_time,
  165.      ) if 0;
  166.  
  167. # Command-line + PERLLIB:
  168. @ini_INC = @INC;
  169.  
  170. # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
  171.  
  172. $trace = $signal = $single = 0;    # Uninitialized warning suppression
  173.                                 # (local $^W cannot help - other packages!).
  174. $inhibit_exit = $option{PrintRet} = 1;
  175.  
  176. @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages 
  177.           compactDump veryCompact quote HighBit undefPrint
  178.           globPrint PrintRet UsageOnly frame AutoTrace
  179.           TTY noTTY ReadLine NonStop LineInfo maxTraceLen
  180.           recallCommand ShellBang pager tkRunning ornaments
  181.           signalLevel warnLevel dieLevel inhibit_exit);
  182.  
  183. %optionVars    = (
  184.          hashDepth    => \$dumpvar::hashDepth,
  185.          arrayDepth    => \$dumpvar::arrayDepth,
  186.          DumpDBFiles    => \$dumpvar::dumpDBFiles,
  187.          DumpPackages    => \$dumpvar::dumpPackages,
  188.          HighBit    => \$dumpvar::quoteHighBit,
  189.          undefPrint    => \$dumpvar::printUndef,
  190.          globPrint    => \$dumpvar::globPrint,
  191.          UsageOnly    => \$dumpvar::usageOnly,     
  192.          frame          => \$frame,
  193.          AutoTrace      => \$trace,
  194.          inhibit_exit   => \$inhibit_exit,
  195.          maxTraceLen    => \$maxtrace,
  196. );
  197.  
  198. %optionAction  = (
  199.           compactDump    => \&dumpvar::compactDump,
  200.           veryCompact    => \&dumpvar::veryCompact,
  201.           quote        => \&dumpvar::quote,
  202.           TTY        => \&TTY,
  203.           noTTY        => \&noTTY,
  204.           ReadLine    => \&ReadLine,
  205.           NonStop    => \&NonStop,
  206.           LineInfo    => \&LineInfo,
  207.           recallCommand    => \&recallCommand,
  208.           ShellBang    => \&shellBang,
  209.           pager        => \&pager,
  210.           signalLevel    => \&signalLevel,
  211.           warnLevel    => \&warnLevel,
  212.           dieLevel    => \&dieLevel,
  213.           tkRunning    => \&tkRunning,
  214.           ornaments    => \&ornaments,
  215.          );
  216.  
  217. %optionRequire = (
  218.           compactDump    => 'dumpvar.pl',
  219.           veryCompact    => 'dumpvar.pl',
  220.           quote        => 'dumpvar.pl',
  221.          );
  222.  
  223. # These guys may be defined in $ENV{PERL5DB} :
  224. $rl = 1 unless defined $rl;
  225. $warnLevel = 1 unless defined $warnLevel;
  226. $dieLevel = 1 unless defined $dieLevel;
  227. $signalLevel = 1 unless defined $signalLevel;
  228. $pre = [] unless defined $pre;
  229. $post = [] unless defined $post;
  230. $pretype = [] unless defined $pretype;
  231. warnLevel($warnLevel);
  232. dieLevel($dieLevel);
  233. signalLevel($signalLevel);
  234. &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
  235. &recallCommand("!") unless defined $prc;
  236. &shellBang("!") unless defined $psh;
  237. $maxtrace = 400 unless defined $maxtrace;
  238.  
  239. if (-e "/dev/tty") {
  240.   $rcfile=".perldb";
  241. } else {
  242.   $rcfile="perldb.ini";
  243. }
  244.  
  245. if (-f $rcfile) {
  246.     do "./$rcfile";
  247. } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
  248.     do "$ENV{LOGDIR}/$rcfile";
  249. } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
  250.     do "$ENV{HOME}/$rcfile";
  251. }
  252.  
  253. if (defined $ENV{PERLDB_OPTS}) {
  254.   parse_options($ENV{PERLDB_OPTS});
  255. }
  256.  
  257. if (exists $ENV{PERLDB_RESTART}) {
  258.   delete $ENV{PERLDB_RESTART};
  259.   # $restart = 1;
  260.   @hist = get_list('PERLDB_HIST');
  261.   %break_on_load = get_list("PERLDB_ON_LOAD");
  262.   %postponed = get_list("PERLDB_POSTPONE");
  263.   my @had_breakpoints= get_list("PERLDB_VISITED");
  264.   for (0 .. $#had_breakpoints) {
  265.     my %pf = get_list("PERLDB_FILE_$_");
  266.     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
  267.   }
  268.   my %opt = get_list("PERLDB_OPT");
  269.   my ($opt,$val);
  270.   while (($opt,$val) = each %opt) {
  271.     $val =~ s/[\\\']/\\$1/g;
  272.     parse_options("$opt'$val'");
  273.   }
  274.   @INC = get_list("PERLDB_INC");
  275.   @ini_INC = @INC;
  276.   $pretype = [get_list("PERLDB_PRETYPE")];
  277.   $pre = [get_list("PERLDB_PRE")];
  278.   $post = [get_list("PERLDB_POST")];
  279.   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
  280. }
  281.  
  282. if ($notty) {
  283.   $runnonstop = 1;
  284. } else {
  285.   # Is Perl being run from Emacs?
  286.   $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
  287.   $rl = 0, shift(@main::ARGV) if $emacs;
  288.  
  289.   #require Term::ReadLine;
  290.  
  291.   if (-e "/dev/tty") {
  292.     $console = "/dev/tty";
  293.   } elsif (-e "con" or $^O eq 'MSWin32') {
  294.     $console = "con";
  295.   } else {
  296.     $console = "sys\$command";
  297.   }
  298.  
  299.   if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
  300.     $console = undef;
  301.   }
  302.  
  303.   # Around a bug:
  304.   if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
  305.     $console = undef;
  306.   }
  307.  
  308.   $console = $tty if defined $tty;
  309.  
  310.   if (defined $console) {
  311.     open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
  312.     open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
  313.       || open(OUT,">&STDOUT");    # so we don't dongle stdout
  314.   } else {
  315.     open(IN,"<&STDIN");
  316.     open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
  317.     $console = 'STDIN/OUT';
  318.   }
  319.   # so open("|more") can read from STDOUT and so we don't dingle stdin
  320.   $IN = \*IN;
  321.  
  322.   $OUT = \*OUT;
  323.   select($OUT);
  324.   $| = 1;            # for DB::OUT
  325.   select(STDOUT);
  326.  
  327.   $LINEINFO = $OUT unless defined $LINEINFO;
  328.   $lineinfo = $console unless defined $lineinfo;
  329.  
  330.   $| = 1;            # for real STDOUT
  331.  
  332.   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  333.   unless ($runnonstop) {
  334.     print $OUT "\nLoading DB routines from $header\n";
  335.     print $OUT ("Emacs support ",
  336.         $emacs ? "enabled" : "available",
  337.         ".\n");
  338.     print $OUT "\nEnter h or `h h' for help.\n\n";
  339.   }
  340. }
  341.  
  342. @ARGS = @ARGV;
  343. for (@args) {
  344.     s/\'/\\\'/g;
  345.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  346. }
  347.  
  348. if (defined &afterinit) {    # May be defined in $rcfile
  349.   &afterinit();
  350. }
  351.  
  352. $I_m_init = 1;
  353.  
  354. ############################################################ Subroutines
  355.  
  356. sub DB {
  357.     # _After_ the perl program is compiled, $single is set to 1:
  358.     if ($single and not $second_time++) {
  359.       if ($runnonstop) {    # Disable until signal
  360.     for ($i=0; $i <= $#stack; ) {
  361.         $stack[$i++] &= ~1;
  362.     }
  363.     $single = 0;
  364.     # return;            # Would not print trace!
  365.       }
  366.     }
  367.     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
  368.     &save;
  369.     ($package, $filename, $line) = caller;
  370.     $filename_ini = $filename;
  371.     $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
  372.       "package $package;";    # this won't let them modify, alas
  373.     local(*dbline) = $main::{'_<' . $filename};
  374.     $max = $#dbline;
  375.     if (($stop,$action) = split(/\0/,$dbline{$line})) {
  376.     if ($stop eq '1') {
  377.         $signal |= 1;
  378.     } elsif ($stop) {
  379.         $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
  380.         $dbline{$line} =~ s/;9($|\0)/$1/;
  381.     }
  382.     }
  383.     my $was_signal = $signal;
  384.     if ($trace & 2) {
  385.       for (my $n = 0; $n <= $#to_watch; $n++) {
  386.     $evalarg = $to_watch[$n];
  387.     my ($val) = &eval;    # Fix context (&eval is doing array)?
  388.     $val = ( (defined $val) ? "'$val'" : 'undef' );
  389.     if ($val ne $old_watch[$n]) {
  390.       $signal = 1;
  391.       print $OUT <<EOP;
  392. Watchpoint $n: $to_watch[$n] changed:
  393. old value: $old_watch[$n]
  394. new value: $val
  395. EOP
  396.       $old_watch[$n] = $val;
  397.     }
  398.       }
  399.     }
  400.     if ($trace & 4) {        # User-installed watch
  401.       return if watchfunction($package, $filename, $line) 
  402.     and not $single and not $was_signal and not ($trace & ~4);
  403.     }
  404.     $was_signal = $signal;
  405.     $signal = 0;
  406.     if ($single || ($trace & 1) || $was_signal) {
  407.     $term || &setterm;
  408.     if ($emacs) {
  409.         $position = "\032\032$filename:$line:0\n";
  410.         print $LINEINFO $position;
  411.     } else {
  412.         $sub =~ s/\'/::/;
  413.         $prefix = $sub =~ /::/ ? "" : "${'package'}::";
  414.         $prefix .= "$sub($filename:";
  415.         $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
  416.         if (length($prefix) > 30) {
  417.             $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
  418.         $prefix = "";
  419.         $infix = ":\t";
  420.         } else {
  421.         $infix = "):\t";
  422.         $position = "$prefix$line$infix$dbline[$line]$after";
  423.         }
  424.         if ($frame) {
  425.         print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
  426.         } else {
  427.         print $LINEINFO $position;
  428.         }
  429.         for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
  430.         last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
  431.         last if $signal;
  432.         $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
  433.         $incr_pos = "$prefix$i$infix$dbline[$i]$after";
  434.         $position .= $incr_pos;
  435.         if ($frame) {
  436.             print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
  437.         } else {
  438.             print $LINEINFO $incr_pos;
  439.         }
  440.         }
  441.     }
  442.     }
  443.     $evalarg = $action, &eval if $action;
  444.     if ($single || $was_signal) {
  445.     local $level = $level + 1;
  446.     foreach $evalarg (@$pre) {
  447.       &eval;
  448.     }
  449.     print $OUT $#stack . " levels deep in subroutine calls!\n"
  450.       if $single & 4;
  451.     $start = $line;
  452.     $incr = -1;        # for backward motion.
  453.     @typeahead = @$pretype, @typeahead;
  454.       CMD:
  455.     while (($term || &setterm),
  456.            ($term_pid == $$ or &resetterm),
  457.            defined ($cmd=&readline("  DB" . ('<' x $level) .
  458.                        ($#hist+1) . ('>' x $level) .
  459.                        " "))) {
  460.         $single = 0;
  461.         $signal = 0;
  462.         $cmd =~ s/\\$/\n/ && do {
  463.             $cmd .= &readline("  cont: ");
  464.             redo CMD;
  465.         };
  466.         $cmd =~ /^$/ && ($cmd = $laststep);
  467.         push(@hist,$cmd) if length($cmd) > 1;
  468.           PIPE: {
  469.             ($i) = split(/\s+/,$cmd);
  470.             eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
  471.             $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
  472.             $cmd =~ /^h$/ && do {
  473.             print_help($help);
  474.             next CMD; };
  475.             $cmd =~ /^h\s+h$/ && do {
  476.             print_help($summary);
  477.             next CMD; };
  478.             $cmd =~ /^h\s+(\S)$/ && do {
  479.             my $asked = "\Q$1";
  480.             if ($help =~ /^(?:[IB]<)$asked/m) {
  481.               while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
  482.                 print_help($1);
  483.               }
  484.             } else {
  485.                 print_help("B<$asked> is not a debugger command.\n");
  486.             }
  487.             next CMD; };
  488.             $cmd =~ /^t$/ && do {
  489.             ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
  490.             print $OUT "Trace = " .
  491.                 (($trace & 1) ? "on" : "off" ) . "\n";
  492.             next CMD; };
  493.             $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
  494.             $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
  495.             foreach $subname (sort(keys %sub)) {
  496.                 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
  497.                 print $OUT $subname,"\n";
  498.                 }
  499.             }
  500.             next CMD; };
  501.             $cmd =~ /^v$/ && do {
  502.             list_versions(); next CMD};
  503.             $cmd =~ s/^X\b/V $package/;
  504.             $cmd =~ /^V$/ && do {
  505.             $cmd = "V $package"; };
  506.             $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
  507.             local ($savout) = select($OUT);
  508.             $packname = $1;
  509.             @vars = split(' ',$2);
  510.             do 'dumpvar.pl' unless defined &main::dumpvar;
  511.             if (defined &main::dumpvar) {
  512.                 local $frame = 0;
  513.                 local $doret = -2;
  514.                 &main::dumpvar($packname,@vars);
  515.             } else {
  516.                 print $OUT "dumpvar.pl not available.\n";
  517.             }
  518.             select ($savout);
  519.             next CMD; };
  520.             $cmd =~ s/^x\b/ / && do { # So that will be evaled
  521.             $onetimeDump = 'dump'; };
  522.             $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
  523.             methods($1); next CMD};
  524.             $cmd =~ s/^m\b/ / && do { # So this will be evaled
  525.             $onetimeDump = 'methods'; };
  526.             $cmd =~ /^f\b\s*(.*)/ && do {
  527.             $file = $1;
  528.             $file =~ s/\s+$//;
  529.             if (!$file) {
  530.                 print $OUT "The old f command is now the r command.\n";
  531.                 print $OUT "The new f command switches filenames.\n";
  532.                 next CMD;
  533.             }
  534.             if (!defined $main::{'_<' . $file}) {
  535.                 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
  536.                           $try = substr($try,2);
  537.                           print $OUT "Choosing $try matching `$file':\n";
  538.                           $file = $try;
  539.                       }}
  540.             }
  541.             if (!defined $main::{'_<' . $file}) {
  542.                 print $OUT "No file matching `$file' is loaded.\n";
  543.                 next CMD;
  544.             } elsif ($file ne $filename) {
  545.                 *dbline = $main::{'_<' . $file};
  546.                 $max = $#dbline;
  547.                 $filename = $file;
  548.                 $start = 1;
  549.                 $cmd = "l";
  550.               } else {
  551.                 print $OUT "Already in $file.\n";
  552.                 next CMD;
  553.               }
  554.               };
  555.             $cmd =~ s/^l\s+-\s*$/-/;
  556.             $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
  557.             $subname = $1;
  558.             $subname =~ s/\'/::/;
  559.             $subname = $package."::".$subname 
  560.               unless $subname =~ /::/;
  561.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  562.             @pieces = split(/:/,find_sub($subname));
  563.             $subrange = pop @pieces;
  564.             $file = join(':', @pieces);
  565.             if ($file ne $filename) {
  566.                 *dbline = $main::{'_<' . $file};
  567.                 $max = $#dbline;
  568.                 $filename = $file;
  569.             }
  570.             if ($subrange) {
  571.                 if (eval($subrange) < -$window) {
  572.                 $subrange =~ s/-.*/+/;
  573.                 }
  574.                 $cmd = "l $subrange";
  575.             } else {
  576.                 print $OUT "Subroutine $subname not found.\n";
  577.                 next CMD;
  578.             } };
  579.             $cmd =~ /^\.$/ && do {
  580.             $incr = -1;        # for backward motion.
  581.             $start = $line;
  582.             $filename = $filename_ini;
  583.             *dbline = $main::{'_<' . $filename};
  584.             $max = $#dbline;
  585.             print $LINEINFO $position;
  586.             next CMD };
  587.             $cmd =~ /^w\b\s*(\d*)$/ && do {
  588.             $incr = $window - 1;
  589.             $start = $1 if $1;
  590.             $start -= $preview;
  591.             #print $OUT 'l ' . $start . '-' . ($start + $incr);
  592.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  593.             $cmd =~ /^-$/ && do {
  594.             $start -= $incr + $window + 1;
  595.             $start = 1 if $start <= 0;
  596.             $incr = $window - 1;
  597.             $cmd = 'l ' . ($start) . '+'; };
  598.             $cmd =~ /^l$/ && do {
  599.             $incr = $window - 1;
  600.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  601.             $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
  602.             $start = $1 if $1;
  603.             $incr = $2;
  604.             $incr = $window - 1 unless $incr;
  605.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  606.             $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  607.             $end = (!defined $2) ? $max : ($4 ? $4 : $2);
  608.             $end = $max if $end > $max;
  609.             $i = $2;
  610.             $i = $line if $i eq '.';
  611.             $i = 1 if $i < 1;
  612.             $incr = $end - $i;
  613.             if ($emacs) {
  614.                 print $OUT "\032\032$filename:$i:0\n";
  615.                 $i = $end;
  616.             } else {
  617.                 for (; $i <= $end; $i++) {
  618.                     ($stop,$action) = split(/\0/, $dbline{$i});
  619.                     $arrow = ($i==$line 
  620.                       and $filename eq $filename_ini) 
  621.                   ?  '==>' 
  622.                     : ($dbline[$i]+0 ? ':' : ' ') ;
  623.                 $arrow .= 'b' if $stop;
  624.                 $arrow .= 'a' if $action;
  625.                 print $OUT "$i$arrow\t", $dbline[$i];
  626.                 last if $signal;
  627.                 }
  628.             }
  629.             $start = $i; # remember in case they want more
  630.             $start = $max if $start > $max;
  631.             next CMD; };
  632.             $cmd =~ /^D$/ && do {
  633.               print $OUT "Deleting all breakpoints...\n";
  634.               my $file;
  635.               for $file (keys %had_breakpoints) {
  636.             local *dbline = $main::{'_<' . $file};
  637.             my $max = $#dbline;
  638.             my $was;
  639.             
  640.             for ($i = 1; $i <= $max ; $i++) {
  641.                 if (defined $dbline{$i}) {
  642.                 $dbline{$i} =~ s/^[^\0]+//;
  643.                 if ($dbline{$i} =~ s/^\0?$//) {
  644.                     delete $dbline{$i};
  645.                 }
  646.                 }
  647.             }
  648.               }
  649.               undef %postponed;
  650.               undef %postponed_file;
  651.               undef %break_on_load;
  652.               undef %had_breakpoints;
  653.               next CMD; };
  654.             $cmd =~ /^L$/ && do {
  655.               my $file;
  656.               for $file (keys %had_breakpoints) {
  657.             local *dbline = $main::{'_<' . $file};
  658.             my $max = $#dbline;
  659.             my $was;
  660.             
  661.             for ($i = 1; $i <= $max; $i++) {
  662.                 if (defined $dbline{$i}) {
  663.                     print "$file:\n" unless $was++;
  664.                 print $OUT " $i:\t", $dbline[$i];
  665.                 ($stop,$action) = split(/\0/, $dbline{$i});
  666.                 print $OUT "   break if (", $stop, ")\n"
  667.                   if $stop;
  668.                 print $OUT "   action:  ", $action, "\n"
  669.                   if $action;
  670.                 last if $signal;
  671.                 }
  672.             }
  673.               }
  674.               if (%postponed) {
  675.             print $OUT "Postponed breakpoints in subroutines:\n";
  676.             my $subname;
  677.             for $subname (keys %postponed) {
  678.               print $OUT " $subname\t$postponed{$subname}\n";
  679.               last if $signal;
  680.             }
  681.               }
  682.               my @have = map { # Combined keys
  683.             keys %{$postponed_file{$_}}
  684.               } keys %postponed_file;
  685.               if (@have) {
  686.             print $OUT "Postponed breakpoints in files:\n";
  687.             my ($file, $line);
  688.             for $file (keys %postponed_file) {
  689.               my $db = $postponed_file{$file};
  690.               print $OUT " $file:\n";
  691.               for $line (sort {$a <=> $b} keys %$db) {
  692.                 print $OUT "  $line:\n";
  693.                 my ($stop,$action) = split(/\0/, $$db{$line});
  694.                 print $OUT "    break if (", $stop, ")\n"
  695.                   if $stop;
  696.                 print $OUT "    action:  ", $action, "\n"
  697.                   if $action;
  698.                 last if $signal;
  699.               }
  700.               last if $signal;
  701.             }
  702.               }
  703.               if (%break_on_load) {
  704.             print $OUT "Breakpoints on load:\n";
  705.             my $file;
  706.             for $file (keys %break_on_load) {
  707.               print $OUT " $file\n";
  708.               last if $signal;
  709.             }
  710.               }
  711.               if ($trace & 2) {
  712.             print $OUT "Watch-expressions:\n";
  713.             my $expr;
  714.             for $expr (@to_watch) {
  715.               print $OUT " $expr\n";
  716.               last if $signal;
  717.             }
  718.               }
  719.               next CMD; };
  720.             $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
  721.             my $file = $1; $file =~ s/\s+$//;
  722.             {
  723.               $break_on_load{$file} = 1;
  724.               $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
  725.               $file .= '.pm', redo unless $file =~ /\./;
  726.             }
  727.             $had_breakpoints{$file} = 1;
  728.             print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
  729.             next CMD; };
  730.             $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
  731.             my $cond = $3 || '1';
  732.             my ($subname, $break) = ($2, $1 eq 'postpone');
  733.             $subname =~ s/\'/::/;
  734.             $subname = "${'package'}::" . $subname
  735.               unless $subname =~ /::/;
  736.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  737.             $postponed{$subname} = $break 
  738.               ? "break +0 if $cond" : "compile";
  739.             next CMD; };
  740.             $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
  741.             $subname = $1;
  742.             $cond = $2 || '1';
  743.             $subname =~ s/\'/::/;
  744.             $subname = "${'package'}::" . $subname
  745.               unless $subname =~ /::/;
  746.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  747.             # Filename below can contain ':'
  748.             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
  749.             $i += 0;
  750.             if ($i) {
  751.                 $filename = $file;
  752.                 *dbline = $main::{'_<' . $filename};
  753.                 $had_breakpoints{$filename} = 1;
  754.                 $max = $#dbline;
  755.                 ++$i while $dbline[$i] == 0 && $i < $max;
  756.                 $dbline{$i} =~ s/^[^\0]*/$cond/;
  757.             } else {
  758.                 print $OUT "Subroutine $subname not found.\n";
  759.             }
  760.             next CMD; };
  761.             $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
  762.             $i = ($1?$1:$line);
  763.             $cond = $2 || '1';
  764.             if ($dbline[$i] == 0) {
  765.                 print $OUT "Line $i not breakable.\n";
  766.             } else {
  767.                 $had_breakpoints{$filename} = 1;
  768.                 $dbline{$i} =~ s/^[^\0]*/$cond/;
  769.             }
  770.             next CMD; };
  771.             $cmd =~ /^d\b\s*(\d+)?/ && do {
  772.             $i = ($1?$1:$line);
  773.             $dbline{$i} =~ s/^[^\0]*//;
  774.             delete $dbline{$i} if $dbline{$i} eq '';
  775.             next CMD; };
  776.             $cmd =~ /^A$/ && do {
  777.               my $file;
  778.               for $file (keys %had_breakpoints) {
  779.             local *dbline = $main::{'_<' . $file};
  780.             my $max = $#dbline;
  781.             my $was;
  782.             
  783.             for ($i = 1; $i <= $max ; $i++) {
  784.                 if (defined $dbline{$i}) {
  785.                 $dbline{$i} =~ s/\0[^\0]*//;
  786.                 delete $dbline{$i} if $dbline{$i} eq '';
  787.                 }
  788.             }
  789.               }
  790.               next CMD; };
  791.             $cmd =~ /^O\s*$/ && do {
  792.             for (@options) {
  793.                 &dump_option($_);
  794.             }
  795.             next CMD; };
  796.             $cmd =~ /^O\s*(\S.*)/ && do {
  797.             parse_options($1);
  798.             next CMD; };
  799.             $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
  800.             push @$pre, action($1);
  801.             next CMD; };
  802.             $cmd =~ /^>>\s*(.*)/ && do {
  803.             push @$post, action($1);
  804.             next CMD; };
  805.             $cmd =~ /^<\s*(.*)/ && do {
  806.                 $pre = [], next CMD unless $1;
  807.             $pre = [action($1)];
  808.             next CMD; };
  809.             $cmd =~ /^>\s*(.*)/ && do {
  810.                 $post = [], next CMD unless $1;
  811.             $post = [action($1)];
  812.             next CMD; };
  813.             $cmd =~ /^\{\{\s*(.*)/ && do {
  814.             push @$pretype, $1;
  815.             next CMD; };
  816.             $cmd =~ /^\{\s*(.*)/ && do {
  817.                 $pretype = [], next CMD unless $1;
  818.             $pretype = [$1];
  819.             next CMD; };
  820.             $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
  821.             $i = $1; $j = $3;
  822.             if ($dbline[$i] == 0) {
  823.                 print $OUT "Line $i may not have an action.\n";
  824.             } else {
  825.                 $dbline{$i} =~ s/\0[^\0]*//;
  826.                 $dbline{$i} .= "\0" . action($j);
  827.             }
  828.             next CMD; };
  829.             $cmd =~ /^n$/ && do {
  830.                 end_report(), next CMD if $finished and $level <= 1;
  831.             $single = 2;
  832.             $laststep = $cmd;
  833.             last CMD; };
  834.             $cmd =~ /^s$/ && do {
  835.                 end_report(), next CMD if $finished and $level <= 1;
  836.             $single = 1;
  837.             $laststep = $cmd;
  838.             last CMD; };
  839.             $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
  840.                 end_report(), next CMD if $finished and $level <= 1;
  841.             $subname = $i = $1;
  842.             if ($i =~ /\D/) { # subroutine name
  843.                 $subname = $package."::".$subname 
  844.                     unless $subname =~ /::/;
  845.                 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
  846.                 $i += 0;
  847.                 if ($i) {
  848.                     $filename = $file;
  849.                 *dbline = $main::{'_<' . $filename};
  850.                 $had_breakpoints{$filename}++;
  851.                 $max = $#dbline;
  852.                 ++$i while $dbline[$i] == 0 && $i < $max;
  853.                 } else {
  854.                 print $OUT "Subroutine $subname not found.\n";
  855.                 next CMD; 
  856.                 }
  857.             }
  858.             if ($i) {
  859.                 if ($dbline[$i] == 0) {
  860.                 print $OUT "Line $i not breakable.\n";
  861.                 next CMD;
  862.                 }
  863.                 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
  864.             }
  865.             for ($i=0; $i <= $#stack; ) {
  866.                 $stack[$i++] &= ~1;
  867.             }
  868.             last CMD; };
  869.             $cmd =~ /^r$/ && do {
  870.                 end_report(), next CMD if $finished and $level <= 1;
  871.             $stack[$#stack] |= 1;
  872.             $doret = $option{PrintRet} ? $#stack - 1 : -2;
  873.             last CMD; };
  874.             $cmd =~ /^R$/ && do {
  875.                 print $OUT "Warning: some settings and command-line options may be lost!\n";
  876.             my (@script, @flags, $cl);
  877.             push @flags, '-w' if $ini_warn;
  878.             # Put all the old includes at the start to get
  879.             # the same debugger.
  880.             for (@ini_INC) {
  881.               push @flags, '-I', $_;
  882.             }
  883.             # Arrange for setting the old INC:
  884.             set_list("PERLDB_INC", @ini_INC);
  885.             if ($0 eq '-e') {
  886.               for (1..$#{'::_<-e'}) { # The first line is PERL5DB
  887.                 chomp ($cl =  $ {'::_<-e'}[$_]);
  888.                 push @script, '-e', $cl;
  889.               }
  890.             } else {
  891.               @script = $0;
  892.             }
  893.             set_list("PERLDB_HIST", 
  894.                  $term->Features->{getHistory} 
  895.                  ? $term->GetHistory : @hist);
  896.             my @had_breakpoints = keys %had_breakpoints;
  897.             set_list("PERLDB_VISITED", @had_breakpoints);
  898.             set_list("PERLDB_OPT", %option);
  899.             set_list("PERLDB_ON_LOAD", %break_on_load);
  900.             my @hard;
  901.             for (0 .. $#had_breakpoints) {
  902.               my $file = $had_breakpoints[$_];
  903.               *dbline = $main::{'_<' . $file};
  904.               next unless %dbline or $postponed_file{$file};
  905.               (push @hard, $file), next 
  906.                 if $file =~ /^\(eval \d+\)$/;
  907.               my @add;
  908.               @add = %{$postponed_file{$file}}
  909.                 if $postponed_file{$file};
  910.               set_list("PERLDB_FILE_$_", %dbline, @add);
  911.             }
  912.             for (@hard) { # Yes, really-really...
  913.               # Find the subroutines in this eval
  914.               *dbline = $main::{'_<' . $_};
  915.               my ($quoted, $sub, %subs, $line) = quotemeta $_;
  916.               for $sub (keys %sub) {
  917.                 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
  918.                 $subs{$sub} = [$1, $2];
  919.               }
  920.               unless (%subs) {
  921.                 print $OUT
  922.                   "No subroutines in $_, ignoring breakpoints.\n";
  923.                 next;
  924.               }
  925.             LINES: for $line (keys %dbline) {
  926.                 # One breakpoint per sub only:
  927.                 my ($offset, $sub, $found);
  928.               SUBS: for $sub (keys %subs) {
  929.                   if ($subs{$sub}->[1] >= $line # Not after the subroutine
  930.                   and (not defined $offset # Not caught
  931.                        or $offset < 0 )) { # or badly caught
  932.                 $found = $sub;
  933.                 $offset = $line - $subs{$sub}->[0];
  934.                 $offset = "+$offset", last SUBS if $offset >= 0;
  935.                   }
  936.                 }
  937.                 if (defined $offset) {
  938.                   $postponed{$found} =
  939.                 "break $offset if $dbline{$line}";
  940.                 } else {
  941.                   print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
  942.                 }
  943.               }
  944.             }
  945.             set_list("PERLDB_POSTPONE", %postponed);
  946.             set_list("PERLDB_PRETYPE", @$pretype);
  947.             set_list("PERLDB_PRE", @$pre);
  948.             set_list("PERLDB_POST", @$post);
  949.             set_list("PERLDB_TYPEAHEAD", @typeahead);
  950.             $ENV{PERLDB_RESTART} = 1;
  951.             #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
  952.             exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
  953.             print $OUT "exec failed: $!\n";
  954.             last CMD; };
  955.             $cmd =~ /^T$/ && do {
  956.             print_trace($OUT, 1); # skip DB
  957.             next CMD; };
  958.             $cmd =~ /^W\s*$/ && do {
  959.             $trace &= ~2;
  960.             @to_watch = @old_watch = ();
  961.             next CMD; };
  962.             $cmd =~ /^W\b\s*(.*)/s && do {
  963.             push @to_watch, $1;
  964.             $evalarg = $1;
  965.             my ($val) = &eval;
  966.             $val = (defined $val) ? "'$val'" : 'undef' ;
  967.             push @old_watch, $val;
  968.             $trace |= 2;
  969.             next CMD; };
  970.             $cmd =~ /^\/(.*)$/ && do {
  971.             $inpat = $1;
  972.             $inpat =~ s:([^\\])/$:$1:;
  973.             if ($inpat ne "") {
  974.                 eval '$inpat =~ m'."\a$inpat\a";    
  975.                 if ($@ ne "") {
  976.                 print $OUT "$@";
  977.                 next CMD;
  978.                 }
  979.                 $pat = $inpat;
  980.             }
  981.             $end = $start;
  982.             $incr = -1;
  983.             eval '
  984.                 for (;;) {
  985.                 ++$start;
  986.                 $start = 1 if ($start > $max);
  987.                 last if ($start == $end);
  988.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  989.                     if ($emacs) {
  990.                     print $OUT "\032\032$filename:$start:0\n";
  991.                     } else {
  992.                     print $OUT "$start:\t", $dbline[$start], "\n";
  993.                     }
  994.                     last;
  995.                 }
  996.                 } ';
  997.             print $OUT "/$pat/: not found\n" if ($start == $end);
  998.             next CMD; };
  999.             $cmd =~ /^\?(.*)$/ && do {
  1000.             $inpat = $1;
  1001.             $inpat =~ s:([^\\])\?$:$1:;
  1002.             if ($inpat ne "") {
  1003.                 eval '$inpat =~ m'."\a$inpat\a";    
  1004.                 if ($@ ne "") {
  1005.                 print $OUT "$@";
  1006.                 next CMD;
  1007.                 }
  1008.                 $pat = $inpat;
  1009.             }
  1010.             $end = $start;
  1011.             $incr = -1;
  1012.             eval '
  1013.                 for (;;) {
  1014.                 --$start;
  1015.                 $start = $max if ($start <= 0);
  1016.                 last if ($start == $end);
  1017.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  1018.                     if ($emacs) {
  1019.                     print $OUT "\032\032$filename:$start:0\n";
  1020.                     } else {
  1021.                     print $OUT "$start:\t", $dbline[$start], "\n";
  1022.                     }
  1023.                     last;
  1024.                 }
  1025.                 } ';
  1026.             print $OUT "?$pat?: not found\n" if ($start == $end);
  1027.             next CMD; };
  1028.             $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
  1029.             pop(@hist) if length($cmd) > 1;
  1030.             $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
  1031.             $cmd = $hist[$i] . "\n";
  1032.             print $OUT $cmd;
  1033.             redo CMD; };
  1034.             $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
  1035.             &system($1);
  1036.             next CMD; };
  1037.             $cmd =~ /^$rc([^$rc].*)$/ && do {
  1038.             $pat = "^$1";
  1039.             pop(@hist) if length($cmd) > 1;
  1040.             for ($i = $#hist; $i; --$i) {
  1041.                 last if $hist[$i] =~ /$pat/;
  1042.             }
  1043.             if (!$i) {
  1044.                 print $OUT "No such command!\n\n";
  1045.                 next CMD;
  1046.             }
  1047.             $cmd = $hist[$i] . "\n";
  1048.             print $OUT $cmd;
  1049.             redo CMD; };
  1050.             $cmd =~ /^$sh$/ && do {
  1051.             &system($ENV{SHELL}||"/bin/sh");
  1052.             next CMD; };
  1053.             $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
  1054.             &system($ENV{SHELL}||"/bin/sh","-c",$1);
  1055.             next CMD; };
  1056.             $cmd =~ /^H\b\s*(-(\d+))?/ && do {
  1057.             $end = $2?($#hist-$2):0;
  1058.             $hist = 0 if $hist < 0;
  1059.             for ($i=$#hist; $i>$end; $i--) {
  1060.                 print $OUT "$i: ",$hist[$i],"\n"
  1061.                   unless $hist[$i] =~ /^.?$/;
  1062.             };
  1063.             next CMD; };
  1064.             $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
  1065.             $cmd =~ s/^p\b/print {\$DB::OUT} /;
  1066.             $cmd =~ /^=/ && do {
  1067.             if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
  1068.                 $alias{$k}="s~$k~$v~";
  1069.                 print $OUT "$k = $v\n";
  1070.             } elsif ($cmd =~ /^=\s*$/) {
  1071.                 foreach $k (sort keys(%alias)) {
  1072.                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
  1073.                     print $OUT "$k = $v\n";
  1074.                 } else {
  1075.                     print $OUT "$k\t$alias{$k}\n";
  1076.                 };
  1077.                 };
  1078.             };
  1079.             next CMD; };
  1080.             $cmd =~ /^\|\|?\s*[^|]/ && do {
  1081.             if ($pager =~ /^\|/) {
  1082.                 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
  1083.                 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  1084.             } else {
  1085.                 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
  1086.             }
  1087.             unless ($piped=open(OUT,$pager)) {
  1088.                 &warn("Can't pipe output to `$pager'");
  1089.                 if ($pager =~ /^\|/) {
  1090.                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  1091.                 open(STDOUT,">&SAVEOUT")
  1092.                   || &warn("Can't restore STDOUT");
  1093.                 close(SAVEOUT);
  1094.                 } else {
  1095.                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  1096.                 }
  1097.                 next CMD;
  1098.             }
  1099.             $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
  1100.               && "" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE};
  1101.             $selected= select(OUT);
  1102.             $|= 1;
  1103.             select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
  1104.             $cmd =~ s/^\|+\s*//;
  1105.             redo PIPE; };
  1106.             # XXX Local variants do not work!
  1107.             $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
  1108.             $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
  1109.             $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
  1110.         }        # PIPE:
  1111.         $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
  1112.         if ($onetimeDump) {
  1113.         $onetimeDump = undef;
  1114.         } elsif ($term_pid == $$) {
  1115.         print $OUT "\n";
  1116.         }
  1117.     } continue {        # CMD:
  1118.         if ($piped) {
  1119.         if ($pager =~ /^\|/) {
  1120.             $?= 0;  close(OUT) || &warn("Can't close DB::OUT");
  1121.             &warn( "Pager `$pager' failed: ",
  1122.               ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
  1123.               ( $? & 128 ) ? " (core dumped)" : "",
  1124.               ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
  1125.             open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  1126.             open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  1127.             $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
  1128.             # Will stop ignoring SIGPIPE if done like nohup(1)
  1129.             # does SIGINT but Perl doesn't give us a choice.
  1130.         } else {
  1131.             open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
  1132.         }
  1133.         close(SAVEOUT);
  1134.         select($selected), $selected= "" unless $selected eq "";
  1135.         $piped= "";
  1136.         }
  1137.     }            # CMD:
  1138.     $exiting = 1 unless defined $cmd;
  1139.     foreach $evalarg (@$post) {
  1140.       &eval;
  1141.     }
  1142.     }                # if ($single || $signal)
  1143.     ($@, $!, $,, $/, $\, $^W) = @saved;
  1144.     ();
  1145. }
  1146.  
  1147. # The following code may be executed now:
  1148. # BEGIN {warn 4}
  1149.  
  1150. sub sub {
  1151.     my ($al, $ret, @ret) = "";
  1152.     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
  1153.     $al = " for $$sub";
  1154.     }
  1155.     push(@stack, $single);
  1156.     $single &= 1;
  1157.     $single |= 4 if $#stack == $deep;
  1158.     ($frame & 4 
  1159.      ? ( (print $LINEINFO ' ' x ($#stack - 1), "in  "), 
  1160.      # Why -1? But it works! :-(
  1161.      print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1162.      : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
  1163.     if (wantarray) {
  1164.     @ret = &$sub;
  1165.     $single |= pop(@stack);
  1166.     ($frame & 4 
  1167.      ? ( (print $LINEINFO ' ' x $#stack, "out "), 
  1168.          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1169.      : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
  1170.     print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
  1171.             "list context return from $sub:\n"), dumpit( \@ret ),
  1172.       $doret = -2 if $doret eq $#stack or $frame & 16;
  1173.     @ret;
  1174.     } else {
  1175.         if (defined wantarray) {
  1176.         $ret = &$sub;
  1177.         } else {
  1178.             &$sub; undef $ret;
  1179.         };
  1180.     $single |= pop(@stack);
  1181.     ($frame & 4 
  1182.      ? ( (print $LINEINFO ' ' x $#stack, "out "), 
  1183.           print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1184.      : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
  1185.     print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
  1186.             "scalar context return from $sub: "), dumpit( $ret ),
  1187.       $doret = -2 if $doret eq $#stack or $frame & 16;
  1188.     $ret;
  1189.     }
  1190. }
  1191.  
  1192. sub save {
  1193.     @saved = ($@, $!, $,, $/, $\, $^W);
  1194.     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
  1195. }
  1196.  
  1197. # The following takes its argument via $evalarg to preserve current @_
  1198.  
  1199. sub eval {
  1200.     my @res;
  1201.     {
  1202.     local (@stack) = @stack; # guard against recursive debugging
  1203.     my $otrace = $trace;
  1204.     my $osingle = $single;
  1205.     my $od = $^D;
  1206.     @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
  1207.     $trace = $otrace;
  1208.     $single = $osingle;
  1209.     $^D = $od;
  1210.     }
  1211.     my $at = $@;
  1212.     local $saved[0];        # Preserve the old value of $@
  1213.     eval "&DB::save";
  1214.     if ($at) {
  1215.     print $OUT $at;
  1216.     } elsif ($onetimeDump eq 'dump') {
  1217.     dumpit(\@res);
  1218.     } elsif ($onetimeDump eq 'methods') {
  1219.     methods($res[0]);
  1220.     }
  1221.     @res;
  1222. }
  1223.  
  1224. sub postponed_sub {
  1225.   my $subname = shift;
  1226.   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
  1227.     my $offset = $1 || 0;
  1228.     # Filename below can contain ':'
  1229.     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
  1230.     if ($i) {
  1231.       $i += $offset;
  1232.       local *dbline = $main::{'_<' . $file};
  1233.       local $^W = 0;        # != 0 is magical below
  1234.       $had_breakpoints{$file}++;
  1235.       my $max = $#dbline;
  1236.       ++$i until $dbline[$i] != 0 or $i >= $max;
  1237.       $dbline{$i} = delete $postponed{$subname};
  1238.     } else {
  1239.       print $OUT "Subroutine $subname not found.\n";
  1240.     }
  1241.     return;
  1242.   }
  1243.   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
  1244.   #print $OUT "In postponed_sub for `$subname'.\n";
  1245. }
  1246.  
  1247. sub postponed {
  1248.   return &postponed_sub
  1249.     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
  1250.   # Cannot be done before the file is compiled
  1251.   local *dbline = shift;
  1252.   my $filename = $dbline;
  1253.   $filename =~ s/^_<//;
  1254.   $signal = 1, print $OUT "'$filename' loaded...\n"
  1255.     if $break_on_load{$filename};
  1256.   print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
  1257.   return unless $postponed_file{$filename};
  1258.   $had_breakpoints{$filename}++;
  1259.   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
  1260.   my $key;
  1261.   for $key (keys %{$postponed_file{$filename}}) {
  1262.     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
  1263.   }
  1264.   delete $postponed_file{$filename};
  1265. }
  1266.  
  1267. sub dumpit {
  1268.     local ($savout) = select($OUT);
  1269.     my $osingle = $single;
  1270.     my $otrace = $trace;
  1271.     $single = $trace = 0;
  1272.     local $frame = 0;
  1273.     local $doret = -2;
  1274.     unless (defined &main::dumpValue) {
  1275.     do 'dumpvar.pl';
  1276.     }
  1277.     if (defined &main::dumpValue) {
  1278.     &main::dumpValue(shift);
  1279.     } else {
  1280.     print $OUT "dumpvar.pl not available.\n";
  1281.     }
  1282.     $single = $osingle;
  1283.     $trace = $otrace;
  1284.     select ($savout);    
  1285. }
  1286.  
  1287. # Tied method do not create a context, so may get wrong message:
  1288.  
  1289. sub print_trace {
  1290.   my $fh = shift;
  1291.   my @sub = dump_trace($_[0] + 1, $_[1]);
  1292.   my $short = $_[2];        # Print short report, next one for sub name
  1293.   my $s;
  1294.   for ($i=0; $i <= $#sub; $i++) {
  1295.     last if $signal;
  1296.     local $" = ', ';
  1297.     my $args = defined $sub[$i]{args} 
  1298.     ? "(@{ $sub[$i]{args} })"
  1299.       : '' ;
  1300.     $args = (substr $args, 0, $maxtrace - 3) . '...' 
  1301.       if length $args > $maxtrace;
  1302.     my $file = $sub[$i]{file};
  1303.     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
  1304.     $s = $sub[$i]{sub};
  1305.     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;    
  1306.     if ($short) {
  1307.       my $sub = @_ >= 4 ? $_[3] : $s;
  1308.       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
  1309.     } else {
  1310.       print $fh "$sub[$i]{context} = $s$args" .
  1311.     " called from $file" . 
  1312.       " line $sub[$i]{line}\n";
  1313.     }
  1314.   }
  1315. }
  1316.  
  1317. sub dump_trace {
  1318.   my $skip = shift;
  1319.   my $count = shift || 1e9;
  1320.   $skip++;
  1321.   $count += $skip;
  1322.   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
  1323.   my $nothard = not $frame & 8;
  1324.   local $frame = 0;        # Do not want to trace this.
  1325.   my $otrace = $trace;
  1326.   $trace = 0;
  1327.   for ($i = $skip; 
  1328.        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); 
  1329.        $i++) {
  1330.     @a = ();
  1331.     for $arg (@args) {
  1332.       my $type;
  1333.       if (not defined $arg) {
  1334.     push @a, "undef";
  1335.       } elsif ($nothard and tied $arg) {
  1336.     push @a, "tied";
  1337.       } elsif ($nothard and $type = ref $arg) {
  1338.     push @a, "ref($type)";
  1339.       } else {
  1340.     local $_ = "$arg";    # Safe to stringify now - should not call f().
  1341.     s/([\'\\])/\\$1/g;
  1342.     s/(.*)/'$1'/s
  1343.       unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
  1344.     s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  1345.     s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  1346.     push(@a, $_);
  1347.       }
  1348.     }
  1349.     $context = $context ? '@' : "\$";
  1350.     $args = $h ? [@a] : undef;
  1351.     $e =~ s/\n\s*\;\s*\Z// if $e;
  1352.     $e =~ s/([\\\'])/\\$1/g if $e;
  1353.     if ($r) {
  1354.       $sub = "require '$e'";
  1355.     } elsif (defined $r) {
  1356.       $sub = "eval '$e'";
  1357.     } elsif ($sub eq '(eval)') {
  1358.       $sub = "eval {...}";
  1359.     }
  1360.     push(@sub, {context => $context, sub => $sub, args => $args,
  1361.         file => $file, line => $line});
  1362.     last if $signal;
  1363.   }
  1364.   $trace = $otrace;
  1365.   @sub;
  1366. }
  1367.  
  1368. sub action {
  1369.     my $action = shift;
  1370.     while ($action =~ s/\\$//) {
  1371.     #print $OUT "+ ";
  1372.     #$action .= "\n";
  1373.     $action .= &gets;
  1374.     }
  1375.     $action;
  1376. }
  1377.  
  1378. sub gets {
  1379.     local($.);
  1380.     #<IN>;
  1381.     &readline("cont: ");
  1382. }
  1383.  
  1384. sub system {
  1385.     # We save, change, then restore STDIN and STDOUT to avoid fork() since
  1386.     # many non-Unix systems can do system() but have problems with fork().
  1387.     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
  1388.     open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
  1389.     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
  1390.     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  1391.     system(@_);
  1392.     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
  1393.     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  1394.     close(SAVEIN); close(SAVEOUT);
  1395.     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
  1396.       ( $? & 128 ) ? " (core dumped)" : "",
  1397.       ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
  1398.     $?;
  1399. }
  1400.  
  1401. sub setterm {
  1402.     local $frame = 0;
  1403.     local $doret = -2;
  1404.     local @stack = @stack;        # Prevent growth by failing `use'.
  1405.     eval { require Term::ReadLine } or die $@;
  1406.     if ($notty) {
  1407.     if ($tty) {
  1408.         open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
  1409.         open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
  1410.         $IN = \*IN;
  1411.         $OUT = \*OUT;
  1412.         my $sel = select($OUT);
  1413.         $| = 1;
  1414.         select($sel);
  1415.     } else {
  1416.         eval "require Term::Rendezvous;" or die $@;
  1417.         my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
  1418.         my $term_rv = new Term::Rendezvous $rv;
  1419.         $IN = $term_rv->IN;
  1420.         $OUT = $term_rv->OUT;
  1421.     }
  1422.     }
  1423.     if (!$rl) {
  1424.     $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
  1425.     } else {
  1426.     $term = new Term::ReadLine 'perldb', $IN, $OUT;
  1427.  
  1428.     $rl_attribs = $term->Attribs;
  1429.     $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 
  1430.       if defined $rl_attribs->{basic_word_break_characters} 
  1431.         and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
  1432.     $rl_attribs->{special_prefixes} = '$@&%';
  1433.     $rl_attribs->{completer_word_break_characters} .= '$@&%';
  1434.     $rl_attribs->{completion_function} = \&db_complete; 
  1435.     }
  1436.     $LINEINFO = $OUT unless defined $LINEINFO;
  1437.     $lineinfo = $console unless defined $lineinfo;
  1438.     $term->MinLine(2);
  1439.     if ($term->Features->{setHistory} and "@hist" ne "?") {
  1440.       $term->SetHistory(@hist);
  1441.     }
  1442.     ornaments($ornaments) if defined $ornaments;
  1443.     $term_pid = $$;
  1444. }
  1445.  
  1446. sub resetterm {            # We forked, so we need a different TTY
  1447.     $term_pid = $$;
  1448.     if (defined &get_fork_TTY) {
  1449.       &get_fork_TTY;
  1450.     } elsif (not defined $fork_TTY 
  1451.          and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' 
  1452.          and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { 
  1453.         # Possibly _inside_ XTERM
  1454.         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
  1455.  sleep 10000000' |];
  1456.         $fork_TTY = <XT>;
  1457.         chomp $fork_TTY;
  1458.     }
  1459.     if (defined $fork_TTY) {
  1460.       TTY($fork_TTY);
  1461.       undef $fork_TTY;
  1462.     } else {
  1463.       print $OUT "Forked, but do not know how to change a TTY.\n",
  1464.           "Define \$DB::fork_TTY or get_fork_TTY().\n";
  1465.     }
  1466. }
  1467.  
  1468. sub readline {
  1469.   if (@typeahead) {
  1470.     my $left = @typeahead;
  1471.     my $got = shift @typeahead;
  1472.     print $OUT "auto(-$left)", shift, $got, "\n";
  1473.     $term->AddHistory($got) 
  1474.       if length($got) > 1 and defined $term->Features->{addHistory};
  1475.     return $got;
  1476.   }
  1477.   local $frame = 0;
  1478.   local $doret = -2;
  1479.   $term->readline(@_);
  1480. }
  1481.  
  1482. sub dump_option {
  1483.     my ($opt, $val)= @_;
  1484.     $val = option_val($opt,'N/A');
  1485.     $val =~ s/([\\\'])/\\$1/g;
  1486.     printf $OUT "%20s = '%s'\n", $opt, $val;
  1487. }
  1488.  
  1489. sub option_val {
  1490.     my ($opt, $default)= @_;
  1491.     my $val;
  1492.     if (defined $optionVars{$opt}
  1493.     and defined $ {$optionVars{$opt}}) {
  1494.     $val = $ {$optionVars{$opt}};
  1495.     } elsif (defined $optionAction{$opt}
  1496.     and defined &{$optionAction{$opt}}) {
  1497.     $val = &{$optionAction{$opt}}();
  1498.     } elsif (defined $optionAction{$opt}
  1499.          and not defined $option{$opt}
  1500.          or defined $optionVars{$opt}
  1501.          and not defined $ {$optionVars{$opt}}) {
  1502.     $val = $default;
  1503.     } else {
  1504.     $val = $option{$opt};
  1505.     }
  1506.     $val
  1507. }
  1508.  
  1509. sub parse_options {
  1510.     local($_)= @_;
  1511.     while ($_ ne "") {
  1512.     s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
  1513.     my ($opt,$sep) = ($1,$2);
  1514.     my $val;
  1515.     if ("?" eq $sep) {
  1516.         print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
  1517.           if /^\S/;
  1518.         #&dump_option($opt);
  1519.     } elsif ($sep !~ /\S/) {
  1520.         $val = "1";
  1521.     } elsif ($sep eq "=") {
  1522.         s/^(\S*)($|\s+)//;
  1523.         $val = $1;
  1524.     } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
  1525.         my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
  1526.         s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
  1527.           print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
  1528.         $val = $1;
  1529.         $val =~ s/\\([\\$end])/$1/g;
  1530.     }
  1531.     my ($option);
  1532.     my $matches =
  1533.       grep(  /^\Q$opt/ && ($option = $_),  @options  );
  1534.     $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
  1535.       unless $matches;
  1536.     print $OUT "Unknown option `$opt'\n" unless $matches;
  1537.     print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
  1538.     $option{$option} = $val if $matches == 1 and defined $val;
  1539.     eval "local \$frame = 0; local \$doret = -2; 
  1540.           require '$optionRequire{$option}'"
  1541.       if $matches == 1 and defined $optionRequire{$option} and defined $val;
  1542.     $ {$optionVars{$option}} = $val 
  1543.       if $matches == 1
  1544.         and defined $optionVars{$option} and defined $val;
  1545.     & {$optionAction{$option}} ($val) 
  1546.       if $matches == 1
  1547.         and defined $optionAction{$option}
  1548.           and defined &{$optionAction{$option}} and defined $val;
  1549.     &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
  1550.         s/^\s+//;
  1551.     }
  1552. }
  1553.  
  1554. sub set_list {
  1555.   my ($stem,@list) = @_;
  1556.   my $val;
  1557.   $ENV{"$ {stem}_n"} = @list;
  1558.   for $i (0 .. $#list) {
  1559.     $val = $list[$i];
  1560.     $val =~ s/\\/\\\\/g;
  1561.     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
  1562.     $ENV{"$ {stem}_$i"} = $val;
  1563.   }
  1564. }
  1565.  
  1566. sub get_list {
  1567.   my $stem = shift;
  1568.   my @list;
  1569.   my $n = delete $ENV{"$ {stem}_n"};
  1570.   my $val;
  1571.   for $i (0 .. $n - 1) {
  1572.     $val = delete $ENV{"$ {stem}_$i"};
  1573.     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
  1574.     push @list, $val;
  1575.   }
  1576.   @list;
  1577. }
  1578.  
  1579. sub catch {
  1580.     $signal = 1;
  1581.     return;            # Put nothing on the stack - malloc/free land!
  1582. }
  1583.  
  1584. sub warn {
  1585.     my($msg)= join("",@_);
  1586.     $msg .= ": $!\n" unless $msg =~ /\n$/;
  1587.     print $OUT $msg;
  1588. }
  1589.  
  1590. sub TTY {
  1591.     if (@_ and $term and $term->Features->{newTTY}) {
  1592.       my ($in, $out) = shift;
  1593.       if ($in =~ /,/) {
  1594.     ($in, $out) = split /,/, $in, 2;
  1595.       } else {
  1596.     $out = $in;
  1597.       }
  1598.       open IN, $in or die "cannot open `$in' for read: $!";
  1599.       open OUT, ">$out" or die "cannot open `$out' for write: $!";
  1600.       $term->newTTY(\*IN, \*OUT);
  1601.       $IN    = \*IN;
  1602.       $OUT    = \*OUT;
  1603.       return $tty = $in;
  1604.     } elsif ($term and @_) {
  1605.     &warn("Too late to set TTY, enabled on next `R'!\n");
  1606.     } 
  1607.     $tty = shift if @_;
  1608.     $tty or $console;
  1609. }
  1610.  
  1611. sub noTTY {
  1612.     if ($term) {
  1613.     &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
  1614.     }
  1615.     $notty = shift if @_;
  1616.     $notty;
  1617. }
  1618.  
  1619. sub ReadLine {
  1620.     if ($term) {
  1621.     &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
  1622.     }
  1623.     $rl = shift if @_;
  1624.     $rl;
  1625. }
  1626.  
  1627. sub tkRunning {
  1628.     if ($ {$term->Features}{tkRunning}) {
  1629.         return $term->tkRunning(@_);
  1630.     } else {
  1631.     print $OUT "tkRunning not supported by current ReadLine package.\n";
  1632.     0;
  1633.     }
  1634. }
  1635.  
  1636. sub NonStop {
  1637.     if ($term) {
  1638.     &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
  1639.     }
  1640.     $runnonstop = shift if @_;
  1641.     $runnonstop;
  1642. }
  1643.  
  1644. sub pager {
  1645.     if (@_) {
  1646.     $pager = shift;
  1647.     $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
  1648.     }
  1649.     $pager;
  1650. }
  1651.  
  1652. sub shellBang {
  1653.     if (@_) {
  1654.     $sh = quotemeta shift;
  1655.     $sh .= "\\b" if $sh =~ /\w$/;
  1656.     }
  1657.     $psh = $sh;
  1658.     $psh =~ s/\\b$//;
  1659.     $psh =~ s/\\(.)/$1/g;
  1660.     &sethelp;
  1661.     $psh;
  1662. }
  1663.  
  1664. sub ornaments {
  1665.   if (defined $term) {
  1666.     local ($warnLevel,$dieLevel) = (0, 1);
  1667.     return '' unless $term->Features->{ornaments};
  1668.     eval { $term->ornaments(@_) } || '';
  1669.   } else {
  1670.     $ornaments = shift;
  1671.   }
  1672. }
  1673.  
  1674. sub recallCommand {
  1675.     if (@_) {
  1676.     $rc = quotemeta shift;
  1677.     $rc .= "\\b" if $rc =~ /\w$/;
  1678.     }
  1679.     $prc = $rc;
  1680.     $prc =~ s/\\b$//;
  1681.     $prc =~ s/\\(.)/$1/g;
  1682.     &sethelp;
  1683.     $prc;
  1684. }
  1685.  
  1686. sub LineInfo {
  1687.     return $lineinfo unless @_;
  1688.     $lineinfo = shift;
  1689.     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
  1690.     $emacs = ($stream =~ /^\|/);
  1691.     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
  1692.     $LINEINFO = \*LINEINFO;
  1693.     my $save = select($LINEINFO);
  1694.     $| = 1;
  1695.     select($save);
  1696.     $lineinfo;
  1697. }
  1698.  
  1699. sub list_versions {
  1700.   my %version;
  1701.   my $file;
  1702.   for (keys %INC) {
  1703.     $file = $_;
  1704.     s,\.p[lm]$,,i ;
  1705.     s,/,::,g ;
  1706.     s/^perl5db$/DB/;
  1707.     s/^Term::ReadLine::readline$/readline/;
  1708.     if (defined $ { $_ . '::VERSION' }) {
  1709.       $version{$file} = "$ { $_ . '::VERSION' } from ";
  1710.     } 
  1711.     $version{$file} .= $INC{$file};
  1712.   }
  1713.   do 'dumpvar.pl' unless defined &main::dumpValue;
  1714.   if (defined &main::dumpValue) {
  1715.     local $frame = 0;
  1716.     &main::dumpValue(\%version);
  1717.   } else {
  1718.     print $OUT "dumpvar.pl not available.\n";
  1719.   }
  1720. }
  1721.  
  1722. sub sethelp {
  1723.     $help = "
  1724. B<T>        Stack trace.
  1725. B<s> [I<expr>]    Single step [in I<expr>].
  1726. B<n> [I<expr>]    Next, steps over subroutine calls [in I<expr>].
  1727. <B<CR>>        Repeat last B<n> or B<s> command.
  1728. B<r>        Return from current subroutine.
  1729. B<c> [I<line>|I<sub>]    Continue; optionally inserts a one-time-only breakpoint
  1730.         at the specified position.
  1731. B<l> I<min>B<+>I<incr>    List I<incr>+1 lines starting at I<min>.
  1732. B<l> I<min>B<->I<max>    List lines I<min> through I<max>.
  1733. B<l> I<line>        List single I<line>.
  1734. B<l> I<subname>    List first window of lines from subroutine.
  1735. B<l>        List next window of lines.
  1736. B<->        List previous window of lines.
  1737. B<w> [I<line>]    List window around I<line>.
  1738. B<.>        Return to the executed line.
  1739. B<f> I<filename>    Switch to viewing I<filename>. Must be loaded.
  1740. B</>I<pattern>B</>    Search forwards for I<pattern>; final B</> is optional.
  1741. B<?>I<pattern>B<?>    Search backwards for I<pattern>; final B<?> is optional.
  1742. B<L>        List all breakpoints and actions.
  1743. B<S> [[B<!>]I<pattern>]    List subroutine names [not] matching I<pattern>.
  1744. B<t>        Toggle trace mode.
  1745. B<t> I<expr>        Trace through execution of I<expr>.
  1746. B<b> [I<line>] [I<condition>]
  1747.         Set breakpoint; I<line> defaults to the current execution line;
  1748.         I<condition> breaks if it evaluates to true, defaults to '1'.
  1749. B<b> I<subname> [I<condition>]
  1750.         Set breakpoint at first line of subroutine.
  1751. B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
  1752. B<b> B<postpone> I<subname> [I<condition>]
  1753.         Set breakpoint at first line of subroutine after 
  1754.         it is compiled.
  1755. B<b> B<compile> I<subname>
  1756.         Stop after the subroutine is compiled.
  1757. B<d> [I<line>]    Delete the breakpoint for I<line>.
  1758. B<D>        Delete all breakpoints.
  1759. B<a> [I<line>] I<command>
  1760.         Set an action to be done before the I<line> is executed.
  1761.         Sequence is: check for breakpoint/watchpoint, print line
  1762.         if necessary, do action, prompt user if necessary,
  1763.         execute expression.
  1764. B<A>        Delete all actions.
  1765. B<W> I<expr>        Add a global watch-expression.
  1766. B<W>        Delete all watch-expressions.
  1767. B<V> [I<pkg> [I<vars>]]    List some (default all) variables in package (default current).
  1768.         Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
  1769. B<X> [I<vars>]    Same as \"B<V> I<currentpackage> [I<vars>]\".
  1770. B<x> I<expr>        Evals expression in array context, dumps the result.
  1771. B<m> I<expr>        Evals expression in array context, prints methods callable
  1772.         on the first element of the result.
  1773. B<m> I<class>        Prints methods callable via the given class.
  1774. B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
  1775.         Set or query values of options.  I<val> defaults to 1.  I<opt> can
  1776.         be abbreviated.  Several options can be listed.
  1777.     I<recallCommand>, I<ShellBang>:    chars used to recall command or spawn shell;
  1778.     I<pager>:            program for output of \"|cmd\";
  1779.     I<tkRunning>:            run Tk while prompting (with ReadLine);
  1780.     I<signalLevel> I<warnLevel> I<dieLevel>:    level of verbosity;
  1781.     I<inhibit_exit>        Allows stepping off the end of the script.
  1782.   The following options affect what happens with B<V>, B<X>, and B<x> commands:
  1783.     I<arrayDepth>, I<hashDepth>:    print only first N elements ('' for all);
  1784.     I<compactDump>, I<veryCompact>:    change style of array and hash dump;
  1785.     I<globPrint>:            whether to print contents of globs;
  1786.     I<DumpDBFiles>:        dump arrays holding debugged files;
  1787.     I<DumpPackages>:        dump symbol tables of packages;
  1788.     I<quote>, I<HighBit>, I<undefPrint>:    change style of string dump;
  1789.   Option I<PrintRet> affects printing of return value after B<r> command,
  1790.          I<frame>    affects printing messages on entry and exit from subroutines.
  1791.          I<AutoTrace> affects printing messages on every possible breaking point.
  1792.      I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
  1793.      I<ornaments> affects screen appearance of the command line.
  1794.         During startup options are initialized from \$ENV{PERLDB_OPTS}.
  1795.         You can put additional initialization options I<TTY>, I<noTTY>,
  1796.         I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
  1797. B<<> I<expr>        Define Perl command to run before each prompt.
  1798. B<<<> I<expr>        Add to the list of Perl commands to run before each prompt.
  1799. B<>> I<expr>        Define Perl command to run after each prompt.
  1800. B<>>B<>> I<expr>    Add to the list of Perl commands to run after each prompt.
  1801. B<{> I<db_command>    Define debugger command to run before each prompt.
  1802. B<{{> I<db_command>    Add to the list of debugger commands to run before each prompt.
  1803. B<$prc> I<number>    Redo a previous command (default previous command).
  1804. B<$prc> I<-number>    Redo number'th-to-last command.
  1805. B<$prc> I<pattern>    Redo last command that started with I<pattern>.
  1806.         See 'B<O> I<recallCommand>' too.
  1807. B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
  1808.   . ( $rc eq $sh ? "" : "
  1809. B<$psh> [I<cmd>]     Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
  1810.         See 'B<O> I<shellBang>' too.
  1811. B<H> I<-number>    Display last number commands (default all).
  1812. B<p> I<expr>        Same as \"I<print {DB::OUT} expr>\" in current package.
  1813. B<|>I<dbcmd>        Run debugger command, piping DB::OUT to current pager.
  1814. B<||>I<dbcmd>        Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
  1815. B<\=> [I<alias> I<value>]    Define a command alias, or list current aliases.
  1816. I<command>        Execute as a perl statement in current package.
  1817. B<v>        Show versions of loaded modules.
  1818. B<R>        Pure-man-restart of debugger, some of debugger state
  1819.         and command-line options may be lost.
  1820.         Currently the following setting are preserved: 
  1821.         history, breakpoints and actions, debugger B<O>ptions 
  1822.         and the following command-line options: I<-w>, I<-I>, I<-e>.
  1823. B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
  1824. B<h h>        Summary of debugger commands.
  1825. B<q> or B<^D>        Quit. Set \$DB::finished to 0 to debug global destruction.
  1826.  
  1827. ";
  1828.     $summary = <<"END_SUM";
  1829. I<List/search source lines:>               I<Control script execution:>
  1830.   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
  1831.   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
  1832.   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
  1833.   B<f> I<filename>  View source in file         <B<CR>>        Repeat last B<n> or B<s>
  1834.   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
  1835.   B<v>          Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
  1836. I<Debugger controls:>                        B<L>           List break/watch/actions
  1837.   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
  1838.   B<<>[B<<>] or B<{>[B<{>] [I<cmd>]   Do before prompt   B<b> [I<ln>|I<event>] [I<cnd>]  Set breakpoint
  1839.   B<>>[B<>>] [I<cmd>]  Do after prompt             B<b> I<sub> [I<cnd>] Set breakpoint for sub
  1840.   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
  1841.   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
  1842.   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
  1843.   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
  1844.   B<|>[B<|>]I<dbcmd>   Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
  1845.   B<q> or B<^D>     Quit              B<R>          Attempt a restart
  1846. I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
  1847.   B<x>|B<m> I<expr>    Evals expr in array context, dumps the result or lists methods.
  1848.   B<p> I<expr>    Print expression (uses script's current package).
  1849.   B<S> [[B<!>]I<pat>]    List subroutine names [not] matching pattern
  1850.   B<V> [I<Pk> [I<Vars>]]    List Variables in Package.  Vars can be ~pattern or !pattern.
  1851.   B<X> [I<Vars>]    Same as \"B<V> I<current_package> [I<Vars>]\".
  1852. END_SUM
  1853.                 # ')}}; # Fix balance of Emacs parsing
  1854. }
  1855.  
  1856. sub print_help {
  1857.   my $message = shift;
  1858.   if (@Term::ReadLine::TermCap::rl_term_set) {
  1859.     $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
  1860.     $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
  1861.   }
  1862.   print $OUT $message;
  1863. }
  1864.  
  1865. sub diesignal {
  1866.     local $frame = 0;
  1867.     local $doret = -2;
  1868.     $SIG{'ABRT'} = 'DEFAULT';
  1869.     kill 'ABRT', $$ if $panic++;
  1870.     if (defined &Carp::longmess) {
  1871.     local $SIG{__WARN__} = '';
  1872.     local $Carp::CarpLevel = 2;        # mydie + confess
  1873.     &warn(Carp::longmess("Signal @_"));
  1874.     }
  1875.     else {
  1876.     print $DB::OUT "Got signal @_\n";
  1877.     }
  1878.     kill 'ABRT', $$;
  1879. }
  1880.  
  1881. sub dbwarn { 
  1882.   local $frame = 0;
  1883.   local $doret = -2;
  1884.   local $SIG{__WARN__} = '';
  1885.   local $SIG{__DIE__} = '';
  1886.   eval { require Carp } if defined $^S;    # If error/warning during compilation,
  1887.                                         # require may be broken.
  1888.   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
  1889.     return unless defined &Carp::longmess;
  1890.   my ($mysingle,$mytrace) = ($single,$trace);
  1891.   $single = 0; $trace = 0;
  1892.   my $mess = Carp::longmess(@_);
  1893.   ($single,$trace) = ($mysingle,$mytrace);
  1894.   &warn($mess); 
  1895. }
  1896.  
  1897. sub dbdie {
  1898.   local $frame = 0;
  1899.   local $doret = -2;
  1900.   local $SIG{__DIE__} = '';
  1901.   local $SIG{__WARN__} = '';
  1902.   my $i = 0; my $ineval = 0; my $sub;
  1903.   if ($dieLevel > 2) {
  1904.       local $SIG{__WARN__} = \&dbwarn;
  1905.       &warn(@_);        # Yell no matter what
  1906.       return;
  1907.   }
  1908.   if ($dieLevel < 2) {
  1909.     die @_ if $^S;        # in eval propagate
  1910.   }
  1911.   eval { require Carp } if defined $^S;    # If error/warning during compilation,
  1912.                                     # require may be broken.
  1913.   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
  1914.     unless defined &Carp::longmess;
  1915.   # We do not want to debug this chunk (automatic disabling works
  1916.   # inside DB::DB, but not in Carp).
  1917.   my ($mysingle,$mytrace) = ($single,$trace);
  1918.   $single = 0; $trace = 0;
  1919.   my $mess = Carp::longmess(@_);
  1920.   ($single,$trace) = ($mysingle,$mytrace);
  1921.   die $mess;
  1922. }
  1923.  
  1924. sub warnLevel {
  1925.   if (@_) {
  1926.     $prevwarn = $SIG{__WARN__} unless $warnLevel;
  1927.     $warnLevel = shift;
  1928.     if ($warnLevel) {
  1929.       $SIG{__WARN__} = \&DB::dbwarn;
  1930.     } else {
  1931.       $SIG{__WARN__} = $prevwarn;
  1932.     }
  1933.   }
  1934.   $warnLevel;
  1935. }
  1936.  
  1937. sub dieLevel {
  1938.   if (@_) {
  1939.     $prevdie = $SIG{__DIE__} unless $dieLevel;
  1940.     $dieLevel = shift;
  1941.     if ($dieLevel) {
  1942.       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
  1943.       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
  1944.       print $OUT "Stack dump during die enabled", 
  1945.         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
  1946.       if $I_m_init;
  1947.       print $OUT "Dump printed too.\n" if $dieLevel > 2;
  1948.     } else {
  1949.       $SIG{__DIE__} = $prevdie;
  1950.       print $OUT "Default die handler restored.\n";
  1951.     }
  1952.   }
  1953.   $dieLevel;
  1954. }
  1955.  
  1956. sub signalLevel {
  1957.   if (@_) {
  1958.     $prevsegv = $SIG{SEGV} unless $signalLevel;
  1959.     $prevbus = $SIG{BUS} unless $signalLevel;
  1960.     $signalLevel = shift;
  1961.     if ($signalLevel) {
  1962.       $SIG{SEGV} = \&DB::diesignal;
  1963.       $SIG{BUS} = \&DB::diesignal;
  1964.     } else {
  1965.       $SIG{SEGV} = $prevsegv;
  1966.       $SIG{BUS} = $prevbus;
  1967.     }
  1968.   }
  1969.   $signalLevel;
  1970. }
  1971.  
  1972. sub find_sub {
  1973.   my $subr = shift;
  1974.   return unless defined &$subr;
  1975.   $sub{$subr} or do {
  1976.     $subr = \&$subr;        # Hard reference
  1977.     my $s;
  1978.     for (keys %sub) {
  1979.       $s = $_, last if $subr eq \&$_;
  1980.     }
  1981.     $sub{$s} if $s;
  1982.   }
  1983. }
  1984.  
  1985. sub methods {
  1986.   my $class = shift;
  1987.   $class = ref $class if ref $class;
  1988.   local %seen;
  1989.   local %packs;
  1990.   methods_via($class, '', 1);
  1991.   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
  1992. }
  1993.  
  1994. sub methods_via {
  1995.   my $class = shift;
  1996.   return if $packs{$class}++;
  1997.   my $prefix = shift;
  1998.   my $prepend = $prefix ? "via $prefix: " : '';
  1999.   my $name;
  2000.   for $name (grep {defined &{$ {"$ {class}::"}{$_}}} 
  2001.          sort keys %{"$ {class}::"}) {
  2002.     next if $seen{ $name }++;
  2003.     print $DB::OUT "$prepend$name\n";
  2004.   }
  2005.   return unless shift;        # Recurse?
  2006.   for $name (@{"$ {class}::ISA"}) {
  2007.     $prepend = $prefix ? $prefix . " -> $name" : $name;
  2008.     methods_via($name, $prepend, 1);
  2009.   }
  2010. }
  2011.  
  2012. # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
  2013.  
  2014. BEGIN {            # This does not compile, alas.
  2015.   $IN = \*STDIN;        # For bugs before DB::OUT has been opened
  2016.   $OUT = \*STDERR;        # For errors before DB::OUT has been opened
  2017.   $sh = '!';
  2018.   $rc = ',';
  2019.   @hist = ('?');
  2020.   $deep = 100;            # warning if stack gets this deep
  2021.   $window = 10;
  2022.   $preview = 3;
  2023.   $sub = '';
  2024.   $SIG{INT} = \&DB::catch;
  2025.   # This may be enabled to debug debugger:
  2026.   #$warnLevel = 1 unless defined $warnLevel;
  2027.   #$dieLevel = 1 unless defined $dieLevel;
  2028.   #$signalLevel = 1 unless defined $signalLevel;
  2029.  
  2030.   $db_stop = 0;            # Compiler warning
  2031.   $db_stop = 1 << 30;
  2032.   $level = 0;            # Level of recursive debugging
  2033.   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
  2034.   # Triggers bug (?) in perl is we postpone this until runtime:
  2035.   @postponed = @stack = (0);
  2036.   $doret = -2;
  2037.   $frame = 0;
  2038. }
  2039.  
  2040. BEGIN {$^W = $ini_warn;}    # Switch warnings back
  2041.  
  2042. #use Carp;            # This did break, left for debuggin
  2043.  
  2044. sub db_complete {
  2045.   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
  2046.   my($text, $line, $start) = @_;
  2047.   my ($itext, $search, $prefix, $pack) =
  2048.     ($text, "^\Q$ {'package'}::\E([^:]+)\$");
  2049.   
  2050.   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
  2051.                                (map { /$search/ ? ($1) : () } keys %sub)
  2052.     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
  2053.   return sort grep /^\Q$text/, values %INC # files
  2054.     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
  2055.   return sort map {($_, db_complete($_ . "::", "V ", 2))}
  2056.     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
  2057.       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
  2058.   return sort map {($_, db_complete($_ . "::", "V ", 2))}
  2059.     grep !/^main::/,
  2060.       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
  2061.                  # packages
  2062.     if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ 
  2063.       and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
  2064.   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
  2065.     # We may want to complete to (eval 9), so $text may be wrong
  2066.     $prefix = length($1) - length($text);
  2067.     $text = $1;
  2068.     return sort 
  2069.     map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
  2070.   }
  2071.   if ((substr $text, 0, 1) eq '&') { # subroutines
  2072.     $text = substr $text, 1;
  2073.     $prefix = "&";
  2074.     return sort map "$prefix$_", 
  2075.                grep /^\Q$text/, 
  2076.                  (keys %sub),
  2077.                  (map { /$search/ ? ($1) : () } 
  2078.             keys %sub);
  2079.   }
  2080.   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
  2081.     $pack = ($1 eq 'main' ? '' : $1) . '::';
  2082.     $prefix = (substr $text, 0, 1) . $1 . '::';
  2083.     $text = $2;
  2084.     my @out 
  2085.       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
  2086.     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
  2087.       return db_complete($out[0], $line, $start);
  2088.     }
  2089.     return sort @out;
  2090.   }
  2091.   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
  2092.     $pack = ($package eq 'main' ? '' : $package) . '::';
  2093.     $prefix = substr $text, 0, 1;
  2094.     $text = substr $text, 1;
  2095.     my @out = map "$prefix$_", grep /^\Q$text/, 
  2096.        (grep /^_?[a-zA-Z]/, keys %$pack), 
  2097.        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
  2098.     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
  2099.       return db_complete($out[0], $line, $start);
  2100.     }
  2101.     return sort @out;
  2102.   }
  2103.   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
  2104.     my @out = grep /^\Q$text/, @options;
  2105.     my $val = option_val($out[0], undef);
  2106.     my $out = '? ';
  2107.     if (not defined $val or $val =~ /[\n\r]/) {
  2108.       # Can do nothing better
  2109.     } elsif ($val =~ /\s/) {
  2110.       my $found;
  2111.       foreach $l (split //, qq/\"\'\#\|/) {
  2112.     $out = "$l$val$l ", last if (index $val, $l) == -1;
  2113.       }
  2114.     } else {
  2115.       $out = "=$val ";
  2116.     }
  2117.     # Default to value if one completion, to question if many
  2118.     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
  2119.     return sort @out;
  2120.   }
  2121.   return $term->filename_list($text); # filenames
  2122. }
  2123.  
  2124. sub end_report {
  2125.   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
  2126. }
  2127.  
  2128. END {
  2129.   $finished = $inhibit_exit;    # So that some keys may be disabled.
  2130.   # Do not stop in at_exit() and destructors on exit:
  2131.   $DB::single = !$exiting && !$runnonstop;
  2132.   DB::fake::at_exit() unless $exiting or $runnonstop;
  2133. }
  2134.  
  2135. package DB::fake;
  2136.  
  2137. sub at_exit {
  2138.   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
  2139. }
  2140.  
  2141. package DB;            # Do not trace this 1; below!
  2142.  
  2143. 1;
  2144.