home *** CD-ROM | disk | FTP | other *** search
/ BURKS 2 / BURKS_AUG97.ISO / SLAKWARE / D12 / PERL1.TGZ / perl1.tar / usr / lib / perl5 / perl5db.pl < prev    next >
Perl Script  |  1996-06-28  |  42KB  |  1,447 lines
  1. package DB;
  2.  
  3. # Debugger for Perl 5.00x; perl5db.pl patch level:
  4.  
  5. $header = 'perl5db.pl patch level 0.94';
  6.  
  7. # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
  8. # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
  9.  
  10. # modified Perl debugger, to be run from Emacs in perldb-mode
  11. # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  12. # Johan Vromans -- upgrade to 4.0 pl 10
  13. # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  14.  
  15. #
  16. # This file is automatically included if you do perl -d.
  17. # It's probably not useful to include this yourself.
  18. #
  19. # Perl supplies the values for @line and %sub.  It effectively inserts
  20. # a &DB'DB(<linenum>); in front of every place that can have a
  21. # breakpoint. Instead of a subroutine call it calls &DB::sub with
  22. # $DB::sub being the called subroutine. It also inserts a BEGIN
  23. # {require 'perl5db.pl'} before the first line.
  24. #
  25. # Note that no subroutine call is possible until &DB::sub is defined
  26. # (for subroutines defined outside this file). In fact the same is
  27. # true if $deep is not defined.
  28. #
  29. # $Log:    perldb.pl,v $
  30.  
  31. #
  32. # At start reads $rcfile that may set important options.  This file
  33. # may define a subroutine &afterinit that will be executed after the
  34. # debugger is initialized.
  35. #
  36. # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  37. # it as a rest of `O ...' line in debugger prompt.
  38. #
  39. # The options that can be specified only at startup:
  40. # [To set in $rcfile, call &parse_options("optionName=new_value").]
  41. #
  42. # TTY  - the TTY to use for debugging i/o.
  43. #
  44. # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  45. # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  46. # Term::Rendezvous.  Current variant is to have the name of TTY in this
  47. # file.
  48. #
  49. # ReadLine - If false, dummy ReadLine is used, so you can debug
  50. # ReadLine applications.
  51. #
  52. # NonStop - if true, no i/o is performed until interrupt.
  53. #
  54. # LineInfo - file or pipe to print line number info to.  If it is a
  55. # pipe, a short "emacs like" message is used.
  56. #
  57. # Example $rcfile: (delete leading hashes!)
  58. #
  59. # &parse_options("NonStop=1 LineInfo=db.out");
  60. # sub afterinit { $trace = 1; }
  61. #
  62. # The script will run without human intervention, putting trace
  63. # information into db.out.  (If you interrupt it, you would better
  64. # reset LineInfo to something "interactive"!)
  65. #
  66.  
  67. # Needed for the statement after exec():
  68.  
  69. BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
  70. local($^W) = 0;            # Switch run-time warnings off during init.
  71. warn (            # Do not ;-)
  72.       $dumpvar::hashDepth,     
  73.       $dumpvar::arrayDepth,    
  74.       $dumpvar::dumpDBFiles,   
  75.       $dumpvar::dumpPackages,  
  76.       $dumpvar::quoteHighBit,  
  77.       $dumpvar::printUndef,    
  78.       $dumpvar::globPrint,     
  79.       $readline::Tk_toloop,    
  80.       $dumpvar::usageOnly,
  81.       @ARGS,
  82.       $Carp::CarpLevel,
  83.       $panic,
  84.       $first_time,
  85.      ) if 0;
  86.  
  87. # Command-line + PERLLIB:
  88. @ini_INC = @INC;
  89.  
  90. # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
  91.  
  92. $trace = $signal = $single = 0;    # Uninitialized warning suppression
  93.                                 # (local $^W cannot help - other packages!).
  94. @stack = (0);
  95.  
  96. $option{PrintRet} = 1;
  97.  
  98. @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages 
  99.           compactDump veryCompact quote HighBit undefPrint
  100.           globPrint PrintRet UsageOnly frame
  101.           TTY noTTY ReadLine NonStop LineInfo
  102.           recallCommand ShellBang pager tkRunning
  103.           signalLevel warnLevel dieLevel);
  104.  
  105. %optionVars    = (
  106.          hashDepth    => \$dumpvar::hashDepth,
  107.          arrayDepth    => \$dumpvar::arrayDepth,
  108.          DumpDBFiles    => \$dumpvar::dumpDBFiles,
  109.          DumpPackages    => \$dumpvar::dumpPackages,
  110.          HighBit    => \$dumpvar::quoteHighBit,
  111.          undefPrint    => \$dumpvar::printUndef,
  112.          globPrint    => \$dumpvar::globPrint,
  113.          tkRunning    => \$readline::Tk_toloop,
  114.          UsageOnly    => \$dumpvar::usageOnly,     
  115.           frame           => \$frame,
  116. );
  117.  
  118. %optionAction  = (
  119.           compactDump    => \&dumpvar::compactDump,
  120.           veryCompact    => \&dumpvar::veryCompact,
  121.           quote        => \&dumpvar::quote,
  122.           TTY        => \&TTY,
  123.           noTTY        => \&noTTY,
  124.           ReadLine    => \&ReadLine,
  125.           NonStop    => \&NonStop,
  126.           LineInfo    => \&LineInfo,
  127.           recallCommand    => \&recallCommand,
  128.           ShellBang    => \&shellBang,
  129.           pager        => \&pager,
  130.           signalLevel    => \&signalLevel,
  131.           warnLevel    => \&warnLevel,
  132.           dieLevel    => \&dieLevel,
  133.          );
  134.  
  135. %optionRequire = (
  136.           compactDump    => 'dumpvar.pl',
  137.           veryCompact    => 'dumpvar.pl',
  138.           quote        => 'dumpvar.pl',
  139.          );
  140.  
  141. # These guys may be defined in $ENV{PERL5DB} :
  142. $rl = 1 unless defined $rl;
  143. warnLevel($warnLevel);
  144. dieLevel($dieLevel);
  145. signalLevel($signalLevel);
  146. &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
  147. &recallCommand("!") unless defined $prc;
  148. &shellBang("!") unless defined $psh;
  149.  
  150. if (-e "/dev/tty") {
  151.   $rcfile=".perldb";
  152. } else {
  153.   $rcfile="perldb.ini";
  154. }
  155.  
  156. if (-f $rcfile) {
  157.     do "./$rcfile";
  158. } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
  159.     do "$ENV{LOGDIR}/$rcfile";
  160. } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
  161.     do "$ENV{HOME}/$rcfile";
  162. }
  163.  
  164. if (defined $ENV{PERLDB_OPTS}) {
  165.   parse_options($ENV{PERLDB_OPTS});
  166. }
  167.  
  168. if (exists $ENV{PERLDB_RESTART}) {
  169.   delete $ENV{PERLDB_RESTART};
  170.   # $restart = 1;
  171.   @hist = get_list('PERLDB_HIST');
  172.   my @visited = get_list("PERLDB_VISITED");
  173.   for (0 .. $#visited) {
  174.     %{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_");
  175.   }
  176.   my %opt = get_list("PERLDB_OPT");
  177.   my ($opt,$val);
  178.   while (($opt,$val) = each %opt) {
  179.     $val =~ s/[\\\']/\\$1/g;
  180.     parse_options("$opt'$val'");
  181.   }
  182.   @INC = get_list("PERLDB_INC");
  183.   @ini_INC = @INC;
  184. }
  185.  
  186. if ($notty) {
  187.   $runnonstop = 1;
  188. } else {
  189.   # Is Perl being run from Emacs?
  190.   $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
  191.   $rl = 0, shift(@main::ARGV) if $emacs;
  192.  
  193.   #require Term::ReadLine;
  194.  
  195.   if (-e "/dev/tty") {
  196.     $console = "/dev/tty";
  197.   } elsif (-e "con") {
  198.     $console = "con";
  199.   } else {
  200.     $console = "sys\$command";
  201.   }
  202.  
  203.   # Around a bug:
  204.   if (defined $ENV{OS2_SHELL} and $emacs) { # In OS/2
  205.     $console = undef;
  206.   }
  207.  
  208.   $console = $tty if defined $tty;
  209.  
  210.   if (defined $console) {
  211.     open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
  212.     open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
  213.       || open(OUT,">&STDOUT");    # so we don't dongle stdout
  214.   } else {
  215.     open(IN,"<&STDIN");
  216.     open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
  217.     $console = 'STDIN/OUT';
  218.   }
  219.   # so open("|more") can read from STDOUT and so we don't dingle stdin
  220.   $IN = \*IN;
  221.  
  222.   $OUT = \*OUT;
  223.   select($OUT);
  224.   $| = 1;            # for DB::OUT
  225.   select(STDOUT);
  226.  
  227.   $LINEINFO = $OUT unless defined $LINEINFO;
  228.   $lineinfo = $console unless defined $lineinfo;
  229.  
  230.   $| = 1;            # for real STDOUT
  231.  
  232.   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  233.   unless ($runnonstop) {
  234.     print $OUT "\nLoading DB routines from $header\n";
  235.     print $OUT ("Emacs support ",
  236.         $emacs ? "enabled" : "available",
  237.         ".\n");
  238.     print $OUT "\nEnter h or `h h' for help.\n\n";
  239.   }
  240. }
  241.  
  242. @ARGS = @ARGV;
  243. for (@args) {
  244.     s/\'/\\\'/g;
  245.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  246. }
  247.  
  248. if (defined &afterinit) {    # May be defined in $rcfile
  249.   &afterinit();
  250. }
  251.  
  252. ############################################################ Subroutines
  253.  
  254. sub DB {
  255.     unless ($first_time++) {    # Do when-running init
  256.       if ($runnonstop) {        # Disable until signal
  257.     for ($i=0; $i <= $#stack; ) {
  258.         $stack[$i++] &= ~1;
  259.     }
  260.     $single = 0;
  261.     return;
  262.       }
  263.       # Define a subroutine in which we will stop
  264. #       eval <<'EOE';
  265. # sub at_end::db {"Debuggee terminating";}
  266. # END {
  267. #   $DB::step = 1; 
  268. #   print $OUT "Debuggee terminating.\n"; 
  269. #   &at_end::db;}
  270. # EOE
  271.     }
  272.     &save;
  273.     if ($doret) {
  274.     $doret = 0;
  275.     if ($option{PrintRet}) {
  276.         print $OUT "$retctx context return from $lastsub:", 
  277.           ($retctx eq 'list') ? "\n" : " " ;
  278.         dumpit( ($retctx eq 'list') ? \@ret : $ret );
  279.     }
  280.     }
  281.     ($package, $filename, $line) = caller;
  282.     $filename_ini = $filename;
  283.     $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
  284.       "package $package;";    # this won't let them modify, alas
  285.     local(*dbline) = "::_<$filename";
  286.     install_