[p5sagit/p5-mst-13.2.git] / perldb

#!/usr/bin/perl

# $Header: perldb,v 2.0 88/06/05 00:09:45 root Exp $
#
# $Log:	perldb,v $
# Revision 2.0  88/06/05  00:09:45  root
# Baseline version 2.0.
# 
#

$tmp = "/tmp/pdb$$";		# default temporary file, -o overrides.

# parse any switches

while ($ARGV[0] =~ /^-/) {
    $_ = shift;
    /^-o$/ && ($tmp = shift,next);
    die "Unrecognized switch: $_";
}

$filename = shift;
die "Usage: perldb [-o output] scriptname arguments" unless $filename;

open(script,$filename) || die "Can't find $filename";

open(tmp, ">$tmp") || die "Can't make temp script";

$perl = '/usr/bin/perl';
$init = 1;
$state = 'statement';

# now translate script to contain DB calls at the appropriate places

while (<script>) {
    chop;
    if ($. == 1) {
	if (/^#! *([^ \t]*) (-[^ \t]*)/) {
	    $perl = $1;
	    $switch = $2;
	}
	elsif (/^#! *([^ \t]*)/) {
	    $perl = $1;
	}
    }
    s/ *$//;
    push(@script,$_);		# remember line for DBinit
    $line = $_;
    next if /^$/;		# blank lines are uninteresting
    next if /^[ \t]*#/;		# likewise comment lines
    if ($init) {
	print tmp "do DBinit($.);"; $init = '';
    }
    if ($inform) {		# skip formats
	if (/^\.$/) {
	    $inform = '';
	    $state = 'statement';
	}
	next;
    }
    if (/^[ \t]*format /) {
	$inform++;
	next;
    }
    if ($state eq 'statement' &&
      !/^[ \t]*}|^[ \t]*else|^[ \t]*continue|^[ \t]*elsif/) {
	if (s/^([ \t]*[A-Za-z_0-9]+:)//) {
	    $label = $1;
	}
	else {
	    $label = '';
	}
	$line = $label . "do DB($.); " . $_;	# all that work for this line
    }
    else {
	$script[$#script - 1] .= ' ';	# mark line as having continuation
    }
    do parse();				# set $state to correct eol value
}
continue {
    print tmp $line,"\n";
}

# now put out our debugging subroutines.  First the one that's called all over.

