home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / perl5db.pl < prev    next >
Encoding:
Perl Script  |  2002-06-19  |  118.8 KB  |  3,592 lines
  1. package DB;
  2.  
  3. # Debugger for Perl 5.00x; perl5db.pl patch level:
  4. $VERSION = 1.19;
  5. $header  = "perl5db.pl version $VERSION";
  6.  
  7. # It is crucial that there is no lexicals in scope of `eval ""' down below
  8. sub eval {
  9.     # 'my' would make it visible from user code
  10.     #    but so does local! --tchrist  [... into @DB::res, not @res. IZ]
  11.     local @res;
  12.     {
  13.     local $otrace = $trace;
  14.     local $osingle = $single;
  15.     local $od = $^D;
  16.     { ($evalarg) = $evalarg =~ /(.*)/s; }
  17.     @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
  18.     $trace = $otrace;
  19.     $single = $osingle;
  20.     $^D = $od;
  21.     }
  22.     my $at = $@;
  23.     local $saved[0];        # Preserve the old value of $@
  24.     eval { &DB::save };
  25.     if ($at) {
  26.     local $\ = '';
  27.     print $OUT $at;
  28.     } elsif ($onetimeDump) {
  29.       if ($onetimeDump eq 'dump')  {
  30.         local $option{dumpDepth} = $onetimedumpDepth 
  31.           if defined $onetimedumpDepth;
  32.     dumpit($OUT, \@res);
  33.       } elsif ($onetimeDump eq 'methods') {
  34.     methods($res[0]) ;
  35.       }
  36.     }
  37.     @res;
  38. }
  39.  
  40. # After this point it is safe to introduce lexicals
  41. # However, one should not overdo it: leave as much control from outside as possible
  42. #
  43. # This file is automatically included if you do perl -d.
  44. # It's probably not useful to include this yourself.
  45. #
  46. # Before venturing further into these twisty passages, it is 
  47. # wise to read the perldebguts man page or risk the ire of dragons.
  48. #
  49. # Perl supplies the values for %sub.  It effectively inserts
  50. # a &DB::DB(); in front of every place that can have a
  51. # breakpoint. Instead of a subroutine call it calls &DB::sub with
  52. # $DB::sub being the called subroutine. It also inserts a BEGIN
  53. # {require 'perl5db.pl'} before the first line.
  54. #
  55. # After each `require'd file is compiled, but before it is executed, a
  56. # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
  57. # $filename is the expanded name of the `require'd file (as found as
  58. # value of %INC).
  59. #
  60. # Additional services from Perl interpreter:
  61. #
  62. # if caller() is called from the package DB, it provides some
  63. # additional data.
  64. #
  65. # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
  66. # line-by-line contents of $filename.
  67. #
  68. # The hash %{'_<'.$filename} (herein called %dbline) contains
  69. # breakpoints and action (it is keyed by line number), and individual
  70. # entries are settable (as opposed to the whole hash). Only true/false
  71. # is important to the interpreter, though the values used by
  72. # perl5db.pl have the form "$break_condition\0$action". Values are
  73. # magical in numeric context.
  74. #
  75. # The scalar ${'_<'.$filename} contains $filename.
  76. #
  77. # Note that no subroutine call is possible until &DB::sub is defined
  78. # (for subroutines defined outside of the package DB). In fact the same is
  79. # true if $deep is not defined.
  80. #
  81. # $Log:    perldb.pl,v $
  82.  
  83. #
  84. # At start reads $rcfile that may set important options.  This file
  85. # may define a subroutine &afterinit that will be executed after the
  86. # debugger is initialized.
  87. #
  88. # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  89. # it as a rest of `O ...' line in debugger prompt.
  90. #
  91. # The options that can be specified only at startup:
  92. # [To set in $rcfile, call &parse_options("optionName=new_value").]
  93. #
  94. # TTY  - the TTY to use for debugging i/o.
  95. #
  96. # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  97. # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  98. # Term::Rendezvous.  Current variant is to have the name of TTY in this
  99. # file.
  100. #
  101. # ReadLine - If false, dummy ReadLine is used, so you can debug
  102. # ReadLine applications.
  103. #
  104. # NonStop - if true, no i/o is performed until interrupt.
  105. #
  106. # LineInfo - file or pipe to print line number info to.  If it is a
  107. # pipe, a short "emacs like" message is used.
  108. #
  109. # RemotePort - host:port to connect to on remote host for remote debugging.
  110. #
  111. # Example $rcfile: (delete leading hashes!)
  112. #
  113. # &parse_options("NonStop=1 LineInfo=db.out");
  114. # sub afterinit { $trace = 1; }
  115. #
  116. # The script will run without human intervention, putting trace
  117. # information into db.out.  (If you interrupt it, you would better
  118. # reset LineInfo to something "interactive"!)
  119. #
  120. ##################################################################
  121.  
  122. # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
  123.  
  124. # modified Perl debugger, to be run from Emacs in perldb-mode
  125. # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  126. # Johan Vromans -- upgrade to 4.0 pl 10
  127. # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  128.  
  129. # Changelog:
  130.  
  131. # A lot of things changed after 0.94. First of all, core now informs
  132. # debugger about entry into XSUBs, overloaded operators, tied operations,
  133. # BEGIN and END. Handy with `O f=2'.
  134.  
  135. # This can make debugger a little bit too verbose, please be patient
  136. # and report your problems promptly.
  137.  
  138. # Now the option frame has 3 values: 0,1,2.
  139.  
  140. # Note that if DESTROY returns a reference to the object (or object),
  141. # the deletion of data may be postponed until the next function call,
  142. # due to the need to examine the return value.
  143.  
  144. # Changes: 0.95: `v' command shows versions.
  145. # Changes: 0.96: `v' command shows version of readline.
  146. #    primitive completion works (dynamic variables, subs for `b' and `l',
  147. #        options). Can `p %var'
  148. #    Better help (`h <' now works). New commands <<, >>, {, {{.
  149. #    {dump|print}_trace() coded (to be able to do it from <<cmd).
  150. #    `c sub' documented.
  151. #    At last enough magic combined to stop after the end of debuggee.
  152. #    !! should work now (thanks to Emacs bracket matching an extra
  153. #    `]' in a regexp is caught).
  154. #    `L', `D' and `A' span files now (as documented).
  155. #    Breakpoints in `require'd code are possible (used in `R').
  156. #    Some additional words on internal work of debugger.
  157. #    `b load filename' implemented.
  158. #    `b postpone subr' implemented.
  159. #    now only `q' exits debugger (overwritable on $inhibit_exit).
  160. #    When restarting debugger breakpoints/actions persist.
  161. #     Buglet: When restarting debugger only one breakpoint/action per 
  162. #        autoloaded function persists.
  163. # Changes: 0.97: NonStop will not stop in at_exit().
  164. #    Option AutoTrace implemented.
  165. #    Trace printed differently if frames are printed too.
  166. #    new `inhibitExit' option.
  167. #    printing of a very long statement interruptible.
  168. # Changes: 0.98: New command `m' for printing possible methods
  169. #    'l -' is a synonym for `-'.
  170. #    Cosmetic bugs in printing stack trace.
  171. #    `frame' & 8 to print "expanded args" in stack trace.
  172. #    Can list/break in imported subs.
  173. #    new `maxTraceLen' option.
  174. #    frame & 4 and frame & 8 granted.
  175. #    new command `m'
  176. #    nonstoppable lines do not have `:' near the line number.
  177. #    `b compile subname' implemented.
  178. #    Will not use $` any more.
  179. #    `-' behaves sane now.
  180. # Changes: 0.99: Completion for `f', `m'.
  181. #    `m' will remove duplicate names instead of duplicate functions.
  182. #    `b load' strips trailing whitespace.
  183. #    completion ignores leading `|'; takes into account current package
  184. #    when completing a subroutine name (same for `l').
  185. # Changes: 1.07: Many fixed by tchrist 13-March-2000
  186. #   BUG FIXES:
  187. #   + Added bare minimal security checks on perldb rc files, plus
  188. #     comments on what else is needed.
  189. #   + Fixed the ornaments that made "|h" completely unusable.
  190. #     They are not used in print_help if they will hurt.  Strip pod
  191. #     if we're paging to less.
  192. #   + Fixed mis-formatting of help messages caused by ornaments
  193. #     to restore Larry's original formatting.  
  194. #   + Fixed many other formatting errors.  The code is still suboptimal, 
  195. #     and needs a lot of work at restructuring.  It's also misindented
  196. #     in many places.
  197. #   + Fixed bug where trying to look at an option like your pager
  198. #     shows "1".  
  199. #   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
  200. #     lose.  You should consider shell escapes not using their shell,
  201. #     or else not caring about detailed status.  This should really be
  202. #     unified into one place, too.
  203. #   + Fixed bug where invisible trailing whitespace on commands hoses you,
  204. #     tricking Perl into thinking you weren't calling a debugger command!
  205. #   + Fixed bug where leading whitespace on commands hoses you.  (One
  206. #     suggests a leading semicolon or any other irrelevant non-whitespace
  207. #     to indicate literal Perl code.)
  208. #   + Fixed bugs that ate warnings due to wrong selected handle.
  209. #   + Fixed a precedence bug on signal stuff.
  210. #   + Fixed some unseemly wording.
  211. #   + Fixed bug in help command trying to call perl method code.
  212. #   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
  213. #   ENHANCEMENTS:
  214. #   + Added some comments.  This code is still nasty spaghetti.
  215. #   + Added message if you clear your pre/post command stacks which was
  216. #     very easy to do if you just typed a bare >, <, or {.  (A command
  217. #     without an argument should *never* be a destructive action; this
  218. #     API is fundamentally screwed up; likewise option setting, which
  219. #     is equally buggered.)
  220. #   + Added command stack dump on argument of "?" for >, <, or {.
  221. #   + Added a semi-built-in doc viewer command that calls man with the
  222. #     proper %Config::Config path (and thus gets caching, man -k, etc),
  223. #     or else perldoc on obstreperous platforms.
  224. #   + Added to and rearranged the help information.
  225. #   + Detected apparent misuse of { ... } to declare a block; this used
  226. #     to work but now is a command, and mysteriously gave no complaint.
  227. #
  228. # Changes: 1.08: Apr 25, 2001  Jon Eveland <jweveland@yahoo.com>
  229. #   BUG FIX:
  230. #   + This patch to perl5db.pl cleans up formatting issues on the help
  231. #     summary (h h) screen in the debugger.  Mostly columnar alignment
  232. #     issues, plus converted the printed text to use all spaces, since
  233. #     tabs don't seem to help much here.
  234. #
  235. # Changes: 1.09: May 19, 2001  Ilya Zakharevich <ilya@math.ohio-state.edu>
  236. #   0) Minor bugs corrected;
  237. #   a) Support for auto-creation of new TTY window on startup, either
  238. #      unconditionally, or if started as a kid of another debugger session;
  239. #   b) New `O'ption CreateTTY
  240. #       I<CreateTTY>       bits control attempts to create a new TTY on events:
  241. #                          1: on fork()   2: debugger is started inside debugger
  242. #                          4: on startup
  243. #   c) Code to auto-create a new TTY window on OS/2 (currently one
  244. #      extra window per session - need named pipes to have more...);
  245. #   d) Simplified interface for custom createTTY functions (with a backward
  246. #      compatibility hack); now returns the TTY name to use; return of ''
  247. #      means that the function reset the I/O handles itself;
  248. #   d') Better message on the semantic of custom createTTY function;
  249. #   e) Convert the existing code to create a TTY into a custom createTTY
  250. #      function;
  251. #   f) Consistent support for TTY names of the form "TTYin,TTYout";
  252. #   g) Switch line-tracing output too to the created TTY window;
  253. #   h) make `b fork' DWIM with CORE::GLOBAL::fork;
  254. #   i) High-level debugger API cmd_*():
  255. #      cmd_b_load($filenamepart)            # b load filenamepart
  256. #      cmd_b_line($lineno [, $cond])        # b lineno [cond]
  257. #      cmd_b_sub($sub [, $cond])            # b sub [cond]
  258. #      cmd_stop()                           # Control-C
  259. #      cmd_d($lineno)                       # d lineno (B)
  260. #      The cmd_*() API returns FALSE on failure; in this case it outputs
  261. #      the error message to the debugging output.
  262. #   j) Low-level debugger API
  263. #      break_on_load($filename)             # b load filename
  264. #      @files = report_break_on_load()      # List files with load-breakpoints
  265. #      breakable_line_in_filename($name, $from [, $to])
  266. #                                           # First breakable line in the
  267. #                                           # range $from .. $to.  $to defaults
  268. #                                           # to $from, and may be less than $to
  269. #      breakable_line($from [, $to])        # Same for the current file
  270. #      break_on_filename_line($name, $lineno [, $cond])
  271. #                                           # Set breakpoint,$cond defaults to 1
  272. #      break_on_filename_line_range($name, $from, $to [, $cond])
  273. #                                           # As above, on the first
  274. #                                           # breakable line in range
  275. #      break_on_line($lineno [, $cond])     # As above, in the current file
  276. #      break_subroutine($sub [, $cond])     # break on the first breakable line
  277. #      ($name, $from, $to) = subroutine_filename_lines($sub)
  278. #                                           # The range of lines of the text
  279. #      The low-level API returns TRUE on success, and die()s on failure.
  280. #
  281. # Changes: 1.10: May 23, 2001  Daniel Lewart <d-lewart@uiuc.edu>
  282. #   BUG FIXES:
  283. #   + Fixed warnings generated by "perl -dWe 42"
  284. #   + Corrected spelling errors
  285. #   + Squeezed Help (h) output into 80 columns
  286. #
  287. # Changes: 1.11: May 24, 2001  David Dyck <dcd@tc.fluke.com>
  288. #   + Made "x @INC" work like it used to
  289. #
  290. # Changes: 1.12: May 24, 2001  Daniel Lewart <d-lewart@uiuc.edu>
  291. #   + Fixed warnings generated by "O" (Show debugger options)
  292. #   + Fixed warnings generated by "p 42" (Print expression)
  293. # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
  294. #   + Added windowSize option 
  295. # Changes: 1.14: Oct  9, 2001 multiple
  296. #   + Clean up after itself on VMS (Charles Lane in 12385)
  297. #   + Adding "@ file" syntax (Peter Scott in 12014)
  298. #   + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
  299. #   + $^S and other debugger fixes (Ilya Zakharevich in 11120)
  300. #   + Forgot a my() declaration (Ilya Zakharevich in 11085)
  301. # Changes: 1.15: Nov  6, 2001 Michael G Schwern <schwern@pobox.com>
  302. #   + Updated 1.14 change log
  303. #   + Added *dbline explainatory comments
  304. #   + Mentioning perldebguts man page
  305. # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
  306. #    + $onetimeDump improvements
  307. # Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net>
  308. #   Moved some code to cmd_[.]()'s for clarity and ease of handling,
  309. #   rationalised the following commands and added cmd_wrapper() to 
  310. #   enable switching between old and frighteningly consistent new 
  311. #   behaviours for diehards: 'o CommandSet=pre580' (sigh...)
  312. #     a(add),       A(del)            # action expr   (added del by line)
  313. #   + b(add),       B(del)            # break  [line] (was b,D)
  314. #   + w(add),       W(del)            # watch  expr   (was W,W) added del by expr
  315. #   + h(summary), h h(long)           # help (hh)     (was h h,h)
  316. #   + m(methods),   M(modules)        # ...           (was m,v)
  317. #   + o(option)                       # lc            (was O)
  318. #   + v(view code), V(view Variables) # ...           (was w,V)
  319. # Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley@rfi.net>
  320. #   + fixed missing cmd_O bug
  321. # Changes: 1.19: Mar 29, 2002 Spider Boardman
  322. #   + Added missing local()s -- DB::DB is called recursively.
  323. # 
  324. ####################################################################
  325.  
  326. # Needed for the statement after exec():
  327.  
  328. BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
  329. local($^W) = 0;            # Switch run-time warnings off during init.
  330. warn (            # Do not ;-)
  331.       $dumpvar::hashDepth,     
  332.       $dumpvar::arrayDepth,    
  333.       $dumpvar::dumpDBFiles,   
  334.       $dumpvar::dumpPackages,  
  335.       $dumpvar::quoteHighBit,  
  336.       $dumpvar::printUndef,    
  337.       $dumpvar::globPrint,     
  338.       $dumpvar::usageOnly,
  339.       @ARGS,
  340.       $Carp::CarpLevel,
  341.       $panic,
  342.       $second_time,
  343.      ) if 0;
  344.  
  345. # Command-line + PERLLIB:
  346. @ini_INC = @INC;
  347.  
  348. # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
  349.  
  350. $trace = $signal = $single = 0;    # Uninitialized warning suppression
  351.                                 # (local $^W cannot help - other packages!).
  352. $inhibit_exit = $option{PrintRet} = 1;
  353.  
  354. @options     = qw(hashDepth arrayDepth CommandSet dumpDepth
  355.                   DumpDBFiles DumpPackages DumpReused
  356.           compactDump veryCompact quote HighBit undefPrint
  357.           globPrint PrintRet UsageOnly frame AutoTrace
  358.           TTY noTTY ReadLine NonStop LineInfo maxTraceLen
  359.           recallCommand ShellBang pager tkRunning ornaments
  360.           signalLevel warnLevel dieLevel inhibit_exit
  361.           ImmediateStop bareStringify CreateTTY
  362.           RemotePort windowSize);
  363.  
  364. %optionVars    = (
  365.          hashDepth    => \$dumpvar::hashDepth,
  366.          arrayDepth    => \$dumpvar::arrayDepth,
  367.          CommandSet => \$CommandSet,
  368.          DumpDBFiles    => \$dumpvar::dumpDBFiles,
  369.          DumpPackages    => \$dumpvar::dumpPackages,
  370.          DumpReused    => \$dumpvar::dumpReused,
  371.          HighBit    => \$dumpvar::quoteHighBit,
  372.          undefPrint    => \$dumpvar::printUndef,
  373.          globPrint    => \$dumpvar::globPrint,
  374.          UsageOnly    => \$dumpvar::usageOnly,
  375.          CreateTTY    => \$CreateTTY,
  376.          bareStringify    => \$dumpvar::bareStringify,
  377.          frame          => \$frame,
  378.          AutoTrace      => \$trace,
  379.          inhibit_exit   => \$inhibit_exit,
  380.          maxTraceLen    => \$maxtrace,
  381.          ImmediateStop    => \$ImmediateStop,
  382.          RemotePort    => \$remoteport,
  383.          windowSize    => \$window,
  384. );
  385.  
  386. %optionAction  = (
  387.           compactDump    => \&dumpvar::compactDump,
  388.           veryCompact    => \&dumpvar::veryCompact,
  389.           quote        => \&dumpvar::quote,
  390.           TTY        => \&TTY,
  391.           noTTY        => \&noTTY,
  392.           ReadLine    => \&ReadLine,
  393.           NonStop    => \&NonStop,
  394.           LineInfo    => \&LineInfo,
  395.           recallCommand    => \&recallCommand,
  396.           ShellBang    => \&shellBang,
  397.           pager        => \&pager,
  398.           signalLevel    => \&signalLevel,
  399.           warnLevel    => \&warnLevel,
  400.           dieLevel    => \&dieLevel,
  401.           tkRunning    => \&tkRunning,
  402.           ornaments    => \&ornaments,
  403.           RemotePort    => \&RemotePort,
  404.          );
  405.  
  406. %optionRequire = (
  407.           compactDump    => 'dumpvar.pl',
  408.           veryCompact    => 'dumpvar.pl',
  409.           quote        => 'dumpvar.pl',
  410.          );
  411.  
  412. # These guys may be defined in $ENV{PERL5DB} :
  413. $rl        = 1    unless defined $rl;
  414. $warnLevel    = 1    unless defined $warnLevel;
  415. $dieLevel    = 1    unless defined $dieLevel;
  416. $signalLevel    = 1    unless defined $signalLevel;
  417. $pre        = []    unless defined $pre;
  418. $post        = []    unless defined $post;
  419. $pretype    = []    unless defined $pretype;
  420. $CreateTTY    = 3    unless defined $CreateTTY;
  421. $CommandSet = '580'    unless defined $CommandSet;
  422.  
  423. warnLevel($warnLevel);
  424. dieLevel($dieLevel);
  425. signalLevel($signalLevel);
  426.  
  427. pager(
  428.       defined $ENV{PAGER}              ? $ENV{PAGER} :
  429.       eval { require Config } && 
  430.         defined $Config::Config{pager} ? $Config::Config{pager}
  431.                                        : 'more'
  432.      ) unless defined $pager;
  433. setman();
  434. &recallCommand("!") unless defined $prc;
  435. &shellBang("!") unless defined $psh;
  436. sethelp();
  437. $maxtrace = 400 unless defined $maxtrace;
  438. $ini_pids = $ENV{PERLDB_PIDS};
  439. if (defined $ENV{PERLDB_PIDS}) {
  440.   $pids = "[$ENV{PERLDB_PIDS}]";
  441.   $ENV{PERLDB_PIDS} .= "->$$";
  442.   $term_pid = -1;
  443. } else {
  444.   $ENV{PERLDB_PIDS} = "$$";
  445.   $pids = "{pid=$$}";
  446.   $term_pid = $$;
  447. }
  448. $pidprompt = '';
  449. *emacs = $slave_editor if $slave_editor;    # May be used in afterinit()...
  450.  
  451. if (-e "/dev/tty") {  # this is the wrong metric!
  452.   $rcfile=".perldb";
  453. } else {
  454.   $rcfile="perldb.ini";
  455. }
  456.  
  457. # This isn't really safe, because there's a race
  458. # between checking and opening.  The solution is to
  459. # open and fstat the handle, but then you have to read and
  460. # eval the contents.  But then the silly thing gets
  461. # your lexical scope, which is unfortunately at best.
  462. sub safe_do { 
  463.     my $file = shift;
  464.  
  465.     # Just exactly what part of the word "CORE::" don't you understand?
  466.     local $SIG{__WARN__};  
  467.     local $SIG{__DIE__};    
  468.  
  469.     unless (is_safe_file($file)) {
  470.     CORE::warn <<EO_GRIPE;
  471. perldb: Must not source insecure rcfile $file.
  472.         You or the superuser must be the owner, and it must not 
  473.     be writable by anyone but its owner.
  474. EO_GRIPE
  475.     return;
  476.     } 
  477.  
  478.     do $file;
  479.     CORE::warn("perldb: couldn't parse $file: $@") if $@;
  480. }
  481.  
  482.  
  483. # Verifies that owner is either real user or superuser and that no
  484. # one but owner may write to it.  This function is of limited use
  485. # when called on a path instead of upon a handle, because there are
  486. # no guarantees that filename (by dirent) whose file (by ino) is
  487. # eventually accessed is the same as the one tested. 
  488. # Assumes that the file's existence is not in doubt.
  489. sub is_safe_file {
  490.     my $path = shift;
  491.     stat($path) || return;    # mysteriously vaporized
  492.     my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
  493.  
  494.     return 0 if $uid != 0 && $uid != $<;
  495.     return 0 if $mode & 022;
  496.     return 1;
  497. }
  498.  
  499. if (-f $rcfile) {
  500.     safe_do("./$rcfile");
  501. } 
  502. elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
  503.     safe_do("$ENV{HOME}/$rcfile");
  504. }
  505. elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
  506.     safe_do("$ENV{LOGDIR}/$rcfile");
  507. }
  508.  
  509. if (defined $ENV{PERLDB_OPTS}) {
  510.   parse_options($ENV{PERLDB_OPTS});
  511. }
  512.  
  513. if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
  514.      and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
  515.     *get_fork_TTY = \&xterm_get_fork_TTY;
  516. } elsif ($^O eq 'os2') {
  517.     *get_fork_TTY = \&os2_get_fork_TTY;
  518. }
  519.  
  520. # Here begin the unreadable code.  It needs fixing.
  521.  
  522. if (exists $ENV{PERLDB_RESTART}) {
  523.   delete $ENV{PERLDB_RESTART};
  524.   # $restart = 1;
  525.   @hist = get_list('PERLDB_HIST');
  526.   %break_on_load = get_list("PERLDB_ON_LOAD");
  527.   %postponed = get_list("PERLDB_POSTPONE");
  528.   my @had_breakpoints= get_list("PERLDB_VISITED");
  529.   for (0 .. $#had_breakpoints) {
  530.     my %pf = get_list("PERLDB_FILE_$_");
  531.     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
  532.   }
  533.   my %opt = get_list("PERLDB_OPT");
  534.   my ($opt,$val);
  535.   while (($opt,$val) = each %opt) {
  536.     $val =~ s/[\\\']/\\$1/g;
  537.     parse_options("$opt'$val'");
  538.   }
  539.   @INC = get_list("PERLDB_INC");
  540.   @ini_INC = @INC;
  541.   $pretype = [get_list("PERLDB_PRETYPE")];
  542.   $pre = [get_list("PERLDB_PRE")];
  543.   $post = [get_list("PERLDB_POST")];
  544.   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
  545. }
  546.  
  547. if ($notty) {
  548.   $runnonstop = 1;
  549. } else {
  550.   # Is Perl being run from a slave editor or graphical debugger?
  551.   $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
  552.   $rl = 0, shift(@main::ARGV) if $slave_editor;
  553.  
  554.   #require Term::ReadLine;
  555.  
  556.   if ($^O eq 'cygwin') {
  557.     # /dev/tty is binary. use stdin for textmode
  558.     undef $console;
  559.   } elsif (-e "/dev/tty") {
  560.     $console = "/dev/tty";
  561.   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
  562.     $console = "con";
  563.   } elsif ($^O eq 'MacOS') {
  564.     if ($MacPerl::Version !~ /MPW/) {
  565.       $console = "Dev:Console:Perl Debug"; # Separate window for application
  566.     } else {
  567.       $console = "Dev:Console";
  568.     }
  569.   } else {
  570.     $console = "sys\$command";
  571.   }
  572.  
  573.   if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
  574.     $console = undef;
  575.   }
  576.  
  577.   if ($^O eq 'NetWare') {
  578.     $console = undef;
  579.   }
  580.  
  581.   # Around a bug:
  582.   if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
  583.     $console = undef;
  584.   }
  585.  
  586.   if ($^O eq 'epoc') {
  587.     $console = undef;
  588.   }
  589.  
  590.   $console = $tty if defined $tty;
  591.  
  592.   if (defined $remoteport) {
  593.     require IO::Socket;
  594.     $OUT = new IO::Socket::INET( Timeout  => '10',
  595.                                  PeerAddr => $remoteport,
  596.                                  Proto    => 'tcp',
  597.                                );
  598.     if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
  599.     $IN = $OUT;
  600.   } else {
  601.     create_IN_OUT(4) if $CreateTTY & 4;
  602.     if ($console) {
  603.       my ($i, $o) = split /,/, $console;
  604.       $o = $i unless defined $o;
  605.       open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
  606.       open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
  607.         || open(OUT,">&STDOUT");    # so we don't dongle stdout
  608.     } elsif (not defined $console) {
  609.       open(IN,"<&STDIN");
  610.       open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
  611.       $console = 'STDIN/OUT';
  612.     }
  613.     # so open("|more") can read from STDOUT and so we don't dingle stdin
  614.     $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
  615.   }
  616.   my $previous = select($OUT);
  617.   $| = 1;            # for DB::OUT
  618.   select($previous);
  619.  
  620.   $LINEINFO = $OUT unless defined $LINEINFO;
  621.   $lineinfo = $console unless defined $lineinfo;
  622.  
  623.   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  624.   unless ($runnonstop) {
  625.     local $\ = '';
  626.     local $, = '';
  627.     if ($term_pid eq '-1') {
  628.       print $OUT "\nDaughter DB session started...\n";
  629.     } else {
  630.       print $OUT "\nLoading DB routines from $header\n";
  631.       print $OUT ("Editor support ",
  632.           $slave_editor ? "enabled" : "available",
  633.           ".\n");
  634.       print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
  635.     }
  636.   }
  637. }
  638.  
  639. @ARGS = @ARGV;
  640. for (@args) {
  641.     s/\'/\\\'/g;
  642.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  643. }
  644.  
  645. if (defined &afterinit) {    # May be defined in $rcfile
  646.   &afterinit();
  647. }
  648.  
  649. $I_m_init = 1;
  650.  
  651. ############################################################ Subroutines
  652.  
  653. sub DB {
  654.     # _After_ the perl program is compiled, $single is set to 1:
  655.     if ($single and not $second_time++) {
  656.       if ($runnonstop) {    # Disable until signal
  657.     for ($i=0; $i <= $stack_depth; ) {
  658.         $stack[$i++] &= ~1;
  659.     }
  660.     $single = 0;
  661.     # return;            # Would not print trace!
  662.       } elsif ($ImmediateStop) {
  663.     $ImmediateStop = 0;
  664.     $signal = 1;
  665.       }
  666.     }
  667.     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
  668.     &save;
  669.     local($package, $filename, $line) = caller;
  670.     local $filename_ini = $filename;
  671.     local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
  672.       "package $package;";    # this won't let them modify, alas
  673.     local(*dbline) = $main::{'_<' . $filename};
  674.  
  675.     # we need to check for pseudofiles on Mac OS (these are files
  676.     # not attached to a filename, but instead stored in Dev:Pseudo)
  677.     if ($^O eq 'MacOS' && $#dbline < 0) {
  678.     $filename_ini = $filename = 'Dev:Pseudo';
  679.     *dbline = $main::{'_<' . $filename};
  680.     }
  681.  
  682.     local $max = $#dbline;
  683.     if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
  684.         if ($stop eq '1') {
  685.             $signal |= 1;
  686.         } elsif ($stop) {
  687.             $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
  688.             $dbline{$line} =~ s/;9($|\0)/$1/;
  689.         }
  690.     }
  691.     my $was_signal = $signal;
  692.     if ($trace & 2) {
  693.       for (my $n = 0; $n <= $#to_watch; $n++) {
  694.         $evalarg = $to_watch[$n];
  695.         local $onetimeDump;    # Do not output results
  696.         my ($val) = &eval;    # Fix context (&eval is doing array)?
  697.         $val = ( (defined $val) ? "'$val'" : 'undef' );
  698.         if ($val ne $old_watch[$n]) {
  699.           $signal = 1;
  700.           print $OUT <<EOP;
  701. Watchpoint $n:\t$to_watch[$n] changed:
  702.     old value:\t$old_watch[$n]
  703.     new value:\t$val
  704. EOP
  705.           $old_watch[$n] = $val;
  706.         }
  707.       }
  708.     }
  709.     if ($trace & 4) {        # User-installed watch
  710.       return if watchfunction($package, $filename, $line) 
  711.     and not $single and not $was_signal and not ($trace & ~4);
  712.     }
  713.     $was_signal = $signal;
  714.     $signal = 0;
  715.     if ($single || ($trace & 1) || $was_signal) {
  716.     if ($slave_editor) {
  717.         $position = "\032\032$filename:$line:0\n";
  718.         print_lineinfo($position);
  719.     } elsif ($package eq 'DB::fake') {
  720.       $term || &setterm;
  721.       print_help(<<EOP);
  722. Debugged program terminated.  Use B<q> to quit or B<R> to restart,
  723.   use B<O> I<inhibit_exit> to avoid stopping after program termination,
  724.   B<h q>, B<h R> or B<h O> to get additional info.  
  725. EOP
  726.       $package = 'main';
  727.       $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
  728.         "package $package;";    # this won't let them modify, alas
  729.     } else {
  730.         $sub =~ s/\'/::/;
  731.         $prefix = $sub =~ /::/ ? "" : "${'package'}::";
  732.         $prefix .= "$sub($filename:";
  733.         $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
  734.         if (length($prefix) > 30) {
  735.             $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
  736.             $prefix = "";
  737.             $infix = ":\t";
  738.         } else {
  739.             $infix = "):\t";
  740.             $position = "$prefix$line$infix$dbline[$line]$after";
  741.         }
  742.         if ($frame) {
  743.             print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
  744.         } else {
  745.             print_lineinfo($position);
  746.         }
  747.         for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
  748.             last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
  749.             last if $signal;
  750.             $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
  751.             $incr_pos = "$prefix$i$infix$dbline[$i]$after";
  752.             $position .= $incr_pos;
  753.             if ($frame) {
  754.                 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
  755.             } else {
  756.                 print_lineinfo($incr_pos);
  757.             }
  758.         }
  759.     }
  760.     }
  761.     $evalarg = $action, &eval if $action;
  762.     if ($single || $was_signal) {
  763.       local $level = $level + 1;
  764.       foreach $evalarg (@$pre) {
  765.         &eval;
  766.       }
  767.       print $OUT $stack_depth . " levels deep in subroutine calls!\n"
  768.               if $single & 4;
  769.         $start = $line;
  770.         $incr = -1;        # for backward motion.
  771.         @typeahead = (@$pretype, @typeahead);
  772.     CMD:
  773.     while (($term || &setterm),
  774.            ($term_pid == $$ or resetterm(1)),
  775.            defined ($cmd=&readline("$pidprompt  DB" . ('<' x $level) .
  776.                        ($#hist+1) . ('>' x $level) . " "))) 
  777.         {
  778.         $single = 0;
  779.         $signal = 0;
  780.         $cmd =~ s/\\$/\n/ && do {
  781.             $cmd .= &readline("  cont: ");
  782.             redo CMD;
  783.         };
  784.         $cmd =~ /^$/ && ($cmd = $laststep);
  785.         push(@hist,$cmd) if length($cmd) > 1;
  786.           PIPE: {
  787.             $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
  788.             $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
  789.             ($i) = split(/\s+/,$cmd);
  790.             if ($alias{$i}) { 
  791.                     # squelch the sigmangler
  792.                     local $SIG{__DIE__};
  793.                     local $SIG{__WARN__};
  794.                     eval "\$cmd =~ $alias{$i}";
  795.                     if ($@) {
  796.                                                 local $\ = '';
  797.                         print $OUT "Couldn't evaluate `$i' alias: $@";
  798.                         next CMD;
  799.                     } 
  800.             }
  801.                     $cmd =~ /^q$/ && do {
  802.                         $fall_off_end = 1;
  803.                         clean_ENV();
  804.                         exit $?;
  805.                     };
  806.             $cmd =~ /^t$/ && do {
  807.             $trace ^= 1;
  808.             local $\ = '';
  809.             print $OUT "Trace = " .
  810.                 (($trace & 1) ? "on" : "off" ) . "\n";
  811.             next CMD; };
  812.             $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
  813.             $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
  814.             local $\ = '';
  815.             local $, = '';
  816.             foreach $subname (sort(keys %sub)) {
  817.                 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
  818.                 print $OUT $subname,"\n";
  819.                 }
  820.             }
  821.             next CMD; };
  822.             $cmd =~ s/^X\b/V $package/;
  823.             $cmd =~ /^V$/ && do {
  824.             $cmd = "V $package"; };
  825.             $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
  826.             local ($savout) = select($OUT);
  827.             $packname = $1;
  828.             @vars = split(' ',$2);
  829.             do 'dumpvar.pl' unless defined &main::dumpvar;
  830.             if (defined &main::dumpvar) {
  831.                 local $frame = 0;
  832.                 local $doret = -2;
  833.                 # must detect sigpipe failures
  834.                            eval { &main::dumpvar($packname,
  835.                                                  defined $option{dumpDepth}
  836.                                                   ? $option{dumpDepth} : -1,
  837.                                                  @vars) };
  838.                 if ($@) {
  839.                 die unless $@ =~ /dumpvar print failed/;
  840.                 } 
  841.             } else {
  842.                 print $OUT "dumpvar.pl not available.\n";
  843.             }
  844.             select ($savout);
  845.             next CMD; };
  846.             $cmd =~ s/^x\b/ / && do { # So that will be evaled
  847.             $onetimeDump = 'dump'; 
  848.                         # handle special  "x 3 blah" syntax
  849.                         if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
  850.                           $onetimedumpDepth = $1;
  851.                         }
  852.                       };
  853.             $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
  854.             methods($1); next CMD};
  855.             $cmd =~ s/^m\b/ / && do { # So this will be evaled
  856.             $onetimeDump = 'methods'; };
  857.             $cmd =~ /^f\b\s*(.*)/ && do {
  858.             $file = $1;
  859.             $file =~ s/\s+$//;
  860.             if (!$file) {
  861.                 print $OUT "The old f command is now the r command.\n"; # hint
  862.                 print $OUT "The new f command switches filenames.\n";
  863.                 next CMD;
  864.             }
  865.             if (!defined $main::{'_<' . $file}) {
  866.                 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
  867.                           $try = substr($try,2);
  868.                           print $OUT "Choosing $try matching `$file':\n";
  869.                           $file = $try;
  870.                       }}
  871.             }
  872.             if (!defined $main::{'_<' . $file}) {
  873.                 print $OUT "No file matching `$file' is loaded.\n";
  874.                 next CMD;
  875.             } elsif ($file ne $filename) {
  876.                 *dbline = $main::{'_<' . $file};
  877.                 $max = $#dbline;
  878.                 $filename = $file;
  879.                 $start = 1;
  880.                 $cmd = "l";
  881.               } else {
  882.                 print $OUT "Already in $file.\n";
  883.                 next CMD;
  884.               }
  885.               };
  886.             $cmd =~ /^\.$/ && do {
  887.             $incr = -1;        # for backward motion.
  888.             $start = $line;
  889.             $filename = $filename_ini;
  890.             *dbline = $main::{'_<' . $filename};
  891.             $max = $#dbline;
  892.             print_lineinfo($position);
  893.             next CMD };
  894.             $cmd =~ /^-$/ && do {
  895.             $start -= $incr + $window + 1;
  896.             $start = 1 if $start <= 0;
  897.             $incr = $window - 1;
  898.             $cmd = 'l ' . ($start) . '+'; };
  899.             # rjsf ->
  900.           $cmd =~ /^([aAbBhlLMoOvwW])\b\s*(.*)/s && do { 
  901.                 &cmd_wrapper($1, $2, $line); 
  902.                 next CMD; 
  903.             };
  904.             # <- rjsf
  905.           $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
  906.             push @$pre, action($1);
  907.             next CMD; };
  908.             $cmd =~ /^>>\s*(.*)/ && do {
  909.             push @$post, action($1);
  910.             next CMD; };
  911.             $cmd =~ /^<\s*(.*)/ && do {
  912.             unless ($1) {
  913.                 print $OUT "All < actions cleared.\n";
  914.                 $pre = [];
  915.                 next CMD;
  916.             } 
  917.             if ($1 eq '?') {
  918.                 unless (@$pre) {
  919.                 print $OUT "No pre-prompt Perl actions.\n";
  920.                 next CMD;
  921.                 } 
  922.                 print $OUT "Perl commands run before each prompt:\n";
  923.                 for my $action ( @$pre ) {
  924.                 print $OUT "\t< -- $action\n";
  925.                 } 
  926.                 next CMD;
  927.             } 
  928.             $pre = [action($1)];
  929.             next CMD; };
  930.             $cmd =~ /^>\s*(.*)/ && do {
  931.             unless ($1) {
  932.                 print $OUT "All > actions cleared.\n";
  933.                 $post = [];
  934.                 next CMD;
  935.             }
  936.             if ($1 eq '?') {
  937.                 unless (@$post) {
  938.                 print $OUT "No post-prompt Perl actions.\n";
  939.                 next CMD;
  940.                 } 
  941.                 print $OUT "Perl commands run after each prompt:\n";
  942.                 for my $action ( @$post ) {
  943.                 print $OUT "\t> -- $action\n";
  944.                 } 
  945.                 next CMD;
  946.             } 
  947.             $post = [action($1)];
  948.             next CMD; };
  949.             $cmd =~ /^\{\{\s*(.*)/ && do {
  950.             if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { 
  951.                 print $OUT "{{ is now a debugger command\n",
  952.                 "use `;{{' if you mean Perl code\n";
  953.                 $cmd = "h {{";
  954.                 redo CMD;
  955.             } 
  956.             push @$pretype, $1;
  957.             next CMD; };
  958.             $cmd =~ /^\{\s*(.*)/ && do {
  959.             unless ($1) {
  960.                 print $OUT "All { actions cleared.\n";
  961.                 $pretype = [];
  962.                 next CMD;
  963.             }
  964.             if ($1 eq '?') {
  965.                 unless (@$pretype) {
  966.                 print $OUT "No pre-prompt debugger actions.\n";
  967.                 next CMD;
  968.                 } 
  969.                 print $OUT "Debugger commands run before each prompt:\n";
  970.                 for my $action ( @$pretype ) {
  971.                 print $OUT "\t{ -- $action\n";
  972.                 } 
  973.                 next CMD;
  974.             } 
  975.             if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { 
  976.                 print $OUT "{ is now a debugger command\n",
  977.                 "use `;{' if you mean Perl code\n";
  978.                 $cmd = "h {";
  979.                 redo CMD;
  980.             } 
  981.             $pretype = [$1];
  982.             next CMD; };
  983.                    $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
  984.                        eval { require PadWalker; PadWalker->VERSION(0.08) }
  985.                          or &warn($@ =~ /locate/
  986.                             ? "PadWalker module not found - please install\n"
  987.                             : $@)
  988.                           and next CMD;
  989.                        do 'dumpvar.pl' unless defined &main::dumpvar;
  990.                        defined &main::dumpvar
  991.                           or print $OUT "dumpvar.pl not available.\n"
  992.                           and next CMD;
  993.                        my @vars = split(' ', $2 || '');
  994.                        my $h = eval { PadWalker::peek_my(($1 || 0) + 1) };
  995.                        $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
  996.                        my $savout = select($OUT);
  997.                        dumpvar::dumplex($_, $h->{$_}, 
  998.                                        defined $option{dumpDepth}
  999.                                        ? $option{dumpDepth} : -1,
  1000.                                        @vars)
  1001.                            for sort keys %$h;
  1002.                        select($savout);
  1003.                        next CMD; };
  1004.                    $cmd =~ /^n$/ && do {
  1005.                 end_report(), next CMD if $finished and $level <= 1;
  1006.             $single = 2;
  1007.             $laststep = $cmd;
  1008.             last CMD; };
  1009.             $cmd =~ /^s$/ && do {
  1010.                 end_report(), next CMD if $finished and $level <= 1;
  1011.             $single = 1;
  1012.             $laststep = $cmd;
  1013.             last CMD; };
  1014.             $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
  1015.                 end_report(), next CMD if $finished and $level <= 1;
  1016.             $subname = $i = $1;
  1017.             #  Probably not needed, since we finish an interactive
  1018.             #  sub-session anyway...
  1019.             # local $filename = $filename;
  1020.             # local *dbline = *dbline;    # XXX Would this work?!
  1021.             if ($subname =~ /\D/) { # subroutine name
  1022.                 $subname = $package."::".$subname 
  1023.                     unless $subname =~ /::/;
  1024.                 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
  1025.                 $i += 0;
  1026.                 if ($i) {
  1027.                     $filename = $file;
  1028.                 *dbline = $main::{'_<' . $filename};
  1029.                 $had_breakpoints{$filename} |= 1;
  1030.                 $max = $#dbline;
  1031.                 ++$i while $dbline[$i] == 0 && $i < $max;
  1032.                 } else {
  1033.                 print $OUT "Subroutine $subname not found.\n";
  1034.                 next CMD; 
  1035.                 }
  1036.             }
  1037.             if ($i) {
  1038.                 if ($dbline[$i] == 0) {
  1039.                 print $OUT "Line $i not breakable.\n";
  1040.                 next CMD;
  1041.                 }
  1042.                 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
  1043.             }
  1044.             for ($i=0; $i <= $stack_depth; ) {
  1045.                 $stack[$i++] &= ~1;
  1046.             }
  1047.             last CMD; };
  1048.             $cmd =~ /^r$/ && do {
  1049.                 end_report(), next CMD if $finished and $level <= 1;
  1050.             $stack[$stack_depth] |= 1;
  1051.             $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
  1052.             last CMD; };
  1053.             $cmd =~ /^R$/ && do {
  1054.                 print $OUT "Warning: some settings and command-line options may be lost!\n";
  1055.             my (@script, @flags, $cl);
  1056.             push @flags, '-w' if $ini_warn;
  1057.             # Put all the old includes at the start to get
  1058.             # the same debugger.
  1059.             for (@ini_INC) {
  1060.               push @flags, '-I', $_;
  1061.             }
  1062.             push @flags, '-T' if ${^TAINT};
  1063.             # Arrange for setting the old INC:
  1064.             set_list("PERLDB_INC", @ini_INC);
  1065.             if ($0 eq '-e') {
  1066.               for (1..$#{'::_<-e'}) { # The first line is PERL5DB
  1067.                     chomp ($cl =  ${'::_<-e'}[$_]);
  1068.                 push @script, '-e', $cl;
  1069.               }
  1070.             } else {
  1071.               @script = $0;
  1072.             }
  1073.             set_list("PERLDB_HIST", 
  1074.                  $term->Features->{getHistory} 
  1075.                  ? $term->GetHistory : @hist);
  1076.             my @had_breakpoints = keys %had_breakpoints;
  1077.             set_list("PERLDB_VISITED", @had_breakpoints);
  1078.             set_list("PERLDB_OPT", %option);
  1079.             set_list("PERLDB_ON_LOAD", %break_on_load);
  1080.             my @hard;
  1081.             for (0 .. $#had_breakpoints) {
  1082.               my $file = $had_breakpoints[$_];
  1083.               *dbline = $main::{'_<' . $file};
  1084.               next unless %dbline or $postponed_file{$file};
  1085.               (push @hard, $file), next 
  1086.                 if $file =~ /^\(\w*eval/;
  1087.               my @add;
  1088.               @add = %{$postponed_file{$file}}
  1089.                 if $postponed_file{$file};
  1090.               set_list("PERLDB_FILE_$_", %dbline, @add);
  1091.             }
  1092.             for (@hard) { # Yes, really-really...
  1093.               # Find the subroutines in this eval
  1094.               *dbline = $main::{'_<' . $_};
  1095.               my ($quoted, $sub, %subs, $line) = quotemeta $_;
  1096.               for $sub (keys %sub) {
  1097.                 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
  1098.                 $subs{$sub} = [$1, $2];
  1099.               }
  1100.               unless (%subs) {
  1101.                 print $OUT
  1102.                   "No subroutines in $_, ignoring breakpoints.\n";
  1103.                 next;
  1104.               }
  1105.             LINES: for $line (keys %dbline) {
  1106.                 # One breakpoint per sub only:
  1107.                 my ($offset, $sub, $found);
  1108.               SUBS: for $sub (keys %subs) {
  1109.                   if ($subs{$sub}->[1] >= $line # Not after the subroutine
  1110.                   and (not defined $offset # Not caught
  1111.                        or $offset < 0 )) { # or badly caught
  1112.                 $found = $sub;
  1113.                 $offset = $line - $subs{$sub}->[0];
  1114.                 $offset = "+$offset", last SUBS if $offset >= 0;
  1115.                   }
  1116.                 }
  1117.                 if (defined $offset) {
  1118.                   $postponed{$found} =
  1119.                 "break $offset if $dbline{$line}";
  1120.                 } else {
  1121.                   print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
  1122.                 }
  1123.               }
  1124.             }
  1125.             set_list("PERLDB_POSTPONE", %postponed);
  1126.             set_list("PERLDB_PRETYPE", @$pretype);
  1127.             set_list("PERLDB_PRE", @$pre);
  1128.             set_list("PERLDB_POST", @$post);
  1129.             set_list("PERLDB_TYPEAHEAD", @typeahead);
  1130.             $ENV{PERLDB_RESTART} = 1;
  1131.             delete $ENV{PERLDB_PIDS}; # Restore ini state
  1132.             $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
  1133.             #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
  1134.             exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
  1135.             print $OUT "exec failed: $!\n";
  1136.             last CMD; };
  1137.             $cmd =~ /^T$/ && do {
  1138.             print_trace($OUT, 1); # skip DB
  1139.             next CMD; };
  1140.             $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w($1); next CMD; };
  1141.             $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W($1); next CMD; };
  1142.             $cmd =~ /^\/(.*)$/ && do {
  1143.             $inpat = $1;
  1144.             $inpat =~ s:([^\\])/$:$1:;
  1145.             if ($inpat ne "") {
  1146.                 # squelch the sigmangler
  1147.                 local $SIG{__DIE__};
  1148.                 local $SIG{__WARN__};
  1149.                 eval '$inpat =~ m'."\a$inpat\a";    
  1150.                 if ($@ ne "") {
  1151.                 print $OUT "$@";
  1152.                 next CMD;
  1153.                 }
  1154.                 $pat = $inpat;
  1155.             }
  1156.             $end = $start;
  1157.             $incr = -1;
  1158.             eval '
  1159.                 for (;;) {
  1160.                 ++$start;
  1161.                 $start = 1 if ($start > $max);
  1162.                 last if ($start == $end);
  1163.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  1164.                     if ($slave_editor) {
  1165.                     print $OUT "\032\032$filename:$start:0\n";
  1166.                     } else {
  1167.                     print $OUT "$start:\t", $dbline[$start], "\n";
  1168.                     }
  1169.                     last;
  1170.                 }
  1171.                 } ';
  1172.             print $OUT "/$pat/: not found\n" if ($start == $end);
  1173.             next CMD; };
  1174.             $cmd =~ /^\?(.*)$/ && do {
  1175.             $inpat = $1;
  1176.             $inpat =~ s:([^\\])\?$:$1:;
  1177.             if ($inpat ne "") {
  1178.                 # squelch the sigmangler
  1179.                 local $SIG{__DIE__};
  1180.                 local $SIG{__WARN__};
  1181.                 eval '$inpat =~ m'."\a$inpat\a";    
  1182.                 if ($@ ne "") {
  1183.                 print $OUT $@;
  1184.                 next CMD;
  1185.                 }
  1186.                 $pat = $inpat;
  1187.             }
  1188.             $end = $start;
  1189.             $incr = -1;
  1190.             eval '
  1191.                 for (;;) {
  1192.                 --$start;
  1193.                 $start = $max if ($start <= 0);
  1194.                 last if ($start == $end);
  1195.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  1196.                     if ($slave_editor) {
  1197.                     print $OUT "\032\032$filename:$start:0\n";
  1198.                     } else {
  1199.                     print $OUT "$start:\t", $dbline[$start], "\n";
  1200.                     }
  1201.                     last;
  1202.                 }
  1203.                 } ';
  1204.             print $OUT "?$pat?: not found\n" if ($start == $end);
  1205.             next CMD; };
  1206.             $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
  1207.             pop(@hist) if length($cmd) > 1;
  1208.             $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
  1209.             $cmd = $hist[$i];
  1210.             print $OUT $cmd, "\n";
  1211.             redo CMD; };
  1212.             $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
  1213.             &system($1);
  1214.             next CMD; };
  1215.             $cmd =~ /^$rc([^$rc].*)$/ && do {
  1216.             $pat = "^$1";
  1217.             pop(@hist) if length($cmd) > 1;
  1218.             for ($i = $#hist; $i; --$i) {
  1219.                 last if $hist[$i] =~ /$pat/;
  1220.             }
  1221.             if (!$i) {
  1222.                 print $OUT "No such command!\n\n";
  1223.                 next CMD;
  1224.             }
  1225.             $cmd = $hist[$i];
  1226.             print $OUT $cmd, "\n";
  1227.             redo CMD; };
  1228.             $cmd =~ /^$sh$/ && do {
  1229.             &system($ENV{SHELL}||"/bin/sh");
  1230.             next CMD; };
  1231.             $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
  1232.             # XXX: using csh or tcsh destroys sigint retvals!
  1233.             #&system($1);  # use this instead
  1234.             &system($ENV{SHELL}||"/bin/sh","-c",$1);
  1235.             next CMD; };
  1236.             $cmd =~ /^H\b\s*(-(\d+))?/ && do {
  1237.             $end = $2 ? ($#hist-$2) : 0;
  1238.             $hist = 0 if $hist < 0;
  1239.             for ($i=$#hist; $i>$end; $i--) {
  1240.                 print $OUT "$i: ",$hist[$i],"\n"
  1241.                   unless $hist[$i] =~ /^.?$/;
  1242.             };
  1243.             next CMD; };
  1244.             $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
  1245.             runman($1);
  1246.             next CMD; };
  1247.             $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
  1248.             $cmd =~ s/^p\b/print {\$DB::OUT} /;
  1249.             $cmd =~ s/^=\s*// && do {
  1250.             my @keys;
  1251.             if (length $cmd == 0) {
  1252.                 @keys = sort keys %alias;
  1253.             } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
  1254.                 # can't use $_ or kill //g state
  1255.                 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
  1256.                 $alias{$k} = "s\a$k\a$v\a";
  1257.                 # squelch the sigmangler
  1258.                 local $SIG{__DIE__};
  1259.                 local $SIG{__WARN__};
  1260.                 unless (eval "sub { s\a$k\a$v\a }; 1") {
  1261.                 print $OUT "Can't alias $k to $v: $@\n"; 
  1262.                 delete $alias{$k};
  1263.                 next CMD;
  1264.                 } 
  1265.                 @keys = ($k);
  1266.             } else {
  1267.                 @keys = ($cmd);
  1268.             } 
  1269.             for my $k (@keys) {
  1270.                 if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) {
  1271.                 print $OUT "$k\t= $1\n";
  1272.                 } 
  1273.                 elsif (defined $alias{$k}) {
  1274.                     print $OUT "$k\t$alias{$k}\n";
  1275.                 } 
  1276.                 else {
  1277.                 print "No alias for $k\n";
  1278.                 } 
  1279.             }
  1280.             next CMD; };
  1281.                     $cmd =~ /^source\s+(.*\S)/ && do {
  1282.               if (open my $fh, $1) {
  1283.             push @cmdfhs, $fh;
  1284.               } else {
  1285.             &warn("Can't execute `$1': $!\n");
  1286.               }
  1287.               next CMD; };
  1288.             $cmd =~ /^\|\|?\s*[^|]/ && do {
  1289.             if ($pager =~ /^\|/) {
  1290.                 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
  1291.                 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  1292.             } else {
  1293.                 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
  1294.             }
  1295.             fix_less();
  1296.             unless ($piped=open(OUT,$pager)) {
  1297.                 &warn("Can't pipe output to `$pager'");
  1298.                 if ($pager =~ /^\|/) {
  1299.                 open(OUT,">&STDOUT") # XXX: lost message
  1300.                     || &warn("Can't restore DB::OUT");
  1301.                 open(STDOUT,">&SAVEOUT")
  1302.                   || &warn("Can't restore STDOUT");
  1303.                 close(SAVEOUT);
  1304.                 } else {
  1305.                 open(OUT,">&STDOUT") # XXX: lost message
  1306.                     || &warn("Can't restore DB::OUT");
  1307.                 }
  1308.                 next CMD;
  1309.             }
  1310.             $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
  1311.                 && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
  1312.             $selected= select(OUT);
  1313.             $|= 1;
  1314.             select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
  1315.             $cmd =~ s/^\|+\s*//;
  1316.             redo PIPE; 
  1317.             };
  1318.             # XXX Local variants do not work!
  1319.             $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
  1320.             $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
  1321.             $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
  1322.         }        # PIPE:
  1323.         $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
  1324.         if ($onetimeDump) {
  1325.         $onetimeDump = undef;
  1326.                 $onetimedumpDepth = undef;
  1327.         } elsif ($term_pid == $$) {
  1328.         print $OUT "\n";
  1329.         }
  1330.     } continue {        # CMD:
  1331.         if ($piped) {
  1332.         if ($pager =~ /^\|/) {
  1333.             $? = 0;  
  1334.             # we cannot warn here: the handle is missing --tchrist
  1335.             close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
  1336.  
  1337.             # most of the $? crud was coping with broken cshisms
  1338.             if ($?) {
  1339.             print SAVEOUT "Pager `$pager' failed: ";
  1340.             if ($? == -1) {
  1341.                 print SAVEOUT "shell returned -1\n";
  1342.             } elsif ($? >> 8) {
  1343.                 print SAVEOUT 
  1344.                   ( $? & 127 ) ? " (SIG#".($?&127).")" : "", 
  1345.                   ( $? & 128 ) ? " -- core dumped" : "", "\n";
  1346.             } else {
  1347.                 print SAVEOUT "status ", ($? >> 8), "\n";
  1348.             } 
  1349.             } 
  1350.  
  1351.             open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  1352.             open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  1353.             $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
  1354.             # Will stop ignoring SIGPIPE if done like nohup(1)
  1355.             # does SIGINT but Perl doesn't give us a choice.
  1356.         } else {
  1357.             open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
  1358.         }
  1359.         close(SAVEOUT);
  1360.         select($selected), $selected= "" unless $selected eq "";
  1361.         $piped= "";
  1362.         }
  1363.     }            # CMD:
  1364.     $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
  1365.     foreach $evalarg (@$post) {
  1366.       &eval;
  1367.     }
  1368.     }                # if ($single || $signal)
  1369.     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
  1370.     ();
  1371. }
  1372.  
  1373. # The following code may be executed now:
  1374. # BEGIN {warn 4}
  1375.  
  1376. sub sub {
  1377.     my ($al, $ret, @ret) = "";
  1378.     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
  1379.     $al = " for $$sub";
  1380.     }
  1381.     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
  1382.     $#stack = $stack_depth;
  1383.     $stack[-1] = $single;
  1384.     $single &= 1;
  1385.     $single |= 4 if $stack_depth == $deep;
  1386.     ($frame & 4 
  1387.      ? ( print_lineinfo(' ' x ($stack_depth - 1), "in  "),
  1388.      # Why -1? But it works! :-(
  1389.      print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1390.      : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
  1391.     if (wantarray) {
  1392.     @ret = &$sub;
  1393.     $single |= $stack[$stack_depth--];
  1394.     ($frame & 4 
  1395.      ? ( print_lineinfo(' ' x $stack_depth, "out "), 
  1396.          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1397.      : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
  1398.     if ($doret eq $stack_depth or $frame & 16) {
  1399.         local $\ = '';
  1400.             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
  1401.         print $fh ' ' x $stack_depth if $frame & 16;
  1402.         print $fh "list context return from $sub:\n"; 
  1403.         dumpit($fh, \@ret );
  1404.         $doret = -2;
  1405.     }
  1406.     @ret;
  1407.     } else {
  1408.         if (defined wantarray) {
  1409.         $ret = &$sub;
  1410.         } else {
  1411.             &$sub; undef $ret;
  1412.         };
  1413.     $single |= $stack[$stack_depth--];
  1414.     ($frame & 4 
  1415.      ? (  print_lineinfo(' ' x $stack_depth, "out "),
  1416.           print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1417.      : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
  1418.     if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
  1419.         local $\ = '';
  1420.             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
  1421.         print $fh (' ' x $stack_depth) if $frame & 16;
  1422.         print $fh (defined wantarray 
  1423.              ? "scalar context return from $sub: " 
  1424.              : "void context return from $sub\n");
  1425.         dumpit( $fh, $ret ) if defined wantarray;
  1426.         $doret = -2;
  1427.     }
  1428.     $ret;
  1429.     }
  1430. }
  1431.  
  1432. ### The API section
  1433.  
  1434. ### Functions with multiple modes of failure die on error, the rest
  1435. ### returns FALSE on error.
  1436. ### User-interface functions cmd_* output error message.
  1437.  
  1438. ### Note all cmd_[a-zA-Z]'s require $line, $dblineno as first arguments
  1439.  
  1440. my %set = ( # 
  1441.     'pre580'    => {
  1442.         'a'    => 'pre580_a', 
  1443.         'A'    => 'pre580_null',
  1444.         'b'    => 'pre580_b', 
  1445.         'B'    => 'pre580_null',
  1446.         'd'    => 'pre580_null',
  1447.         'D'    => 'pre580_D',
  1448.         'h'    => 'pre580_h',
  1449.         'M'    => 'pre580_null',
  1450.         'O'    => 'o',
  1451.         'o'    => 'pre580_null',
  1452.         'v'    => 'M',
  1453.         'w'    => 'v',
  1454.         'W'    => 'pre580_W',
  1455.     },
  1456. );
  1457.  
  1458. sub cmd_wrapper {
  1459.     my $cmd      = shift;
  1460.     my $line     = shift;
  1461.     my $dblineno = shift;
  1462.  
  1463.     # with this level of indirection we can wrap 
  1464.     # to old (pre580) or other command sets easily
  1465.     # 
  1466.     my $call = 'cmd_'.(
  1467.         $set{$CommandSet}{$cmd} || $cmd
  1468.     );
  1469.     # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
  1470.  
  1471.     return &$call($line, $dblineno);
  1472. }
  1473.  
  1474. sub cmd_a {
  1475.     my $line   = shift || ''; # [.|line] expr
  1476.     my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
  1477.     if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
  1478.         my ($lineno, $expr) = ($1, $2);
  1479.         if (length $expr) {
  1480.             if ($dbline[$lineno] == 0) {
  1481.                 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
  1482.             } else {
  1483.                 $had_breakpoints{$filename} |= 2;
  1484.                 $dbline{$lineno} =~ s/\0[^\0]*//;
  1485.                 $dbline{$lineno} .= "\0" . action($expr);
  1486.             }
  1487.         }
  1488.     } else {
  1489.         print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
  1490.     }
  1491. }
  1492.  
  1493. sub cmd_A {
  1494.     my $line   = shift || '';
  1495.     my $dbline = shift; $line =~ s/^\./$dbline/;
  1496.     if ($line eq '*') {
  1497.         eval { &delete_action(); 1 } or print $OUT $@ and return;
  1498.     } elsif ($line =~ /^(\S.*)/) {
  1499.         eval { &delete_action($1); 1 } or print $OUT $@ and return;
  1500.     } else {
  1501.         print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
  1502.     }
  1503. }
  1504.  
  1505. sub delete_action {
  1506.   my $i = shift;
  1507.   if (defined($i)) {
  1508.         die "Line $i has no action .\n" if $dbline[$i] == 0;
  1509.         $dbline{$i} =~ s/\0[^\0]*//; # \^a
  1510.         delete $dbline{$i} if $dbline{$i} eq '';
  1511.     } else {
  1512.         print $OUT "Deleting all actions...\n";
  1513.         for my $file (keys %had_breakpoints) {
  1514.             local *dbline = $main::{'_<' . $file};
  1515.             my $max = $#dbline;
  1516.             my $was;
  1517.             for ($i = 1; $i <= $max ; $i++) {
  1518.                     if (defined $dbline{$i}) {
  1519.                             $dbline{$i} =~ s/\0[^\0]*//;
  1520.                             delete $dbline{$i} if $dbline{$i} eq '';
  1521.                     }
  1522.                 unless ($had_breakpoints{$file} &= ~2) {
  1523.                         delete $had_breakpoints{$file};
  1524.                 }
  1525.             }
  1526.         }
  1527.     }
  1528. }
  1529.  
  1530. sub cmd_b {
  1531.     my $line   = shift; # [.|line] [cond]
  1532.     my $dbline = shift; $line =~ s/^\./$dbline/;
  1533.     if ($line =~ /^\s*$/) {
  1534.         &cmd_b_line($dbline, 1);
  1535.     } elsif ($line =~ /^load\b\s*(.*)/) {
  1536.         my $file = $1; $file =~ s/\s+$//;
  1537.         &cmd_b_load($file);
  1538.     } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
  1539.         my $cond = length $3 ? $3 : '1';
  1540.         my ($subname, $break) = ($2, $1 eq 'postpone');
  1541.         $subname =~ s/\'/::/g;
  1542.         $subname = "${'package'}::" . $subname unless $subname =~ /::/;
  1543.         $subname = "main".$subname if substr($subname,0,2) eq "::";
  1544.         $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
  1545.     } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) { 
  1546.         $subname = $1;
  1547.         $cond = length $2 ? $2 : '1';
  1548.         &cmd_b_sub($subname, $cond);
  1549.     } elsif ($line =~ /^(\d*)\s*(.*)/) { 
  1550.         $line = $1 || $dbline;
  1551.         $cond = length $2 ? $2 : '1';
  1552.         &cmd_b_line($line, $cond);
  1553.     } else {
  1554.         print "confused by line($line)?\n";
  1555.     }
  1556. }
  1557.  
  1558. sub break_on_load {
  1559.   my $file = shift;
  1560.   $break_on_load{$file} = 1;
  1561.   $had_breakpoints{$file} |= 1;
  1562. }
  1563.  
  1564. sub report_break_on_load {
  1565.   sort keys %break_on_load;
  1566. }
  1567.  
  1568. sub cmd_b_load {
  1569.   my $file = shift;
  1570.   my @files;
  1571.   {
  1572.     push @files, $file;
  1573.     push @files, $::INC{$file} if $::INC{$file};
  1574.     $file .= '.pm', redo unless $file =~ /\./;
  1575.   }
  1576.   break_on_load($_) for @files;
  1577.   @files = report_break_on_load;
  1578.   local $\ = '';
  1579.   local $" = ' ';
  1580.   print $OUT "Will stop on load of `@files'.\n";
  1581. }
  1582.  
  1583. $filename_error = '';
  1584.  
  1585. sub breakable_line {
  1586.   my ($from, $to) = @_;
  1587.   my $i = $from;
  1588.   if (@_ >= 2) {
  1589.     my $delta = $from < $to ? +1 : -1;
  1590.     my $limit = $delta > 0 ? $#dbline : 1;
  1591.     $limit = $to if ($limit - $to) * $delta > 0;
  1592.     $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
  1593.   }
  1594.   return $i unless $dbline[$i] == 0;
  1595.   my ($pl, $upto) = ('', '');
  1596.   ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
  1597.   die "Line$pl $from$upto$filename_error not breakable\n";
  1598. }
  1599.  
  1600. sub breakable_line_in_filename {
  1601.   my ($f) = shift;
  1602.   local *dbline = $main::{'_<' . $f};
  1603.   local $filename_error = " of `$f'";
  1604.   breakable_line(@_);
  1605. }
  1606.  
  1607. sub break_on_line {
  1608.   my ($i, $cond) = @_;
  1609.   $cond = 1 unless @_ >= 2;
  1610.   my $inii = $i;
  1611.   my $after = '';
  1612.   my $pl = '';
  1613.   die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
  1614.   $had_breakpoints{$filename} |= 1;
  1615.   if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
  1616.   else { $dbline{$i} = $cond; }
  1617. }
  1618.  
  1619. sub cmd_b_line {
  1620.   eval { break_on_line(@_); 1 } or do {
  1621.     local $\ = '';
  1622.     print $OUT $@ and return;
  1623.   };
  1624. }
  1625.  
  1626. sub break_on_filename_line {
  1627.   my ($f, $i, $cond) = @_;
  1628.   $cond = 1 unless @_ >= 3;
  1629.   local *dbline = $main::{'_<' . $f};
  1630.   local $filename_error = " of `$f'";
  1631.   local $filename = $f;
  1632.   break_on_line($i, $cond);
  1633. }
  1634.  
  1635. sub break_on_filename_line_range {
  1636.   my ($f, $from, $to, $cond) = @_;
  1637.   my $i = breakable_line_in_filename($f, $from, $to);
  1638.   $cond = 1 unless @_ >= 3;
  1639.   break_on_filename_line($f,$i,$cond);
  1640. }
  1641.  
  1642. sub subroutine_filename_lines {
  1643.   my ($subname,$cond) = @_;
  1644.   # Filename below can contain ':'
  1645.   find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
  1646. }
  1647.  
  1648. sub break_subroutine {
  1649.   my $subname = shift;
  1650.   my ($file,$s,$e) = subroutine_filename_lines($subname) or
  1651.     die "Subroutine $subname not found.\n";
  1652.   $cond = 1 unless @_ >= 2;
  1653.   break_on_filename_line_range($file,$s,$e,@_);
  1654. }
  1655.  
  1656. sub cmd_b_sub {
  1657.   my ($subname,$cond) = @_;
  1658.   $cond = 1 unless @_ >= 2;
  1659.   unless (ref $subname eq 'CODE') {
  1660.     $subname =~ s/\'/::/g;
  1661.     my $s = $subname;
  1662.     $subname = "${'package'}::" . $subname
  1663.       unless $subname =~ /::/;
  1664.     $subname = "CORE::GLOBAL::$s"
  1665.       if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
  1666.     $subname = "main".$subname if substr($subname,0,2) eq "::";
  1667.   }
  1668.   eval { break_subroutine($subname,$cond); 1 } or do {
  1669.     local $\ = '';
  1670.     print $OUT $@ and return;
  1671.   }
  1672. }
  1673.  
  1674. sub cmd_B {
  1675.     my $line   = ($_[0] =~ /^\./) ? $dbline : shift || ''; 
  1676.     my $dbline = shift; $line =~ s/^\./$dbline/;
  1677.     if ($line eq '*') {
  1678.         eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
  1679.     } elsif ($line =~ /^(\S.*)/) {
  1680.         eval { &delete_breakpoint($line || $dbline); 1 } or do {
  1681.                     local $\ = '';
  1682.                     print $OUT $@ and return;
  1683.                 };
  1684.     } else {
  1685.         print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
  1686.     }
  1687. }
  1688.  
  1689. sub delete_breakpoint {
  1690.   my $i = shift;
  1691.   if (defined($i)) {
  1692.       die "Line $i not breakable.\n" if $dbline[$i] == 0;
  1693.       $dbline{$i} =~ s/^[^\0]*//;
  1694.       delete $dbline{$i} if $dbline{$i} eq '';
  1695.   } else {
  1696.           print $OUT "Deleting all breakpoints...\n";
  1697.           for my $file (keys %had_breakpoints) {
  1698.                     local *dbline = $main::{'_<' . $file};
  1699.                     my $max = $#dbline;
  1700.                     my $was;
  1701.                     for ($i = 1; $i <= $max ; $i++) {
  1702.                             if (defined $dbline{$i}) {
  1703.                         $dbline{$i} =~ s/^[^\0]+//;
  1704.                         if ($dbline{$i} =~ s/^\0?$//) {
  1705.                                 delete $dbline{$i};
  1706.                         }
  1707.                             }
  1708.                     }
  1709.                     if (not $had_breakpoints{$file} &= ~1) {
  1710.                             delete $had_breakpoints{$file};
  1711.                     }
  1712.           }
  1713.           undef %postponed;
  1714.           undef %postponed_file;
  1715.           undef %break_on_load;
  1716.     }
  1717. }
  1718.  
  1719. sub cmd_stop {            # As on ^C, but not signal-safy.
  1720.   $signal = 1;
  1721. }
  1722.  
  1723. sub cmd_h {
  1724.     my $line   = shift || '';
  1725.     if ($line  =~ /^h\s*/) {
  1726.         print_help($help);
  1727.     } elsif ($line =~ /^(\S.*)$/) { 
  1728.             # support long commands; otherwise bogus errors
  1729.             # happen when you ask for h on <CR> for example
  1730.             my $asked = $1;            # for proper errmsg
  1731.             my $qasked = quotemeta($asked); # for searching
  1732.             # XXX: finds CR but not <CR>
  1733.             if ($help =~ /^<?(?:[IB]<)$qasked/m) {
  1734.               while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
  1735.                 print_help($1);
  1736.               }
  1737.             } else {
  1738.                 print_help("B<$asked> is not a debugger command.\n");
  1739.             }
  1740.     } else {
  1741.             print_help($summary);
  1742.     }
  1743. }
  1744.  
  1745. sub cmd_l {
  1746.     my $line = shift;
  1747.     $line =~ s/^-\s*$/-/;
  1748.     if ($line =~ /^(\$.*)/s) {
  1749.         $evalarg = $2;
  1750.         my ($s) = &eval;
  1751.         print($OUT "Error: $@\n"), next CMD if $@;
  1752.         $s = CvGV_name($s);
  1753.         print($OUT "Interpreted as: $1 $s\n");
  1754.         $line = "$1 $s";
  1755.         &cmd_l($s);
  1756.     } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) { 
  1757.         my $s = $subname = $1;
  1758.         $subname =~ s/\'/::/;
  1759.         $subname = $package."::".$subname 
  1760.         unless $subname =~ /::/;
  1761.         $subname = "CORE::GLOBAL::$s"
  1762.         if not defined &$subname and $s !~ /::/
  1763.              and defined &{"CORE::GLOBAL::$s"};
  1764.         $subname = "main".$subname if substr($subname,0,2) eq "::";
  1765.         @pieces = split(/:/,find_sub($subname) || $sub{$subname});
  1766.         $subrange = pop @pieces;
  1767.         $file = join(':', @pieces);
  1768.         if ($file ne $filename) {
  1769.             print $OUT "Switching to file '$file'.\n"
  1770.         unless $slave_editor;
  1771.             *dbline = $main::{'_<' . $file};
  1772.             $max = $#dbline;
  1773.             $filename = $file;
  1774.         }
  1775.         if ($subrange) {
  1776.             if (eval($subrange) < -$window) {
  1777.         $subrange =~ s/-.*/+/;
  1778.             }
  1779.             $line = $subrange;
  1780.             &cmd_l($subrange);
  1781.         } else {
  1782.             print $OUT "Subroutine $subname not found.\n";
  1783.         }
  1784.     } elsif ($line =~ /^\s*$/) {
  1785.         $incr = $window - 1;
  1786.         $line = $start . '-' . ($start + $incr); 
  1787.         &cmd_l($line);
  1788.     } elsif ($line =~ /^(\d*)\+(\d*)$/) { 
  1789.         $start = $1 if $1;
  1790.         $incr = $2;
  1791.         $incr = $window - 1 unless $incr;
  1792.         $line = $start . '-' . ($start + $incr); 
  1793.         &cmd_l($line);    
  1794.     } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) { 
  1795.         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
  1796.         $end = $max if $end > $max;
  1797.         $i = $2;
  1798.         $i = $line if $i eq '.';
  1799.         $i = 1 if $i < 1;
  1800.         $incr = $end - $i;
  1801.         if ($slave_editor) {
  1802.             print $OUT "\032\032$filename:$i:0\n";
  1803.             $i = $end;
  1804.         } else {
  1805.             for (; $i <= $end; $i++) {
  1806.                 my ($stop,$action);
  1807.                 ($stop,$action) = split(/\0/, $dbline{$i}) if
  1808.                         $dbline{$i};
  1809.                             $arrow = ($i==$line 
  1810.                         and $filename eq $filename_ini) 
  1811.                     ?  '==>' 
  1812.                         : ($dbline[$i]+0 ? ':' : ' ') ;
  1813.                 $arrow .= 'b' if $stop;
  1814.                 $arrow .= 'a' if $action;
  1815.                 print $OUT "$i$arrow\t", $dbline[$i];
  1816.                 $i++, last if $signal;
  1817.             }
  1818.             print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
  1819.         }
  1820.         $start = $i; # remember in case they want more
  1821.         $start = $max if $start > $max;
  1822.     }
  1823. }
  1824.  
  1825. sub cmd_L {
  1826.     my $arg    = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
  1827.     my $action_wanted = ($arg =~ /a/) ? 1 : 0;
  1828.     my $break_wanted  = ($arg =~ /b/) ? 1 : 0;
  1829.     my $watch_wanted  = ($arg =~ /w/) ? 1 : 0;
  1830.  
  1831.     if ($break_wanted or $action_wanted) {
  1832.         for my $file (keys %had_breakpoints) {
  1833.             local *dbline = $main::{'_<' . $file};
  1834.             my $max = $#dbline;
  1835.             my $was;
  1836.             for ($i = 1; $i <= $max; $i++) {
  1837.                 if (defined $dbline{$i}) {
  1838.                     print $OUT "$file:\n" unless $was++;
  1839.                     print $OUT " $i:\t", $dbline[$i];
  1840.                     ($stop,$action) = split(/\0/, $dbline{$i});
  1841.                     print $OUT "   break if (", $stop, ")\n"
  1842.                         if $stop and $break_wanted;
  1843.                     print $OUT "   action:  ", $action, "\n"
  1844.                         if $action and $action_wanted;
  1845.                     last if $signal;
  1846.                 }
  1847.             }
  1848.         }
  1849.     }
  1850.     if (%postponed and $break_wanted) {
  1851.         print $OUT "Postponed breakpoints in subroutines:\n";
  1852.         my $subname;
  1853.         for $subname (keys %postponed) {
  1854.           print $OUT " $subname\t$postponed{$subname}\n";
  1855.           last if $signal;
  1856.         }
  1857.     }
  1858.     my @have = map { # Combined keys
  1859.             keys %{$postponed_file{$_}}
  1860.     } keys %postponed_file;
  1861.     if (@have and ($break_wanted or $action_wanted)) {
  1862.         print $OUT "Postponed breakpoints in files:\n";
  1863.         my ($file, $line);
  1864.         for $file (keys %postponed_file) {
  1865.           my $db = $postponed_file{$file};
  1866.           print $OUT " $file:\n";
  1867.           for $line (sort {$a <=> $b} keys %$db) {
  1868.             print $OUT "  $line:\n";
  1869.             my ($stop,$action) = split(/\0/, $$db{$line});
  1870.             print $OUT "    break if (", $stop, ")\n"
  1871.               if $stop and $break_wanted;
  1872.             print $OUT "    action:  ", $action, "\n"
  1873.               if $action and $action_wanted;
  1874.             last if $signal;
  1875.           }
  1876.           last if $signal;
  1877.         }
  1878.     }
  1879.   if (%break_on_load and $break_wanted) {
  1880.         print $OUT "Breakpoints on load:\n";
  1881.         my $file;
  1882.         for $file (keys %break_on_load) {
  1883.           print $OUT " $file\n";
  1884.           last if $signal;
  1885.         }
  1886.   }
  1887.   if ($watch_wanted) {
  1888.     if ($trace & 2) {
  1889.         print $OUT "Watch-expressions:\n" if @to_watch;
  1890.         for my $expr (@to_watch) {
  1891.             print $OUT " $expr\n";
  1892.             last if $signal;
  1893.         }
  1894.     }
  1895.   }
  1896. }
  1897.  
  1898. sub cmd_M {
  1899.     &list_modules();
  1900. }
  1901.  
  1902. sub cmd_o {
  1903.     my $opt      = shift || ''; # opt[=val]
  1904.     if ($opt =~ /^(\S.*)/) {
  1905.         &parse_options($1);
  1906.     } else {
  1907.         for (@options) {
  1908.             &dump_option($_);
  1909.         }
  1910.     }
  1911. }
  1912.  
  1913. sub cmd_O {
  1914.     print $OUT "The old O command is now the o command.\n";        # hint
  1915.     print $OUT "Use 'h' to get current command help synopsis or\n"; # 
  1916.     print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; # 
  1917. }
  1918.  
  1919. sub cmd_v {
  1920.     my $line = shift;
  1921.  
  1922.     if ($line =~ /^(\d*)$/) {
  1923.         $incr = $window - 1;
  1924.         $start = $1 if $1;
  1925.         $start -= $preview;
  1926.         $line = $start . '-' . ($start + $incr);
  1927.         &cmd_l($line);
  1928.     }
  1929. }
  1930.  
  1931. sub cmd_w {
  1932.     my $expr     = shift || '';
  1933.     if ($expr =~ /^(\S.*)/) {
  1934.         push @to_watch, $expr;
  1935.         $evalarg = $expr;
  1936.         my ($val) = &eval;
  1937.         $val = (defined $val) ? "'$val'" : 'undef' ;
  1938.         push @old_watch, $val;
  1939.         $trace |= 2;
  1940.     } else {
  1941.         print $OUT "Adding a watch-expression requires an expression\n"; # hint
  1942.     }
  1943. }
  1944.  
  1945. sub cmd_W {
  1946.     my $expr     = shift || '';
  1947.     if ($expr eq '*') {
  1948.         $trace &= ~2;
  1949.         print $OUT "Deleting all watch expressions ...\n";
  1950.         @to_watch = @old_watch = ();
  1951.     } elsif ($expr =~ /^(\S.*)/) {
  1952.         my $i_cnt = 0;
  1953.         foreach (@to_watch) {
  1954.             my $val = $to_watch[$i_cnt];
  1955.             if ($val eq $expr) { # =~ m/^\Q$i$/) {
  1956.                 splice(@to_watch, $i_cnt, 1);
  1957.             }
  1958.             $i_cnt++;
  1959.         }
  1960.     } else {
  1961.         print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
  1962.     }
  1963. }
  1964.  
  1965. ### END of the API section
  1966.  
  1967. sub save {
  1968.     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
  1969.     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
  1970. }
  1971.  
  1972. sub print_lineinfo {
  1973.   resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
  1974.   local $\ = '';
  1975.   local $, = '';
  1976.   print $LINEINFO @_;
  1977. }
  1978.  
  1979. # The following takes its argument via $evalarg to preserve current @_
  1980.  
  1981. sub postponed_sub {
  1982.   my $subname = shift;
  1983.   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
  1984.     my $offset = $1 || 0;
  1985.     # Filename below can contain ':'
  1986.     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
  1987.     if ($i) {
  1988.       $i += $offset;
  1989.       local *dbline = $main::{'_<' . $file};
  1990.       local $^W = 0;        # != 0 is magical below
  1991.       $had_breakpoints{$file} |= 1;
  1992.       my $max = $#dbline;
  1993.       ++$i until $dbline[$i] != 0 or $i >= $max;
  1994.       $dbline{$i} = delete $postponed{$subname};
  1995.     } else {
  1996.       local $\ = '';
  1997.       print $OUT "Subroutine $subname not found.\n";
  1998.     }
  1999.     return;
  2000.   }
  2001.   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
  2002.   #print $OUT "In postponed_sub for `$subname'.\n";
  2003. }
  2004.  
  2005. sub postponed {
  2006.   if ($ImmediateStop) {
  2007.     $ImmediateStop = 0;
  2008.     $signal = 1;
  2009.   }
  2010.   return &postponed_sub
  2011.     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
  2012.   # Cannot be done before the file is compiled
  2013.   local *dbline = shift;
  2014.   my $filename = $dbline;
  2015.   $filename =~ s/^_<//;
  2016.   local $\ = '';
  2017.   $signal = 1, print $OUT "'$filename' loaded...\n"
  2018.     if $break_on_load{$filename};
  2019.   print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
  2020.   return unless $postponed_file{$filename};
  2021.   $had_breakpoints{$filename} |= 1;
  2022.   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
  2023.   my $key;
  2024.   for $key (keys %{$postponed_file{$filename}}) {
  2025.     $dbline{$key} = ${$postponed_file{$filename}}{$key};
  2026.   }
  2027.   delete $postponed_file{$filename};
  2028. }
  2029.  
  2030. sub dumpit {
  2031.     local ($savout) = select(shift);
  2032.     my $osingle = $single;
  2033.     my $otrace = $trace;
  2034.     $single = $trace = 0;
  2035.     local $frame = 0;
  2036.     local $doret = -2;
  2037.     unless (defined &main::dumpValue) {
  2038.     do 'dumpvar.pl';
  2039.     }
  2040.     if (defined &main::dumpValue) {
  2041.         local $\ = '';
  2042.         local $, = '';
  2043.         local $" = ' ';
  2044.         my $v = shift;
  2045.         my $maxdepth = shift || $option{dumpDepth};
  2046.         $maxdepth = -1 unless defined $maxdepth;   # -1 means infinite depth
  2047.     &main::dumpValue($v, $maxdepth);
  2048.     } else {
  2049.         local $\ = '';
  2050.     print $OUT "dumpvar.pl not available.\n";
  2051.     }
  2052.     $single = $osingle;
  2053.     $trace = $otrace;
  2054.     select ($savout);    
  2055. }
  2056.  
  2057. # Tied method do not create a context, so may get wrong message:
  2058.  
  2059. sub print_trace {
  2060.   local $\ = '';
  2061.   my $fh = shift;
  2062.   resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
  2063.   my @sub = dump_trace($_[0] + 1, $_[1]);
  2064.   my $short = $_[2];        # Print short report, next one for sub name
  2065.   my $s;
  2066.   for ($i=0; $i <= $#sub; $i++) {
  2067.     last if $signal;
  2068.     local $" = ', ';
  2069.     my $args = defined $sub[$i]{args} 
  2070.     ? "(@{ $sub[$i]{args} })"
  2071.       : '' ;
  2072.     $args = (substr $args, 0, $maxtrace - 3) . '...' 
  2073.       if length $args > $maxtrace;
  2074.     my $file = $sub[$i]{file};
  2075.     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
  2076.     $s = $sub[$i]{sub};
  2077.     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;    
  2078.     if ($short) {
  2079.       my $sub = @_ >= 4 ? $_[3] : $s;
  2080.       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
  2081.     } else {
  2082.       print $fh "$sub[$i]{context} = $s$args" .
  2083.     " called from $file" . 
  2084.       " line $sub[$i]{line}\n";
  2085.     }
  2086.   }
  2087. }
  2088.  
  2089. sub dump_trace {
  2090.   my $skip = shift;
  2091.   my $count = shift || 1e9;
  2092.   $skip++;
  2093.   $count += $skip;
  2094.   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
  2095.   my $nothard = not $frame & 8;
  2096.   local $frame = 0;        # Do not want to trace this.
  2097.   my $otrace = $trace;
  2098.   $trace = 0;
  2099.   for ($i = $skip; 
  2100.        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); 
  2101.        $i++) {
  2102.     @a = ();
  2103.     for $arg (@args) {
  2104.       my $type;
  2105.       if (not defined $arg) {
  2106.     push @a, "undef";
  2107.       } elsif ($nothard and tied $arg) {
  2108.     push @a, "tied";
  2109.       } elsif ($nothard and $type = ref $arg) {
  2110.     push @a, "ref($type)";
  2111.       } else {
  2112.     local $_ = "$arg";    # Safe to stringify now - should not call f().
  2113.     s/([\'\\])/\\$1/g;
  2114.     s/(.*)/'$1'/s
  2115.       unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
  2116.     s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  2117.     s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  2118.     push(@a, $_);
  2119.       }
  2120.     }
  2121.     $context = $context ? '@' : (defined $context ? "\$" : '.');
  2122.     $args = $h ? [@a] : undef;
  2123.     $e =~ s/\n\s*\;\s*\Z// if $e;
  2124.     $e =~ s/([\\\'])/\\$1/g if $e;
  2125.     if ($r) {
  2126.       $sub = "require '$e'";
  2127.     } elsif (defined $r) {
  2128.       $sub = "eval '$e'";
  2129.     } elsif ($sub eq '(eval)') {
  2130.       $sub = "eval {...}";
  2131.     }
  2132.     push(@sub, {context => $context, sub => $sub, args => $args,
  2133.         file => $file, line => $line});
  2134.     last if $signal;
  2135.   }
  2136.   $trace = $otrace;
  2137.   @sub;
  2138. }
  2139.  
  2140. sub action {
  2141.     my $action = shift;
  2142.     while ($action =~ s/\\$//) {
  2143.     #print $OUT "+ ";
  2144.     #$action .= "\n";
  2145.     $action .= &gets;
  2146.     }
  2147.     $action;
  2148. }
  2149.  
  2150. sub unbalanced { 
  2151.     # i hate using globals!
  2152.     $balanced_brace_re ||= qr{ 
  2153.     ^ \{
  2154.           (?:
  2155.          (?> [^{}] + )            # Non-parens without backtracking
  2156.            |
  2157.          (??{ $balanced_brace_re }) # Group with matching parens
  2158.           ) *
  2159.       \} $
  2160.    }x;
  2161.    return $_[0] !~ m/$balanced_brace_re/;
  2162. }
  2163.  
  2164. sub gets {
  2165.     &readline("cont: ");
  2166. }
  2167.  
  2168. sub system {
  2169.     # We save, change, then restore STDIN and STDOUT to avoid fork() since
  2170.     # some non-Unix systems can do system() but have problems with fork().
  2171.     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
  2172.     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
  2173.     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
  2174.     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  2175.  
  2176.     # XXX: using csh or tcsh destroys sigint retvals!
  2177.     system(@_);
  2178.     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
  2179.     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  2180.     close(SAVEIN); 
  2181.     close(SAVEOUT);
  2182.  
  2183.  
  2184.     # most of the $? crud was coping with broken cshisms
  2185.     if ($? >> 8) {
  2186.     &warn("(Command exited ", ($? >> 8), ")\n");
  2187.     } elsif ($?) { 
  2188.     &warn( "(Command died of SIG#",  ($? & 127),
  2189.         (($? & 128) ? " -- core dumped" : "") , ")", "\n");
  2190.     } 
  2191.  
  2192.     return $?;
  2193.  
  2194. }
  2195.  
  2196. sub setterm {
  2197.     local $frame = 0;
  2198.     local $doret = -2;
  2199.     eval { require Term::ReadLine } or die $@;
  2200.     if ($notty) {
  2201.     if ($tty) {
  2202.         my ($i, $o) = split $tty, /,/;
  2203.         $o = $i unless defined $o;
  2204.         open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
  2205.         open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
  2206.         $IN = \*IN;
  2207.         $OUT = \*OUT;
  2208.         my $sel = select($OUT);
  2209.         $| = 1;
  2210.         select($sel);
  2211.     } else {
  2212.         eval "require Term::Rendezvous;" or die;
  2213.         my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
  2214.         my $term_rv = new Term::Rendezvous $rv;
  2215.         $IN = $term_rv->IN;
  2216.         $OUT = $term_rv->OUT;
  2217.     }
  2218.     }
  2219.     if ($term_pid eq '-1') {        # In a TTY with another debugger
  2220.     resetterm(2);
  2221.     }
  2222.     if (!$rl) {
  2223.     $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
  2224.     } else {
  2225.     $term = new Term::ReadLine 'perldb', $IN, $OUT;
  2226.  
  2227.     $rl_attribs = $term->Attribs;
  2228.     $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 
  2229.       if defined $rl_attribs->{basic_word_break_characters} 
  2230.         and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
  2231.     $rl_attribs->{special_prefixes} = '$@&%';
  2232.     $rl_attribs->{completer_word_break_characters} .= '$@&%';
  2233.     $rl_attribs->{completion_function} = \&db_complete; 
  2234.     }
  2235.     $LINEINFO = $OUT unless defined $LINEINFO;
  2236.     $lineinfo = $console unless defined $lineinfo;
  2237.     $term->MinLine(2);
  2238.     if ($term->Features->{setHistory} and "@hist" ne "?") {
  2239.       $term->SetHistory(@hist);
  2240.     }
  2241.     ornaments($ornaments) if defined $ornaments;
  2242.     $term_pid = $$;
  2243. }
  2244.  
  2245. # Example get_fork_TTY functions
  2246. sub xterm_get_fork_TTY {
  2247.   (my $name = $0) =~ s,^.*[/\\],,s;
  2248.   open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
  2249.  sleep 10000000' |];
  2250.   my $tty = <XT>;
  2251.   chomp $tty;
  2252.   $pidprompt = '';        # Shown anyway in titlebar
  2253.   return $tty;
  2254. }
  2255.  
  2256. # This example function resets $IN, $OUT itself
  2257. sub os2_get_fork_TTY {
  2258.   local $^F = 40;            # XXXX Fixme!
  2259.   local $\ = '';
  2260.   my ($in1, $out1, $in2, $out2);
  2261.   # Having -d in PERL5OPT would lead to a disaster...
  2262.   local $ENV{PERL5OPT} = $ENV{PERL5OPT}    if $ENV{PERL5OPT};
  2263.   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b//  if $ENV{PERL5OPT};
  2264.   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
  2265.   print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
  2266.   local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
  2267.   $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
  2268.   $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
  2269.   (my $name = $0) =~ s,^.*[/\\],,s;
  2270.   my @args;
  2271.   if ( pipe $in1, $out1 and pipe $in2, $out2
  2272.        # system P_SESSION will fail if there is another process
  2273.        # in the same session with a "dependent" asynchronous child session.
  2274.        and @args = ($rl, fileno $in1, fileno $out2,
  2275.             "Daughter Perl debugger $pids $name") and
  2276.        (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
  2277. END {sleep 5 unless $loaded}
  2278. BEGIN {open STDIN,  '</dev/con' or warn "reopen stdin: $!"}
  2279. use OS2::Process;
  2280.  
  2281. my ($rl, $in) = (shift, shift);        # Read from $in and pass through
  2282. set_title pop;
  2283. system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
  2284.   open IN, '<&=$in' or die "open <&=$in: \$!";
  2285.   \$| = 1; print while sysread IN, \$_, 1<<16;
  2286. EOS
  2287.  
  2288. my $out = shift;
  2289. open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
  2290. select OUT;    $| = 1;
  2291. require Term::ReadKey if $rl;
  2292. Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd.  Pipe is automatically nodelay...
  2293. print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
  2294. ES
  2295.      or warn "system P_SESSION: $!, $^E" and 0)
  2296.     and close $in1 and close $out2 ) {
  2297.       $pidprompt = '';            # Shown anyway in titlebar
  2298.       reset_IN_OUT($in2, $out1);
  2299.       $tty = '*reset*';
  2300.       return '';            # Indicate that reset_IN_OUT is called
  2301.    }
  2302.    return;
  2303. }
  2304.  
  2305. sub create_IN_OUT {    # Create a window with IN/OUT handles redirected there
  2306.     my $in = &get_fork_TTY if defined &get_fork_TTY;
  2307.     $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
  2308.     if (not defined $in) {
  2309.       my $why = shift;
  2310.       print_help(<<EOP) if $why == 1;
  2311. I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
  2312. EOP
  2313.       print_help(<<EOP) if $why == 2;
  2314. I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
  2315.   This may be an asynchronous session, so the parent debugger may be active.
  2316. EOP
  2317.       print_help(<<EOP) if $why != 4;
  2318.   Since two debuggers fight for the same TTY, input is severely entangled.
  2319.  
  2320. EOP
  2321.       print_help(<<EOP);
  2322.   I know how to switch the output to a different window in xterms
  2323.   and OS/2 consoles only.  For a manual switch, put the name of the created I<TTY>
  2324.   in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
  2325.  
  2326.   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
  2327.   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
  2328.  
  2329. EOP
  2330.     } elsif ($in ne '') {
  2331.       TTY($in);
  2332.     } else {
  2333.       $console = '';        # Indicate no need to open-from-the-console 
  2334.     }
  2335.     undef $fork_TTY;
  2336. }
  2337.  
  2338. sub resetterm {            # We forked, so we need a different TTY
  2339.     my $in = shift;
  2340.     my $systemed = $in > 1 ? '-' : '';
  2341.     if ($pids) {
  2342.       $pids =~ s/\]/$systemed->$$]/;
  2343.     } else {
  2344.       $pids = "[$term_pid->$$]";
  2345.     }
  2346.     $pidprompt = $pids;
  2347.     $term_pid = $$;
  2348.     return unless $CreateTTY & $in;
  2349.     create_IN_OUT($in);
  2350. }
  2351.  
  2352. sub readline {
  2353.   local $.;
  2354.   if (@typeahead) {
  2355.     my $left = @typeahead;
  2356.     my $got = shift @typeahead;
  2357.     local $\ = '';
  2358.     print $OUT "auto(-$left)", shift, $got, "\n";
  2359.     $term->AddHistory($got) 
  2360.       if length($got) > 1 and defined $term->Features->{addHistory};
  2361.     return $got;
  2362.   }
  2363.   local $frame = 0;
  2364.   local $doret = -2;
  2365.   while (@cmdfhs) {
  2366.     my $line = CORE::readline($cmdfhs[-1]);
  2367.     defined $line ? (print $OUT ">> $line" and return $line)
  2368.                   : close pop @cmdfhs;
  2369.   }
  2370.   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
  2371.     $OUT->write(join('', @_));
  2372.     my $stuff;
  2373.     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
  2374.     $stuff;
  2375.   }
  2376.   else {
  2377.     $term->readline(@_);
  2378.   }
  2379. }
  2380.  
  2381. sub dump_option {
  2382.     my ($opt, $val)= @_;
  2383.     $val = option_val($opt,'N/A');
  2384.     $val =~ s/([\\\'])/\\$1/g;
  2385.     printf $OUT "%20s = '%s'\n", $opt, $val;
  2386. }
  2387.  
  2388. sub option_val {
  2389.     my ($opt, $default)= @_;
  2390.     my $val;
  2391.     if (defined $optionVars{$opt}
  2392.     and defined ${$optionVars{$opt}}) {
  2393.     $val = ${$optionVars{$opt}};
  2394.     } elsif (defined $optionAction{$opt}
  2395.     and defined &{$optionAction{$opt}}) {
  2396.     $val = &{$optionAction{$opt}}();
  2397.     } elsif (defined $optionAction{$opt}
  2398.          and not defined $option{$opt}
  2399.          or defined $optionVars{$opt}
  2400.          and not defined ${$optionVars{$opt}}) {
  2401.     $val = $default;
  2402.     } else {
  2403.     $val = $option{$opt};
  2404.     }
  2405.     $val = $default unless defined $val;
  2406.     $val
  2407. }
  2408.  
  2409. sub parse_options {
  2410.     local($_)= @_;
  2411.     local $\ = '';
  2412.     # too dangerous to let intuitive usage overwrite important things
  2413.     # defaultion should never be the default
  2414.     my %opt_needs_val = map { ( $_ => 1 ) } qw{
  2415.         dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
  2416.         pager quote ReadLine recallCommand RemotePort ShellBang TTY
  2417.     };
  2418.     while (length) {
  2419.     my $val_defaulted;
  2420.     s/^\s+// && next;
  2421.     s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
  2422.     my ($opt,$sep) = ($1,$2);
  2423.     my $val;
  2424.     if ("?" eq $sep) {
  2425.         print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
  2426.           if /^\S/;
  2427.         #&dump_option($opt);
  2428.     } elsif ($sep !~ /\S/) {
  2429.         $val_defaulted = 1;
  2430.         $val = "1";  #  this is an evil default; make 'em set it!
  2431.     } elsif ($sep eq "=") {
  2432.             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { 
  2433.                 my $quote = $1;
  2434.                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
  2435.         } else { 
  2436.         s/^(\S*)//;
  2437.         $val = $1;
  2438.         print OUT qq(Option better cleared using $opt=""\n)
  2439.             unless length $val;
  2440.         }
  2441.  
  2442.     } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
  2443.         my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
  2444.         s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
  2445.           print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
  2446.         ($val = $1) =~ s/\\([\\$end])/$1/g;
  2447.     }
  2448.  
  2449.     my $option;
  2450.     my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
  2451.            || grep( /^\Q$opt/i && ($option = $_),  @options  );
  2452.  
  2453.     print($OUT "Unknown option `$opt'\n"), next     unless $matches;
  2454.     print($OUT "Ambiguous option `$opt'\n"), next     if $matches > 1;
  2455.  
  2456.        if ($opt_needs_val{$option} && $val_defaulted) {
  2457.              my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
  2458.         print $OUT "Option `$opt' is non-boolean.  Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
  2459.         next;
  2460.     } 
  2461.  
  2462.     $option{$option} = $val if defined $val;
  2463.  
  2464.     eval qq{
  2465.         local \$frame = 0; 
  2466.         local \$doret = -2; 
  2467.             require '$optionRequire{$option}';
  2468.         1;
  2469.      } || die  # XXX: shouldn't happen
  2470.         if  defined $optionRequire{$option}        &&
  2471.             defined $val;
  2472.  
  2473.     ${$optionVars{$option}} = $val         
  2474.         if  defined $optionVars{$option}        &&
  2475.         defined $val;
  2476.  
  2477.     &{$optionAction{$option}} ($val)    
  2478.         if defined $optionAction{$option}        &&
  2479.                defined &{$optionAction{$option}}    &&
  2480.                defined $val;
  2481.  
  2482.     # Not $rcfile
  2483.     dump_option($option)     unless $OUT eq \*STDERR; 
  2484.     }
  2485. }
  2486.  
  2487. sub set_list {
  2488.   my ($stem,@list) = @_;
  2489.   my $val;
  2490.   $ENV{"${stem}_n"} = @list;
  2491.   for $i (0 .. $#list) {
  2492.     $val = $list[$i];
  2493.     $val =~ s/\\/\\\\/g;
  2494.     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
  2495.     $ENV{"${stem}_$i"} = $val;
  2496.   }
  2497. }
  2498.  
  2499. sub get_list {
  2500.   my $stem = shift;
  2501.   my @list;
  2502.   my $n = delete $ENV{"${stem}_n"};
  2503.   my $val;
  2504.   for $i (0 .. $n - 1) {
  2505.     $val = delete $ENV{"${stem}_$i"};
  2506.     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
  2507.     push @list, $val;
  2508.   }
  2509.   @list;
  2510. }
  2511.  
  2512. sub catch {
  2513.     $signal = 1;
  2514.     return;            # Put nothing on the stack - malloc/free land!
  2515. }
  2516.  
  2517. sub warn {
  2518.     my($msg)= join("",@_);
  2519.     $msg .= ": $!\n" unless $msg =~ /\n$/;
  2520.     local $\ = '';
  2521.     print $OUT $msg;
  2522. }
  2523.  
  2524. sub reset_IN_OUT {
  2525.     my $switch_li = $LINEINFO eq $OUT;
  2526.     if ($term and $term->Features->{newTTY}) {
  2527.       ($IN, $OUT) = (shift, shift);
  2528.       $term->newTTY($IN, $OUT);
  2529.     } elsif ($term) {
  2530.     &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
  2531.     } else {
  2532.       ($IN, $OUT) = (shift, shift);
  2533.     }
  2534.     my $o = select $OUT;
  2535.     $| = 1;
  2536.     select $o;
  2537.     $LINEINFO = $OUT if $switch_li;
  2538. }
  2539.  
  2540. sub TTY {
  2541.     if (@_ and $term and $term->Features->{newTTY}) {
  2542.       my ($in, $out) = shift;
  2543.       if ($in =~ /,/) {
  2544.     ($in, $out) = split /,/, $in, 2;
  2545.       } else {
  2546.     $out = $in;
  2547.       }
  2548.       open IN, $in or die "cannot open `$in' for read: $!";
  2549.       open OUT, ">$out" or die "cannot open `$out' for write: $!";
  2550.       reset_IN_OUT(\*IN,\*OUT);
  2551.       return $tty = $in;
  2552.     }
  2553.     &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
  2554.     # Useful if done through PERLDB_OPTS:
  2555.     $console = $tty = shift if @_;
  2556.     $tty or $console;
  2557. }
  2558.  
  2559. sub noTTY {
  2560.     if ($term) {
  2561.     &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
  2562.     }
  2563.     $notty = shift if @_;
  2564.     $notty;
  2565. }
  2566.  
  2567. sub ReadLine {
  2568.     if ($term) {
  2569.     &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
  2570.     }
  2571.     $rl = shift if @_;
  2572.     $rl;
  2573. }
  2574.  
  2575. sub RemotePort {
  2576.     if ($term) {
  2577.         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
  2578.     }
  2579.     $remoteport = shift if @_;
  2580.     $remoteport;
  2581. }
  2582.  
  2583. sub tkRunning {
  2584.     if (${$term->Features}{tkRunning}) {
  2585.         return $term->tkRunning(@_);
  2586.     } else {
  2587.     local $\ = '';
  2588.     print $OUT "tkRunning not supported by current ReadLine package.\n";
  2589.     0;
  2590.     }
  2591. }
  2592.  
  2593. sub NonStop {
  2594.     if ($term) {
  2595.     &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
  2596.     }
  2597.     $runnonstop = shift if @_;
  2598.     $runnonstop;
  2599. }
  2600.  
  2601. sub pager {
  2602.     if (@_) {
  2603.     $pager = shift;
  2604.     $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
  2605.     }
  2606.     $pager;
  2607. }
  2608.  
  2609. sub shellBang {
  2610.     if (@_) {
  2611.     $sh = quotemeta shift;
  2612.     $sh .= "\\b" if $sh =~ /\w$/;
  2613.     }
  2614.     $psh = $sh;
  2615.     $psh =~ s/\\b$//;
  2616.     $psh =~ s/\\(.)/$1/g;
  2617.     $psh;
  2618. }
  2619.  
  2620. sub ornaments {
  2621.   if (defined $term) {
  2622.     local ($warnLevel,$dieLevel) = (0, 1);
  2623.     return '' unless $term->Features->{ornaments};
  2624.     eval { $term->ornaments(@_) } || '';
  2625.   } else {
  2626.     $ornaments = shift;
  2627.   }
  2628. }
  2629.  
  2630. sub recallCommand {
  2631.     if (@_) {
  2632.     $rc = quotemeta shift;
  2633.     $rc .= "\\b" if $rc =~ /\w$/;
  2634.     }
  2635.     $prc = $rc;
  2636.     $prc =~ s/\\b$//;
  2637.     $prc =~ s/\\(.)/$1/g;
  2638.     $prc;
  2639. }
  2640.  
  2641. sub LineInfo {
  2642.     return $lineinfo unless @_;
  2643.     $lineinfo = shift;
  2644.     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
  2645.     $slave_editor = ($stream =~ /^\|/);
  2646.     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
  2647.     $LINEINFO = \*LINEINFO;
  2648.     my $save = select($LINEINFO);
  2649.     $| = 1;
  2650.     select($save);
  2651.     $lineinfo;
  2652. }
  2653.  
  2654. sub list_modules { # versions
  2655.   my %version;
  2656.   my $file;
  2657.   for (keys %INC) {
  2658.     $file = $_;
  2659.     s,\.p[lm]$,,i ;
  2660.     s,/,::,g ;
  2661.     s/^perl5db$/DB/;
  2662.     s/^Term::ReadLine::readline$/readline/;
  2663.     if (defined ${ $_ . '::VERSION' }) {
  2664.       $version{$file} = "${ $_ . '::VERSION' } from ";
  2665.     } 
  2666.     $version{$file} .= $INC{$file};
  2667.   }
  2668.   dumpit($OUT,\%version);
  2669. }
  2670.  
  2671. sub sethelp {
  2672.     # XXX: make sure there are tabs between the command and explanation,
  2673.     #      or print_help will screw up your formatting if you have
  2674.     #      eeevil ornaments enabled.  This is an insane mess.
  2675.  
  2676.     $help = "
  2677. Help is currently only available for the new 580 CommandSet, 
  2678. if you really want old behaviour, presumably you know what 
  2679. you're doing ?-)
  2680.  
  2681. B<T>        Stack trace.
  2682. B<s> [I<expr>]    Single step [in I<expr>].
  2683. B<n> [I<expr>]    Next, steps over subroutine calls [in I<expr>].
  2684. <B<CR>>        Repeat last B<n> or B<s> command.
  2685. B<r>        Return from current subroutine.
  2686. B<c> [I<line>|I<sub>]    Continue; optionally inserts a one-time-only breakpoint
  2687.         at the specified position.
  2688. B<l> I<min>B<+>I<incr>    List I<incr>+1 lines starting at I<min>.
  2689. B<l> I<min>B<->I<max>    List lines I<min> through I<max>.
  2690. B<l> I<line>        List single I<line>.
  2691. B<l> I<subname>    List first window of lines from subroutine.
  2692. B<l> I<\$var>        List first window of lines from subroutine referenced by I<\$var>.
  2693. B<l>        List next window of lines.
  2694. B<->        List previous window of lines.
  2695. B<v> [I<line>]    View window around I<line>.
  2696. B<.>        Return to the executed line.
  2697. B<f> I<filename>    Switch to viewing I<filename>. File must be already loaded.
  2698.         I<filename> may be either the full name of the file, or a regular
  2699.         expression matching the full file name:
  2700.         B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
  2701.         Evals (with saved bodies) are considered to be filenames:
  2702.         B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
  2703.         (in the order of execution).
  2704. B</>I<pattern>B</>    Search forwards for I<pattern>; final B</> is optional.
  2705. B<?>I<pattern>B<?>    Search backwards for I<pattern>; final B<?> is optional.
  2706. B<L> [I<a|b|w>]        List actions and or breakpoints and or watch-expressions.
  2707. B<S> [[B<!>]I<pattern>]    List subroutine names [not] matching I<pattern>.
  2708. B<t>        Toggle trace mode.
  2709. B<t> I<expr>        Trace through execution of I<expr>.
  2710. B<b>        Sets breakpoint on current line)
  2711. B<b> [I<line>] [I<condition>]
  2712.         Set breakpoint; I<line> defaults to the current execution line;
  2713.         I<condition> breaks if it evaluates to true, defaults to '1'.
  2714. B<b> I<subname> [I<condition>]
  2715.         Set breakpoint at first line of subroutine.
  2716. B<b> I<\$var>        Set breakpoint at first line of subroutine referenced by I<\$var>.
  2717. B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
  2718. B<b> B<postpone> I<subname> [I<condition>]
  2719.         Set breakpoint at first line of subroutine after 
  2720.         it is compiled.
  2721. B<b> B<compile> I<subname>
  2722.         Stop after the subroutine is compiled.
  2723. B<B> [I<line>]    Delete the breakpoint for I<line>.
  2724. B<B> I<*>             Delete all breakpoints.
  2725. B<a> [I<line>] I<command>
  2726.         Set an action to be done before the I<line> is executed;
  2727.         I<line> defaults to the current execution line.
  2728.         Sequence is: check for breakpoint/watchpoint, print line
  2729.         if necessary, do action, prompt user if necessary,
  2730.         execute line.
  2731. B<a>        Does nothing
  2732. B<A> [I<line>]    Delete the action for I<line>.
  2733. B<A> I<*>             Delete all actions.
  2734. B<w> I<expr>        Add a global watch-expression.
  2735. B<w>             Does nothing
  2736. B<W> I<expr>        Delete a global watch-expression.
  2737. B<W> I<*>             Delete all watch-expressions.
  2738. B<V> [I<pkg> [I<vars>]]    List some (default all) variables in package (default current).
  2739.         Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
  2740. B<X> [I<vars>]    Same as \"B<V> I<currentpackage> [I<vars>]\".
  2741. B<x> I<expr>        Evals expression in list context, dumps the result.
  2742. B<m> I<expr>        Evals expression in list context, prints methods callable
  2743.         on the first element of the result.
  2744. B<m> I<class>        Prints methods callable via the given class.
  2745. B<M>        Show versions of loaded modules.
  2746.  
  2747. B<<> ?            List Perl commands to run before each prompt.
  2748. B<<> I<expr>        Define Perl command to run before each prompt.
  2749. B<<<> I<expr>        Add to the list of Perl commands to run before each prompt.
  2750. B<>> ?            List Perl commands to run after each prompt.
  2751. B<>> I<expr>        Define Perl command to run after each prompt.
  2752. B<>>B<>> I<expr>        Add to the list of Perl commands to run after each prompt.
  2753. B<{> I<db_command>    Define debugger command to run before each prompt.
  2754. B<{> ?            List debugger commands to run before each prompt.
  2755. B<{{> I<db_command>    Add to the list of debugger commands to run before each prompt.
  2756. B<$prc> I<number>    Redo a previous command (default previous command).
  2757. B<$prc> I<-number>    Redo number'th-to-last command.
  2758. B<$prc> I<pattern>    Redo last command that started with I<pattern>.
  2759.         See 'B<O> I<recallCommand>' too.
  2760. B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
  2761.   . ( $rc eq $sh ? "" : "
  2762. B<$psh> [I<cmd>]     Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
  2763.         See 'B<O> I<shellBang>' too.
  2764. B<source> I<file>        Execute I<file> containing debugger commands (may nest).
  2765. B<H> I<-number>    Display last number commands (default all).
  2766. B<p> I<expr>        Same as \"I<print {DB::OUT} expr>\" in current package.
  2767. B<|>I<dbcmd>        Run debugger command, piping DB::OUT to current pager.
  2768. B<||>I<dbcmd>        Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
  2769. B<\=> [I<alias> I<value>]    Define a command alias, or list current aliases.
  2770. I<command>        Execute as a perl statement in current package.
  2771. B<R>        Pure-man-restart of debugger, some of debugger state
  2772.         and command-line options may be lost.
  2773.         Currently the following settings are preserved:
  2774.         history, breakpoints and actions, debugger B<O>ptions 
  2775.         and the following command-line options: I<-w>, I<-I>, I<-e>.
  2776.  
  2777. B<o> [I<opt>] ...    Set boolean option to true
  2778. B<o> [I<opt>B<?>]    Query options
  2779. B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 
  2780.         Set options.  Use quotes in spaces in value.
  2781.     I<recallCommand>, I<ShellBang>    chars used to recall command or spawn shell;
  2782.     I<pager>            program for output of \"|cmd\";
  2783.     I<tkRunning>            run Tk while prompting (with ReadLine);
  2784.     I<signalLevel> I<warnLevel> I<dieLevel>    level of verbosity;
  2785.     I<inhibit_exit>        Allows stepping off the end of the script.
  2786.     I<ImmediateStop>        Debugger should stop as early as possible.
  2787.     I<RemotePort>            Remote hostname:port for remote debugging
  2788.   The following options affect what happens with B<V>, B<X>, and B<x> commands:
  2789.     I<arrayDepth>, I<hashDepth>     print only first N elements ('' for all);
  2790.     I<compactDump>, I<veryCompact>     change style of array and hash dump;
  2791.     I<globPrint>             whether to print contents of globs;
  2792.     I<DumpDBFiles>         dump arrays holding debugged files;
  2793.     I<DumpPackages>         dump symbol tables of packages;
  2794.     I<DumpReused>             dump contents of \"reused\" addresses;
  2795.     I<quote>, I<HighBit>, I<undefPrint>     change style of string dump;
  2796.     I<bareStringify>         Do not print the overload-stringified value;
  2797.   Other options include:
  2798.     I<PrintRet>        affects printing of return value after B<r> command,
  2799.     I<frame>        affects printing messages on subroutine entry/exit.
  2800.     I<AutoTrace>    affects printing messages on possible breaking points.
  2801.     I<maxTraceLen>    gives max length of evals/args listed in stack trace.
  2802.     I<ornaments>     affects screen appearance of the command line.
  2803.     I<CreateTTY>     bits control attempts to create a new TTY on events:
  2804.             1: on fork()    2: debugger is started inside debugger
  2805.             4: on startup
  2806.     During startup options are initialized from \$ENV{PERLDB_OPTS}.
  2807.     You can put additional initialization options I<TTY>, I<noTTY>,
  2808.     I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
  2809.     `B<R>' after you set them).
  2810.  
  2811. B<q> or B<^D>        Quit. Set B<\$DB::finished = 0> to debug global destruction.
  2812. B<h>        Summary of debugger commands.
  2813. B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
  2814. B<h h>        Long help for debugger commands
  2815. B<$doccmd> I<manpage>    Runs the external doc viewer B<$doccmd> command on the 
  2816.         named Perl I<manpage>, or on B<$doccmd> itself if omitted.
  2817.         Set B<\$DB::doccmd> to change viewer.
  2818.  
  2819. Type `|h h' for a paged display if this was too hard to read.
  2820.  
  2821. "; # Fix balance of vi % matching: }}}}
  2822.  
  2823.     #  note: tabs in the following section are not-so-helpful
  2824.     $summary = <<"END_SUM";
  2825. I<List/search source lines:>               I<Control script execution:>
  2826.   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
  2827.   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
  2828.   B<v> [I<line>]    View around line            B<n> [I<expr>]    Next, steps over subs
  2829.   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
  2830.   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
  2831.   B<M>           Show module versions        B<c> [I<ln>|I<sub>]  Continue until position
  2832. I<Debugger controls:>                        B<L>           List break/watch/actions
  2833.   B<o> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
  2834.   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
  2835.   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<B> I<ln|*>      Delete a/all breakpoints
  2836.   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
  2837.   B<=> [I<a> I<val>]   Define/list an alias        B<A> I<ln|*>      Delete a/all actions
  2838.   B<h> [I<db_cmd>]  Get help on command         B<w> I<expr>      Add a watch expression
  2839.   B<h h>         Complete help page          B<W> I<expr|*>    Delete a/all watch exprs
  2840.   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
  2841.   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
  2842. I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
  2843.   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
  2844.   B<p> I<expr>         Print expression (uses script's current package).
  2845.   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
  2846.   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
  2847.   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
  2848.   B<y> [I<n> [I<Vars>]]   List lexicals in higher scope <n>.  Vars same as B<V>.
  2849. For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
  2850. END_SUM
  2851.                 # ')}}; # Fix balance of vi % matching
  2852.  
  2853.     # and this is really numb...
  2854.     $pre580_help = "
  2855. B<T>        Stack trace.
  2856. B<s> [I<expr>]    Single step [in I<expr>].
  2857. B<n> [I<expr>]    Next, steps over subroutine calls [in I<expr>].
  2858. <B<CR>>        Repeat last B<n> or B<s> command.
  2859. B<r>        Return from current subroutine.
  2860. B<c> [I<line>|I<sub>]    Continue; optionally inserts a one-time-only breakpoint
  2861.         at the specified position.
  2862. B<l> I<min>B<+>I<incr>    List I<incr>+1 lines starting at I<min>.
  2863. B<l> I<min>B<->I<max>    List lines I<min> through I<max>.
  2864. B<l> I<line>        List single I<line>.
  2865. B<l> I<subname>    List first window of lines from subroutine.
  2866. B<l> I<\$var>        List first window of lines from subroutine referenced by I<\$var>.
  2867. B<l>        List next window of lines.
  2868. B<->        List previous window of lines.
  2869. B<w> [I<line>]    List window around I<line>.
  2870. B<.>        Return to the executed line.
  2871. B<f> I<filename>    Switch to viewing I<filename>. File must be already loaded.
  2872.         I<filename> may be either the full name of the file, or a regular
  2873.         expression matching the full file name:
  2874.         B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
  2875.         Evals (with saved bodies) are considered to be filenames:
  2876.         B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
  2877.         (in the order of execution).
  2878. B</>I<pattern>B</>    Search forwards for I<pattern>; final B</> is optional.
  2879. B<?>I<pattern>B<?>    Search backwards for I<pattern>; final B<?> is optional.
  2880. B<L>        List all breakpoints and actions.
  2881. B<S> [[B<!>]I<pattern>]    List subroutine names [not] matching I<pattern>.
  2882. B<t>        Toggle trace mode.
  2883. B<t> I<expr>        Trace through execution of I<expr>.
  2884. B<b> [I<line>] [I<condition>]
  2885.         Set breakpoint; I<line> defaults to the current execution line;
  2886.         I<condition> breaks if it evaluates to true, defaults to '1'.
  2887. B<b> I<subname> [I<condition>]
  2888.         Set breakpoint at first line of subroutine.
  2889. B<b> I<\$var>        Set breakpoint at first line of subroutine referenced by I<\$var>.
  2890. B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
  2891. B<b> B<postpone> I<subname> [I<condition>]
  2892.         Set breakpoint at first line of subroutine after 
  2893.         it is compiled.
  2894. B<b> B<compile> I<subname>
  2895.         Stop after the subroutine is compiled.
  2896. B<d> [I<line>]    Delete the breakpoint for I<line>.
  2897. B<D>        Delete all breakpoints.
  2898. B<a> [I<line>] I<command>
  2899.         Set an action to be done before the I<line> is executed;
  2900.         I<line> defaults to the current execution line.
  2901.         Sequence is: check for breakpoint/watchpoint, print line
  2902.         if necessary, do action, prompt user if necessary,
  2903.         execute line.
  2904. B<a> [I<line>]    Delete the action for I<line>.
  2905. B<A>        Delete all actions.
  2906. B<W> I<expr>        Add a global watch-expression.
  2907. B<W>        Delete all watch-expressions.
  2908. B<V> [I<pkg> [I<vars>]]    List some (default all) variables in package (default current).
  2909.         Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
  2910. B<X> [I<vars>]    Same as \"B<V> I<currentpackage> [I<vars>]\".
  2911. B<x> I<expr>        Evals expression in list context, dumps the result.
  2912. B<m> I<expr>        Evals expression in list context, prints methods callable
  2913.         on the first element of the result.
  2914. B<m> I<class>        Prints methods callable via the given class.
  2915.  
  2916. B<<> ?            List Perl commands to run before each prompt.
  2917. B<<> I<expr>        Define Perl command to run before each prompt.
  2918. B<<<> I<expr>        Add to the list of Perl commands to run before each prompt.
  2919. B<>> ?            List Perl commands to run after each prompt.
  2920. B<>> I<expr>        Define Perl command to run after each prompt.
  2921. B<>>B<>> I<expr>        Add to the list of Perl commands to run after each prompt.
  2922. B<{> I<db_command>    Define debugger command to run before each prompt.
  2923. B<{> ?            List debugger commands to run before each prompt.
  2924. B<{{> I<db_command>    Add to the list of debugger commands to run before each prompt.
  2925. B<$prc> I<number>    Redo a previous command (default previous command).
  2926. B<$prc> I<-number>    Redo number'th-to-last command.
  2927. B<$prc> I<pattern>    Redo last command that started with I<pattern>.
  2928.         See 'B<O> I<recallCommand>' too.
  2929. B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
  2930.   . ( $rc eq $sh ? "" : "
  2931. B<$psh> [I<cmd>]     Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
  2932.         See 'B<O> I<shellBang>' too.
  2933. B<source> I<file>        Execute I<file> containing debugger commands (may nest).
  2934. B<H> I<-number>    Display last number commands (default all).
  2935. B<p> I<expr>        Same as \"I<print {DB::OUT} expr>\" in current package.
  2936. B<|>I<dbcmd>        Run debugger command, piping DB::OUT to current pager.
  2937. B<||>I<dbcmd>        Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
  2938. B<\=> [I<alias> I<value>]    Define a command alias, or list current aliases.
  2939. I<command>        Execute as a perl statement in current package.
  2940. B<v>        Show versions of loaded modules.
  2941. B<R>        Pure-man-restart of debugger, some of debugger state
  2942.         and command-line options may be lost.
  2943.         Currently the following settings are preserved:
  2944.         history, breakpoints and actions, debugger B<O>ptions 
  2945.         and the following command-line options: I<-w>, I<-I>, I<-e>.
  2946.  
  2947. B<O> [I<opt>] ...    Set boolean option to true
  2948. B<O> [I<opt>B<?>]    Query options
  2949. B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 
  2950.         Set options.  Use quotes in spaces in value.
  2951.     I<recallCommand>, I<ShellBang>    chars used to recall command or spawn shell;
  2952.     I<pager>            program for output of \"|cmd\";
  2953.     I<tkRunning>            run Tk while prompting (with ReadLine);
  2954.     I<signalLevel> I<warnLevel> I<dieLevel>    level of verbosity;
  2955.     I<inhibit_exit>        Allows stepping off the end of the script.
  2956.     I<ImmediateStop>        Debugger should stop as early as possible.
  2957.     I<RemotePort>            Remote hostname:port for remote debugging
  2958.   The following options affect what happens with B<V>, B<X>, and B<x> commands:
  2959.     I<arrayDepth>, I<hashDepth>     print only first N elements ('' for all);
  2960.     I<compactDump>, I<veryCompact>     change style of array and hash dump;
  2961.     I<globPrint>             whether to print contents of globs;
  2962.     I<DumpDBFiles>         dump arrays holding debugged files;
  2963.     I<DumpPackages>         dump symbol tables of packages;
  2964.     I<DumpReused>             dump contents of \"reused\" addresses;
  2965.     I<quote>, I<HighBit>, I<undefPrint>     change style of string dump;
  2966.     I<bareStringify>         Do not print the overload-stringified value;
  2967.   Other options include:
  2968.     I<PrintRet>        affects printing of return value after B<r> command,
  2969.     I<frame>        affects printing messages on subroutine entry/exit.
  2970.     I<AutoTrace>    affects printing messages on possible breaking points.
  2971.     I<maxTraceLen>    gives max length of evals/args listed in stack trace.
  2972.     I<ornaments>     affects screen appearance of the command line.
  2973.     I<CreateTTY>     bits control attempts to create a new TTY on events:
  2974.             1: on fork()    2: debugger is started inside debugger
  2975.             4: on startup
  2976.     During startup options are initialized from \$ENV{PERLDB_OPTS}.
  2977.     You can put additional initialization options I<TTY>, I<noTTY>,
  2978.     I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
  2979.     `B<R>' after you set them).
  2980.  
  2981. B<q> or B<^D>        Quit. Set B<\$DB::finished = 0> to debug global destruction.
  2982. B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
  2983. B<h h>        Summary of debugger commands.
  2984. B<$doccmd> I<manpage>    Runs the external doc viewer B<$doccmd> command on the 
  2985.         named Perl I<manpage>, or on B<$doccmd> itself if omitted.
  2986.         Set B<\$DB::doccmd> to change viewer.
  2987.  
  2988. Type `|h' for a paged display if this was too hard to read.
  2989.  
  2990. "; # Fix balance of vi % matching: }}}}
  2991.  
  2992.     #  note: tabs in the following section are not-so-helpful
  2993.     $pre580_summary = <<"END_SUM";
  2994. I<List/search source lines:>               I<Control script execution:>
  2995.   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
  2996.   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
  2997.   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
  2998.   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
  2999.   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
  3000.   B<v>           Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
  3001. I<Debugger controls:>                        B<L>           List break/watch/actions
  3002.   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
  3003.   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
  3004.   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
  3005.   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
  3006.   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
  3007.   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
  3008.   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
  3009.   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
  3010. I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
  3011.   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
  3012.   B<p> I<expr>         Print expression (uses script's current package).
  3013.   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
  3014.   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
  3015.   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
  3016.   B<y> [I<n> [I<Vars>]]   List lexicals in higher scope <n>.  Vars same as B<V>.
  3017. For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
  3018. END_SUM
  3019.                 # ')}}; # Fix balance of vi % matching
  3020.  
  3021. }
  3022.  
  3023. sub print_help {
  3024.     local $_ = shift;
  3025.  
  3026.     # Restore proper alignment destroyed by eeevil I<> and B<>
  3027.     # ornaments: A pox on both their houses!
  3028.     #
  3029.     # A help command will have everything up to and including
  3030.     # the first tab sequence padded into a field 16 (or if indented 20)
  3031.     # wide.  If it's wider than that, an extra space will be added.
  3032.     s{
  3033.     ^                 # only matters at start of line
  3034.       ( \040{4} | \t )*    # some subcommands are indented
  3035.       ( < ?         # so <CR> works
  3036.         [BI] < [^\t\n] + )  # find an eeevil ornament
  3037.       ( \t+ )        # original separation, discarded
  3038.       ( .* )        # this will now start (no earlier) than 
  3039.                 # column 16
  3040.     } {
  3041.     my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
  3042.     my $clean = $command;
  3043.     $clean =~ s/[BI]<([^>]*)>/$1/g;  
  3044.     # replace with this whole string:
  3045.     ($leadwhite ? " " x 4 : "")
  3046.       . $command
  3047.       . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
  3048.       . $text;
  3049.  
  3050.     }mgex;
  3051.  
  3052.     s{                # handle bold ornaments
  3053.     B < ( [^>] + | > ) >
  3054.     } {
  3055.       $Term::ReadLine::TermCap::rl_term_set[2] 
  3056.     . $1
  3057.     . $Term::ReadLine::TermCap::rl_term_set[3]
  3058.     }gex;
  3059.  
  3060.     s{                # handle italic ornaments
  3061.     I < ( [^>] + | > ) >
  3062.     } {
  3063.       $Term::ReadLine::TermCap::rl_term_set[0] 
  3064.     . $1
  3065.     . $Term::ReadLine::TermCap::rl_term_set[1]
  3066.     }gex;
  3067.  
  3068.     local $\ = '';
  3069.     print $OUT $_;
  3070. }
  3071.  
  3072. sub fix_less {
  3073.     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
  3074.     my $is_less = $pager =~ /\bless\b/;
  3075.     if ($pager =~ /\bmore\b/) { 
  3076.     my @st_more = stat('/usr/bin/more');
  3077.     my @st_less = stat('/usr/bin/less');
  3078.     $is_less = @st_more    && @st_less 
  3079.         && $st_more[0] == $st_less[0] 
  3080.         && $st_more[1] == $st_less[1];
  3081.     }
  3082.     # changes environment!
  3083.     $ENV{LESS} .= 'r'     if $is_less;
  3084. }
  3085.  
  3086. sub diesignal {
  3087.     local $frame = 0;
  3088.     local $doret = -2;
  3089.     $SIG{'ABRT'} = 'DEFAULT';
  3090.     kill 'ABRT', $$ if $panic++;
  3091.     if (defined &Carp::longmess) {
  3092.     local $SIG{__WARN__} = '';
  3093.     local $Carp::CarpLevel = 2;        # mydie + confess
  3094.     &warn(Carp::longmess("Signal @_"));
  3095.     }
  3096.     else {
  3097.     local $\ = '';
  3098.     print $DB::OUT "Got signal @_\n";
  3099.     }
  3100.     kill 'ABRT', $$;
  3101. }
  3102.  
  3103. sub dbwarn { 
  3104.   local $frame = 0;
  3105.   local $doret = -2;
  3106.   local $SIG{__WARN__} = '';
  3107.   local $SIG{__DIE__} = '';
  3108.   eval { require Carp } if defined $^S;    # If error/warning during compilation,
  3109.                                         # require may be broken.
  3110.   CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
  3111.     return unless defined &Carp::longmess;
  3112.   my ($mysingle,$mytrace) = ($single,$trace);
  3113.   $single = 0; $trace = 0;
  3114.   my $mess = Carp::longmess(@_);
  3115.   ($single,$trace) = ($mysingle,$mytrace);
  3116.   &warn($mess); 
  3117. }
  3118.  
  3119. sub dbdie {
  3120.   local $frame = 0;
  3121.   local $doret = -2;
  3122.   local $SIG{__DIE__} = '';
  3123.   local $SIG{__WARN__} = '';
  3124.   my $i = 0; my $ineval = 0; my $sub;
  3125.   if ($dieLevel > 2) {
  3126.       local $SIG{__WARN__} = \&dbwarn;
  3127.       &warn(@_);        # Yell no matter what
  3128.       return;
  3129.   }
  3130.   if ($dieLevel < 2) {
  3131.     die @_ if $^S;        # in eval propagate
  3132.   }
  3133.   # No need to check $^S, eval is much more robust nowadays
  3134.   eval { require Carp }; #if defined $^S;# If error/warning during compilation,
  3135.                                     # require may be broken.
  3136.  
  3137.   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
  3138.     unless defined &Carp::longmess;
  3139.  
  3140.   # We do not want to debug this chunk (automatic disabling works
  3141.   # inside DB::DB, but not in Carp).
  3142.   my ($mysingle,$mytrace) = ($single,$trace);
  3143.   $single = 0; $trace = 0;
  3144.   my $mess = "@_";
  3145.   { 
  3146.     package Carp;        # Do not include us in the list
  3147.     eval {
  3148.       $mess = Carp::longmess(@_);
  3149.     };
  3150.   }
  3151.   ($single,$trace) = ($mysingle,$mytrace);
  3152.   die $mess;
  3153. }
  3154.  
  3155. sub warnLevel {
  3156.   if (@_) {
  3157.     $prevwarn = $SIG{__WARN__} unless $warnLevel;
  3158.     $warnLevel = shift;
  3159.     if ($warnLevel) {
  3160.       $SIG{__WARN__} = \&DB::dbwarn;
  3161.     } elsif ($prevwarn) {
  3162.       $SIG{__WARN__} = $prevwarn;
  3163.     }
  3164.   }
  3165.   $warnLevel;
  3166. }
  3167.  
  3168. sub dieLevel {
  3169.   local $\ = '';
  3170.   if (@_) {
  3171.     $prevdie = $SIG{__DIE__} unless $dieLevel;
  3172.     $dieLevel = shift;
  3173.     if ($dieLevel) {
  3174.       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
  3175.       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
  3176.       print $OUT "Stack dump during die enabled", 
  3177.         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
  3178.       if $I_m_init;
  3179.       print $OUT "Dump printed too.\n" if $dieLevel > 2;
  3180.     } elsif ($prevdie) {
  3181.       $SIG{__DIE__} = $prevdie;
  3182.       print $OUT "Default die handler restored.\n";
  3183.     }
  3184.   }
  3185.   $dieLevel;
  3186. }
  3187.  
  3188. sub signalLevel {
  3189.   if (@_) {
  3190.     $prevsegv = $SIG{SEGV} unless $signalLevel;
  3191.     $prevbus = $SIG{BUS} unless $signalLevel;
  3192.     $signalLevel = shift;
  3193.     if ($signalLevel) {
  3194.       $SIG{SEGV} = \&DB::diesignal;
  3195.       $SIG{BUS} = \&DB::diesignal;
  3196.     } else {
  3197.       $SIG{SEGV} = $prevsegv;
  3198.       $SIG{BUS} = $prevbus;
  3199.     }
  3200.   }
  3201.   $signalLevel;
  3202. }
  3203.  
  3204. sub CvGV_name {
  3205.   my $in = shift;
  3206.   my $name = CvGV_name_or_bust($in);
  3207.   defined $name ? $name : $in;
  3208. }
  3209.  
  3210. sub CvGV_name_or_bust {
  3211.   my $in = shift;
  3212.   return if $skipCvGV;        # Backdoor to avoid problems if XS broken...
  3213.   return unless ref $in;
  3214.   $in = \&$in;            # Hard reference...
  3215.   eval {require Devel::Peek; 1} or return;
  3216.   my $gv = Devel::Peek::CvGV($in) or return;
  3217.   *$gv{PACKAGE} . '::' . *$gv{NAME};
  3218. }
  3219.  
  3220. sub find_sub {
  3221.   my $subr = shift;
  3222.   $sub{$subr} or do {
  3223.     return unless defined &$subr;
  3224.     my $name = CvGV_name_or_bust($subr);
  3225.     my $data;
  3226.     $data = $sub{$name} if defined $name;
  3227.     return $data if defined $data;
  3228.  
  3229.     # Old stupid way...
  3230.     $subr = \&$subr;        # Hard reference
  3231.     my $s;
  3232.     for (keys %sub) {
  3233.       $s = $_, last if $subr eq \&$_;
  3234.     }
  3235.     $sub{$s} if $s;
  3236.   }
  3237. }
  3238.  
  3239. sub methods {
  3240.   my $class = shift;
  3241.   $class = ref $class if ref $class;
  3242.   local %seen;
  3243.   local %packs;
  3244.   methods_via($class, '', 1);
  3245.   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
  3246. }
  3247.  
  3248. sub methods_via {
  3249.   my $class = shift;
  3250.   return if $packs{$class}++;
  3251.   my $prefix = shift;
  3252.   my $prepend = $prefix ? "via $prefix: " : '';
  3253.   my $name;
  3254.   for $name (grep {defined &{${"${class}::"}{$_}}} 
  3255.          sort keys %{"${class}::"}) {
  3256.     next if $seen{ $name }++;
  3257.     local $\ = '';
  3258.     local $, = '';
  3259.     print $DB::OUT "$prepend$name\n";
  3260.   }
  3261.   return unless shift;        # Recurse?
  3262.   for $name (@{"${class}::ISA"}) {
  3263.     $prepend = $prefix ? $prefix . " -> $name" : $name;
  3264.     methods_via($name, $prepend, 1);
  3265.   }
  3266. }
  3267.  
  3268. sub setman { 
  3269.     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
  3270.         ? "man"             # O Happy Day!
  3271.         : "perldoc";        # Alas, poor unfortunates
  3272. }
  3273.  
  3274. sub runman {
  3275.     my $page = shift;
  3276.     unless ($page) {
  3277.     &system("$doccmd $doccmd");
  3278.     return;
  3279.     } 
  3280.     # this way user can override, like with $doccmd="man -Mwhatever"
  3281.     # or even just "man " to disable the path check.
  3282.     unless ($doccmd eq 'man') {
  3283.     &system("$doccmd $page");
  3284.     return;
  3285.     } 
  3286.  
  3287.     $page = 'perl' if lc($page) eq 'help';
  3288.  
  3289.     require Config;
  3290.     my $man1dir = $Config::Config{'man1dir'};
  3291.     my $man3dir = $Config::Config{'man3dir'};
  3292.     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ } 
  3293.     my $manpath = '';
  3294.     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
  3295.     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
  3296.     chop $manpath if $manpath;
  3297.     # harmless if missing, I figure
  3298.     my $oldpath = $ENV{MANPATH};
  3299.     $ENV{MANPATH} = $manpath if $manpath;
  3300.     my $nopathopt = $^O =~ /dunno what goes here/;
  3301.     if (CORE::system($doccmd, 
  3302.         # I just *know* there are men without -M
  3303.         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),  
  3304.         split ' ', $page) )
  3305.     {
  3306.     unless ($page =~ /^perl\w/) {
  3307.         if (grep { $page eq $_ } qw{ 
  3308.         5004delta 5005delta amiga api apio book boot bot call compile
  3309.         cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
  3310.         faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
  3311.         form func guts hack hist hpux intern ipc lexwarn locale lol mod
  3312.         modinstall modlib number obj op opentut os2 os390 pod port 
  3313.         ref reftut run sec style sub syn thrtut tie toc todo toot tootc
  3314.         trap unicode var vms win32 xs xstut
  3315.           }) 
  3316.         {
  3317.         $page =~ s/^/perl/;
  3318.         CORE::system($doccmd, 
  3319.             (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),  
  3320.             $page);
  3321.         }
  3322.     }
  3323.     } 
  3324.     if (defined $oldpath) {
  3325.     $ENV{MANPATH} = $manpath;
  3326.     } else {
  3327.     delete $ENV{MANPATH};
  3328.     } 
  3329. } 
  3330.  
  3331. # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
  3332.  
  3333. BEGIN {            # This does not compile, alas.
  3334.   $IN = \*STDIN;        # For bugs before DB::OUT has been opened
  3335.   $OUT = \*STDERR;        # For errors before DB::OUT has been opened
  3336.   $sh = '!';
  3337.   $rc = ',';
  3338.   @hist = ('?');
  3339.   $deep = 100;            # warning if stack gets this deep
  3340.   $window = 10;
  3341.   $preview = 3;
  3342.   $sub = '';
  3343.   $SIG{INT} = \&DB::catch;
  3344.   # This may be enabled to debug debugger:
  3345.   #$warnLevel = 1 unless defined $warnLevel;
  3346.   #$dieLevel = 1 unless defined $dieLevel;
  3347.   #$signalLevel = 1 unless defined $signalLevel;
  3348.  
  3349.   $db_stop = 0;            # Compiler warning
  3350.   $db_stop = 1 << 30;
  3351.   $level = 0;            # Level of recursive debugging
  3352.   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
  3353.   # Triggers bug (?) in perl is we postpone this until runtime:
  3354.   @postponed = @stack = (0);
  3355.   $stack_depth = 0;        # Localized $#stack
  3356.   $doret = -2;
  3357.   $frame = 0;
  3358. }
  3359.  
  3360. BEGIN {$^W = $ini_warn;}    # Switch warnings back
  3361.  
  3362. #use Carp;            # This did break, left for debugging
  3363.  
  3364. sub db_complete {
  3365.   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
  3366.   my($text, $line, $start) = @_;
  3367.   my ($itext, $search, $prefix, $pack) =
  3368.     ($text, "^\Q${'package'}::\E([^:]+)\$");
  3369.   
  3370.   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
  3371.                                (map { /$search/ ? ($1) : () } keys %sub)
  3372.     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
  3373.   return sort grep /^\Q$text/, values %INC # files
  3374.     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
  3375.   return sort map {($_, db_complete($_ . "::", "V ", 2))}
  3376.     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
  3377.       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
  3378.   return sort map {($_, db_complete($_ . "::", "V ", 2))}
  3379.     grep !/^main::/,
  3380.       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
  3381.                  # packages
  3382.     if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ 
  3383.       and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
  3384.   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
  3385.     # We may want to complete to (eval 9), so $text may be wrong
  3386.     $prefix = length($1) - length($text);
  3387.     $text = $1;
  3388.     return sort 
  3389.     map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
  3390.   }
  3391.   if ((substr $text, 0, 1) eq '&') { # subroutines
  3392.     $text = substr $text, 1;
  3393.     $prefix = "&";
  3394.     return sort map "$prefix$_", 
  3395.                grep /^\Q$text/, 
  3396.                  (keys %sub),
  3397.                  (map { /$search/ ? ($1) : () } 
  3398.             keys %sub);
  3399.   }
  3400.   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
  3401.     $pack = ($1 eq 'main' ? '' : $1) . '::';
  3402.     $prefix = (substr $text, 0, 1) . $1 . '::';
  3403.     $text = $2;
  3404.     my @out 
  3405.       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
  3406.     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
  3407.       return db_complete($out[0], $line, $start);
  3408.     }
  3409.     return sort @out;
  3410.   }
  3411.   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
  3412.     $pack = ($package eq 'main' ? '' : $package) . '::';
  3413.     $prefix = substr $text, 0, 1;
  3414.     $text = substr $text, 1;
  3415.     my @out = map "$prefix$_", grep /^\Q$text/, 
  3416.        (grep /^_?[a-zA-Z]/, keys %$pack), 
  3417.        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
  3418.     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
  3419.       return db_complete($out[0], $line, $start);
  3420.     }
  3421.     return sort @out;
  3422.   }
  3423.   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
  3424.     my @out = grep /^\Q$text/, @options;
  3425.     my $val = option_val($out[0], undef);
  3426.     my $out = '? ';
  3427.     if (not defined $val or $val =~ /[\n\r]/) {
  3428.       # Can do nothing better
  3429.     } elsif ($val =~ /\s/) {
  3430.       my $found;
  3431.       foreach $l (split //, qq/\"\'\#\|/) {
  3432.     $out = "$l$val$l ", last if (index $val, $l) == -1;
  3433.       }
  3434.     } else {
  3435.       $out = "=$val ";
  3436.     }
  3437.     # Default to value if one completion, to question if many
  3438.     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
  3439.     return sort @out;
  3440.   }
  3441.   return $term->filename_list($text); # filenames
  3442. }
  3443.  
  3444. sub end_report {
  3445.   local $\ = '';
  3446.   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
  3447. }
  3448.  
  3449. sub clean_ENV {
  3450.     if (defined($ini_pids)) {
  3451.         $ENV{PERLDB_PIDS} = $ini_pids;
  3452.     } else {
  3453.         delete($ENV{PERLDB_PIDS});
  3454.     }
  3455. }
  3456.  
  3457. END {
  3458.   $finished = 1 if $inhibit_exit;      # So that some keys may be disabled.
  3459.   $fall_off_end = 1 unless $inhibit_exit;
  3460.   # Do not stop in at_exit() and destructors on exit:
  3461.   $DB::single = !$fall_off_end && !$runnonstop;
  3462.   DB::fake::at_exit() unless $fall_off_end or $runnonstop;
  3463. }
  3464.  
  3465.  
  3466. # ===================================== pre580 ================================
  3467. # this is very sad below here...
  3468. #
  3469.  
  3470. sub cmd_pre580_null {
  3471.     # do nothing...
  3472. }
  3473.  
  3474. sub cmd_pre580_a {
  3475.     my $cmd = shift;
  3476.     if ($cmd =~ /^(\d*)\s*(.*)/) {
  3477.         $i = $1 || $line; $j = $2;
  3478.         if (length $j) {
  3479.             if ($dbline[$i] == 0) {
  3480.                 print $OUT "Line $i may not have an action.\n";
  3481.             } else {
  3482.                 $had_breakpoints{$filename} |= 2;
  3483.                 $dbline{$i} =~ s/\0[^\0]*//;
  3484.                 $dbline{$i} .= "\0" . action($j);
  3485.             }
  3486.         } else {
  3487.             $dbline{$i} =~ s/\0[^\0]*//;
  3488.             delete $dbline{$i} if $dbline{$i} eq '';
  3489.         }
  3490.     }
  3491. }
  3492.  
  3493. sub cmd_pre580_b {
  3494.     my $cmd    = shift;
  3495.     my $dbline = shift;
  3496.     if ($cmd =~ /^load\b\s*(.*)/) {
  3497.         my $file = $1; $file =~ s/\s+$//;
  3498.         &cmd_b_load($file);
  3499.     } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
  3500.         my $cond = length $3 ? $3 : '1';
  3501.         my ($subname, $break) = ($2, $1 eq 'postpone');
  3502.         $subname =~ s/\'/::/g;
  3503.         $subname = "${'package'}::" . $subname
  3504.         unless $subname =~ /::/;
  3505.         $subname = "main".$subname if substr($subname,0,2) eq "::";
  3506.         $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
  3507.     } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) { 
  3508.         my $subname = $1;
  3509.         my $cond = length $2 ? $2 : '1';
  3510.         &cmd_b_sub($subname, $cond);
  3511.     } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
  3512.         my $i = $1 || $dbline;
  3513.         my $cond = length $2 ? $2 : '1';
  3514.         &cmd_b_line($i, $cond);
  3515.     }
  3516. }
  3517.  
  3518. sub cmd_pre580_D {
  3519.     my $cmd = shift;
  3520.     if ($cmd =~ /^\s*$/) {
  3521.         print $OUT "Deleting all breakpoints...\n";
  3522.         my $file;
  3523.         for $file (keys %had_breakpoints) {
  3524.             local *dbline = $main::{'_<' . $file};
  3525.             my $max = $#dbline;
  3526.             my $was;
  3527.  
  3528.             for ($i = 1; $i <= $max ; $i++) {
  3529.                 if (defined $dbline{$i}) {
  3530.                     $dbline{$i} =~ s/^[^\0]+//;
  3531.                     if ($dbline{$i} =~ s/^\0?$//) {
  3532.                         delete $dbline{$i};
  3533.                     }
  3534.                 }
  3535.             }
  3536.  
  3537.             if (not $had_breakpoints{$file} &= ~1) {
  3538.                 delete $had_breakpoints{$file};
  3539.             }
  3540.         }
  3541.         undef %postponed;
  3542.         undef %postponed_file;
  3543.         undef %break_on_load;
  3544.     }
  3545. }
  3546.  
  3547. sub cmd_pre580_h {
  3548.     my $cmd = shift;
  3549.     if ($cmd =~ /^\s*$/) {
  3550.         print_help($pre580_help);
  3551.     } elsif ($cmd =~ /^h\s*/) {
  3552.         print_help($pre580_summary);
  3553.     } elsif ($cmd =~ /^h\s+(\S.*)$/) { 
  3554.         my $asked = $1;            # for proper errmsg
  3555.         my $qasked = quotemeta($asked); # for searching
  3556.         # XXX: finds CR but not <CR>
  3557.         if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
  3558.             while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
  3559.                 print_help($1);
  3560.             }
  3561.         } else {
  3562.             print_help("B<$asked> is not a debugger command.\n");
  3563.         }
  3564.     }
  3565. }
  3566.  
  3567. sub cmd_pre580_W {
  3568.     my $cmd = shift;
  3569.     if ($cmd =~ /^$/) { 
  3570.         $trace &= ~2;
  3571.         @to_watch = @old_watch = ();
  3572.     } elsif ($cmd =~ /^(.*)/s) {
  3573.         push @to_watch, $1;
  3574.         $evalarg = $1;
  3575.         my ($val) = &eval;
  3576.         $val = (defined $val) ? "'$val'" : 'undef' ;
  3577.         push @old_watch, $val;
  3578.         $trace |= 2;
  3579.     }
  3580. }
  3581.  
  3582. package DB::fake;
  3583.  
  3584. sub at_exit {
  3585.   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
  3586. }
  3587.  
  3588. package DB;            # Do not trace this 1; below!
  3589.  
  3590. 1;
  3591.  
  3592.