esac
echo "Extracting Makefile (with variable substitutions)"
cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 1.0.1.3 88/01/26 14:14:52 root Exp $
+# $Header: Makefile.SH,v 1.0.1.4 88/01/28 10:17:59 root Exp $
#
# $Log: Makefile.SH,v $
+# Revision 1.0.1.4 88/01/28 10:17:59 root
+# patch8: added perldb.man
+#
# Revision 1.0.1.3 88/01/26 14:14:52 root
# Added mallocsrc stuff.
#
cat >>Makefile <<'!NO!SUBS!'
-public = perl
+public = perl perldb
private =
-manpages = perl.man
+manpages = perl.man perldb.man
util =
-/* $Header: arg.c,v 1.0.1.3 88/01/26 12:30:33 root Exp $
+/* $Header: arg.c,v 1.0.1.4 88/01/28 10:22:06 root Exp $
*
* $Log: arg.c,v $
- * Revision 1.0.1.3 88/01/26 12:30:33 root
- * patch 6: sprintf didn't finish processing format string when out of args.
+ * Revision 1.0.1.4 88/01/28 10:22:06 root
+ * patch8: added eval operator.
*
* Revision 1.0.1.2 88/01/24 03:52:34 root
* patch 2: added STATBLKS dependencies.
opargs[O_UNSHIFT] = A(1,0,0);
opargs[O_LINK] = A(1,1,0);
opargs[O_REPEAT] = A(1,1,0);
+ opargs[O_EVAL] = A(1,0,0);
}
#ifdef VOIDSIG
}
value = (double)(ary->ary_fill + 1);
break;
+ case O_EVAL:
+ str_sset(str,
+ do_eval(arg[1].arg_type != A_NULL ? sarg[1] : defstab->stab_val) );
+ STABSET(str);
+ break;
}
#ifdef DEBUGGING
dlevel--;
-/* $Header: arg.h,v 1.0 87/12/18 13:04:39 root Exp $
+/* $Header: arg.h,v 1.0.1.1 88/01/28 10:22:40 root Exp $
*
* $Log: arg.h,v $
+ * Revision 1.0.1.1 88/01/28 10:22:40 root
+ * patch8: added eval operator.
+ *
* Revision 1.0 87/12/18 13:04:39 root
* Initial revision
*
#define O_UNSHIFT 102
#define O_LINK 103
#define O_REPEAT 104
-#define MAXO 105
+#define O_EVAL 105
+#define MAXO 106
#ifndef DOINIT
extern char *opname[];
"UNSHIFT",
"LINK",
"REPEAT",
- "105"
+ "EVAL",
+ "106"
};
#endif
-/* $Header: cmd.h,v 1.0 87/12/18 13:04:59 root Exp $
+/* $Header: cmd.h,v 1.0.1.1 88/01/28 10:23:07 root Exp $
*
* $Log: cmd.h,v $
+ * Revision 1.0.1.1 88/01/28 10:23:07 root
+ * patch8: added eval_root for eval operator.
+ *
* Revision 1.0 87/12/18 13:04:59 root
* Initial revision
*
#define Nullcmd Null(CMD*)
EXT CMD *main_root INIT(Nullcmd);
+EXT CMD *eval_root INIT(Nullcmd);
EXT struct compcmd {
CMD *comp_true;
-#define PATCHLEVEL 7
+#define PATCHLEVEL 8
-/* $Header: perl.h,v 1.0.1.2 88/01/24 03:53:47 root Exp $
+/* $Header: perl.h,v 1.0.1.3 88/01/28 10:24:17 root Exp $
*
* $Log: perl.h,v $
+ * Revision 1.0.1.3 88/01/28 10:24:17 root
+ * patch8: added eval operator.
+ *
* Revision 1.0.1.2 88/01/24 03:53:47 root
* patch 2: hid str_peek() in #ifdef DEBUGGING.
*
STR *arg_to_str();
STR *str_new();
STR *stab_str();
-STR *eval();
+STR *eval(); /* this evaluates expressions */
+STR *do_eval(); /* this evaluates eval operator */
FCMD *load_format();
EXT char tokenbuf[256];
EXT int expectterm INIT(TRUE);
EXT int lex_newlines INIT(FALSE);
+EXT int in_eval INIT(FALSE);
FILE *popen();
/* char *str_get(); */
EXT int loop_ptr INIT(-1);
EXT jmp_buf top_env;
+EXT jmp_buf eval_env;
EXT char *goto_targ INIT(Nullch); /* cmd_exec gets strange when set */
-/* $Header: perl.y,v 1.0 87/12/18 15:48:59 root Exp $
+/* $Header: perl.y,v 1.0.1.1 88/01/28 10:25:31 root Exp $
*
* $Log: perl.y,v $
+ * Revision 1.0.1.1 88/01/28 10:25:31 root
+ * patch8: added eval operator.
+ *
* Revision 1.0 87/12/18 15:48:59 root
* Initial revision
*
%% /* RULES */
prog : lineseq
- { main_root = block_head($1); }
+ { if (in_eval)
+ eval_root = block_head($1);
+ else
+ main_root = block_head($1); }
;
compblock: block CONTINUE block
--- /dev/null
+#!/bin/perl
+
+# $Header: perldb,v 1.0.1.1 88/01/28 10:27:16 root Exp $
+#
+# $Log: perldb,v $
+# Revision 1.0.1.1 88/01/28 10:27:16 root
+# patch8: created this file.
+#
+#
+
+$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 = '/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]*}/) {
+ 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(.)//;
+ 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]+//;
+ 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';
+}
--- /dev/null
+.rn '' }`
+''' $Header: perldb.man,v 1.0.1.1 88/01/28 10:28:19 root Exp $
+'''
+''' $Log: perldb.man,v $
+''' Revision 1.0.1.1 88/01/28 10:28:19 root
+''' patch8: created this file.
+'''
+'''
+.de Sh
+.br
+.ne 5
+.PP
+\fB\\$1\fR
+.PP
+..
+.de Sp
+.if t .sp .5v
+.if n .sp
+..
+.de Ip
+.br
+.ie \\n.$>=3 .ne \\$3
+.el .ne 3
+.IP "\\$1" \\$2
+..
+'''
+''' Set up \*(-- to give an unbreakable dash;
+''' string Tr holds user defined translation string.
+''' Bell System Logo is used as a dummy character.
+'''
+.tr \(bs-|\(bv\*(Tr
+.ie n \{\
+.ds -- \(bs-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\h'-8u'-\" diablo 12 pitch
+.ds L" ""
+.ds R" ""
+.ds L' '
+.ds R' '
+'br\}
+.el\{\
+.ds -- \(em\|
+.tr \*(Tr
+.ds L" ``
+.ds R" ''
+.ds L' `
+.ds R' '
+'br\}
+.TH PERLDB 1 LOCAL
+.SH NAME
+perldb - Perl Debugger
+.SH SYNOPSIS
+.B perldb [-o output] perlscript arguments
+.SH DESCRIPTION
+.I Perldb
+is a symbolic debugger for
+.I perl
+scripts.
+Run your script just as you normally would, only prepend \*(L"perldb\*(R" to
+the command.
+(On systems where #! doesn't work, put any perl switches into the #! line
+anyway\*(--perldb will pass them off to perl when it runs the script.)
+Perldb copies your script to a temporary file, instrumenting it in the process
+and adding a debugging monitor.
+It then executes the instrumented script for
+you and stops at the first statement so you can set any breakpoints or actions
+you desire.
+.PP
+There is only one switch: \-o, which tells perldb to put its temporary file
+in the filename you specify, and to refrain from deleting the file.
+Use this switch if you intend to rerun the instrumented script, or want to
+look at it for some reason.
+.PP
+These are the debugging commands:
+.Ip s 8
+Single step.
+Subsequent carriage returns will single step.
+.Ip c 8
+Continue.
+Turns off single step mode and runs till the next break point.
+Subsequent carriage returns will continue.
+.Ip <CR> 8
+Repeat last s or c.
+.Ip "l min-max" 8
+List lines in the indicated range.
+.Ip "l line" 8
+List indicated line.
+.Ip l 8
+List the whole program.
+.Ip L 8
+List breakpoints.
+.Ip t 8
+Toggle trace mode.
+.Ip "b line" 8
+Set breakpoint at indicated line.
+.Ip "d line" 8
+Delete breakpoint at indicated line.
+.Ip d 8
+Delete breakpoint at this line.
+.Ip "a line command" 8
+Set an action for indicated line.
+The command must be a valid perl command, except that a missing trailing ;
+will be supplied.
+.Ip q 8
+Quit.
+.Ip command 8
+Execute command as a perl statement.
+A missing trailing ; will be supplied if necessary.
+.SH ENVIRONMENT
+No environment variables are used by perldb.
+.SH AUTHOR
+Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
+.SH FILES
+/tmp/pdb$$ temporary file for instrumented script
+.SH SEE ALSO
+perl
+.SH DIAGNOSTICS
+.SH BUGS
+.rn }` ''
-char rcsid[] = "$Header: perly.c,v 1.0.1.2 88/01/24 00:06:03 root Exp $";
+char rcsid[] = "$Header: perly.c,v 1.0.1.3 88/01/28 10:28:31 root Exp $";
/*
* $Log: perly.c,v $
+ * Revision 1.0.1.3 88/01/28 10:28:31 root
+ * patch8: added eval operator. Also fixed expectterm following right curly.
+ *
* Revision 1.0.1.2 88/01/24 00:06:03 root
* patch 2: s/(abc)/\1/ grandfathering didn't work right.
*
bool assume_n = FALSE;
bool assume_p = FALSE;
bool doswitches = FALSE;
+bool allstabs = FALSE; /* init all customary symbols in symbol table?*/
char *filename;
char *e_tmpname = "/tmp/perl-eXXXXXX";
FILE *e_fp = Nullfp;
str_numset(stabent(argv[0]+1,TRUE)->stab_val,(double)1.0);
}
}
- if (argvstab = stabent("ARGV",FALSE)) {
+ if (argvstab = stabent("ARGV",allstabs)) {
for (; argc > 0; argc--,argv++) {
apush(argvstab->stab_array,str_make(argv[0]));
}
}
- if (envstab = stabent("ENV",FALSE)) {
+ if (envstab = stabent("ENV",allstabs)) {
for (; *env; env++) {
if (!(s = index(*env,'=')))
continue;
*--s = '=';
}
}
- sigstab = stabent("SIG",FALSE);
+ sigstab = stabent("SIG",allstabs);
magicalize("!#?^~=-%0123456789.+&*(),\\/[|");
- (tmpstab = stabent("0",FALSE)) && str_set(STAB_STR(tmpstab),filename);
- (tmpstab = stabent("$",FALSE)) &&
+ (tmpstab = stabent("0",allstabs)) && str_set(STAB_STR(tmpstab),filename);
+ (tmpstab = stabent("$",allstabs)) &&
str_numset(STAB_STR(tmpstab),(double)getpid());
tmpstab = stabent("stdin",TRUE);
tmpstab = stabent("stderr",TRUE);
tmpstab->stab_io = stio_new();
tmpstab->stab_io->fp = stderr;
+ safefree(filename);
+ filename = "(eval)";
setjmp(top_env); /* sets goto_targ on longjump */
sym[1] = '\0';
while (*sym = *list++) {
- if (stab = stabent(sym,FALSE)) {
+ if (stab = stabent(sym,allstabs)) {
stab->stab_flags = SF_VMAGIC;
stab->stab_val->str_link.str_magic = stab;
}
filename = savestr(s);
s = str_get(linestr);
}
- *s = '\0';
+ if (in_eval) {
+ while (*s && *s != '\n')
+ s++;
+ if (*s)
+ s++;
+ line++;
+ }
+ else
+ *s = '\0';
if (lex_newlines)
RETURN('\n');
goto retry;
OPERATOR(tmp);
case ')':
case ']':
- case '}':
tmp = *s++;
TERM(tmp);
+ case '}':
+ tmp = *s++;
+ for (d = s; *d == ' ' || *d == '\t'; d++) ;
+ if (*d == '\n' || *d == '#')
+ OPERATOR(tmp); /* block end */
+ else
+ TERM(tmp); /* associative array end */
case '&':
s++;
tmp = *s++;
OPERATOR(SEQ);
if (strEQ(d,"exit"))
UNI(O_EXIT);
+ if (strEQ(d,"eval")) {
+ allstabs = TRUE; /* must initialize everything since */
+ UNI(O_EVAL); /* we don't know what will be used */
+ }
if (strEQ(d,"eof"))
TERM(FEOF);
if (strEQ(d,"exp"))
strcpy(tname,"^?");
else
sprintf(tname,"%c",yychar);
- printf("%s in file %s at line %d, next token \"%s\"\n",
+ sprintf(tokenbuf, "%s in file %s at line %d, next token \"%s\"\n",
s,filename,line,tname);
+ if (in_eval)
+ str_set(stabent("@",TRUE)->stab_val,tokenbuf);
+ else
+ fputs(tokenbuf,stderr);
}
char *
str_numset(str, (double)str_len(s1));
break;
case O_SUBSTR:
- if (arg[3].arg_type != A_SINGLE || stabent("[",FALSE)) {
+ if (arg[3].arg_type != A_SINGLE || stabent("[",allstabs)) {
str_free(str); /* making the fallacious assumption */
str = Nullstr; /* that any $[ occurs before substr()*/
}
yyerror("Format not terminated");
return froot.f_next;
}
+
+STR *
+do_eval(str)
+STR *str;
+{
+ int retval;
+ CMD *myroot;
+
+ in_eval++;
+ str_set(stabent("@",TRUE)->stab_val,"");
+ line = 1;
+ str_sset(linestr,str);
+ bufptr = str_get(linestr);
+ if (setjmp(eval_env))
+ retval = 1;
+ else
+ retval = yyparse();
+ myroot = eval_root; /* in case cmd_exec does another eval! */
+ if (retval)
+ str = &str_no;
+ else {
+ str = cmd_exec(eval_root);
+ cmd_free(myroot); /* can't free on error, for some reason */
+ }
+ in_eval--;
+ return str;
+}
+
+cmd_free(cmd)
+register CMD *cmd;
+{
+ register CMD *tofree;
+ register CMD *head = cmd;
+
+ while (cmd) {
+ if (cmd->c_label)
+ safefree(cmd->c_label);
+ if (cmd->c_first)
+ str_free(cmd->c_first);
+ if (cmd->c_spat)
+ spat_free(cmd->c_spat);
+ if (cmd->c_expr)
+ arg_free(cmd->c_expr);
+ switch (cmd->c_type) {
+ case C_WHILE:
+ case C_BLOCK:
+ case C_IF:
+ if (cmd->ucmd.ccmd.cc_true)
+ cmd_free(cmd->ucmd.ccmd.cc_true);
+ if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
+ cmd_free(cmd->ucmd.ccmd.cc_alt,Nullcmd);
+ break;
+ case C_EXPR:
+ if (cmd->ucmd.acmd.ac_stab)
+ arg_free(cmd->ucmd.acmd.ac_stab);
+ if (cmd->ucmd.acmd.ac_expr)
+ arg_free(cmd->ucmd.acmd.ac_expr);
+ break;
+ }
+ tofree = cmd;
+ cmd = cmd->c_next;
+ safefree((char*)tofree);
+ if (cmd && cmd == head) /* reached end of while loop */
+ break;
+ }
+}
+
+arg_free(arg)
+register ARG *arg;
+{
+ register int i;
+
+ for (i = 1; i <= arg->arg_len; i++) {
+ switch (arg[i].arg_type) {
+ case A_NULL:
+ break;
+ case A_LEXPR:
+ case A_EXPR:
+ arg_free(arg[i].arg_ptr.arg_arg);
+ break;
+ case A_CMD:
+ cmd_free(arg[i].arg_ptr.arg_cmd);
+ break;
+ case A_STAB:
+ case A_LVAL:
+ case A_READ:
+ case A_ARYLEN:
+ break;
+ case A_SINGLE:
+ case A_DOUBLE:
+ case A_BACKTICK:
+ str_free(arg[i].arg_ptr.arg_str);
+ break;
+ case A_SPAT:
+ spat_free(arg[i].arg_ptr.arg_spat);
+ break;
+ case A_NUMBER:
+ break;
+ }
+ }
+ free_arg(arg);
+}
+
+spat_free(spat)
+register SPAT *spat;
+{
+ register SPAT *sp;
+
+ if (spat->spat_runtime)
+ arg_free(spat->spat_runtime);
+ if (spat->spat_repl) {
+ arg_free(spat->spat_repl);
+ }
+ free_compex(&spat->spat_compex);
+
+ /* now unlink from spat list */
+ if (spat_root == spat)
+ spat_root = spat->spat_next;
+ else {
+ for (sp = spat_root; sp->spat_next != spat; sp = sp->spat_next) ;
+ sp->spat_next = spat->spat_next;
+ }
+
+ safefree((char*)spat);
+}
-/* $Header: search.c,v 1.0.1.1 88/01/24 03:55:05 root Exp $
+/* $Header: search.c,v 1.0.1.2 88/01/28 10:30:46 root Exp $
*
* $Log: search.c,v $
+ * Revision 1.0.1.2 88/01/28 10:30:46 root
+ * patch8: uncommented free_compex for use with eval operator.
+ *
* Revision 1.0.1.1 88/01/24 03:55:05 root
* patch 2: made depend on perl.h.
*
compex->subbase = Nullch;
}
-#ifdef NOTUSED
void
free_compex(compex)
register COMPEX *compex;
compex->subbase = Nullch;
}
}
-#endif
static char *gbr_str = Nullch;
static int gbr_siz = 0;
-/* $Header: stab.c,v 1.0 87/12/18 13:06:14 root Exp $
+/* $Header: stab.c,v 1.0.1.1 88/01/28 10:35:17 root Exp $
*
* $Log: stab.c,v $
+ * Revision 1.0.1.1 88/01/28 10:35:17 root
+ * patch8: changed some stabents to support eval operator.
+ *
* Revision 1.0 87/12/18 13:06:14 root
* Initial revision
*
case '^':
safefree(curoutstab->stab_io->top_name);
curoutstab->stab_io->top_name = str_get(str);
- curoutstab->stab_io->top_stab = stabent(str_get(str),FALSE);
+ curoutstab->stab_io->top_stab = stabent(str_get(str),TRUE);
break;
case '~':
safefree(curoutstab->stab_io->fmt_name);
curoutstab->stab_io->fmt_name = str_get(str);
- curoutstab->stab_io->fmt_stab = stabent(str_get(str),FALSE);
+ curoutstab->stab_io->fmt_stab = stabent(str_get(str),TRUE);
break;
case '=':
curoutstab->stab_io->page_len = (long)str_gnum(str);
ARRAY *savearray;
STR *str;
- stab = stabent(str_get(hfetch(sigstab->stab_hash,sig_name[sig])),FALSE);
+ stab = stabent(str_get(hfetch(sigstab->stab_hash,sig_name[sig])),TRUE);
savearray = defstab->stab_array;
defstab->stab_array = anew();
str = str_new(0);
#!./perl
-# $Header: base.lex,v 1.0 87/12/18 13:11:51 root Exp $
+# $Header: base.lex,v 1.0.1.1 88/01/28 10:37:00 root Exp $
-print "1..4\n";
+print "1..6\n";
$ # this is the register <space>
= 'x';
$x = '\\'; # ';
if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
+
+eval 'while (0) {
+ print "foo\n";
+}
+/^/ && (print "ok 5\n");
+';
+
+eval '$foo{1} / 1;';
+if (!$@) {print "ok 6\n";} else {print "not ok 6\n";}
--- /dev/null
+#!./perl
+
+print "1..6\n";
+
+eval 'print "ok 1\n";';
+
+if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
+
+eval "\$foo\n = # this is a comment\n'ok 3';";
+print $foo,"\n";
+
+eval "\$foo\n = # this is a comment\n'ok 4\n';";
+print $foo;
+
+eval '
+$foo ='; # this tests for a call through yyerror()
+if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
+
+eval '$foo = /'; # this tests for a call through fatal()
+if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
-/* $Header: util.c,v 1.0 87/12/18 13:06:30 root Exp $
+/* $Header: util.c,v 1.0.1.1 88/01/28 11:06:35 root Exp $
*
* $Log: util.c,v $
+ * Revision 1.0.1.1 88/01/28 11:06:35 root
+ * patch8: changed fatal() to support eval operator with exiting.
+ *
* Revision 1.0 87/12/18 13:06:30 root
* Initial revision
*
extern FILE *e_fp;
extern char *e_tmpname;
+ if (in_eval) {
+ sprintf(tokenbuf,pat,a1,a2,a3,a4);
+ str_set(stabent("@",TRUE)->stab_val,tokenbuf);
+ longjmp(eval_env,1);
+ }
fprintf(stderr,pat,a1,a2,a3,a4);
if (e_fp)
UNLINK(e_tmpname);
-/* $Header: a2py.c,v 1.0 87/12/18 17:50:33 root Exp $
+/* $Header: a2py.c,v 1.0.1.1 88/01/28 11:07:08 root Exp $
*
* $Log: a2py.c,v $
+ * Revision 1.0.1.1 88/01/28 11:07:08 root
+ * patch8: added support for FOO=bar switches using eval.
+ *
* Revision 1.0 87/12/18 17:50:33 root
* Initial revision
*
tmpstr = walk(0,0,root,&i);
str = str_make("#!/bin/perl\n\n");
+ str_cat(str,
+ "eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;\n");
+ str_cat(str,
+ " # process any FOO=bar switches\n\n");
if (do_opens && opens) {
str_scat(str,opens);
str_free(opens);
-/* $Header: walk.c,v 1.0 87/12/18 13:07:40 root Exp $
+/* $Header: walk.c,v 1.0.1.1 88/01/28 11:07:56 root Exp $
*
* $Log: walk.c,v $
+ * Revision 1.0.1.1 88/01/28 11:07:56 root
+ * patch8: changed some misleading comments.
+ *
* Revision 1.0 87/12/18 13:07:40 root
* Initial revision
*
str_cat(str,"';\t\t# field separator from -F switch\n");
}
else if (saw_FS && !const_FS) {
- str_cat(str,"$FS = '[ \\t\\n]+';\t\t# default field separator\n");
+ str_cat(str,"$FS = '[ \\t\\n]+';\t\t# set field separator\n");
}
if (saw_OFS) {
- str_cat(str,"$, = ' ';\t\t# default output field separator\n");
+ str_cat(str,"$, = ' ';\t\t# set output field separator\n");
}
if (saw_ORS) {
- str_cat(str,"$\\ = \"\\n\";\t\t# default output record separator\n");
+ str_cat(str,"$\\ = \"\\n\";\t\t# set output record separator\n");
}
if (str->str_cur > 20)
str_cat(str,"\n");
projects / p5sagit/p5-mst-13.2.git / commitdiff