print tmp '
sub DB {
    push(@DB,$. ,$@, $!, $[, $,, $/, $\ );
    $[ = 0; $, = ""; $/ = "\n"; $\ = "";
    $DBline=pop(@_);
    if ($DBsingle || $DBstop[$DBline] || $DBtrace) {
	print "$DBline:\t",$DBline[$DBline],"\n";
	for ($DBi = $DBline; $DBline[$DBi++] =~ / $/; ) {
	    print "$DBi:\t",$DBline[$DBi],"\n";
	}
    }
    if ($DBaction[$DBline]) {
	eval $DBaction[$DBline];  print $@;
    }
    if ($DBstop[$DBline] || $DBsingle) {
	for (;;) {
	    print "perldb> ";
	    $DBcmd = <stdin>;
	    last if $DBcmd =~ /^$/;
	    if ($DBcmd =~ /^q$/) {
		exit 0;
	    }
	    if ($DBcmd =~ /^h$/) {
		print "
s		Single step.
c		Continue.
<CR>		Repeat last s or c.
l min-max	List lines.
l line		List line.
l		List the whole program.
L		List breakpoints.
t		Toggle trace mode.
b line		Set breakpoint.
d line		Delete breakpoint.
d		Delete breakpoint at this line.
a line command	Set an action for this line.
q		Quit.
command		Execute as a perl statement.

";
		next;
	    }
	    if ($DBcmd =~ /^t$/) {
		$DBtrace = !$DBtrace;
		print "Trace = $DBtrace\n";
		next;
	    }
	    if ($DBcmd =~ /^l (.*)[-,](.*)/) {
		for ($DBi = $1; $DBi <= $2; $DBi++) {
		    print "$DBi:\t", $DBline[$DBi], "\n";
		}
		next;
	    }
	    if ($DBcmd =~ /^l (.*)/) {
		print "$1:\t", $DBline[$1], "\n";
		next;
	    }
	    if ($DBcmd =~ /^l$/) {
		for ($DBi = 1; $DBi <= $DBmax ; $DBi++) {
		    print "$DBi:\t", $DBline[$DBi], "\n";
		}
		next;
	    }
	    if ($DBcmd =~ /^L$/) {
		for ($DBi = 1; $DBi <= $DBmax ; $DBi++) {
		    print "$DBi:\t", $DBline[$DBi], "\n" if $DBstop[$DBi];
		}
		next;
	    }
	    if ($DBcmd =~ /^b (.*)/) {
		$DBi = $1;
		if ($DBline[$DBi-1] =~ / $/) {
		    print "Line $DBi not breakable.\n";
		}
		else {
		    $DBstop[$DBi] = 1;
		}
		next;
	    }
	    if ($DBcmd =~ /^d (.*)/) {
		$DBstop[$1] = 0;
		next;
	    }
	    if ($DBcmd =~ /^d$/) {
		$DBstop[$DBline] = 0;
		next;
	    }
	    if ($DBcmd =~ /^a ([0-9]+)[ \t]+(.*)/) {
		$DBi = $1;
		$DBaction = $2;
		$DBaction .= ";" unless $DBaction =~ /[;}]$/;
		$DBaction[$DBi] = $DBaction;
		next;
	    }
	    if ($DBcmd =~ /^s$/) {
		$DBsingle = 1;
		last;
	    }
	    if ($DBcmd =~ /^c$/) {
		$DBsingle = 0;
		last;
	    }
	    chop($DBcmd);
	    $DBcmd .= ";" unless $DBcmd =~ /[;}]$/;
	    eval $DBcmd;
	    print $@,"\n";
	}
    }
    $\ = pop(@DB);
    $/ = pop(@DB);
    $, = pop(@DB);
    $[ = pop(@DB);
    $! = pop(@DB);
    $@ = pop(@DB);
    $. = pop(@DB);
}

sub DBinit {
    $DBstop[$_[0]] = 1;
';
print tmp "    \$0 = '$script';\n";
print tmp "    \$DBmax = $.;\n";
print tmp "    unlink '/tmp/pdb$$';\n";		# expected to fail on -o.
for ($i = 1; $#script >= 0; $i++) {
    $_ = shift(@script);
    s/'/\\'/g;
    print tmp "    \$DBline[$i] = '$_';\n";
}
print tmp '}
';

close tmp;

# prepare to run the new script

unshift(@ARGV,$tmp);
unshift(@ARGV,$switch) if $switch;
unshift(@ARGV,$perl);
exec @ARGV;

# This routine tokenizes one perl line good enough to tell what state we are
# in by the end of the line, so we can tell if the next line should contain
# a call to DB or not.

sub parse {
    until ($_ eq '') {
	$ord = ord($_);
	if ($quoting) {
	    if ($quote == $ord) {
		$quoting--;
	    }
	    s/^.//			if /^[\\]/;
	    s/^.//;
	    last if $_ eq "\n";
	    $state = 'term'		unless $quoting;
	    next;
	}
	if ($ord > 64) {
	    do quote(ord($1),1), next	if s/^m\b(.)//;
	    do quote(ord($1),2), next	if s/^s\b(.)//;
	    do quote(ord($1),2), next	if s/^y\b(.)//;
	    do quote(ord($1),2), next	if s/^tr\b(.)//;
	    do quote($ord,1), next	if s/^`//;
	    next			if s/^[A-Za-z_][A-Za-z_0-9]*://;
	    $state = 'term', next	if s/^eof\b//;
	    $state = 'term', next	if s/^shift\b//;
	    $state = 'term', next	if s/^split\b//;
	    $state = 'term', next	if s/^tell\b//;
	    $state = 'term', next	if s/^write\b//;
	    $state = 'operator', next	if s/^[A-Za-z_][A-Za-z_0-9]*//;
	    $state = 'operator', next	if s/^[~^|]+//;
	    $state = 'statement', next	if s/^{//;
	    $state = 'statement', next	if s/^}[ \t]*$//;
	    $state = 'statement', next	if s/^}[ \t]*#/#/;
	    $state = 'term', next	if s/^}//;
	    $state = 'operator', next	if s/^\[//;
	    $state = 'term', next	if s/^]//;
	    die "Illegal character $_";
	}
	elsif ($ord < 33) {
	    next if s/[ \t\n\f]+//;
	    die "Illegal character $_";
	}
	else {
	    $state = 'statement', next	if s/^;//;
	    $state = 'term', next	if s/^\.[0-9eE]+//;
	    $state = 'term', next	if s/^[0-9][0-9xaAbBcCddeEfF.]*//;
	    $state = 'term', next	if s/^\$[A-Za-z_][A-Za-z_0-9]*//;
	    $state = 'term', next	if s/^\$.//;
	    $state = 'term', next	if s/^@[A-Za-z_][A-Za-z_0-9]*//;
	    $state = 'term', next	if s/^@.//;
	    $state = 'term', next	if s/^<[A-Za-z_0-9]*>//;
	    next			if s/^\+\+//;
	    next			if s/^--//;
	    $state = 'operator', next	if s/^[-(!%&*=+:,.<>]//;
	    $state = 'term', next	if s/^\)+//;
	    do quote($ord,1), next	if s/^'//;
	    do quote($ord,1), next	if s/^"//;
	    if (s|^[/?]||) {
		if ($state =~ /stat|oper/) {
		    $state = 'term';
		    do quote($ord,1), next;
		}
		$state = 'operator', next;
	    }
	    next			if s/^#.*//;
	}
    }
}

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