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