perl 3.0 patch #26 patch #19, continued

See patch #19.

13 files changed, 439 insertions, 135 deletions

diff --git a/h2pl/eg/sysexits.pl b/h2pl/eg/sysexits.pl
new file mode 100644
index 0000000000..f4cb777ee9
--- /dev/null
+++ b/h2pl/eg/sysexits.pl
@@ -0,0 +1,16 @@
+$EX_OK = 0x0;
+$EX__BASE = 0x40;
+$EX_USAGE = 0x40;
+$EX_DATAERR = 0x41;
+$EX_NOINPUT = 0x42;
+$EX_NOUSER = 0x43;
+$EX_NOHOST = 0x44;
+$EX_UNAVAILABLE = 0x45;
+$EX_SOFTWARE = 0x46;
+$EX_OSERR = 0x47;
+$EX_OSFILE = 0x48;
+$EX_CANTCREAT = 0x49;
+$EX_IOERR = 0x4A;
+$EX_TEMPFAIL = 0x4B;
+$EX_PROTOCOL = 0x4C;
+$EX_NOPERM = 0x4D;
diff --git a/h2pl/tcbreak b/h2pl/tcbreak
new file mode 100644
index 0000000000..2677cc982b
--- /dev/null
+++ b/h2pl/tcbreak
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+require 'cbreak.pl';
+
+&cbreak;
+
+$| = 1;
+
+print "gimme a char: ";
+
+$c = getc;
+
+print "$c\n";
+
+printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
+
+&cooked;
diff --git a/h2pl/tcbreak2 b/h2pl/tcbreak2
new file mode 100644
index 0000000000..fcbf926516
--- /dev/null
+++ b/h2pl/tcbreak2
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+require 'cbreak2.pl';
+
+&cbreak;
+
+$| = 1;
+
+print "gimme a char: ";
+
+$c = getc;
+
+print "$c\n";
+
+printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
+
+&cooked;
diff --git a/lib/stat.pl b/lib/stat.pl
index 8cf0bde193..df9e1dba5b 100644
--- a/lib/stat.pl
+++ b/lib/stat.pl
@@ -1,6 +1,7 @@
-;# $Header: stat.pl,v 3.0 89/10/18 15:19:53 lwall Locked $
+;# $Header: stat.pl,v 3.0.1.1 90/08/09 04:01:34 lwall Locked $
 
 ;# Usage:
+;#	require 'stat.pl';
 ;#	@ary = stat(foo);
 ;#	$st_dev = @ary[$ST_DEV];
 ;#
