perl 3.0 patch #34 patch #29, continued
authorLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Mon, 15 Oct 1990 23:06:41 +0000 (23:06 +0000)
committerLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Mon, 15 Oct 1990 23:06:41 +0000 (23:06 +0000)
See patch #29.

os2/popen.c
os2/selfrun.cmd [new file with mode: 0644]
patchlevel.h
regcomp.c
regexec.c
stab.c
x2p/s2p.SH

index 7c71ccc..15c1112 100644 (file)
-/*
- * Pipe support for OS/2.
- *
- * WARNING:  I am guilty of chumminess with the runtime library because
- *           I had no choice.  Details to follow.
- *
+/* added real/protect mode branch at runtime and real mode version
+ * names changed for perl
+ * Kai Uwe Rommel
  */
 
-#include "EXTERN.h"
-#include "perl.h"
-#define INCL_DOSPROCESS
-#define INCL_DOSQUEUES
-#define INCL_DOSMISC
-#define INCL_DOSMEMMGR
-#include <os2.h>
+/*
+Several people in the past have asked about having Unix-like pipe
+calls in OS/2.  The following source file, adapted from 4.3 BSD Unix,
+uses a #define to give you a pipe(2) call, and contains function
+definitions for popen(3) and pclose(3).  Anyone with problems should
+send mail to me; they seem to work fine.
 
-extern char **environ;
+Mark Towfigh
+Racal Interlan, Inc.
+----------------------------------cut-here------------------------------------
+*/
 
-/* This mysterious array _osfile is used internally by the runtime
- * library to remember assorted things about open file handles.
- * The problem is that we are creating file handles via DosMakePipe,
- * rather than via the runtime library.  This means that we have
- * to fake the runtime library into thinking that the handles we've
- * created are honest file handles.  So just before doing the fdopen,
- * we poke in a magic value that fools the library functions into
- * thinking that the handle is already open in text mode.
+/*
+ * The following code segment is derived from BSD 4.3 Unix.  See
+ * copyright below.  Any bugs, questions, improvements, or problems
+ * should be sent to Mark Towfigh (towfiq@interlan.interlan.com).
  *
- * This might not work for your compiler, so beware.
+ * Racal InterLan Inc.
  */
-extern char _osfile[];
 
-/* The maximum number of simultaneously open pipes.  We create an
- * array of this size to record information about each open pipe.
+/*
+ * Copyright (c) 1980 Regents of the University of California.
+ * All rights reserved.  The Berkeley software License Agreement
+ * specifies the terms and conditions for redistribution.
  */
-#define MAXPIPES 5
 
-/* Information to remember about each open pipe.
- * The (FILE *) that popen returns is stored because that's the only
- * way we can keep track of the pipes.
+#include <stdio.h>
+#include <stdlib.h>
+#include <io.h>
+#include <string.h>
+#include <process.h>
+#include <errno.h>
+
+#define INCL_NOPM
+#define        INCL_DOS
+#include <os2.h>
+
+static FILE *dos_popen(const char *cmd, const char *flags);
+static int dos_pclose(FILE *pipe);
+
+/*
+ * emulate Unix pipe(2) call
  */
-typedef struct pipeinfo {
-       FILE *pfId;             /* Which FILE we're talking about */
-       HFILE hfMe;             /* handle I should close at pclose */
-       PID pidChild;           /* Child's PID */
-       CHAR fReading;          /* A read or write pipe? */
-} PIPEINFO, *PPIPEINFO;                /* pi and ppi */
 
-static PIPEINFO PipeInfo[MAXPIPES];
+#define        tst(a,b)        (*mode == 'r'? (b) : (a))
+#define READH           0
+#define WRITEH          1
+
+static  int       popen_pid[20];
 
