3 # $Header: perldb,v 1.0.1.1 88/01/28 10:27:16 root Exp $
6 # Revision 1.0.1.1 88/01/28 10:27:16 root
7 # patch8: created this file.
11 $tmp = "/tmp/pdb$$"; # default temporary file, -o overrides.
15 while ($ARGV[0] =~ /^-/) {
17 /^-o$/ && ($tmp = shift,next);
18 die "Unrecognized switch: $_";
22 die "Usage: perldb [-o output] scriptname arguments" unless $filename;
24 open(script,$filename) || die "Can't find $filename";
26 open(tmp, ">$tmp") || die "Can't make temp script";
32 # now translate script to contain DB calls at the appropriate places
37 if (/^#! *([^ \t]*) (-[^ \t]*)/) {
41 elsif (/^#! *([^ \t]*)/) {
46 push(@script,$_); # remember line for DBinit
48 next if /^$/; # blank lines are uninteresting
49 next if /^[ \t]*#/; # likewise comment lines
51 print tmp "do DBinit($.);"; $init = '';
53 if ($inform) { # skip formats
60 if (/^[ \t]*format /) {
64 if ($state eq 'statement' && !/^[ \t]*}/) {
65 if (s/^([ \t]*[A-Za-z_0-9]+:)//) {
71 $line = $label . "do DB($.); " . $_; # all that work for this line
74 $script[$#script - 1] .= ' '; # mark line as having continuation
76 do parse(); # set $state to correct eol value
82 # now put out our debugging subroutines. First the one that's called all over.
86 push(@DB,$. ,$@, $!, $[, $,, $/, $\ );
87 $[ = 0; $, = ""; $/ = "\n"; $\ = "";
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";
95 if ($DBaction[$DBline]) {
96 eval $DBaction[$DBline]; print $@;
98 if ($DBstop[$DBline] || $DBsingle) {
102 last if $DBcmd =~ /^$/;
103 if ($DBcmd =~ /^q$/) {
106 if ($DBcmd =~ /^h$/) {
110 <CR> Repeat last s or c.
111 l min-max List lines.
113 l List the whole program.
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.
121 command Execute as a perl statement.
126 if ($DBcmd =~ /^t$/) {
127 $DBtrace = !$DBtrace;
128 print "Trace = $DBtrace\n";
131 if ($DBcmd =~ /^l (.*)[-,](.*)/) {
132 for ($DBi = $1; $DBi <= $2; $DBi++) {
133 print "$DBi:\t", $DBline[$DBi], "\n";
137 if ($DBcmd =~ /^l (.*)/) {
138 print "$1:\t", $DBline[$1], "\n";
141 if ($DBcmd =~ /^l$/) {
142 for ($DBi = 1; $DBi <= $DBmax ; $DBi++) {
143 print "$DBi:\t", $DBline[$DBi], "\n";
147 if ($DBcmd =~ /^L$/) {
148 for ($DBi = 1; $DBi <= $DBmax ; $DBi++) {
149 print "$DBi:\t", $DBline[$DBi], "\n" if $DBstop[$DBi];
153 if ($DBcmd =~ /^b (.*)/) {
155 if ($DBline[$DBi-1] =~ / $/) {
156 print "Line $DBi not breakable.\n";
163 if ($DBcmd =~ /^d (.*)/) {
167 if ($DBcmd =~ /^d$/) {
168 $DBstop[$DBline] = 0;
171 if ($DBcmd =~ /^a ([0-9]+)[ \t]+(.*)/) {
174 $DBaction .= ";" unless $DBaction =~ /[;}]$/;
175 $DBaction[$DBi] = $DBaction;
178 if ($DBcmd =~ /^s$/) {
182 if ($DBcmd =~ /^c$/) {
187 $DBcmd .= ";" unless $DBcmd =~ /[;}]$/;
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++) {
210 print tmp " \$DBline[$i] = '$_';\n";
217 # prepare to run the new script
220 unshift(@ARGV,$switch) if $switch;
221 unshift(@ARGV,$perl);
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.
232 if ($quote == $ord) {
238 $state = 'term' unless $quoting;
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 $_";
263 next if s/[ \t\n]+//;
264 die "Illegal character $_";
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]*>//;
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/^"//;
282 if ($state =~ /stat|oper/) {
284 do quote($ord,1), next;
286 $state = 'operator', next;
294 ($quote,$quoting) = @_;