From a559c25918b1466cdb50c9f978a86f01be0bac10 Mon Sep 17 00:00:00 2001
From: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Date: Wed, 27 Jan 1988 22:18:25 +0000
Subject: perl 1.0 patch 8: perl needed an eval operator and a symbolic
 debugger

I didn't add an eval operator to the original perl because
I hadn't thought of any good uses for it.  Recently I thought
of some.  Along with creating the eval operator, this patch
introduces a symbolic debugger for perl scripts, which makes
use of eval to interpret some debugging commands.  Having eval
also lets me emulate awk's FOO=bar command line behavior with
a line such as the one a2p now inserts at the beginning of
translated scripts.
---
 Makefile.SH  |   9 +-
 arg.c        |  12 ++-
 arg.h        |  11 ++-
 cmd.h        |   6 +-
 patchlevel.h |   2 +-
 perl.h       |  10 +-
 perl.y       |  10 +-
 perldb       | 296 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 perldb.man   | 119 ++++++++++++++++++++++++
 perly.c      | 175 ++++++++++++++++++++++++++++++++---
 search.c     |   7 +-
 stab.c       |  11 ++-
 t/base.lex   |  13 ++-
 t/op.eval    |  20 ++++
 util.c       |  10 +-
 x2p/a2py.c   |   9 +-
 x2p/walk.c   |  11 ++-
 17 files changed, 690 insertions(+), 41 deletions(-)
 create mode 100644 perldb
 create mode 100644 perldb.man
 create mode 100644 t/op.eval

diff --git a/Makefile.SH b/Makefile.SH
index fc05ca2b6a..a486289535 100644
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -14,9 +14,12 @@ case "$0" in
 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.
 # 
@@ -47,11 +50,11 @@ libs = $libnm -lm
 
 cat >>Makefile <<'!NO!SUBS!'
 
-public = perl
+public = perl perldb
 
 private = 
 
-manpages = perl.man
+manpages = perl.man perldb.man
 
 util =
 
diff --git a/arg.c b/arg.c
index 728f44d819..df4887ad3a 100644
--- a/arg.c
+++ b/arg.c
@@ -1,8 +1,8 @@
-/* $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.
@@ -1190,6 +1190,7 @@ init_eval()
     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
@@ -2092,6 +2093,11 @@ STR ***retary;		/* where to return an array to, null if nowhere */
 	}
 	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--;
diff --git a/arg.h b/arg.h
index 2e1bd8a339..d442b02dfa 100644
--- a/arg.h
+++ b/arg.h
@@ -1,6 +1,9 @@
-/* $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
  * 
@@ -111,7 +114,8 @@
 #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[];
@@ -222,7 +226,8 @@ char *opname[] = {
     "UNSHIFT",
     "LINK",
     "REPEAT",
-    "105"
+    "EVAL",
+    "106"
 };
 #endif
 
diff --git a/cmd.h b/cmd.h
index 9eb4a8f79d..9a019f2c74 100644
--- a/cmd.h
+++ b/cmd.h
@@ -1,6 +1,9 @@
-/* $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
  * 
@@ -106,6 +109,7 @@ struct cmd {
 #define Nullcmd Null(CMD*)
 
 EXT CMD *main_root INIT(Nullcmd);
+EXT CMD *eval_root INIT(Nullcmd);
 
 EXT struct compcmd {
     CMD *comp_true;
diff --git a/patchlevel.h b/patchlevel.h
index e19cd94440..a6997a9a35 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1 +1 @@
-#define PATCHLEVEL 7
+#define PATCHLEVEL 8
diff --git a/perl.h b/perl.h
index 751b8cdc61..9b877f3e30 100644
--- a/perl.h
+++ b/perl.h
@@ -1,6 +1,9 @@
-/* $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.
  * 
@@ -103,7 +106,8 @@ ARG *flipflip();
 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();
 
@@ -164,6 +168,7 @@ EXT char *inplace INIT(Nullch);
 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(); */