@@ -19,6 +20,7 @@ $ST_BLKSIZE =	11 + $[;
 $ST_BLOCKS =	12 + $[;
 
 ;# Usage:
+;#	require 'stat.pl';
 ;#	do Stat('foo');		# sets st_* as a side effect
 ;#
 sub Stat {
diff --git a/lib/syslog.pl b/lib/syslog.pl
index 46c8c86eda..c98baf32e3 100644
--- a/lib/syslog.pl
+++ b/lib/syslog.pl
@@ -8,7 +8,7 @@
 # call syslog() with a string priority and a list of printf() args
 # like syslog(3)
 #
-#  usage: do 'syslog.pl' || die "syslog.pl: $@";
+#  usage: require 'syslog.pl';
 #
 #  then (put these all in a script to test function)
 #		
@@ -29,8 +29,7 @@ package syslog;
 
 $host = 'localhost' unless $host;	# set $syslog'host to change
 
-do '/usr/local/lib/perl/syslog.h'
-	|| die "syslog: Can't do syslog.h: ",($@||$!),"\n";
+require 'syslog.ph';
 
 sub main'openlog {
     ($ident, $logopt, $facility) = @_;  # package vars
diff --git a/lib/termcap.pl b/lib/termcap.pl
index 35b5ec0655..d64852667c 100644
--- a/lib/termcap.pl
+++ b/lib/termcap.pl
@@ -1,10 +1,10 @@
-;# $Header: termcap.pl,v 3.0.1.2 90/03/14 12:28:28 lwall Locked $
+;# $Header: termcap.pl,v 3.0.1.3 90/08/09 04:02:53 lwall Locked $
 ;#
 ;# Usage:
-;#	do 'ioctl.pl';
+;#	require 'ioctl.pl';
 ;#	ioctl(TTY,$TIOCGETP,$foo);
 ;#	($ispeed,$ospeed) = unpack('cc',$foo);
-;#	do 'termcap.pl' || die "Can't get termcap.pl";
+;#	require 'termcap.pl';
 ;#	&Tgetent('vt100');	# sets $TC{'cm'}, etc.
 ;#	&Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
 ;#	&Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
diff --git a/os2/eg/syscalls.pl b/os2/eg/syscalls.pl
new file mode 100644
index 0000000000..2356f2e478
--- /dev/null
+++ b/os2/eg/syscalls.pl
@@ -0,0 +1,16 @@
+# OS/2 syscall values
+
+$OS2_GetVersion = 0;
+$OS2_Shutdown = 1;
+$OS2_Beep = 2;
+$OS2_PhysicalDisk = 3;
+$OS2_Config = 4;
+$OS2_IOCtl = 5;
+$OS2_QCurDisk = 6;
+$OS2_SelectDisk = 7;
+$OS2_SetMaxFH = 8;
+$OS2_Sleep = 9;
+$OS2_StartSession = 10;
+$OS2_StopSession = 11;
+$OS2_SelectSession = 12;
+1;
diff --git a/os2/suffix.c b/os2/suffix.c
new file mode 100644
index 0000000000..2dbb02b525
--- /dev/null
+++ b/os2/suffix.c
@@ -0,0 +1,146 @@
+/*
+ * Suffix appending for in-place editing under MS-DOS and OS/2.
+ *
+ * Here are the rules:
+ *
+ * Style 0:  Append the suffix exactly as standard perl would do it.
+ *           If the filesystem groks it, use it.  (HPFS will always
+ *           grok it.  FAT will rarely accept it.)
+ *
+ * Style 1:  The suffix begins with a '.'.  The extension is replaced.
+ *           If the name matches the original name, use the fallback method.
+ *
+ * Style 2:  The suffix is a single character, not a '.'.  Try to add the 
+ *           suffix to the following places, using the first one that works.
+ *               [1] Append to extension.  
+ *               [2] Append to filename, 
+ *               [3] Replace end of extension, 
+ *               [4] Replace end of filename.
+ *           If the name matches the original name, use the fallback method.
+ *
+ * Style 3:  Any other case:  Ignore the suffix completely and use the
+ *           fallback method.
+ *
+ * Fallback method:  Change the extension to ".$$$".  If that matches the
+ *           original name, then change the extension to ".~~~".
+ *
+ * If filename is more than 1000 characters long, we die a horrible
+ * death.  Sorry.
+ *
+ * The filename restriction is a cheat so that we can use buf[] to store
+ * assorted temporary goo.
+ *
+ * Examples, assuming style 0 failed.
+ *
+ * suffix = ".bak" (style 1)
+ *                foo.bar => foo.bak
+ *                foo.bak => foo.$$$	(fallback)
+ *                foo.$$$ => foo.~~~	(fallback)
+ *                makefile => makefile.bak
+ *
+ * suffix = "~" (style 2)
+ *                foo.c => foo.c~
+ *                foo.c~ => foo.c~~
+ *                foo.c~~ => foo~.c~~
+ *                foo~.c~~ => foo~~.c~~
+ *                foo~~~~~.c~~ => foo~~~~~.$$$ (fallback)
+ *
+ *                foo.pas => foo~.pas
+ *                makefile => makefile.~
+ *                longname.fil => longname.fi~
+ *                longname.fi~ => longnam~.fi~
+ *                longnam~.fi~ => longnam~.$$$
+ *                
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#ifdef OS2
+#define INCL_DOSFILEMGR
+#define INCL_DOSERRORS
+#include <os2.h>
+#endif /* OS2 */
+
+static char suffix1[] = ".$$$";
+static char suffix2[] = ".~~~";
+
+#define ext (&buf[1000])
+
+add_suffix(str,suffix)
+register STR *str;
+register char *suffix;
+{
+    int baselen;
+    int extlen;
+    char *s, *t, *p;
+    STRLEN slen;
+
+    if (!(str->str_pok)) (void)str_2ptr(str);
+    if (str->str_cur > 1000)
+        fatal("Cannot do inplace edit on long filename (%d characters)", str->str_cur);
+
+#ifdef OS2
+    /* Style 0 */
+    slen = str->str_cur;
+    str_cat(str, suffix);
+    if (valid_filename(str->str_ptr)) return;
+
+    /* Fooey, style 0 failed.  Fix str before continuing. */
+    str->str_ptr[str->str_cur = slen] = '\0';
+#endif /* OS2 */
+
+    slen = strlen(suffix);
+    t = buf; baselen = 0; s = str->str_ptr;
+    while ( (*t = *s) && *s != '.') {
+	baselen++;
+	if (*s == '\\' || *s == '/') baselen = 0;
+ 	s++; t++;
+    }
+    p = t;
+
+    t = ext; extlen = 0;
+    while (*t++ = *s++) extlen++;
+    if (extlen == 0) { ext[0] = '.'; ext[1] = 0; extlen++; }
+
+    if (*suffix == '.') {        /* Style 1 */
+        if (strEQ(ext, suffix)) goto fallback;
+	strcpy(p, suffix);
+    } else if (suffix[1] == '\0') {  /* Style 2 */
+        if (extlen < 4) { 
+	    ext[extlen] = *suffix;
+	    ext[++extlen] = '\0';
+        } else if (baselen < 8) {
+   	    *p++ = *suffix;
+	} else if (ext[3] != *suffix) {
+	    ext[3] = *suffix;
+	} else if (buf[7] != *suffix) {
+	    buf[7] = *suffix;
+	} else goto fallback;
+	strcpy(p, ext);
+    } else { /* Style 3:  Panic */
+fallback:
+	(void)bcopy(strEQ(ext, suffix1) ? suffix2 : suffix1, p, 4+1);
+    }
+    str_set(str, buf);
+}
+
+#ifdef OS2
+int 
+valid_filename(s)
+char *s;
+{
+    HFILE hf;
+    USHORT usAction;
+
+    switch(DosOpen(s, &hf, &usAction, 0L, 0, FILE_OPEN,
+	OPEN_ACCESS_READONLY | OPEN_SHARE_DENYNONE, 0L)) {
+    case NO_ERROR:
+	DosClose(hf);
+	/*FALLTHROUGH*/
+    default:
+	return 1;
+    case ERROR_FILENAME_EXCED_RANGE:
+	return 0;
+    }
+}
+#endif /* OS2 */
diff --git a/patchlevel.h b/patchlevel.h
index 10c8c21b10..9705476214 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1 +1 @@
-#define PATCHLEVEL 25
+#define PATCHLEVEL 26
diff --git a/stab.h b/stab.h
index db2d60c36f..aeb7133700 100644
--- a/stab.h
+++ b/stab.h
@@ -1,4 +1,4 @@
-/* $Header: stab.h,v 3.0.1.2 90/03/12 17:00:43 lwall Locked $
+/* $Header: stab.h,v 3.0.1.3 90/08/09 05:18:42 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:	stab.h,v $
+ * Revision 3.0.1.3  90/08/09  05:18:42  lwall
+ * patch19: Added support for linked-in C subroutines
+ * 
  * Revision 3.0.1.2  90/03/12  17:00:43  lwall
  * patch13: did some ndir straightening up for Xenix
  * 
@@ -88,6 +91,8 @@ struct stio {
 
 struct sub {
     CMD		*cmd;
+    int		(*usersub)();
+    int		userindex;
     char	*filename;
     long	depth;	/* >= 2 indicates recursive call */
     ARRAY	*tosave;
diff --git a/str.c b/str.c
index 324e10065c..0b6dfea697 100644
--- a/str.c
+++ b/str.c
@@ -1,4 +1,4 @@
-/* $Header: str.c,v 3.0.1.7 90/03/27 16:24:11 lwall Locked $
+/* $Header: str.c,v 3.0.1.8 90/08/09 05:22:18 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,10 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:	str.c,v $
+ * Revision 3.0.1.8  90/08/09  05:22:18  lwall
+ * patch19: the number to string converter wasn't allocating enough space
+ * patch19: tainting didn't work on setgid scripts
+ * 
  * Revision 3.0.1.7  90/03/27  16:24:11  lwall
  * patch16: strings with prefix chopped off sometimes freed wrong
  * patch16: taint check blows up on undefined array element
@@ -97,10 +101,20 @@ STR *Str;
 char *
 str_grow(str,newlen)
 register STR *str;
+#ifndef MSDOS
 register int newlen;
+#else
+unsigned long newlen;
+#endif
 {
     register char *s = str->str_ptr;
 
+#ifdef MSDOS
+    if (newlen >= 0x10000) {
+	fprintf(stderr, "Allocation too large: %lx\n", newlen);
+	exit(1);
+    }
+#endif /* MSDOS */
     if (str->str_state == SS_INCR) {		/* data before str_ptr? */
 	str->str_len += str->str_u.str_useful;
 	str->str_ptr -= str->str_u.str_useful;
@@ -129,7 +143,7 @@ double num;
     if (str->str_pok) {
 	str->str_pok = 0;	/* invalidate pointer */
 	if (str->str_state == SS_INCR)
-	    str_grow(str,0);
+	    Str_Grow(str,0);
     }
     str->str_u.str_nval = num;
     str->str_state = SS_NORM;
@@ -149,15 +163,7 @@ register STR *str;
     if (!str)
 	return "";
     if (str->str_nok) {
-/* this is a problem on the sun 4... 24 bytes is not always enough and the
-	exponent blows away the malloc stack
-	PEJ Wed Jan 31 18:41:34 CST 1990
-*/
-#ifdef sun4
 	STR_GROW(str, 30);
-#else
-	STR_GROW(str, 24);
-#endif /* sun 4 */
 	s = str->str_ptr;
 	olderrno = errno;	/* some Xenix systems wipe out errno here */
 #if defined(scs) && defined(ns32000)
@@ -182,11 +188,7 @@ register STR *str;
 	    return No;
 	if (dowarn)
 	    warn("Use of uninitialized variable");
-#ifdef sun4
 	STR_GROW(str, 30);
-#else
-	STR_GROW(str, 24);
-#endif
 	s = str->str_ptr;
     }
     *s = '\0';
@@ -206,7 +208,7 @@ register STR *str;
     if (!str)
 	return 0.0;
     if (str->str_state == SS_INCR)
-	str_grow(str,0);       /* just force copy down */
+	Str_Grow(str,0);       /* just force copy down */
     str->str_state = SS_NORM;
     if (str->str_len && str->str_pok)
 	str->str_u.str_nval = atof(str->str_ptr);
@@ -257,7 +259,7 @@ register STR *sstr;
 	str_numset(dstr,sstr->str_u.str_nval);
     else {
 	if (dstr->str_state == SS_INCR)
-	    str_grow(dstr,0);       /* just force copy down */
+	    Str_Grow(dstr,0);       /* just force copy down */
 
 #ifdef STRUCTCOPY
 	dstr->str_u = sstr->str_u;
@@ -271,7 +273,7 @@ register STR *sstr;
 str_nset(str,ptr,len)
 register STR *str;
 register char *ptr;
-register int len;
+register STRLEN len;
 {
     STR_GROW(str, len + 1);
     if (ptr)
@@ -289,7 +291,7 @@ str_set(str,ptr)
 register STR *str;
 register char *ptr;
 {
-    register int len;
+    register STRLEN len;
 
     if (!ptr)
 	ptr = "";
@@ -308,7 +310,7 @@ str_chop(str,ptr)	/* like set but assuming ptr is in str */
 register STR *str;
 register char *ptr;
 {
-    register int delta;
+    register STRLEN delta;
 
     if (!(str->str_pok))
 	fatal("str_chop: internal inconsistency");
@@ -329,7 +331,7 @@ register char *ptr;
 str_ncat(str,ptr,len)
 register STR *str;
 register char *ptr;
-register int len;
+register STRLEN len;
 {
     if (!(str->str_pok))
 	(void)str_2ptr(str);
@@ -363,7 +365,7 @@ str_cat(str,ptr)
 register STR *str;
 register char *ptr;
 {
-    register int len;
+    register STRLEN len;
 
     if (!ptr)
 	return;
@@ -389,7 +391,7 @@ register int delim;
 char *keeplist;
 {
     register char *to;
-    register int len;
+    register STRLEN len;
 
     if (!from)
 	return Nullch;
@@ -427,7 +429,7 @@ int x;
 #else
 str_new(len)
 #endif
-int len;
+STRLEN len;
 {
     register STR *str;
     
@@ -451,7 +453,7 @@ register STR *str;
 STAB *stab;
 int how;
 char *name;
-int namlen;
+STRLEN namlen;
 {
     if (str->str_magic)
 	return;
@@ -466,10 +468,10 @@ int namlen;
 void
 str_insert(bigstr,offset,len,little,littlelen)
 STR *bigstr;
-int offset;
-int len;
+STRLEN offset;
+STRLEN len;
 char *little;
-int littlelen;
+STRLEN littlelen;
 {
     register char *big;
     register char *mid;
@@ -549,9 +551,9 @@ register STR *str;
 register STR *nstr;
 {
     if (str->str_state == SS_INCR)
-	str_grow(str,0);	/* just force copy down */
+	Str_Grow(str,0);	/* just force copy down */
     if (nstr->str_state == SS_INCR)
-	str_grow(nstr,0);
+	Str_Grow(nstr,0);
     if (str->str_ptr)
 	Safefree(str->str_ptr);
     str->str_ptr = nstr->str_ptr;
@@ -616,6 +618,7 @@ register STR *str;
 #endif /* LEAKTEST */
 }
 
+STRLEN
 str_len(str)
 register STR *str;
 {
@@ -690,8 +693,8 @@ int append;
     register STDCHAR *ptr;	/*   in the innermost loop into registers */
     register int newline = record_separator;/* (assuming >= 6 registers) */
     int i;
-    int bpx;
-    int obpx;
+    STRLEN bpx;
+    STRLEN obpx;
     register int get_paragraph;
     register char *oldbp;
 
@@ -786,9 +789,8 @@ STR *str;
 {
     register CMD *cmd;
     register ARG *arg;
-    line_t oldline = line;
+    CMD *oldcurcmd = curcmd;
     int retval;
-    char *tmps;
 
     str_sset(linestr,str);
     in_eval++;
@@ -812,14 +814,17 @@ STR *str;
     }
 #ifdef DEBUGGING
     if (debug & 4) {
-	tmps = loop_stack[loop_ptr].loop_label;
+	char *tmps = loop_stack[loop_ptr].loop_label;
 	deb("(Popping label #%d %s)\n",loop_ptr,
 	    tmps ? tmps : "" );
     }
 #endif
     loop_ptr--;
     error_count = 0;
+    curcmd = &compiling;
+    curcmd->c_line = oldcurcmd->c_line;
     retval = yyparse();
+    curcmd = oldcurcmd;
     in_eval--;
     if (retval || error_count)
 	fatal("Invalid component in string or format");
@@ -828,7 +833,6 @@ STR *str;
     if (cmd->c_type != C_EXPR || cmd->c_next || arg->arg_type != O_LIST)
 	fatal("panic: error in parselist %d %x %d", cmd->c_type,
 	  cmd->c_next, arg ? arg->arg_type : -1);
-    line = oldline;
     Safefree(cmd);
     return arg;
 }
@@ -842,7 +846,7 @@ STR *src;
     register STR *str;
     register char *t;
     STR *toparse;
-    int len;
+    STRLEN len;
     register int brackets;
     register char *d;
     STAB *stab;
@@ -1222,7 +1226,7 @@ register STR *str;
 STR *
 str_make(s,len)
 char *s;
-int len;
+STRLEN len;
 {
     register STR *str = Str_new(79,0);
 
@@ -1257,7 +1261,7 @@ register STR *old;
 	return Nullstr;
     }
     if (old->str_state == SS_INCR && !(old->str_pok & 2))
-	str_grow(old,0);
+	Str_Grow(old,0);
     if (new->str_ptr)
 	Safefree(new->str_ptr);
     Copy(old,new,1,STR);
@@ -1328,7 +1332,7 @@ char *s;
     if (debug & 2048)
 	fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid);
 #endif
-    if (tainted && (!euid || euid != uid)) {
+    if (tainted && (!euid || euid != uid || egid != gid)) {
 	if (!unsafe)
 	    fatal("%s", s);
 	else if (dowarn)
diff --git a/str.h b/str.h
index 2c14029c7e..cdc3d586b5 100644
--- a/str.h
+++ b/str.h
@@ -1,4 +1,4 @@
-/* $Header: str.h,v 3.0.1.1 89/10/26 23:24:42 lwall Locked $
+/* $Header: str.h,v 3.0.1.2 90/08/09 05:23:24 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:	str.h,v $
+ * Revision 3.0.1.2  90/08/09  05:23:24  lwall
+ * patch19: various MSDOS and OS/2 patches folded in
+ * 
  * Revision 3.0.1.1  89/10/26  23:24:42  lwall
  * patch1: rearranged some structures to align doubles better on Gould
  * 
@@ -16,7 +19,7 @@
 
 struct string {
     char *	str_ptr;	/* pointer to malloced string */
-    int		str_len;	/* allocated size */
+    STRLEN	str_len;	/* allocated size */
     union {
 	double	str_nval;	/* numeric value, if any */
 	STAB	*str_stab;	/* magic stab for magic "key" string */
@@ -25,8 +28,8 @@ struct string {
 	HASH	*str_hash;	/* string represents an assoc array (stab?) */
 	ARRAY	*str_array;	/* string represents an array */
     } str_u;
-    int		str_cur;	/* length of str_ptr as a C string */
-    STR *str_magic;		/* while free, link to next free str */
+    STRLEN	str_cur;	/* length of str_ptr as a C string */
+    STR		*str_magic;	/* while free, link to next free str */
 				/* while in use, ptr to "key" for magic items */
     char	str_pok;	/* state of str_ptr */
     char	str_nok;	/* state of str_nval */
@@ -40,7 +43,7 @@ struct string {
 
 struct stab {	/* should be identical, except for str_ptr */
     STBP *	str_ptr;	/* pointer to malloced string */
-    int		str_len;	/* allocated size */
+    STRLEN	str_len;	/* allocated size */
     union {
 	double	str_nval;	/* numeric value, if any */
 	STAB	*str_stab;	/* magic stab for magic "key" string */
@@ -49,8 +52,8 @@ struct stab {	/* should be identical, except for str_ptr */
 	HASH	*str_hash;	/* string represents an assoc array (stab?) */
 	ARRAY	*str_array;	/* string represents an array */
     } str_u;
-    int		str_cur;	/* length of str_ptr as a C string */
-    STR *str_magic;		/* while free, link to next free str */
+    STRLEN	str_cur;	/* length of str_ptr as a C string */
+    STR		*str_magic;	/* while free, link to next free str */
 				/* while in use, ptr to "key" for magic items */
     char	str_pok;	/* state of str_ptr */
     char	str_nok;	/* state of str_nval */
@@ -66,8 +69,8 @@ struct stab {	/* should be identical, except for str_ptr */
 
 struct lstring {
     struct string lstr;
-    int	lstr_offset;
-    int	lstr_len;
+    STRLEN	lstr_offset;
+    STRLEN	lstr_len;
 };
 
 /* These are the values of str_pok:		*/
@@ -127,3 +130,4 @@ int str_cmp();
 int str_eq();
 void str_magic();
 void str_insert();
+STRLEN str_len();
diff --git a/toke.c b/toke.c
index 40df16ab6d..ec45b31fdd 100644
--- a/toke.c
+++ b/toke.c
@@ -1,4 +1,4 @@
-/* $Header: toke.c,v 3.0.1.7 90/03/27 16:32:37 lwall Locked $
+/* $Header: toke.c,v 3.0.1.8 90/08/09 05:39:58 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,18 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:	toke.c,v $
+ * Revision 3.0.1.8  90/08/09  05:39:58  lwall
+ * patch19: added require operator
+ * patch19: added -x switch to extract script from input trash
+ * patch19: bare @name didn't add array to symbol table
+ * patch19: Added __LINE__ and __FILE__ tokens
+ * patch19: Added __END__ token
+ * patch19: Numeric literals are now stored only in floating point
+ * patch19: some support for FPS compiler misfunction
+ * patch19: "\\$foo" not handled right
+ * patch19: program and data can now both come from STDIN
+ * patch19: "here" strings caused warnings about uninitialized variables
+ * 
  * Revision 3.0.1.7  90/03/27  16:32:37  lwall
  * patch16: MSDOS support
  * patch16: formats didn't work inside eval
@@ -52,7 +64,7 @@ char *reparse;		/* if non-null, scanreg found ${foo[$bar]} */
 #ifdef CLINE
 #undef CLINE
 #endif
-#define CLINE (cmdline = (line < cmdline ? line : cmdline))
+#define CLINE (cmdline = (curcmd->c_line < cmdline ? curcmd->c_line : cmdline))
 
 #define META(c) ((c) | 128)
 
@@ -172,6 +184,15 @@ yylex()
 	else
 	    fprintf(stderr,"Tokener at %s\n",s);
 #endif
+#ifdef BADSWITCH
+    if (*s & 128) {
+	if ((*s & 127) == '(')
+	    *s++ = '(';
+	else
+	    warn("Unrecognized character \\%03o ignored", *s++);
+	goto retry;
+    }
+#endif
     switch (*s) {
     default:
 	if ((*s & 127) == '(')
@@ -179,6 +200,9 @@ yylex()
 	else
 	    warn("Unrecognized character \\%03o ignored", *s++);
 	goto retry;
+    case 4:
+    case 26:
+	goto fake_eof;			/* emulate EOF on ^D or ^Z */
     case 0:
 	if (!rsfp)
 	    RETURN(0);
@@ -189,8 +213,7 @@ yylex()
 	    if (minus_n || minus_p || perldb) {
 		str_set(linestr,"");
 		if (perldb)
-		    str_cat(linestr,
-"do 'perldb.pl' || die \"Can't find perldb.pl in @INC\"; print $@;");
+		    str_cat(linestr, "require 'perldb.pl';");
 		if (minus_n || minus_p) {
 		    str_cat(linestr,"line: while (<>) {");
 		    if (minus_a)
@@ -207,33 +230,43 @@ yylex()
 	    in_format = FALSE;
 	    oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
 	    bufend = linestr->str_ptr + linestr->str_cur;
-	    TERM(FORMLIST);
-	}
-	line++;
-	if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
-	    if (preprocess)
-		(void)mypclose(rsfp);
-	    else if (rsfp != stdin)
-		(void)fclose(rsfp);
-	    rsfp = Nullfp;
-	    if (minus_n || minus_p) {
-		str_set(linestr,minus_p ? ";}continue{print" : "");
-		str_cat(linestr,";}");
+	    OPERATOR(FORMLIST);
+	}
+	curcmd->c_line++;
+#ifdef CRYPTSCRIPT
+	cryptswitch();
+#endif /* CRYPTSCRIPT */
+	do {
+	    if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
+	      fake_eof:
+		if (preprocess)
+		    (void)mypclose(rsfp);
+		else if (rsfp == stdin)
+		    clearerr(stdin);
+		else
+		    (void)fclose(rsfp);
+		rsfp = Nullfp;
+		if (minus_n || minus_p) {
+		    str_set(linestr,minus_p ? ";}continue{print" : "");
+		    str_cat(linestr,";}");
+		    oldoldbufptr = oldbufptr = s = str_get(linestr);
+		    bufend = linestr->str_ptr + linestr->str_cur;
+		    minus_n = minus_p = 0;
+		    goto retry;
+		}
 		oldoldbufptr = oldbufptr = s = str_get(linestr);
-		bufend = linestr->str_ptr + linestr->str_cur;
-		minus_n = minus_p = 0;
-		goto retry;
+		str_set(linestr,"");
+		RETURN(';');	/* not infinite loop because rsfp is NULL now */
 	    }
-	    oldoldbufptr = oldbufptr = s = str_get(linestr);
-	    str_set(linestr,"");
-	    RETURN(';');	/* not infinite loop because rsfp is NULL now */
-	}
+	    if (doextract && *linestr->str_ptr == '#')
+		doextract = FALSE;
+	} while (doextract);
 	oldoldbufptr = oldbufptr = bufptr = s;
 	if (perldb) {
 	    STR *str = Str_new(85,0);
 
 	    str_sset(str,linestr);
-	    astore(lineary,(int)line,str);
+	    astore(lineary,(int)curcmd->c_line,str);
 	}
 #ifdef DEBUG
 	if (firstline) {
@@ -242,7 +275,7 @@ yylex()
 	}
 #endif
 	bufend = linestr->str_ptr + linestr->str_cur;
-	if (line == 1) {
+	if (curcmd->c_line == 1) {
 	    if (*s == '#' && s[1] == '!') {
 		if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) {
 		    char **newargv;
@@ -283,16 +316,13 @@ yylex()
     case ' ': case '\t': case '\f':
 	s++;
 	goto retry;
-    case '\n':
     case '#':
 	if (preprocess && s == str_get(linestr) &&
 	       s[1] == ' ' && isdigit(s[2])) {
-	    line = atoi(s+2)-1;
+	    curcmd->c_line = atoi(s+2)-1;
 	    for (s += 2; isdigit(*s); s++) ;
 	    d = bufend;
 	    while (s < d && isspace(*s)) s++;
-	    if (filename)
-		Safefree(filename);
 	    s[strlen(s)-1] = '\0';	/* wipe out newline */
 	    if (*s == '"') {
 		s++;
@@ -301,9 +331,11 @@ yylex()
 	    if (*s)
 		filename = savestr(s);
 	    else
-		filename = savestr(origfilename);
+		filename = origfilename;
 	    oldoldbufptr = oldbufptr = s = str_get(linestr);
 	}
+	/* FALL THROUGH */
+    case '\n':
 	if (in_eval && !rsfp) {
 	    d = bufend;
 	    while (s < d && *s != '\n')
@@ -317,7 +349,7 @@ yylex()
 		oldoldbufptr = oldbufptr = s = bufptr + 1;
 		TERM(FORMLIST);
 	    }
-	    line++;
+	    curcmd->c_line++;
 	}
 	else {
 	    *s = '\0';
@@ -412,8 +444,8 @@ yylex()
 	    cmdline = NOLINE;   /* invalidate current command line number */
 	OPERATOR(tmp);
     case ';':
-	if (line < cmdline)
-	    cmdline = line;
+	if (curcmd->c_line < cmdline)
+	    cmdline = curcmd->c_line;
 	tmp = *s++;
 	OPERATOR(tmp);
     case ')':
@@ -521,7 +553,7 @@ yylex()
 	s = scanreg(s,bufend,tokenbuf);
 	if (reparse)
 	    goto do_reparse;
-	yylval.stabval = stabent(tokenbuf,TRUE);
+	yylval.stabval = aadd(stabent(tokenbuf,TRUE));
 	TERM(ARY);
 
     case '/':			/* may either be division or pattern */
@@ -556,6 +588,23 @@ yylex()
 	/* FALL THROUGH */
     case '_':
 	SNARFWORD;
+	if (d[1] == '_') {
+	    if (strEQ(d,"__LINE__") || strEQ(d,"__FILE__")) {
+		ARG *arg = op_new(1);
+
+		yylval.arg = arg;
+		arg->arg_type = O_ITEM;
+		if (d[2] == 'L')
+		    (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line);
+		else
+		    strcpy(tokenbuf, filename);
+		arg[1].arg_type = A_SINGLE;
+		arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
+		TERM(RSTRING);
+	    }
+	    else if (strEQ(d,"__END__"))
+		goto fake_eof;
+	}
 	break;
     case 'a': case 'A':
 	SNARFWORD;
@@ -630,7 +679,7 @@ yylex()
 	if (strEQ(d,"else"))
 	    OPERATOR(ELSE);
 	if (strEQ(d,"elsif")) {
-	    yylval.ival = line;
+	    yylval.ival = curcmd->c_line;
 	    OPERATOR(ELSIF);
 	}
 	if (strEQ(d,"eq") || strEQ(d,"EQ"))
@@ -667,7 +716,7 @@ yylex()
     case 'f': case 'F':
 	SNARFWORD;
 	if (strEQ(d,"for") || strEQ(d,"foreach")) {
-	    yylval.ival = line;
+	    yylval.ival = curcmd->c_line;
 	    OPERATOR(FOR);
 	}
 	if (strEQ(d,"format")) {
@@ -778,7 +827,7 @@ yylex()
     case 'i': case 'I':
 	SNARFWORD;
 	if (strEQ(d,"if")) {
-	    yylval.ival = line;
+	    yylval.ival = curcmd->c_line;
 	    OPERATOR(IF);
 	}
 	if (strEQ(d,"index"))
@@ -897,6 +946,10 @@ yylex()
 	SNARFWORD;
 	if (strEQ(d,"return"))
 	    OLDLOP(O_RETURN);
+	if (strEQ(d,"require")) {
+	    allstabs = TRUE;		/* must initialize everything since */
+	    UNI(O_REQUIRE);		/* we don't know what will be used */
+	}
 	if (strEQ(d,"reset"))
 	    UNI(O_RESET);
 	if (strEQ(d,"redo"))
@@ -945,7 +998,7 @@ yylex()
 	    break;
 	case 'e':
 	    if (strEQ(d,"select"))
-		OPERATOR(SELECT);
+		OPERATOR(SSELECT);
 	    if (strEQ(d,"seek"))
 		FOP3(O_SEEK);
 	    if (strEQ(d,"send"))
@@ -998,7 +1051,7 @@ yylex()
 	    if (strEQ(d,"socket"))
 		FOP4(O_SOCKET);
 	    if (strEQ(d,"socketpair"))
-		FOP25(O_SOCKETPAIR);
+		FOP25(O_SOCKPAIR);
 	    if (strEQ(d,"sort")) {
 		checkcomma(s,"subroutine name");
 		d = bufend;
@@ -1053,7 +1106,7 @@ yylex()
 	    if (strEQ(d,"substr"))
 		FUN3(O_SUBSTR);
 	    if (strEQ(d,"sub")) {
-		subline = line;
+		subline = curcmd->c_line;
 		d = bufend;
 		while (s < d && isspace(*s))
 		    s++;
@@ -1110,17 +1163,19 @@ yylex()
 	    FUN0(O_TIME);
 	if (strEQ(d,"times"))
 	    FUN0(O_TMS);
+	if (strEQ(d,"truncate"))
+	    FOP2(O_TRUNCATE);
 	break;
     case 'u': case 'U':
 	SNARFWORD;
 	if (strEQ(d,"using"))
 	    OPERATOR(USING);
 	if (strEQ(d,"until")) {
-	    yylval.ival = line;
+	    yylval.ival = curcmd->c_line;
 	    OPERATOR(UNTIL);
 	}
 	if (strEQ(d,"unless")) {
-	    yylval.ival = line;
+	    yylval.ival = curcmd->c_line;
 	    OPERATOR(UNLESS);
 	}
 	if (strEQ(d,"unlink"))
@@ -1150,7 +1205,7 @@ yylex()
     case 'w': case 'W':
 	SNARFWORD;
 	if (strEQ(d,"while")) {
-	    yylval.ival = line;
+	    yylval.ival = curcmd->c_line;
 	    OPERATOR(WHILE);
 	}
 	if (strEQ(d,"warn"))
@@ -1206,18 +1261,29 @@ checkcomma(s,what)
 register char *s;
 char *what;
 {
+    char *word;
+
     if (*s == '(')
 	s++;
     while (s < bufend && isascii(*s) && isspace(*s))
 	s++;
     if (isascii(*s) && (isalpha(*s) || *s == '_')) {
-	s++;
+	word = s++;
 	while (isalpha(*s) || isdigit(*s) || *s == '_')
 	    s++;
 	while (s < bufend && isspace(*s))
 	    s++;
-	if (*s == ',')
+	if (*s == ',') {
+	    *s = '\0';
+	    word = instr(
+	      "tell eof times getlogin wait length shift umask getppid \
+	      cos exp int log rand sin sqrt ord wantarray",
+	      word);
+	    *s = ',';
+	    if (word)
+		return;
 	    fatal("No comma allowed after %s", what);
+	}
     }
 }
 
@@ -1396,8 +1462,10 @@ register char *s;
     }
     e = tokenbuf + len;
     for (d=tokenbuf; d < e; d++) {
-	if ((*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') ||
-	    (*d == '@' && d[-1] != '\\')) {
+	if (*d == '\\')
+	    d++;
+	else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') ||
+		 (*d == '@')) {
 	    register ARG *arg;
 
 	    spat->spat_runtime = arg = op_new(1);
@@ -1408,11 +1476,13 @@ register char *s;
 	    d = scanreg(d,bufend,buf);
 	    (void)stabent(buf,TRUE);		/* make sure it's created */
 	    for (; d < e; d++) {
-		if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+		if (*d == '\\')
+		    d++;
+		else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
 		    d = scanreg(d,bufend,buf);
 		    (void)stabent(buf,TRUE);
 		}
-		else if (*d == '@' && d[-1] != '\\') {
+		else if (*d == '@') {
 		    d = scanreg(d,bufend,buf);
 		    if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
 		      strEQ(buf,"SIG") || strEQ(buf,"INC"))
@@ -1448,7 +1518,7 @@ register char *s;
     if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
 	fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
 	spat->spat_regexp = regcomp(tokenbuf,tokenbuf+len,
-	    spat->spat_flags & SPAT_FOLD,1);
+	    spat->spat_flags & SPAT_FOLD);
 		/* Note that this regexp can still be used if someone says
 		 * something like /a/ && s//b/;  so we can't delete it.
 		 */
@@ -1629,12 +1699,12 @@ register char *s;
 int len;
 int *retlen;
 {
-    char t[512];
+    char t[520];
     register char *d = t;
     register int i;
     register char *send = s + len;
 
-    while (s < send) {
+    while (s < send && d - t <= 256) {
 	if (s[1] == '-' && s+2 < send) {
 	    for (i = s[0]; i <= s[2]; i++)
 		*d++ = i;
@@ -1711,6 +1781,7 @@ register char *s;
     bool alwaysdollar = FALSE;
     bool hereis = FALSE;
     STR *herewas;
+    STR *str;
     char *leave = "\\$@nrtfb0123456789[{]}"; /* which backslash sequences to keep */
     int len;
 
@@ -1764,13 +1835,14 @@ register char *s;
 		}
 	    }
 	  out:
-	    (void)sprintf(tokenbuf,"%ld",i);
-	    arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
-#ifdef MICROPORT	/* Microport 2.4 hack */
-	    { double zz = str_2num(arg[1].arg_ptr.arg_str); }
-#else
-	    (void)str_2num(arg[1].arg_ptr.arg_str);
-#endif		/* Microport 2.4 hack */
+	    str = Str_new(92,0);
+	    str_numset(str,(double)i);
+	    if (str->str_ptr) {
+		Safefree(str->str_ptr);
+		str->str_ptr = Nullch;
+		str->str_len = str->str_cur = 0;
+	    }
+	    arg[1].arg_ptr.arg_str = str;
 	}
 	break;
     case '1': case '2': case '3': case '4': case '5':
@@ -1801,12 +1873,14 @@ register char *s;
 		*d++ = *s++;
 	}
 	*d = '\0';
-	arg[1].arg_ptr.arg_str = str_make(tokenbuf, d - tokenbuf);
-#ifdef MICROPORT	/* Microport 2.4 hack */
-	{ double zz = str_2num(arg[1].arg_ptr.arg_str); }
-#else
-	(void)str_2num(arg[1].arg_ptr.arg_str);
-#endif		/* Microport 2.4 hack */
+	str = Str_new(92,0);
+	str_numset(str,atof(tokenbuf));
+	if (str->str_ptr) {
+	    Safefree(str->str_ptr);
+	    str->str_ptr = Nullch;
+	    str->str_len = str->str_cur = 0;
+	}
+	arg[1].arg_ptr.arg_str = str;
 	break;
     case '<':
 	if (*++s == '<') {
@@ -1873,8 +1947,10 @@ register char *s;
 	    }
 	    else {
 		arg[1].arg_type = A_READ;
+#ifdef NOTDEF
 		if (rsfp == stdin && (strEQ(d,"stdin") || strEQ(d,"STDIN")))
 		    yyerror("Can't get both program and data from <STDIN>");
+#endif
 		arg[1].arg_ptr.arg_stab = stabent(d,TRUE);
 		if (!stab_io(arg[1].arg_ptr.arg_stab))
 		    stab_io(arg[1].arg_ptr.arg_stab) = stio_new();
@@ -1919,7 +1995,7 @@ register char *s;
 	    STR *tmpstr;
 	    char *tmps;
 
-	    multi_start = line;
+	    multi_start = curcmd->c_line;
 	    if (hereis)
 		multi_open = multi_close = '<';
 	    else {
@@ -1936,10 +2012,10 @@ register char *s;
 		    while (s < bufend &&
 		      (*s != term || bcmp(s,tokenbuf,len) != 0) ) {
 			if (*s++ == '\n')
-			    line++;
+			    curcmd->c_line++;
 		    }
 		    if (s >= bufend) {
-			line = multi_start;
+			curcmd->c_line = multi_start;
 			fatal("EOF in string");
 		    }
 		    str_nset(tmpstr,d+1,s-d);
@@ -1950,21 +2026,23 @@ register char *s;
 		    bufend = linestr->str_ptr + linestr->str_cur;
 		    hereis = FALSE;
 		}
+		else
+		    str_nset(tmpstr,"",0);   /* avoid "uninitialized" warning */
 	    }
 	    else
 		s = str_append_till(tmpstr,s+1,bufend,term,leave);
 	    while (s >= bufend) {	/* multiple line string? */
 		if (!rsfp ||
 		 !(oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0))) {
-		    line = multi_start;
+		    curcmd->c_line = multi_start;
 		    fatal("EOF in string");
 		}
-		line++;
+		curcmd->c_line++;
 		if (perldb) {
 		    STR *str = Str_new(88,0);
 
 		    str_sset(str,linestr);
-		    astore(lineary,(int)line,str);
+		    astore(lineary,(int)curcmd->c_line,str);
 		}
 		bufend = linestr->str_ptr + linestr->str_cur;
 		if (hereis) {
@@ -1982,7 +2060,7 @@ register char *s;
 		else
 		    s = str_append_till(tmpstr,s,bufend,term,leave);
 	    }
-	    multi_end = line;
+	    multi_end = curcmd->c_line;
 	    s++;
 	    if (tmpstr->str_cur + 5 < tmpstr->str_len) {
 		tmpstr->str_len = tmpstr->str_cur + 1;
@@ -1997,7 +2075,7 @@ register char *s;
 	    send = s + tmpstr->str_cur;
 	    while (s < send) {		/* see if we can make SINGLE */
 		if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) &&
-		  !alwaysdollar )
+		  !alwaysdollar && s[1] != '0')
 		    *s = '$';		/* grandfather \digit in subst */
 		if ((*s == '$' || *s == '@') && s+1 < send &&
 		  (alwaysdollar || (s[1] != ')' && s[1] != '|'))) {
@@ -2100,12 +2178,12 @@ load_format()
     Zero(&froot, 1, FCMD);
     s = bufptr;
     while (s < bufend || (s = str_gets(linestr,rsfp, 0)) != Nullch) {
-	line++;
+	curcmd->c_line++;
 	if (perldb) {
 	    STR *tmpstr = Str_new(89,0);
 
 	    str_sset(tmpstr,linestr);
-	    astore(lineary,(int)line,tmpstr);
+	    astore(lineary,(int)curcmd->c_line,tmpstr);
 	}
 	if (in_eval && !rsfp) {
 	    eol = index(s,'\n');
@@ -2188,12 +2266,12 @@ load_format()
 	  again:
 	    if (s >= bufend && (s = str_gets(linestr, rsfp, 0)) == Nullch)
 		goto badform;
-	    line++;
+	    curcmd->c_line++;
 	    if (perldb) {
 		STR *tmpstr = Str_new(90,0);
 
 		str_sset(tmpstr,linestr);
-		astore(lineary,(int)line,tmpstr);
+		astore(lineary,(int)curcmd->c_line,tmpstr);
 	    }
 	    if (in_eval && !rsfp) {
 		eol = index(s,'\n');
@@ -2214,7 +2292,7 @@ load_format()
 	    str = flinebeg->f_unparsed = Str_new(91,eol - s);
 	    str->str_u.str_hash = curstash;
 	    str_nset(str,"(",1);
-	    flinebeg->f_line = line;
+	    flinebeg->f_line = curcmd->c_line;
 	    eol[-1] = '\0';
 	    if (!flinebeg->f_next->f_type || index(s, ',')) {
 		eol[-1] = '\n';