perldb

   1 #!/usr/bin/perl
   2
   3 # $Header: perldb,v 2.0 88/06/05 00:09:45 root Exp $
   4 #
   5 # $Log: perldb,v $
   6 # Revision 2.0  88/06/05  00:09:45  root
   7 # Baseline version 2.0.
   8 #
   9 #
  10
  11 $tmp = "/tmp/pdb$$";            # default temporary file, -o overrides.
  12
  13 # parse any switches
  14
  15 while ($ARGV[0] =~ /^-/) {
  16     $_ = shift;
  17     /^-o$/ && ($tmp = shift,next);
  18     die "Unrecognized switch: $_";
  19 }
  20
  21 $filename = shift;
  22 die "Usage: perldb [-o output] scriptname arguments" unless $filename;
  23
  24 open(script,$filename) || die "Can't find $filename";
  25
  26 open(tmp, ">$tmp") || die "Can't make temp script";
  27
  28 $perl = '/usr/bin/perl';
  29 $init = 1;
  30 $state = 'statement';
  31
  32 # now translate script to contain DB calls at the appropriate places
  33
  34 while (<script>) {
  35     chop;
  36     if ($. == 1) {
  37         if (/^#! *([^ \t]*) (-[^ \t]*)/) {
  38             $perl = $1;
  39             $switch = $2;
  40         }
  41         elsif (/^#! *([^ \t]*)/) {
  42             $perl = $1;
  43         }
  44     }
  45     s/ *$//;
  46     push(@script,$_);           # remember line for DBinit
  47     $line = $_;
  48     next if /^$/;               # blank lines are uninteresting
  49     next if /^[ \t]*#/;         # likewise comment lines
  50     if ($init) {
  51         print tmp "do DBinit($.);"; $init = '';
  52     }
  53     if ($inform) {              # skip formats
  54         if (/^\.$/) {
  55             $inform = '';
  56             $state = 'statement';
  57         }
  58         next;
  59     }
  60     if (/^[ \t]*format /) {
  61         $inform++;
  62         next;
  63     }
  64     if ($state eq 'statement' &&
  65       !/^[ \t]*}|^[ \t]*else|^[ \t]*continue|^[ \t]*elsif/) {
  66         if (s/^([ \t]*[A-Za-z_0-9]+:)//) {
  67             $label = $1;
  68         }
  69         else {
  70             $label = '';
  71         }
  72         $line = $label . "do DB($.); " . $_;    # all that work for this line
  73     }
  74     else {
  75         $script[$#script - 1] .= ' ';   # mark line as having continuation
  76     }
  77     do parse();                         # set $state to correct eol value
  78 }
  79 continue {
  80     print tmp $line,"\n";
  81 }
  82
  83 # now put out our debugging subroutines.  First the one that's called all over.
  84
  85 print tmp '
  86 sub DB {
  87     push(@DB,$. ,$@, $!, $[, $,, $/, $\ );
  88     $[ = 0; $, = ""; $/ = "\n"; $\ = "";
  89     $DBline=pop(@_);
  90     if ($DBsingle || $DBstop[$DBline] || $DBtrace) {
  91         print "$DBline:\t",$DBline[$DBline],"\n";
  92         for ($DBi = $DBline; $DBline[$DBi++] =~ / $/; ) {
  93             print "$DBi:\t",$DBline[$DBi],"\n";
  94         }
  95     }
  96     if ($DBaction[$DBline]) {
  97         eval $DBaction[$DBline];  print $@;
  98     }
  99     if ($DBstop[$DBline] || $DBsingle) {
 100         for (;;) {
 101             print "perldb> ";
 102             $DBcmd = <stdin>;
 103             last if $DBcmd =~ /^$/;
 104             if ($DBcmd =~ /^q$/) {
 105                 exit 0;
 106             }
 107             if ($DBcmd =~ /^h$/) {
 108                 print "
 109 s               Single step.
 110 c               Continue.
 111 <CR>            Repeat last s or c.
 112 l min-max       List lines.
 113 l line          List line.
 114 l               List the whole program.
 115 L               List breakpoints.
 116 t               Toggle trace mode.
 117 b line          Set breakpoint.
 118 d line          Delete breakpoint.
 119 d               Delete breakpoint at this line.
 120 a line command  Set an action for this line.
 121 q               Quit.
 122 command         Execute as a perl statement.
 123
 124 ";
 125                 next;
 126             }
 127             if ($DBcmd =~ /^t$/) {
 128                 $DBtrace = !$DBtrace;
 129                 print "Trace = $DBtrace\n";
 130                 next;
 131             }
 132             if ($DBcmd =~ /^l (.*)[-,](.*)/) {
 133                 for ($DBi = $1; $DBi <= $2; $DBi++) {
 134                     print "$DBi:\t", $DBline[$DBi], "\n";
 135                 }
 136                 next;
 137             }
 138             if ($DBcmd =~ /^l (.*)/) {
 139                 print "$1:\t", $DBline[$1], "\n";
 140                 next;
 141             }
 142             if ($DBcmd =~ /^l$/) {
 143                 for ($DBi = 1; $DBi <= $DBmax ; $DBi++) {
 144                     print "$DBi:\t", $DBline[$DBi], "\n";
 145                 }
 146                 next;
 147             }
 148             if ($DBcmd =~ /^L$/) {
 149                 for ($DBi = 1; $DBi <= $DBmax ; $DBi++) {
 150                     print "$DBi:\t", $DBline[$DBi], "\n" if $DBstop[$DBi];
 151                 }
 152                 next;
 153             }
 154             if ($DBcmd =~ /^b (.*)/) {
 155                 $DBi = $1;
 156                 if ($DBline[$DBi-1] =~ / $/) {
 157                     print "Line $DBi not breakable.\n";
 158                 }
 159                 else {
 160                     $DBstop[$DBi] = 1;
 161                 }
 162                 next;
 163             }
 164             if ($DBcmd =~ /^d (.*)/) {
 165                 $DBstop[$1] = 0;
 166                 next;
 167             }
 168             if ($DBcmd =~ /^d$/) {
 169                 $DBstop[$DBline] = 0;
 170                 next;
 171             }
 172             if ($DBcmd =~ /^a ([0-9]+)[ \t]+(.*)/) {
 173                 $DBi = $1;
 174                 $DBaction = $2;
 175                 $DBaction .= ";" unless $DBaction =~ /[;}]$/;
 176                 $DBaction[$DBi] = $DBaction;
 177                 next;
 178             }
 179             if ($DBcmd =~ /^s$/) {
 180                 $DBsingle = 1;
 181                 last;
 182             }
 183             if ($DBcmd =~ /^c$/) {
 184                 $DBsingle = 0;
 185                 last;
 186             }
 187             chop($DBcmd);
 188             $DBcmd .= ";" unless $DBcmd =~ /[;}]$/;
 189             eval $DBcmd;
 190             print $@,"\n";
 191         }
 192     }
 193     $\ = pop(@DB);
 194     $/ = pop(@DB);
 195     $, = pop(@DB);
 196     $[ = pop(@DB);
 197     $! = pop(@DB);
 198     $@ = pop(@DB);
 199     $. = pop(@DB);
 200 }
 201
 202 sub DBinit {
 203     $DBstop[$_[0]] = 1;
 204 ';
 205 print tmp "    \$0 = '$script';\n";
 206 print tmp "    \$DBmax = $.;\n";
 207 print tmp "    unlink '/tmp/pdb$$';\n";         # expected to fail on -o.
 208 for ($i = 1; $#script >= 0; $i++) {
 209     $_ = shift(@script);
 210     s/'/\\'/g;
 211     print tmp "    \$DBline[$i] = '$_';\n";
 212 }
 213 print tmp '}
 214 ';
 215
 216 close tmp;
 217
 218 # prepare to run the new script
 219
 220 unshift(@ARGV,$tmp);
 221 unshift(@ARGV,$switch) if $switch;
 222 unshift(@ARGV,$perl);
 223 exec @ARGV;
 224
 225 # This routine tokenizes one perl line good enough to tell what state we are
 226 # in by the end of the line, so we can tell if the next line should contain
 227 # a call to DB or not.
 228
 229 sub parse {
 230     until ($_ eq '') {
 231         $ord = ord($_);
 232         if ($quoting) {
 233             if ($quote == $ord) {
 234                 $quoting--;
 235             }
 236             s/^.//                      if /^[\\]/;
 237             s/^.//;
 238             last if $_ eq "\n";
 239             $state = 'term'             unless $quoting;
 240             next;
 241         }
 242         if ($ord > 64) {
 243             do quote(ord($1),1), next   if s/^m\b(.)//;
 244             do quote(ord($1),2), next   if s/^s\b(.)//;
 245             do quote(ord($1),2), next   if s/^y\b(.)//;
 246             do quote(ord($1),2), next   if s/^tr\b(.)//;
 247             do quote($ord,1), next      if s/^`//;
 248             next                        if s/^[A-Za-z_][A-Za-z_0-9]*://;
 249             $state = 'term', next       if s/^eof\b//;
 250             $state = 'term', next       if s/^shift\b//;
 251             $state = 'term', next       if s/^split\b//;
 252             $state = 'term', next       if s/^tell\b//;
 253             $state = 'term', next       if s/^write\b//;
 254             $state = 'operator', next   if s/^[A-Za-z_][A-Za-z_0-9]*//;
 255             $state = 'operator', next   if s/^[~^|]+//;
 256             $state = 'statement', next  if s/^{//;
 257             $state = 'statement', next  if s/^}[ \t]*$//;
 258             $state = 'statement', next  if s/^}[ \t]*#/#/;
 259             $state = 'term', next       if s/^}//;
 260             $state = 'operator', next   if s/^\[//;
 261             $state = 'term', next       if s/^]//;
 262             die "Illegal character $_";
 263         }
 264         elsif ($ord < 33) {
 265             next if s/[ \t\n\f]+//;
 266             die "Illegal character $_";
 267         }
 268         else {
 269             $state = 'statement', next  if s/^;//;
 270             $state = 'term', next       if s/^\.[0-9eE]+//;
 271             $state = 'term', next       if s/^[0-9][0-9xaAbBcCddeEfF.]*//;
 272             $state = 'term', next       if s/^\$[A-Za-z_][A-Za-z_0-9]*//;
 273             $state = 'term', next       if s/^\$.//;
 274             $state = 'term', next       if s/^@[A-Za-z_][A-Za-z_0-9]*//;
 275             $state = 'term', next       if s/^@.//;
 276             $state = 'term', next       if s/^<[A-Za-z_0-9]*>//;
 277             next                        if s/^\+\+//;
 278             next                        if s/^--//;
 279             $state = 'operator', next   if s/^[-(!%&*=+:,.<>]//;
 280             $state = 'term', next       if s/^\)+//;
 281             do quote($ord,1), next      if s/^'//;
 282             do quote($ord,1), next      if s/^"//;
 283             if (s|^[/?]||) {
 284                 if ($state =~ /stat|oper/) {
 285                     $state = 'term';
 286                     do quote($ord,1), next;
 287                 }
 288                 $state = 'operator', next;
 289             }
 290             next                        if s/^#.*//;
 291         }
 292     }
 293 }
 294
 295 sub quote {
 296     ($quote,$quoting) = @_;
 297     $state = 'quote';
 298 }