Commit | Line | Data |
a559c259 |
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 | } |