This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 1.0 patch 9: 3 portability problems
[perl5.git] / 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 }