-FILE *mypopen(const char *command, const char *t)
+FILE *mypopen(char *cmd, char *mode)
 {
-       typedef char *PSZZ;
-       PSZZ pszzPipeArgs = 0;
-       PSZZ pszzEnviron = 0;
-       PSZ *ppsz;
-       PSZ psz;
-       FILE *f;
-       HFILE hfMe, hfYou;
-       HFILE hf, hfSave;
-       RESULTCODES rc;
-       USHORT us;
-       PPIPEINFO ppi;
-       UINT i;
-
-       /* Validate pipe type */
-       if (*t != 'w' && *t != 'r') fatal("Unknown pipe type");
-
-       /* Room for another pipe? */
-       for (ppi = &PipeInfo[0]; ppi < &PipeInfo[MAXPIPES]; ppi++)
-               if (ppi->pfId == 0) goto foundone;
-       return NULL;
-
-foundone:
-
-       /* Make the pipe */
-       if (DosMakePipe(&hfMe, &hfYou, 0)) return NULL;
-
-       /* Build the environment.  First compute its length, then copy
-        * the environment strings into it.
-        */
-       i = 0;
-       for (ppsz = environ; *ppsz; ppsz++) i += 1 + strlen(*ppsz);
-       New(1204, pszzEnviron, 1+i, CHAR);
-
-       psz = pszzEnviron;
-       for (ppsz = environ; *ppsz; ppsz++) {
-               strcpy(psz, *ppsz);
-               psz += 1 + strlen(*ppsz);
+       int p[2];
+        register myside, hisside, save_stream;
+        char *shell = getenv("COMPSPEC");
+
+        if ( shell == NULL )
+          shell = "C:\\OS2\\CMD.EXE";
+
+        if ( _osmode == DOS_MODE )
+          return dos_popen(cmd, mode);
+
+       if (DosMakePipe((PHFILE) &p[0], (PHFILE) &p[1], 4096) < 0)
+                return NULL;
+
+        myside = tst(p[WRITEH], p[READH]);
+        hisside = tst(p[READH], p[WRITEH]);
+
+       /* set up file descriptors for remote function */
+       save_stream = dup(tst(0, 1));           /* don't lose stdin/out! */
+        if (dup2(hisside, tst(0, 1)) < 0)
+        {
+               perror("dup2");
+               return NULL;
        }
-       *psz = 0;
+        close(hisside);
 
-       /* Build the command string to execute.
-        * 6 = length(0 "/c " 0 0)
+       /*
+        * make sure that we can close our side of the pipe, by
+        * preventing it from being inherited!
         */
-       if (DosScanEnv("COMSPEC", &psz)) psz = "C:\\OS2\\cmd.exe";
-#if 0
-       New(1203, pszzPipeArgs, strlen(psz) + strlen(command) + 6, CHAR);
-#else
-#define pszzPipeArgs buf
-#endif
-       sprintf(pszzPipeArgs, "%s%c/c %s%c", psz, 0, command, 0);
-
-       /* Now some stuff that depends on what kind of pipe we're doing.
-        * We pull a sneaky trick; namely, that stdin = 0 = false,
-        * and stdout = 1 = true.  The end result is that if the
-        * pipe is a read pipe, then hf = 1; if it's a write pipe, then
-        * hf = 0 and Me and You are reversed.
-        */
-       if (!(hf = (*t == 'r'))) {
-               /* The meaning of Me and You is reversed for write pipes. */
-               hfSave = hfYou; hfYou = hfMe; hfMe = hfSave;
-       }
 
-       ppi->fReading = hf;
+       /* set no-inheritance flag */
+       DosSetFHandState(myside, OPEN_FLAGS_NOINHERIT);
 
-       /* Trick number 1:  Fooling the runtime library into thinking
-        * that the file handle is legit.
-        *
-        * Trick number 2:  Don't let my handle go over to the child!
-        * Since the child never closes it (why should it?), I'd better
-        * make sure he never sees it in the first place.  Otherwise,
-        * we are in deadlock city.
-        */
-       _osfile[hfMe] = 0x81;           /* Danger, Will Robinson! */
-       if (!(ppi->pfId = fdopen(hfMe, t))) goto no_fdopen;
-       DosSetFHandState(hfMe, OPEN_FLAGS_NOINHERIT);
+       /* execute the command:  it will inherit our other file descriptors */
+        popen_pid[myside] = spawnlp(P_NOWAIT, shell, shell, "/C", cmd, NULL);
+
+       /* now restore our previous file descriptors */
+        if (dup2(save_stream, tst(0, 1)) < 0)   /* retrieve stdin/out */
+        {
+               perror("dup2");
+               return NULL;
+       }
+        close(save_stream);
 
-       /* Save the original handle because we're going to diddle it */
-       hfSave = 0xFFFF;
-       if (DosDupHandle(hf, &hfSave)) goto no_dup_init;
+       return fdopen(myside, mode);            /* return a FILE pointer */
+}
 
-       /* Force the child's handle onto the stdio handle */
-       if (DosDupHandle(hfYou, &hf)) goto no_force_dup;
-       DosClose(hfYou);
+int mypclose(FILE *ptr)
+{
+       register f;
+        int status;
 
-       /* Now run the guy servicing the pipe */
-       us = DosExecPgm(NULL, 0, EXEC_ASYNCRESULT, pszzPipeArgs, pszzEnviron,
-                       &rc, pszzPipeArgs);
+        if ( _osmode == DOS_MODE )
+          return dos_pclose(ptr);
 
-       /* Restore stdio handle, even if exec failed. */
-       DosDupHandle(hfSave, &hf); close(hfSave);
+       f = fileno(ptr);
+        fclose(ptr);
 
-       /* See if the exec succeeded. */
-       if (us) goto no_exec_pgm;
+       /* wait for process to terminate */
+       cwait(&status, popen_pid[f], WAIT_GRANDCHILD);
 
-       /* Remember the child's PID */
-       ppi->pidChild = rc.codeTerminate;
+       return status;
+}
 
-       Safefree(pszzEnviron);
 
-       /* Phew. */
-       return ppi->pfId;
+int pipe(int *filedes)
+{
+  int res;
+
+  if ( res = DosMakePipe((PHFILE) &filedes[0], (PHFILE) &filedes[1], 4096) )
+    return res;
 
-       /* Here is where we clean up after an error. */
-no_exec_pgm: ;
-no_force_dup: close(hfSave);
-no_dup_init: fclose(f);
-no_fdopen:
-       DosClose(hfMe); DosClose(hfYou);
-       ppi->pfId = 0;
-       Safefree(pszzEnviron);
-       return NULL;
+  DosSetFHandState(filedes[0], OPEN_FLAGS_NOINHERIT);
+  DosSetFHandState(filedes[1], OPEN_FLAGS_NOINHERIT);
+  return 0;
 }
 
 
-/* mypclose:  Closes the pipe associated with the file handle.
- * After waiting for the child process to terminate, its return
- * code is returned.  If the stream was not associated with a pipe,
- * we return -1.
- */
-int
-mypclose(FILE *f)
+/* this is the MS-DOS version */
+
+typedef enum { unopened = 0, reading, writing } pipemode;
+
+static struct
 {
-       PPIPEINFO ppi;
-       RESULTCODES rc;
-       USHORT us;
-
-       /* Find the pipe this (FILE *) refers to */
-       for (ppi = &PipeInfo[0]; ppi < &PipeInfo[MAXPIPES]; ppi++)
-               if (ppi->pfId == f) goto foundit;
-       return -1;
-foundit:
-       if (ppi->fReading && !DosRead(fileno(f), &rc, 1, &us) && us > 0) {
-               DosKillProcess(DKP_PROCESSTREE, ppi->pidChild);
-       }
-       fclose(f);
-       DosCwait(DCWA_PROCESS, DCWW_WAIT, &rc, &ppi->pidChild, ppi->pidChild);
-       ppi->pfId = 0;
-       return rc.codeResult;
+    char *name;
+    char *command;
+    pipemode pmode;
 }
+pipes[_NFILE];
 
-/* pipe:  The only tricky thing is letting the runtime library know about
- * our two new file descriptors.
- */
-int pipe(int filedes[2])
+static FILE *dos_popen(const char *command, const char *mode)
 {
-       HFILE hfRead, hfWrite;
-       USHORT usResult;
-
-       usResult = DosMakePipe(&hfRead, &hfWrite, 0);
-       if (usResult) {
-               /* Error 4 == ERROR_TOO_MANY_OPEN_FILES */
-               errno = (usResult == 4) ? ENFILE : ENOMEM;
-               return -1;
-       }
-       _osfile[hfRead] = _osfile[hfWrite] = 0x81;/* Danger, Will Robinson! */
-       filedes[0] = hfRead;
-       filedes[1] = hfWrite;
-       return 0;
+    FILE *current;
+    char name[128];
+    int cur;
+    pipemode curmode;
+
+    /*
+    ** decide on mode.
+    */
+    if(strchr(mode, 'r') != NULL)
+        curmode = reading;
+    else if(strchr(mode, 'w') != NULL)
+        curmode = writing;
+    else
+        return NULL;
+
+    /*
+    ** get a name to use.
+    */
+    strcpy(name, "piXXXXXX");
+    Mktemp(name);
+
+    /*
+    ** If we're reading, just call system to get a file filled with
+    ** output.
+    */
+    if(curmode == reading)
+    {
+        char cmd[256];
+        sprintf(cmd,"%s > %s", command, name);
+        system(cmd);
+
+        if((current = fopen(name, mode)) == NULL)
+            return NULL;
+    }
+    else
+    {
+        if((current = fopen(name, mode)) == NULL)
+            return NULL;
+    }
+
+    cur = fileno(current);
+    pipes[cur].name = strdup(name);
+    pipes[cur].command = strdup(command);
+    pipes[cur].pmode = curmode;
+
+    return current;
+}
+
+static int dos_pclose(FILE * current)
+{
+    int cur = fileno(current), rval;
+    char command[256];
+
+    /*
+    ** check for an open file.
+    */
+    if(pipes[cur].pmode == unopened)
+        return -1;
+
+    if(pipes[cur].pmode == reading)
+    {
+        /*
+        ** input pipes are just files we're done with.
+        */
+        rval = fclose(current);
+        unlink(pipes[cur].name);
+    }
+    else
+    {
+        /*
+        ** output pipes are temporary files we have
+        ** to cram down the throats of programs.
+        */
+        fclose(current);
+        sprintf(command,"%s < %s", pipes[cur].command, pipes[cur].name);
+        rval = system(command);
+        unlink(pipes[cur].name);
+    }
+
+    /*
+    ** clean up current pipe.
+    */
+    free(pipes[cur].name);
+    free(pipes[cur].command);
+    pipes[cur].pmode = unopened;
+
+    return rval;
 }
diff --git a/os2/selfrun.cmd b/os2/selfrun.cmd
new file mode 100644 (file)
index 0000000..471a959
--- /dev/null
@@ -0,0 +1,7 @@
+extproc perl -x
+#!perl
+
+printf "
+This is a self-running perl script using the
+extproc feature of the OS/2 command processor.
+"
index 1d5b76f..3b47b47 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 33
+#define PATCHLEVEL 34
index e3ef1ba..04d62c3 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -7,9 +7,12 @@
  * blame Henry for some of the lack of readability.
  */
 
-/* $Header: regcomp.c,v 3.0.1.5 90/08/13 22:23:29 lwall Locked $
+/* $Header: regcomp.c,v 3.0.1.6 90/10/16 10:17:33 lwall Locked $
  *
  * $Log:       regcomp.c,v $
+ * Revision 3.0.1.6  90/10/16  10:17:33  lwall
+ * patch29: patterns with multiple short literal strings sometimes failed
+ * 
  * Revision 3.0.1.5  90/08/13  22:23:29  lwall
  * patch28: /x{m}/ didn't work right
  * 
@@ -138,7 +141,8 @@ int fold;
 {
        register regexp *r;
        register char *scan;
-       register STR *longest;
+       register STR *longish;
+       STR *longest;
        register int len;
        register char *first;
        int flags;
@@ -241,6 +245,7 @@ int fold;
                 * it happens that curback has been invalidated, since the
                 * earlier string may buy us something the later one won't.]
                 */
+               longish = str_make("",0);
                longest = str_make("",0);
                len = 0;
                curback = 0;
@@ -260,7 +265,7 @@ int fold;
                            while (OP(regnext(scan)) >= CLOSE)
                                scan = regnext(scan);
                            if (curback - back == len) {
-                               str_ncat(longest, OPERAND(first)+1,
+                               str_ncat(longish, OPERAND(first)+1,
                                    *OPERAND(first));
                                len += *OPERAND(first);
                                curback += *OPERAND(first);
@@ -268,7 +273,7 @@ int fold;
                            }
                            else if (*OPERAND(first) >= len + (curback >= 0)) {
                                len = *OPERAND(first);
-                               str_nset(longest, OPERAND(first)+1,len);
+                               str_nset(longish, OPERAND(first)+1,len);
                                back = curback;
                                curback += len;
                                first = regnext(scan);
@@ -276,18 +281,27 @@ int fold;
                            else
                                curback += *OPERAND(first);
                        }
-                       else if (index(varies,OP(scan)))
-                               curback = -30000;
+                       else if (index(varies,OP(scan))) {
+                           curback = -30000;
+                           len = 0;
+                           if (longish->str_cur > longest->str_cur)
+                               str_sset(longest,longish);
+                           str_nset(longish,"",0);
+                       }
                        else if (index(simple,OP(scan)))
-                               curback++;
+                           curback++;
                        scan = regnext(scan);
                }
-               if (len) {
+               if (longish->str_cur > longest->str_cur)
+                   str_sset(longest,longish);
+               str_free(longish);
+               if (longest->str_cur) {
                        r->regmust = longest;
                        if (back < 0)
                                back = -1;
                        r->regback = back;
-                       if (len > !(sawstudy||fold||OP(first)==EOL))
+                       if (longest->str_cur
+                         > !(sawstudy || fold || OP(first) == EOL) )
                                fbmcompile(r->regmust,fold);
                        r->regmust->str_u.str_useful = 100;
                        if (OP(first) == EOL) /* is match anchored to EOL? */
@@ -1123,6 +1137,8 @@ regexp *r;
 #endif
                op = OP(s);
                fprintf(stderr,"%2d%s", s-r->program, regprop(s));      /* Where, what. */
+               if (op == CURLY)
+                   s += 4;
                next = regnext(s);
                if (next == NULL)               /* Next ptr. */
                        fprintf(stderr,"(0)");
index 61439ea..b0b8fa1 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -7,9 +7,14 @@
  * blame Henry for some of the lack of readability.
  */
 
-/* $Header: regexec.c,v 3.0.1.4 90/08/09 05:12:03 lwall Locked $
+/* $Header: regexec.c,v 3.0.1.5 90/10/16 10:25:36 lwall Locked $
  *
  * $Log:       regexec.c,v $
+ * Revision 3.0.1.5  90/10/16  10:25:36  lwall
+ * patch29: /^pat/ occasionally matched in middle of string when $* = 0
+ * patch29: /.{n,m}$/ could match with fewer than n characters remaining
+ * patch29: /\d{9}/ could match more than 9 characters
+ * 
  * Revision 3.0.1.4  90/08/09  05:12:03  lwall
  * patch19: sped up /x+y/ patterns greatly by not retrying on every x
  * patch19: inhibited backoff on patterns anchored to the end like /\s+$/
@@ -139,8 +144,11 @@ int safebase;      /* no need to remember string in subbase */
 
        if (string == strbeg)   /* is ^ valid at stringarg? */
            regprev = '\n';
-       else
+       else {
            regprev = stringarg[-1];
+           if (!multiline && regprev == '\n')
+               regprev = '\0';         /* force ^ to NOT match */
+       }
        regprecomp = prog->precomp;
        /* Check validity of program. */
        if (UCHARAT(prog->program) != MAGIC) {
@@ -771,7 +779,7 @@ char *prog;
                                nextchar = -1000;
                        reginput = locinput;
                        n = regrepeat(scan, n);
-                       if (!multiline && OP(next) == EOL)
+                       if (!multiline && OP(next) == EOL && ln < n)
                            ln = n;                     /* why back off? */
                        while (n >= ln) {
                                /* If it could work, try it. */
@@ -845,7 +853,7 @@ int max;
                }
                break;
        case ALNUM:
-               while (isALNUM(*scan))
+               while (scan < loceol && isALNUM(*scan))
                        scan++;
                break;
        case NALNUM:
@@ -861,7 +869,7 @@ int max;
                        scan++;
                break;
        case DIGIT:
-               while (isDIGIT(*scan))
+               while (scan < loceol && isDIGIT(*scan))
                        scan++;
                break;
        case NDIGIT:
diff --git a/stab.c b/stab.c
index 00cee82..f968dfc 100644 (file)
--- a/stab.c
+++ b/stab.c
@@ -1,4 +1,4 @@
-/* $Header: stab.c,v 3.0.1.8 90/08/13 22:30:17 lwall Locked $
+/* $Header: stab.c,v 3.0.1.9 90/10/16 10:32:05 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,13 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       stab.c,v $
+ * Revision 3.0.1.9  90/10/16  10:32:05  lwall
+ * patch29: added -M, -A and -C
+ * patch29: taintperl now checks for world writable PATH components
+ * patch29: *foo now prints as *package'foo
+ * patch29: scripts now run at almost full speed under the debugger
+ * patch29: package behavior is now more consistent
+ * 
  * Revision 3.0.1.8  90/08/13  22:30:17  lwall
  * patch28: the NSIG hack didn't work right on Xenix
  * 
@@ -77,6 +84,9 @@ STR *str;
        return stab_val(stab);
 
     switch (*stab->str_magic->str_ptr) {
+    case '\024':               /* ^T */
+       str_numset(stab_val(stab),(double)basetime);
+       break;
     case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9': case '&':
        if (curspat) {
@@ -220,7 +230,7 @@ STR *str;
            struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
 
            if (uf && uf->uf_val)
-               uf->uf_val(uf->uf_index, stab_val(stab));
+               (*uf->uf_val)(uf->uf_index, stab_val(stab));
        }
        break;
     }
@@ -240,7 +250,22 @@ STR *str;
     case 'E':
        setenv(mstr->str_ptr,str_get(str));
                                /* And you'll never guess what the dog had */
-       break;                  /*   in its mouth... */
+                               /*   in its mouth... */
+#ifdef TAINT
+       if (strEQ(mstr->str_ptr,"PATH")) {
+           char *strend = str->str_ptr + str->str_cur;
+
+           s = str->str_ptr;
+           while (s < strend) {
+               s = cpytill(tokenbuf,s,strend,':',&i);
+               s++;
+               if (*tokenbuf != '/'
+                 || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
+                   str->str_tainted = 2;
+           }
+       }
+#endif
+       break;
     case 'S':
        s = str_get(str);
        i = whichsig(mstr->str_ptr);    /* ...no, a brick */
@@ -252,14 +277,30 @@ STR *str;
 #endif
        else if (strEQ(s,"DEFAULT") || !*s)
            (void)signal(i,SIG_DFL);
-       else
+       else {
            (void)signal(i,sighandler);
+           if (!index(s,'\'')) {
+               sprintf(tokenbuf, "main'%s",s);
+               str_set(str,tokenbuf);
+           }
+       }
        break;
 #ifdef SOME_DBM
     case 'D':
        hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
        break;
 #endif
+    case 'L':
+       {
+           CMD *cmd;
+
+           i = str_true(str);
+           str = afetch(stab_xarray(stab),atoi(mstr->str_ptr));
+           cmd = str->str_magic->str_u.str_cmd;
+           cmd->c_flags &= ~CF_OPTIMIZE;
+           cmd->c_flags |= i? CFT_D1 : CFT_D0;
+       }
+       break;
     case '#':
        afill(stab_array(stab), (int)str_gnum(str) - arybase);
        break;
@@ -310,6 +351,9 @@ STR *str;
 
     case 0:
        switch (*stab->str_magic->str_ptr) {
+       case '\024':    /* ^T */
+           basetime = (long)str_gnum(str);
+           break;
        case '.':
            if (localizing)
                savesptr((STR**)&last_in_stab);
@@ -473,7 +517,7 @@ STR *str;
                struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
 
                if (uf && uf->uf_set)
-                   uf->uf_set(uf->uf_index, str);
+                   (*uf->uf_set)(uf->uf_index, str);
            }
            break;
        }
@@ -507,14 +551,16 @@ int sig;
     STAB *stab;
     ARRAY *savearray;
     STR *str;
-    char *oldfile = filename;
+    CMD *oldcurcmd = curcmd;
     int oldsave = savestack->ary_fill;
     ARRAY *oldstack = stack;
+    CSV *oldcurcsv = curcsv;
     SUBR *sub;
 
 #ifdef OS2             /* or anybody else who requires SIG_ACK */
     signal(sig, SIG_ACK);
 #endif
+    curcsv = Nullcsv;
     stab = stabent(
        str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
          TRUE)), TRUE);
@@ -546,7 +592,6 @@ int sig;
            warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
        savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
     }