@@ -196,6 +201,7 @@ EXT struct loop {
 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 */
 
diff --git a/perl.y b/perl.y
index 16f8a9aa96..b9a7a8e30e 100644
--- a/perl.y
+++ b/perl.y
@@ -1,6 +1,9 @@
-/* $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
  * 
@@ -97,7 +100,10 @@ char *tokename[] = {
 %% /* 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
diff --git a/perldb b/perldb
new file mode 100644
index 0000000000..d548f7299d
--- /dev/null
+++ b/perldb
@@ -0,0 +1,296 @@
+#!/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';
+}
diff --git a/perldb.man b/perldb.man
new file mode 100644
index 0000000000..5a4224126d
--- /dev/null
+++ b/perldb.man
@@ -0,0 +1,119 @@
+.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 }` ''
diff --git a/perly.c b/perly.c
index dfd83d9b46..d2119acc66 100644
--- a/perly.c
+++ b/perly.c
@@ -1,6 +1,9 @@
-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.
  * 
@@ -16,6 +19,7 @@ bool preprocess = FALSE;
 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;
@@ -161,12 +165,12 @@ register char **env;
 	    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;
@@ -177,12 +181,12 @@ register char **env;
 	    *--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);
@@ -198,6 +202,8 @@ register char **env;
     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 */
 
@@ -225,7 +231,7 @@ register char *list;
 
     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;
 	}
@@ -322,7 +328,15 @@ yylex()
 	    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;
@@ -350,9 +364,15 @@ yylex()
 	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++;
@@ -508,6 +528,10 @@ yylex()
 	    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"))
@@ -1480,8 +1504,12 @@ char *s;
 	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 *
@@ -1964,7 +1992,7 @@ register ARG *arg;
 	    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()*/
 	    }
@@ -2464,3 +2492,128 @@ load_format()
     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);
+}
diff --git a/search.c b/search.c
index b812ee1aa5..3a15e29b6f 100644
--- a/search.c
+++ b/search.c
@@ -1,6 +1,9 @@
-/* $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.
  * 
@@ -107,7 +110,6 @@ register COMPEX *compex;
     compex->subbase = Nullch;
 }
 
-#ifdef NOTUSED
 void
 free_compex(compex)
 register COMPEX *compex;
@@ -121,7 +123,6 @@ register COMPEX *compex;
 	compex->subbase = Nullch;
     }
 }
-#endif
 
 static char *gbr_str = Nullch;
 static int gbr_siz = 0;
diff --git a/stab.c b/stab.c
index b9ef533dce..fc158ff19a 100644
--- a/stab.c
+++ b/stab.c
@@ -1,6 +1,9 @@
-/* $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
  * 
@@ -169,12 +172,12 @@ STR *str;
 	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);
@@ -274,7 +277,7 @@ int sig;
     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);
diff --git a/t/base.lex b/t/base.lex
index 2cfe311ed8..015f442c77 100644
--- a/t/base.lex
+++ b/t/base.lex
@@ -1,8 +1,8 @@
 #!./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';
@@ -21,3 +21,12 @@ if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
 $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";}
diff --git a/t/op.eval b/t/op.eval
new file mode 100644
index 0000000000..191571015c
--- /dev/null
+++ b/t/op.eval
@@ -0,0 +1,20 @@
+#!./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";}
diff --git a/util.c b/util.c
index b0b78f1926..3572c4279c 100644
--- a/util.c
+++ b/util.c
@@ -1,6 +1,9 @@
-/* $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
  * 
@@ -205,6 +208,11 @@ char *pat;
     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);
diff --git a/x2p/a2py.c b/x2p/a2py.c
index 8a1ad78b96..c99504046a 100644
--- a/x2p/a2py.c
+++ b/x2p/a2py.c
@@ -1,6 +1,9 @@
-/* $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
  * 
@@ -114,6 +117,10 @@ register char **env;
 
     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);
diff --git a/x2p/walk.c b/x2p/walk.c
index 04d133b9c4..e745510b1d 100644
--- a/x2p/walk.c
+++ b/x2p/walk.c
@@ -1,6 +1,9 @@
-/* $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
  * 
@@ -68,13 +71,13 @@ int *numericptr;
 	    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");
-- 
cgit v1.2.1