perl 3.0 patch #26 patch #19, continued
Larry Wall [Wed, 8 Aug 1990 17:06:25 +0000 (17:06 +0000)]
See patch #19.

13 files changed:
h2pl/eg/sysexits.pl [new file with mode: 0644]
h2pl/tcbreak [new file with mode: 0644]
h2pl/tcbreak2 [new file with mode: 0644]
lib/stat.pl
lib/syslog.pl
lib/termcap.pl
os2/eg/syscalls.pl [new file with mode: 0644]
os2/suffix.c [new file with mode: 0644]
patchlevel.h
stab.h
str.c
str.h
toke.c

diff --git a/h2pl/eg/sysexits.pl b/h2pl/eg/sysexits.pl
new file mode 100644 (file)
index 0000000..f4cb777
--- /dev/null
@@ -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 (file)
index 0000000..2677cc9
--- /dev/null
@@ -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 (file)
index 0000000..fcbf926
--- /dev/null
@@ -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;
index 8cf0bde..df9e1db 100644 (file)
@@ -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 {
index 46c8c86..c98baf3 100644 (file)
@@ -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
index 35b5ec0..d648526 100644 (file)
@@ -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 (file)
index 0000000..2356f2e
--- /dev/null
@@ -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 (file)
index 0000000..2dbb02b
--- /dev/null
@@ -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 */
index 10c8c21..9705476 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 25
+#define PATCHLEVEL 26
diff --git a/stab.h b/stab.h
index db2d60c..aeb7133 100644 (file)
--- 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 324e100..0b6dfea 100644 (file)
--- 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 2c14029..cdc3d58 100644 (file)
--- 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 40df16a..ec45b31 100644 (file)
--- 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';