-    filename = sub->filename;
 
     (void)cmd_exec(sub->cmd,G_SCALAR,1);               /* so do it already */
 
@@ -555,9 +600,10 @@ int sig;
     afree(stab_xarray(defstab));  /* put back old $_[] */
     stab_xarray(defstab) = savearray;
     stack = oldstack;
-    filename = oldfile;
     if (savestack->ary_fill > oldsave)
        restorelist(oldsave);
+    curcmd = oldcurcmd;
+    curcsv = oldcurcsv;
 }
 
 STAB *
@@ -578,6 +624,21 @@ register STAB *stab;
     return stab;
 }
 
+STAB *
+fstab(name)
+char *name;
+{
+    char tmpbuf[1200];
+    STAB *stab;
+
+    sprintf(tmpbuf,"'_<%s", name);
+    stab = stabent(tmpbuf, TRUE);
+    str_set(stab_val(stab), name);
+    if (perldb)
+       (void)hadd(aadd(stab));
+    return stab;
+}
+
 STAB *
 stabent(name,add)
 register char *name;
@@ -625,8 +686,10 @@ int add;
     }
     else if (!isalpha(*name) || global)
        stash = defstash;
-    else
+    else if (curcmd == &compiling)
        stash = curstash;
+    else
+       stash = curcmd->c_stash;
     if (sawquote) {
        char tmpbuf[256];
        char *s, *d;
@@ -645,12 +708,14 @@ int add;
        stab = stabent(tmpbuf,TRUE);
        if (!(stash = stab_xhash(stab)))
            stash = stab_xhash(stab) = hnew(0);
+       if (!stash->tbl_name)
+           stash->tbl_name = savestr(name);
        name = sawquote+1;
        *sawquote = '\'';
     }
     len = namend - name;
     stab = (STAB*)hfetch(stash,name,len,add);
