perldb

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