-    if (!stab)
+    if (stab == (STAB*)&str_undef)
        return Nullstab;
     if (stab->str_pok) {
        stab->str_pok |= SP_MULTI;
@@ -667,10 +732,20 @@ int add;
        stab_val(stab) = Str_new(72,0);
        stab_line(stab) = curcmd->c_line;
        str_magic(stab,stab,'*',name,len);
+       stab_stash(stab) = stash;
        return stab;
     }
 }
 
+stab_fullname(str,stab)
+STR *str;
+STAB *stab;
+{
+    str_set(str,stab_stash(stab)->tbl_name);
+    str_ncat(str,"'", 1);
+    str_scat(str,stab->str_magic);
+}
+
 STIO *
 stio_new()
 {
@@ -719,7 +794,7 @@ register STAB *stab;
     SUBR *sub;
 
     afree(stab_xarray(stab));
-    (void)hfree(stab_xhash(stab));
+    (void)hfree(stab_xhash(stab), FALSE);
     str_free(stab_val(stab));
     if (stio = stab_io(stab)) {
        do_close(stab,FALSE);
index 66d7b72..553cfd6 100644 (file)
@@ -28,9 +28,12 @@ $spitshell >s2p <<!GROK!THIS!
 : In the following dollars and backticks do not need the extra backslash.
 $spitshell >>s2p <<'!NO!SUBS!'
 
-# $Header: s2p.SH,v 3.0.1.4 90/08/09 05:50:43 lwall Locked $
+# $Header: s2p.SH,v 3.0.1.5 90/10/16 11:32:40 lwall Locked $
 #
 # $Log:        s2p.SH,v $
+# Revision 3.0.1.5  90/10/16  11:32:40  lwall
+# patch29: s2p modernized
+# 
 # Revision 3.0.1.4  90/08/09  05:50:43  lwall
 # patch19: s2p didn't translate \n right
 # 
@@ -59,14 +62,13 @@ $spitshell >>s2p <<'!NO!SUBS!'
 $indent = 4;
 $shiftwidth = 4;
 $l = '{'; $r = '}';
-$tempvar = '1';
 
-while ($ARGV[0] =~ '^-') {
+while ($ARGV[0] =~ /^-/) {
     $_ = shift;
   last if /^--/;
     if (/^-D/) {
        $debug++;
-       open(body,'>-');
+       open(BODY,'>-');
        next;
     }
     if (/^-n/) {
@@ -81,25 +83,27 @@ while ($ARGV[0] =~ '^-') {
 }
 
 unless ($debug) {
-    open(body,">/tmp/sperl$$") || do Die("Can't open temp file");
+    open(BODY,">/tmp/sperl$$") ||
+      &Die("Can't open temp file: $!\n");
 }
 
 if (!$assumen && !$assumep) {
-    print body
-'while ($ARGV[0] =~ /^-/) {
+    print BODY <<'EOT';
+while ($ARGV[0] =~ /^-/) {
     $_ = shift;
   last if /^--/;
     if (/^-n/) {
        $nflag++;
        next;
     }
-    die "I don\'t recognize this switch: $_\\n";
+    die "I don't recognize this switch: $_\\n";
 }
 
-';
+EOT
 }
 
-print body '
+print BODY <<'EOT';
+
 #ifdef PRINTIT
 #ifdef ASSUMEP
 $printit++;
@@ -107,21 +111,27 @@ $printit++;
 $printit++ unless $nflag;
 #endif
 #endif
-line: while (<>) {
-';
+LINE: while (<>) {
+EOT
+
+LINE: while (<>) {
+
+    # Wipe out surrounding whitespace.
 
-line: while (<>) {
     s/[ \t]*(.*)\n$/$1/;
+
+    # Perhaps it's a label/comment.
+
     if (/^:/) {
        s/^:[ \t]*//;
-       $label = do make_label($_);
+       $label = &make_label($_);
        if ($. == 1) {
            $toplabel = $label;
        }
        $_ = "$label:";
        if ($lastlinewaslabel++) {
            $indent += 4;
-           print body "\t" x ($indent / 8), ' ' x ($indent % 8), ";\n";
+           print BODY &tab, ";\n";
            $indent -= 4;
        }
        if ($indent >= 2) {
@@ -132,6 +142,9 @@ line: while (<>) {
     } else {
        $lastlinewaslabel = '';
     }
+
+    # Look for one or two address clauses
+
     $addr1 = '';
     $addr2 = '';
     if (s/^([0-9]+)//) {
@@ -141,7 +154,7 @@ line: while (<>) {
        $addr1 = 'eof()';
     }
     elsif (s|^/||) {
-       $addr1 = do fetchpat('/');
+       $addr1 = &fetchpat('/');
     }
     if (s/^,//) {
        if (s/^([0-9]+)//) {
@@ -149,14 +162,18 @@ line: while (<>) {
        } elsif (s/^\$//) {
            $addr2 = "eof()";
        } elsif (s|^/||) {
-           $addr2 = do fetchpat('/');
+           $addr2 = &fetchpat('/');
        } else {
-           do Die("Invalid second address at line $.\n");
+           &Die("Invalid second address at line $.\n");
        }
        $addr1 .= " .. $addr2";
     }
-                                       # a { to keep vi happy
+
+    # Now we check for metacommands {, }, and ! and worry
+    # about indentation.
+
     s/^[ \t]+//;
+    # a { to keep vi happy
     if ($_ eq '}') {
        $indent -= 4;
        next;
@@ -180,55 +197,59 @@ line: while (<>) {
        } else {
            $space = '';
        }
-       $_ = do transmogrify();
+       $_ = &transmogrify();
     }
 
+    # See if we can optimize to modifier form.
+
     if ($addr1) {
        if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
          $_ !~ / if / && $_ !~ / unless /) {
            s/;$/ $if $addr1;/;
            $_ = substr($_,$shiftwidth,1000);
        } else {
-           $command = $_;
-           $_ = "$if ($addr1) $l\n$change$command$rmaybe";
+           $_ = "$if ($addr1) $l\n$change$_$rmaybe";
        }
        $change = '';
-       next line;
+       next LINE;
     }
 } continue {
     @lines = split(/\n/,$_);
-    while ($#lines >= 0) {
-       $_ = shift(lines);
+    for (@lines) {
        unless (s/^ *<<--//) {
-           print body "\t" x ($indent / 8), ' ' x ($indent % 8);
+           print BODY &tab;
        }
-       print body $_, "\n";
+       print BODY $_, "\n";
     }
     $indent += $indmod;
     $indmod = 0;
     if ($redo) {
        $_ = $redo;
        $redo = '';
-       redo line;
+       redo LINE;
     }
 }
 if ($lastlinewaslabel++) {
     $indent += 4;
-    print body "\t" x ($indent / 8), ' ' x ($indent % 8), ";\n";
+    print BODY &tab, ";\n";
     $indent -= 4;
 }
 
-print body "}\n";
+print BODY "}\n";
 if ($appendseen || $tseen || !$assumen) {
     $printit++ if $dseen || (!$assumen && !$assumep);
-    print body '
+    print BODY <<'EOT';
+
 continue {
 #ifdef PRINTIT
 #ifdef DSEEN
 #ifdef ASSUMEP
     print if $printit++;
 #else
-    if ($printit) { print;} else { $printit++ unless $nflag; }
+    if ($printit)
+       { print; }
+    else
+       { $printit++ unless $nflag; }
 #endif
 #else
     print if $printit;
@@ -237,40 +258,43 @@ continue {
     print;
 #endif
 #ifdef TSEEN
-    $tflag = \'\';
+    $tflag = '';
 #endif
 #ifdef APPENDSEEN
-    if ($atext) { print $atext; $atext = \'\'; }
+    if ($atext) { print $atext; $atext = ''; }
 #endif
 }
-';
+EOT
 }
 
-close body;
+close BODY;
 
 unless ($debug) {
-    open(head,">/tmp/sperl2$$.c") || do Die("Can't open temp file 2");
-    print head "#define PRINTIT\n" if ($printit);
-    print head "#define APPENDSEEN\n" if ($appendseen);
-    print head "#define TSEEN\n" if ($tseen);
-    print head "#define DSEEN\n" if ($dseen);
-    print head "#define ASSUMEN\n" if ($assumen);
-    print head "#define ASSUMEP\n" if ($assumep);
-    if ($opens) {print head "$opens\n";}
-    open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file");
-    while (<body>) {
-       print head $_;
+    open(HEAD,">/tmp/sperl2$$.c")
+      || &Die("Can't open temp file 2: $!\n");
+    print HEAD "#define PRINTIT\n" if ($printit);
+    print HEAD "#define APPENDSEEN\n" if ($appendseen);
+    print HEAD "#define TSEEN\n" if ($tseen);
+    print HEAD "#define DSEEN\n" if ($dseen);
+    print HEAD "#define ASSUMEN\n" if ($assumen);
+    print HEAD "#define ASSUMEP\n" if ($assumep);
+    if ($opens) {print HEAD "$opens\n";}
+    open(BODY,"/tmp/sperl$$")
+      || &Die("Can't reopen temp file: $!\n");
+    while (<BODY>) {
+       print HEAD $_;
     }
-    close head;
+    close HEAD;
 
-    print "#!$bin/perl
-eval \"exec $bin/perl -S \$0 \$*\"
+    print <<"EOT";
+#!$bin/perl
+eval 'exec $bin/perl -S \$0 \$*'
        if \$running_under_some_shell;
 
-";
-    open(body,"cc -E /tmp/sperl2$$.c |") ||
-       do Die("Can't reopen temp file");
-    while (<body>) {
+EOT
+    open(BODY,"cc -E /tmp/sperl2$$.c |") ||
+       &Die("Can't reopen temp file: $!\n");
+    while (<BODY>) {
        /^# [0-9]/ && next;
        /^[ \t]*$/ && next;
        s/^<><>//;
@@ -278,39 +302,44 @@ eval \"exec $bin/perl -S \$0 \$*\"
     }
 }
 
-unlink "/tmp/sperl$$", "/tmp/sperl2$$", "/tmp/sperl2$$.c";
+&Cleanup;
+exit;
 
+sub Cleanup {
+    chdir "/tmp";
+    unlink "sperl$$", "sperl2$$", "sperl2$$.c";
+}
 sub Die {
-    unlink "/tmp/sperl$$", "/tmp/sperl2$$", "/tmp/sperl2$$.c";
+    &Cleanup;
     die $_[0];
 }
+sub tab {
+    "\t" x ($indent / 8) . ' ' x ($indent % 8);
+}
 sub make_filehandle {
-    $fname = $_ = $_[0];
+    local($_) = $_[0];
+    local($fname) = $_;
     s/[^a-zA-Z]/_/g;
     s/^_*//;
-    if (/^([a-z])([a-z]*)$/) {
-       $first = $1;
-       $rest = $2;
-       $first =~ y/a-z/A-Z/;
-       $_ = $first . $rest;
-    }
+    substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
     if (!$seen{$_}) {
-       $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n";
+       $opens .= <<"EOT";
+open($_,'>$fname') || die "Can't create $fname";
+EOT
     }
     $seen{$_} = $_;
 }
 
 sub make_label {
-    $label = $_[0];
+    local($label) = @_;
     $label =~ s/[^a-zA-Z0-9]/_/g;
     if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
     $label = substr($label,0,8);
-    if ($label =~ /^([a-z])([a-z]*)$/) {       # could be reserved word
-       $first = $1;
-       $rest = $2;
-       $first =~ y/a-z/A-Z/;                   # so capitalize it
-       $label = $first . $rest;
-    }
+
+    # Could be a reserved word, so capitalize it.
+    substr($label,0,1) =~ y/a-z/A-Z/
+      if $label =~ /^[a-z]/;
+
     $label;
 }
 
@@ -318,22 +347,26 @@ sub transmogrify {
     {  # case
        if (/^d/) {
            $dseen++;
-           $_ = '
+           chop($_ = <<'EOT');
 <<--#ifdef PRINTIT
-$printit = \'\';
+$printit = '';
 <<--#endif
-next line;';
+next LINE;
+EOT
            next;
        }
 
        if (/^n/) {
-           $_ =
-'<<--#ifdef PRINTIT
+           chop($_ = <<'EOT');
+<<--#ifdef PRINTIT
 <<--#ifdef DSEEN
 <<--#ifdef ASSUMEP
 print if $printit++;
 <<--#else
-if ($printit) { print;} else { $printit++ unless $nflag; }
+if ($printit)
+    { print; }
+else
+    { $printit++ unless $nflag; }
 <<--#endif
 <<--#else
 print if $printit;
@@ -342,18 +375,19 @@ print if $printit;
 print;
 <<--#endif
 <<--#ifdef APPENDSEEN
-if ($atext) {print $atext; $atext = \'\';}
+if ($atext) {print $atext; $atext = '';}
 <<--#endif
 $_ = <>;
 <<--#ifdef TSEEN
-$tflag = \'\';
-<<--#endif';
+$tflag = '';
+<<--#endif
+EOT
            next;
        }
 
        if (/^a/) {
            $appendseen++;
-           $command = $space .  '$atext .=' . "\n<<--'";
+           $command = $space . '$atext .=' . "\n<<--'";
            $lastline = 0;
            while (<>) {
                s/^[ \t]*//;
@@ -372,7 +406,8 @@ $tflag = \'\';
        if (/^[ic]/) {
            if (/^c/) { $change = 1; }
            $addr1 = '$iter = (' . $addr1 . ')';
-           $command = $space .  'if ($iter == 1) { print' . "\n<<--'";
+           $command = $space . 'if ($iter == 1) { print'
+             . "\n<<--'";
            $lastline = 0;
            while (<>) {
                s/^[ \t]*//;
@@ -388,11 +423,12 @@ $tflag = \'\';
            if ($change) {
                $dseen++;
                $change = "$_\n";
-               $_ = "
+               chop($_ = <<"EOT");
 <<--#ifdef PRINTIT
 $space\$printit = '';
 <<--#endif
-${space}next line;";
+${space}next LINE;
+EOT
            }
            last;
        }
@@ -406,7 +442,7 @@ ${space}next line;";
                $c = substr($_,$i,1);
                if ($c eq $delim) {
                    if ($inbracket) {
-                       $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
+                       substr($_, $i, 0) = '\\';
                        $i++;
                        $len++;
                    }
@@ -430,12 +466,14 @@ ${space}next line;";
                    elsif (substr($_,$i,1) =~ /^[n]$/) {
                        ;
                    }
-                   elsif (!$repl && substr($_,$i,1) =~ /^[(){}\w]$/) {
+                   elsif (!$repl &&
+                     substr($_,$i,1) =~ /^[(){}\w]$/) {
                        $i--;
                        $len--;
-                       $_ = substr($_,0,$i) . substr($_,$i+1,10000);
+                       substr($_, $i, 1) = '';
                    }
-                   elsif (!$repl && substr($_,$i,1) =~ /^[<>]$/) {
+                   elsif (!$repl &&
+                     substr($_,$i,1) =~ /^[<>]$/) {
                        substr($_,$i,1) = 'b';
                    }
                }
@@ -448,14 +486,15 @@ ${space}next line;";
                    $inbracket = 0;
                }
                elsif (!$repl && index("()+",$c) >= 0) {
-                   $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
+                   substr($_, $i, 0) = '\\';
                    $i++;
                    $len++;
                }
            }
-           do Die("Malformed substitution at line $.\n") unless $end;
+           &Die("Malformed substitution at line $.\n")
+             unless $end;
            $pat = substr($_, 0, $repl + 1);
-           $repl = substr($_, $repl + 1, $end - $repl - 1);
+           $repl = substr($_, $repl+1, $end-$repl-1);
            $end = substr($_, $end + 1, 1000);
            $dol = '$';
            $repl =~ s/\$/\\$/;
@@ -464,22 +503,30 @@ ${space}next line;";
            $subst = "$pat$repl$delim";
            $cmd = '';
            while ($end) {
-               if ($end =~ s/^g//) { $subst .= 'g'; next; }
-               if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; }
+               if ($end =~ s/^g//) {
+                   $subst .= 'g';
+                   next;
+               }
+               if ($end =~ s/^p//) {
+                   $cmd .= ' && (print)';
+                   next;
+               }
                if ($end =~ s/^w[ \t]*//) {
-                   $fh = do make_filehandle($end);
+                   $fh = &make_filehandle($end);
                    $cmd .= " && (print $fh \$_)";
                    $end = '';
                    next;
                }
-               do Die("Unrecognized substitution command ($end) at line $.\n");
+               &Die("Unrecognized substitution command".
+                 "($end) at line $.\n");
            }
-           $_ =
-"<<--#ifdef TSEEN
+           chop ($_ = <<"EOT");
+<<--#ifdef TSEEN
 $subst && \$tflag++$cmd;
 <<--#else
 $subst$cmd;
-<<--#endif";
+<<--#endif
+EOT
            next;
        }
 
@@ -490,7 +537,7 @@ $subst$cmd;
 
        if (/^w/) {
            s/^w[ \t]*//;
-           $fh = do make_filehandle($_);
+           $fh = &make_filehandle($_);
            $_ = "print $fh \$_;";
            next;
        }
@@ -509,19 +556,21 @@ $subst$cmd;
        }
 
        if (/^D/) {
-           $_ =
-'s/^.*\n//;
-redo line if $_;
-next line;';
+           chop($_ = <<'EOT');
+s/^.*\n//;
+redo LINE if $_;
+next LINE;
+EOT
            next;
        }
 
        if (/^N/) {
-           $_ = '
+           chop($_ = <<'EOT');
 $_ .= <>;
 <<--#ifdef TSEEN
-$tflag = \'\';
-<<--#endif';
+$tflag = '';
+<<--#endif
+EOT
            next;
        }
 
@@ -551,15 +600,15 @@ $tflag = \'\';
        }
 
        if (/^b$/) {
-           $_ = 'next line;';
+           $_ = 'next LINE;';
            next;
        }
 
        if (/^b/) {
            s/^b[ \t]*//;
-           $lab = do make_label($_);
+           $lab = &make_label($_);
            if ($lab eq $toplabel) {
-               $_ = 'redo line;';
+               $_ = 'redo LINE;';
            } else {
                $_ = "goto $lab;";
            }
@@ -567,18 +616,19 @@ $tflag = \'\';
        }
 
        if (/^t$/) {
-           $_ = 'next line if $tflag;';
+           $_ = 'next LINE if $tflag;';
            $tseen++;
            next;
        }
 
        if (/^t/) {
            s/^t[ \t]*//;
-           $lab = do make_label($_);
+           $lab = &make_label($_);
+           $_ = q/if ($tflag) {$tflag = ''; /;
            if ($lab eq $toplabel) {
-               $_ = 'if ($tflag) {$tflag = \'\'; redo line;}';
+               $_ .= 'redo LINE;}';
            } else {
-               $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}";
+               $_ .= "goto $lab;}";
            }
            $tseen++;
            next;
@@ -590,10 +640,11 @@ $tflag = \'\';
        }
 
        if (/^q/) {
-           $_ =
-'close(ARGV);
+           chop($_ = <<'EOT');
+close(ARGV);
 @ARGV = ();
-next line;';
+next LINE;
+EOT
            next;
        }
     } continue {
@@ -612,7 +663,9 @@ sub fetchpat {
     local($inbracket);
     local($prefix,$delim,$ch);
 
-    delim: while (s:^([^\]+(|)[\\/]*)([]+(|)[\\/])::) {
+    # Process pattern one potential delimiter at a time.
+
+    DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
        $prefix = $1;
        $delim = $2;
        if ($delim eq '\\') {
@@ -636,7 +689,7 @@ sub fetchpat {
        $addr .= $prefix;
        $addr .= $delim;
        if ($delim eq $outer && !$inbracket) {
-           last delim;
+           last DELIM;
        }
     }
     $addr;