This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 3.0 patch #31 patch #29, continued
authorLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Tue, 16 Oct 1990 02:30:59 +0000 (02:30 +0000)
committerLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Tue, 16 Oct 1990 02:30:59 +0000 (02:30 +0000)
See patch #29.

MANIFEST
doio.c
dolist.c
dump.c
eval.c
patchlevel.h

index 74327df..ecc18be 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -52,6 +52,10 @@ eg/scan/scan_sudo    Scan for sudo anomalies
 eg/scan/scan_suid      Scan for setuid anomalies
 eg/scan/scanner                An anomaly reporter
 eg/shmkill             A program to remove unused shared memory
+eg/sysvipc/README      Intro to Sys V IPC examples
+eg/sysvipc/ipcmsg      Example of SYS V IPC message queues
+eg/sysvipc/ipcsem      Example of Sys V IPC semaphores
+eg/sysvipc/ipcshm      Example of Sys V IPC shared memory
 eg/travesty            A program to print travesties of its input text
 eg/van/empty           A program to empty the trashcan
 eg/van/unvanish                A program to undo what vanish does
@@ -81,6 +85,7 @@ hash.c                        Associative arrays
 hash.h                 Public declarations for the above
 ioctl.pl               Sample ioctl.pl
 lib/abbrev.pl          An abbreviation table builder
+lib/cacheout.pl                Manages output filehandles when you need too many
 lib/complete.pl                A command completion subroutine
 lib/ctime.pl           A ctime workalike
 lib/dumpvar.pl         A variable dumper
@@ -89,7 +94,6 @@ lib/getopt.pl         Perl library supporting option parsing
 lib/getopts.pl         Perl library supporting option parsing
 lib/importenv.pl       Perl routine to get environment into variables
 lib/look.pl            A "look" equivalent
-lib/nsyslog.pl         Newer syslog.pl
 lib/perldb.pl          Perl debugging routines
 lib/pwd.pl             Routines to keep track of PWD environment variable
 lib/stat.pl            Perl library supporting stat function
@@ -115,10 +119,24 @@ msdos/msdos.c             MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn
 msdos/popen.c          My_popen and my_pclose for MS-DOS
 os2/Makefile           Makefile for OS/2
 os2/README.OS2         Notes for OS/2
+os2/a2p.cs             Compiler script for a2p
+os2/a2p.def            Linker defs for a2p
 os2/config.h           Configuration file for OS/2
+os2/dir.h              Directory header
+os2/director.c         Directory routines
 os2/eg/os2.pl          Sample script for OS/2
 os2/eg/syscalls.pl     Example of syscall on OS/2
+os2/makefile           Make file
+os2/mktemp.c           Mktemp() using TMP
+os2/os2.c              Unix compatibility functions
+os2/perl.bad           names of protect-only API calls for BIND
+os2/perl.cs            Compiler script for perl
+os2/perl.def           Linker defs for perl
+os2/perlglob.cs                Compiler script for perlglob
+os2/perlglob.def       Linker defs for perlglob
+os2/perlsh.cmd         Poor man's shell for os2
 os2/popen.c            Code for opening pipes
+os2/selfrun.cmd                Example of extproc feature
 os2/suffix.c           Code for creating backup filenames
 patchlevel.h           The current patch level of perl
 perl.h                 Global declarations
diff --git a/doio.c b/doio.c
index 40ac26c..9dee302 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1,4 +1,4 @@
-/* $Header: doio.c,v 3.0.1.10 90/08/13 22:14:29 lwall Locked $
+/* $Header: doio.c,v 3.0.1.11 90/10/15 16:16:11 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,14 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       doio.c,v $
+ * Revision 3.0.1.11  90/10/15  16:16:11  lwall
+ * patch29: added SysV IPC
+ * patch29: file - didn't auto-close cleanly
+ * patch29: close; core dumped
+ * patch29: more MSDOS and OS/2 updates, from Kai Uwe Rommel
+ * patch29: various portability fixes
+ * patch29: *foo now prints as *package'foo
+ * 
  * Revision 3.0.1.10  90/08/13  22:14:29  lwall
  * patch28: close-on-exec problems on dup'ed file descriptors
  * patch28: F_FREESP wasn't implemented the way I thought
 #include <sys/select.h>
 #endif
 
+#ifdef SYSVIPC
+#include <sys/ipc.h>
+#include <sys/msg.h>
+#include <sys/sem.h>
+#include <sys/shm.h>
+#endif
+
 #ifdef I_PWD
 #include <pwd.h>
 #endif
@@ -112,15 +127,18 @@ int len;
        fd = fileno(stio->ifp);
        if (stio->type == '|')
            result = mypclose(stio->ifp);
+       else if (stio->type == '-')
+           result = 0;
        else if (stio->ifp != stio->ofp) {
-           if (stio->ofp)
-               fclose(stio->ofp);
-           result = fclose(stio->ifp);
+           if (stio->ofp) {
+               result = fclose(stio->ofp);
+               fclose(stio->ifp);      /* clear stdio, fd already closed */
+           }
+           else
+               result = fclose(stio->ifp);
        }
-       else if (stio->type != '-')
-           result = fclose(stio->ifp);
        else
-           result = 0;
+           result = fclose(stio->ifp);
        if (result == EOF && fd > 2)
            fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
              stab_name(stab));
@@ -391,9 +409,14 @@ STAB *stab;
 bool explicit;
 {
     bool retval = FALSE;
-    register STIO *stio = stab_io(stab);
+    register STIO *stio;
     int status;
 
+    if (!stab)
+       stab = argvstab;
+    if (!stab)
+       return FALSE;
+    stio = stab_io(stab);
     if (!stio) {               /* never opened */
        if (dowarn && explicit)
            warn("Close on unopened file <%s>",stab_name(stab));
@@ -408,9 +431,12 @@ bool explicit;
        else if (stio->type == '-')
            retval = TRUE;
        else {
-           if (stio->ofp && stio->ofp != stio->ifp)            /* a socket */
-               fclose(stio->ofp);
-           retval = (fclose(stio->ifp) != EOF);
+           if (stio->ofp && stio->ofp != stio->ifp) {          /* a socket */
+               retval = (fclose(stio->ofp) != EOF);
+               fclose(stio->ifp);      /* clear stdio, fd already closed */
+           }
+           else
+               retval = (fclose(stio->ifp) != EOF);
        }
        stio->ofp = stio->ifp = Nullfp;
     }
@@ -552,7 +578,11 @@ STR *argstr;
     }
     else {
        retval = (int)str_gnum(argstr);
+#ifdef MSDOS
+       s = (char*)(long)retval;                /* ouch */
+#else
        s = (char*)retval;              /* ouch */
+#endif
     }
 
 #ifndef lint
@@ -593,7 +623,7 @@ int *arglast;
        if (tmpstab != defstab) {
            statstab = tmpstab;
            str_set(statname,"");
-           if (!stab_io(tmpstab) ||
+           if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
              fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) {
                max = 0;
            }
@@ -665,7 +695,7 @@ int *arglast;
 }
 
 #if !defined(TRUNCATE) && !defined(CHSIZE) && defined(F_FREESP)
-           /* code courtesy of Pim Zandbergen */
+       /* code courtesy of William Kucharski */
 #define CHSIZE
 
 int chsize(fd, length)
@@ -836,10 +866,12 @@ FILE *fp;
     }
     else {
        tmps = str_get(str);
-       if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'a' && tmps[3] == 'b'
+       if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'B' && tmps[3] == '\0'
          && str->str_cur == sizeof(STBP) && strlen(tmps) < str->str_cur) {
-           tmps = stab_name(((STAB*)str));     /* a stab value, be nice */
-           str = ((STAB*)str)->str_magic;
+           STR *tmpstr = str_static(&str_undef);
+           stab_fullname(tmpstr,((STAB*)str));/* a stab value, be nice */
+           str = tmpstr;
+           tmps = str->str_ptr;
            putc('*',fp);
        }
        if (str->str_cur && (fwrite(tmps,1,str->str_cur,fp) == 0 || ferror(fp)))
@@ -1920,8 +1952,10 @@ int *arglast;
 #ifdef PWCLASS
        str_set(str,pwent->pw_class);
 #else
+#ifdef PWCOMMENT
        str_set(str, pwent->pw_comment);
 #endif
+#endif
        (void)astore(ary, ++sp, str = str_static(&str_no));
        str_set(str, pwent->pw_gecos);
        (void)astore(ary, ++sp, str = str_static(&str_no));
@@ -2288,3 +2322,242 @@ int effective;
 #endif
     return FALSE;
 }
+
+#ifdef SYSVIPC
+
+int
+do_ipcget(optype, arglast)
+int optype;
+int *arglast;
+{
+    register STR **st = stack->ary_array;
+    register int sp = arglast[0];
+    key_t key;
+    int n, flags;
+
+    key = (key_t)str_gnum(st[++sp]);
+    n = (optype == O_MSGGET) ? 0 : (int)str_gnum(st[++sp]);
+    flags = (int)str_gnum(st[++sp]);
+    errno = 0;
+    switch (optype)
+    {
+    case O_MSGGET:
+       return msgget(key, flags);
+    case O_SEMGET:
+       return semget(key, n, flags);
+    case O_SHMGET:
+       return shmget(key, n, flags);
+    }
+    return -1;                 /* should never happen */
+}
+
+int
+do_ipcctl(optype, arglast)
+int optype;
+int *arglast;
+{
+    register STR **st = stack->ary_array;
+    register int sp = arglast[0];
+    STR *astr;
+    char *a;
+    int id, n, cmd, infosize, getinfo, ret;
+
+    id = (int)str_gnum(st[++sp]);
+    n = (optype == O_SEMCTL) ? (int)str_gnum(st[++sp]) : 0;
+    cmd = (int)str_gnum(st[++sp]);
+    astr = st[++sp];
+
+    infosize = 0;
+    getinfo = (cmd == IPC_STAT);
+
+    switch (optype)
+    {
+    case O_MSGCTL:
+       if (cmd == IPC_STAT || cmd == IPC_SET)
+           infosize = sizeof(struct msqid_ds);
+       break;
+    case O_SHMCTL:
+       if (cmd == IPC_STAT || cmd == IPC_SET)
+           infosize = sizeof(struct shmid_ds);
+       break;
+    case O_SEMCTL:
+       if (cmd == IPC_STAT || cmd == IPC_SET)
+           infosize = sizeof(struct semid_ds);
+       else if (cmd == GETALL || cmd == SETALL)
+       {
+           struct semid_ds semds;
+           if (semctl(id, 0, IPC_STAT, &semds) == -1)
+               return -1;
+           getinfo = (cmd == GETALL);
+           infosize = semds.sem_nsems * sizeof(ushort);
+       }
+       break;
+    }
+
+    if (infosize)
+    {
+       if (getinfo)
+       {
+           STR_GROW(astr, infosize+1);
+           a = str_get(astr);
+       }
+       else
+       {
+           a = str_get(astr);
+           if (astr->str_cur != infosize)
+           {
+               errno = EINVAL;
+               return -1;
+           }
+       }
+    }
+    else
+    {
+       int i = (int)str_gnum(astr);
+       a = (char *)i;          /* ouch */
+    }
+    errno = 0;
+    switch (optype)
+    {
+    case O_MSGCTL:
+       ret = msgctl(id, cmd, a);
+       break;
+    case O_SEMCTL:
+       ret = semctl(id, n, cmd, a);
+       break;
+    case O_SHMCTL:
+       ret = shmctl(id, cmd, a);
+       break;
+    }
+    if (getinfo && ret >= 0) {
+       astr->str_cur = infosize;
+       astr->str_ptr[infosize] = '\0';
+    }
+    return ret;
+}
+
+int
+do_msgsnd(arglast)
+int *arglast;
+{
+    register STR **st = stack->ary_array;
+    register int sp = arglast[0];
+    STR *mstr;
+    char *mbuf;
+    int id, msize, flags;
+
+    id = (int)str_gnum(st[++sp]);
+    mstr = st[++sp];
+    flags = (int)str_gnum(st[++sp]);
+    mbuf = str_get(mstr);
+    if ((msize = mstr->str_cur - sizeof(long)) < 0) {
+       errno = EINVAL;
+       return -1;
+    }
+    errno = 0;
+    return msgsnd(id, mbuf, msize, flags);
+}
+
+int
+do_msgrcv(arglast)
+int *arglast;
+{
+    register STR **st = stack->ary_array;
+    register int sp = arglast[0];
+    STR *mstr;
+    char *mbuf;
+    long mtype;
+    int id, msize, flags, ret;
+
+    id = (int)str_gnum(st[++sp]);
+    mstr = st[++sp];
+    msize = (int)str_gnum(st[++sp]);
+    mtype = (long)str_gnum(st[++sp]);
+    flags = (int)str_gnum(st[++sp]);
+    mbuf = str_get(mstr);
+    if (mstr->str_cur < sizeof(long)+msize+1) {
+       STR_GROW(mstr, sizeof(long)+msize+1);
+       mbuf = str_get(mstr);
+    }
+    errno = 0;
+    ret = msgrcv(id, mbuf, msize, mtype, flags);
+    if (ret >= 0) {
+       mstr->str_cur = sizeof(long)+ret;
+       mstr->str_ptr[sizeof(long)+ret] = '\0';
+    }
+    return ret;
+}
+
+int
+do_semop(arglast)
+int *arglast;
+{
+    register STR **st = stack->ary_array;
+    register int sp = arglast[0];
+    STR *opstr;
+    char *opbuf;
+    int id, opsize;
+
+    id = (int)str_gnum(st[++sp]);
+    opstr = st[++sp];
+    opbuf = str_get(opstr);
+    opsize = opstr->str_cur;
+    if (opsize < sizeof(struct sembuf)
+       || (opsize % sizeof(struct sembuf)) != 0) {
+       errno = EINVAL;
+       return -1;
+    }
+    errno = 0;
+    return semop(id, opbuf, opsize/sizeof(struct sembuf));
+}
+
+int
+do_shmio(optype, arglast)
+int optype;
+int *arglast;
+{
+    register STR **st = stack->ary_array;
+    register int sp = arglast[0];
+    STR *mstr;
+    char *mbuf, *shm;
+    int id, mpos, msize;
+    struct shmid_ds shmds;
+    extern char *shmat();
+
+    id = (int)str_gnum(st[++sp]);
+    mstr = st[++sp];
+    mpos = (int)str_gnum(st[++sp]);
+    msize = (int)str_gnum(st[++sp]);
+    errno = 0;
+    if (shmctl(id, IPC_STAT, &shmds) == -1)
+       return -1;
+    if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
+       errno = EFAULT;         /* can't do as caller requested */
+       return -1;
+    }
+    shm = shmat(id, (char *)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
+    if (shm == (char *)-1)     /* I hate System V IPC, I really do */
+       return -1;
+    mbuf = str_get(mstr);
+    if (optype == O_SHMREAD) {
+       if (mstr->str_cur < msize) {
+           STR_GROW(mstr, msize+1);
+           mbuf = str_get(mstr);
+       }
+       bcopy(shm + mpos, mbuf, msize);
+       mstr->str_cur = msize;
+       mstr->str_ptr[msize] = '\0';
+    }
+    else {
+       int n;
+
+       if ((n = mstr->str_cur) > msize)
+           n = msize;
+       bcopy(mbuf, shm + mpos, n);
+       if (n < msize)
+           bzero(shm + mpos + n, msize - n);
+    }
+    return shmdt(shm);
+}
+
+#endif /* SYSVIPC */
index dbdcaa7..fa970a1 100644 (file)
--- a/dolist.c
+++ b/dolist.c
@@ -1,4 +1,4 @@
-/* $Header: dolist.c,v 3.0.1.9 90/08/13 22:15:35 lwall Locked $
+/* $Header: dolist.c,v 3.0.1.10 90/10/15 16:19:48 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,11 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       dolist.c,v $
+ * Revision 3.0.1.10  90/10/15  16:19:48  lwall
+ * patch29: added caller
+ * patch29: added scalar reverse
+ * patch29: sort undefined_subroutine @array is now a fatal error
+ * 
  * Revision 3.0.1.9  90/08/13  22:15:35  lwall
  * patch28: defined(@array) and defined(%array) didn't work right
  * 
@@ -1301,12 +1306,6 @@ int *arglast;
     register STR **down = &st[arglast[2]];
     register int i = arglast[2] - arglast[1];
 
-    if (gimme != G_ARRAY) {
-       str_sset(str,&str_undef);
-       STABSET(str);
-       st[arglast[0]+1] = str;
-       return arglast[0]+1;
-    }
     while (i-- > 0) {
        *up++ = *down;
        if (i-- > 0)
@@ -1317,6 +1316,32 @@ int *arglast;
     return arglast[2] - 1;
 }
 
+int
+do_sreverse(str,gimme,arglast)
+STR *str;
+int gimme;
+int *arglast;
+{
+    STR **st = stack->ary_array;
+    register char *up;
+    register char *down;
+    register int tmp;
+
+    str_sset(str,st[arglast[2]]);
+    up = str_get(str);
+    if (str->str_cur > 1) {
+       down = str->str_ptr + str->str_cur - 1;
+       while (down > up) {
+           tmp = *up;
+           *up++ = *down;
+           *down-- = tmp;
+       }
+    }
+    STABSET(str);
+    st[arglast[0]+1] = str;
+    return arglast[0]+1;
+}
+
 static CMD *sortcmd;
 static STAB *firststab = Nullstab;
 static STAB *secondstab = Nullstab;
@@ -1359,9 +1384,11 @@ int *arglast;
     max = up - &st[sp];
     sp--;
     if (max > 1) {
-       if (stab_sub(stab) && (sortcmd = stab_sub(stab)->cmd)) {
+       if (stab) {
            int oldtmps_base = tmps_base;
 
+           if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd))
+               fatal("Undefined subroutine \"%s\" in sort", stab_name(stab));
            if (!sortstack) {
                sortstack = anew(Nullstab);
                sortstack->ary_flags = 0;
@@ -1468,11 +1495,79 @@ int *arglast;
 }
 
 int
+do_caller(arg,maxarg,gimme,arglast)
+ARG *arg;
+int maxarg;
+int gimme;
+int *arglast;
+{
+    STR **st = stack->ary_array;
+    register int sp = arglast[0];
+    register CSV *csv = curcsv;
+    STR *str;
+    int count = 0;
+
+    if (!csv)
+       fatal("There is no caller");
+    if (maxarg)
+       count = (int) str_gnum(st[sp+1]);
+    for (;;) {
+       if (!csv)
+           return sp;
+       if (csv->curcsv && csv->curcsv->sub == stab_sub(DBsub))
+           count++;
+       if (!count--)
+           break;
+       csv = csv->curcsv;
+    }
+    if (gimme != G_ARRAY) {
+       STR *str = arg->arg_ptr.arg_str;
+       str_set(str,csv->curcmd->c_stash->tbl_name);
+       STABSET(str);
+       st[++sp] = str;
+       return sp;
+    }
+
+#ifndef lint
+    (void)astore(stack,++sp,
+      str_2static(str_make(csv->curcmd->c_stash->tbl_name,0)) );
+    (void)astore(stack,++sp,
+      str_2static(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
+    (void)astore(stack,++sp,
+      str_2static(str_nmake((double)csv->curcmd->c_line)) );
+    if (!maxarg)
+       return sp;
+    str = str_static(&str_undef);
+    stab_fullname(str, csv->stab);
+    (void)astore(stack,++sp, str);
+    (void)astore(stack,++sp,
+      str_2static(str_nmake((double)csv->hasargs)) );
+    (void)astore(stack,++sp,
+      str_2static(str_nmake((double)csv->wantarray)) );
+    if (csv->hasargs) {
+       ARRAY *ary = csv->argarray;
+
+       if (dbargs->ary_max < ary->ary_fill)
+           astore(dbargs,ary->ary_fill,Nullstr);
+       Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
+       dbargs->ary_fill = ary->ary_fill;
+    }
+#else
+    (void)astore(stack,++sp,
+      str_2static(str_make("",0)));
+#endif
+    return sp;
+}
+
+int
 do_tms(str,gimme,arglast)
 STR *str;
 int gimme;
 int *arglast;
 {
+#ifdef MSDOS
+    return -1;
+#else
     STR **st = stack->ary_array;
     register int sp = arglast[0];
 
@@ -1502,6 +1597,7 @@ int *arglast;
       str_2static(str_nmake(0.0)));
 #endif
     return sp;
+#endif
 }
 
 int
diff --git a/dump.c b/dump.c
index c5f2a31..7b6a338 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1,4 +1,4 @@
-/* $Header: dump.c,v 3.0.1.1 90/03/27 15:49:58 lwall Locked $
+/* $Header: dump.c,v 3.0.1.2 90/10/15 16:22:10 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:       dump.c,v $
+ * Revision 3.0.1.2  90/10/15  16:22:10  lwall
+ * patch29: *foo now prints as *package'foo
+ * 
  * Revision 3.0.1.1  90/03/27  15:49:58  lwall
  * patch16: changed unsigned to unsigned int
  * 
@@ -25,13 +28,15 @@ dump_all()
     register int i;
     register STAB *stab;
     register HENT *entry;
+    STR *str = str_static(&str_undef);
 
     dump_cmd(main_root,Nullcmd);
     for (i = 0; i <= 127; i++) {
        for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
            stab = (STAB*)entry->hent_val;
            if (stab_sub(stab)) {
-               dump("\nSUB %s = ", stab_name(stab));
+               stab_fullname(str,stab);
+               dump("\nSUB %s = ", str->str_ptr);
                dump_cmd(stab_sub(stab)->cmd,Nullcmd);
            }
        }
@@ -246,13 +251,17 @@ unsigned int flags;
 dump_stab(stab)
 register STAB *stab;
 {
+    STR *str;
+
     if (!stab) {
        fprintf(stderr,"{}\n");
        return;
     }
+    str = str_static(&str_undef);
     dumplvl++;
     fprintf(stderr,"{\n");
-    dump("STAB_NAME = %s\n",stab_name(stab));
+    stab_fullname(str,stab);
+    dump("STAB_NAME = %s\n", str->str_ptr);
     dumplvl--;
     dump("}\n");
 }
diff --git a/eval.c b/eval.c
index 7bd5342..2020eb7 100644 (file)
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* $Header: eval.c,v 3.0.1.8 90/08/13 22:17:14 lwall Locked $
+/* $Header: eval.c,v 3.0.1.9 90/10/15 16:46:13 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,20 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       eval.c,v $
+ * Revision 3.0.1.9  90/10/15  16:46:13  lwall
+ * patch29: added caller
+ * patch29: added scalar
+ * patch29: added cmp and <=>
+ * patch29: added sysread and syswrite
+ * patch29: added -M, -A and -C
+ * patch29: index and substr now have optional 3rd args
+ * patch29: you can now read into the middle string
+ * patch29: ~ now works on vector string
+ * patch29: non-existent array values no longer cause core dumps
+ * patch29: eof; core dumped
+ * patch29: oct and hex now produce unsigned result
+ * patch29: unshift did not return the documented value
+ * 
  * Revision 3.0.1.8  90/08/13  22:17:14  lwall
  * patch28: the NSIG hack didn't work right on Xenix
  * patch28: defined(@array) and defined(%array) didn't work right
@@ -90,7 +104,6 @@ static STAB *stab2;
 static STIO *stio;
 static struct lstring *lstr;
 static int old_record_separator;
-extern int wantarray;
 
 double sin(), cos(), atan2(), pow();
 
@@ -158,6 +171,8 @@ register int sp;
     case O_ITEM:
        if (gimme == G_ARRAY)
            goto array_return;
+       /* FALL THROUGH */
+    case O_SCALAR:
        STR_SSET(str,st[1]);
        STABSET(str);
        break;
@@ -353,6 +368,14 @@ register int sp;
        value = str_gnum(st[1]);
        value = (value != str_gnum(st[2])) ? 1.0 : 0.0;
        goto donumset;
+    case O_NCMP:
+       value = str_gnum(st[1]);
+       value -= str_gnum(st[2]);
+       if (value > 0.0)
+           value = 1.0;
+       else if (value < 0.0)
+           value = -1.0;
+       goto donumset;
     case O_BIT_AND:
        if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
            value = str_gnum(st[1]);
@@ -466,12 +489,12 @@ register int sp;
        else {
            STR_SSET(str,st[1]);
            tmps = str_get(str);
-           for (anum = str->str_cur; anum; anum--)
+           for (anum = str->str_cur; anum; anum--, tmps++)
                *tmps = ~*tmps;
        }
        break;
     case O_SELECT:
-       tmps = stab_name(defoutstab);
+       stab_fullname(str,defoutstab);
        if (maxarg > 0) {
            if ((arg[1].arg_type & A_MASK) == A_WORD)
                defoutstab = arg[1].arg_ptr.arg_stab;
@@ -481,7 +504,6 @@ register int sp;
                stab_io(defoutstab) = stio_new();
            curoutstab = defoutstab;
        }
-       str_set(str, tmps);
        STABSET(str);
        break;
     case O_WRITE:
@@ -617,8 +639,6 @@ register int sp;
     case O_AELEM:
        anum = ((int)str_gnum(st[2])) - arybase;
        str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE);
-       if (!str)
-           goto say_undef;
        break;
     case O_DELETE:
        tmpstab = arg[1].arg_ptr.arg_stab;
@@ -653,13 +673,11 @@ register int sp;
        tmpstab = arg[1].arg_ptr.arg_stab;
        tmps = str_get(st[2]);
        str = hfetch(stab_hash(tmpstab),tmps,st[2]->str_cur,FALSE);
-       if (!str)
-           goto say_undef;
        break;
     case O_LAELEM:
        anum = ((int)str_gnum(st[2])) - arybase;
        str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,TRUE);
-       if (!str)
+       if (!str || str == &str_undef)
            fatal("Assignment to non-creatable value, subscript %d",anum);
        break;
     case O_LHELEM:
@@ -667,7 +685,7 @@ register int sp;
        tmps = str_get(st[2]);
        anum = st[2]->str_cur;
        str = hfetch(stab_hash(tmpstab),tmps,anum,TRUE);
-       if (!str)
+       if (!str || str == &str_undef)
            fatal("Assignment to non-creatable value, subscript \"%s\"",tmps);
        if (tmpstab == envstab)         /* heavy wizardry going on here */
            str_magic(str, tmpstab, 'E', tmps, anum);   /* str is now magic */
@@ -678,6 +696,8 @@ register int sp;
        else if (stab_hash(tmpstab)->tbl_dbm)
            str_magic(str, tmpstab, 'D', tmps, anum);
 #endif
+       else if (perldb && tmpstab == DBline)
+           str_magic(str, tmpstab, 'L', tmps, anum);
        break;
     case O_LSLICE:
        anum = 2;
@@ -752,7 +772,7 @@ register int sp;
        if (anum < 0 || anum > st[1]->str_cur)
            str_nset(str,"",0);
        else {
-           optype = (int)str_gnum(st[3]);
+           optype = maxarg < 3 ? st[1]->str_cur : (int)str_gnum(st[3]);
            if (optype < 0)
                optype = 0;
            tmps += anum;
@@ -802,12 +822,20 @@ register int sp;
        tmps = str_get(st[1]);
        value = (double) !str_eq(st[1],st[2]);
        goto donumset;
+    case O_SCMP:
+       tmps = str_get(st[1]);
+       value = (double) str_cmp(st[1],st[2]);
+       goto donumset;
     case O_SUBR:
        sp = do_subr(arg,gimme,arglast);
        st = stack->ary_array + arglast[0];             /* maybe realloced */
        goto array_return;
     case O_DBSUBR:
-       sp = do_dbsubr(arg,gimme,arglast);
+       sp = do_subr(arg,gimme,arglast);
+       st = stack->ary_array + arglast[0];             /* maybe realloced */
+       goto array_return;
+    case O_CALLER:
+       sp = do_caller(arg,maxarg,gimme,arglast);
        st = stack->ary_array + arglast[0];             /* maybe realloced */
        goto array_return;
     case O_SORT:
@@ -815,14 +843,16 @@ register int sp;
            stab = arg[1].arg_ptr.arg_stab;
        else
            stab = stabent(str_get(st[1]),TRUE);
-       if (!stab)
-           stab = defoutstab;
        sp = do_sort(str,stab,
          gimme,arglast);
        goto array_return;
     case O_REVERSE:
-       sp = do_reverse(str,
-         gimme,arglast);
+       if (gimme == G_ARRAY)
+           sp = do_reverse(str,
+             gimme,arglast);
+       else
+           sp = do_sreverse(str,
+             gimme,arglast);
        goto array_return;
     case O_WARN:
        if (arglast[2] - arglast[1] != 1) {
@@ -893,13 +923,11 @@ register int sp;
            tmps = str_get(st[1]);
        if (!tmps || !*tmps) {
            tmpstr = hfetch(stab_hash(envstab),"HOME",4,FALSE);
-           if (tmpstr)
-               tmps = str_get(tmpstr);
+           tmps = str_get(tmpstr);
        }
        if (!tmps || !*tmps) {
            tmpstr = hfetch(stab_hash(envstab),"LOGDIR",6,FALSE);
-           if (tmpstr)
-               tmps = str_get(tmpstr);
+           tmps = str_get(tmpstr);
        }
 #ifdef TAINT
        taintproper("Insecure dependency in chdir");
@@ -918,7 +946,7 @@ register int sp;
            tmps = "";
        else
            tmps = str_get(st[1]);
-       str_reset(tmps,arg[2].arg_ptr.arg_hash);
+       str_reset(tmps,curcmd->c_stash);
        value = 1.0;
        goto donumset;
     case O_LIST:
@@ -946,8 +974,10 @@ register int sp;
            stab = arg[1].arg_ptr.arg_stab;
        else
            stab = stabent(str_get(st[1]),TRUE);
-       if (do_eof(stab))       /* make sure we have fp with something */
-           str_set(str, No);
+       if (!stab)
+           stab = argvstab;
+       if (!stab || do_eof(stab)) /* make sure we have fp with something */
+           goto say_undef;
        else {
 #ifdef TAINT
            tainted = 1;
@@ -972,21 +1002,27 @@ register int sp;
        goto donumset;
     case O_RECV:
     case O_READ:
+    case O_SYSREAD:
        if ((arg[1].arg_type & A_MASK) == A_WORD)
            stab = arg[1].arg_ptr.arg_stab;
        else
            stab = stabent(str_get(st[1]),TRUE);
        tmps = str_get(st[2]);
        anum = (int)str_gnum(st[3]);
-       STR_GROW(st[2], anum+1), (tmps = str_get(st[2]));       /* sneaky */
        errno = 0;
+       maxarg = sp - arglast[0];
+       if (maxarg > 4)
+           warn("Too many args on read");
+       if (maxarg == 4)
+           maxarg = (int)str_gnum(st[4]);
+       else
+           maxarg = 0;
        if (!stab_io(stab) || !stab_io(stab)->ifp)
-           goto say_zero;
+           goto say_undef;
 #ifdef SOCKET
-       else if (optype == O_RECV) {
+       if (optype == O_RECV) {
            argtype = sizeof buf;
-           optype = (int)str_gnum(st[4]);
-           anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, optype,
+           anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, maxarg,
                buf, &argtype);
            if (anum >= 0) {
                st[2]->str_cur = anum;
@@ -997,55 +1033,77 @@ register int sp;
                str_sset(str,&str_undef);
            break;
        }
-       else if (stab_io(stab)->type == 's') {
+#else
+       if (optype == O_RECV)
+           goto badsock;
+#endif
+       STR_GROW(st[2], anum+maxarg+1), (tmps = str_get(st[2]));  /* sneaky */
+#ifdef SOCKET
+       if (stab_io(stab)->type == 's') {
            argtype = sizeof buf;
-           anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, 0,
+           anum = recvfrom(fileno(stab_io(stab)->ifp), tmps+maxarg, anum, 0,
                buf, &argtype);
        }
-#else
-       else if (optype == O_RECV)
-           goto badsock;
+       else
 #endif
+       if (optype == O_SYSREAD) {
+           anum = read(fileno(stab_io(stab)->ifp), tmps+maxarg, anum);
+       }
        else
-           anum = fread(tmps, 1, anum, stab_io(stab)->ifp);
+           anum = fread(tmps+maxarg, 1, anum, stab_io(stab)->ifp);
        if (anum < 0)
            goto say_undef;
-       st[2]->str_cur = anum;
-       st[2]->str_ptr[anum] = '\0';
+       st[2]->str_cur = anum+maxarg;
+       st[2]->str_ptr[anum+maxarg] = '\0';
        value = (double)anum;
        goto donumset;
+    case O_SYSWRITE:
     case O_SEND:
-#ifdef SOCKET
        if ((arg[1].arg_type & A_MASK) == A_WORD)
            stab = arg[1].arg_ptr.arg_stab;
        else
            stab = stabent(str_get(st[1]),TRUE);
        tmps = str_get(st[2]);
        anum = (int)str_gnum(st[3]);
-       optype = sp - arglast[0];
        errno = 0;
-       if (optype > 4)
-           warn("Too many args on send");
        stio = stab_io(stab);
+       maxarg = sp - arglast[0];
        if (!stio || !stio->ifp) {
            anum = -1;
-           if (dowarn)
-               warn("Send on closed socket");
+           if (dowarn) {
+               if (optype == O_SYSWRITE)
+                   warn("Syswrite on closed filehandle");
+               else
+                   warn("Send on closed socket");
+           }
+       }
+       else if (optype == O_SYSWRITE) {
+           if (maxarg > 4)
+               warn("Too many args on syswrite");
+           if (maxarg == 4)
+               optype = (int)str_gnum(st[4]);
+           else
+               optype = 0;
+           anum = write(fileno(stab_io(stab)->ifp), tmps+optype, anum);
        }
-       else if (optype >= 4) {
+#ifdef SOCKET
+       else if (maxarg >= 4) {
+           if (maxarg > 4)
+               warn("Too many args on send");
            tmps2 = str_get(st[4]);
            anum = sendto(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur,
              anum, tmps2, st[4]->str_cur);
        }
        else
            anum = send(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum);
+#else
+       else
+           goto badsock;
+#endif
        if (anum < 0)
            goto say_undef;
        value = (double)anum;
        goto donumset;
-#else
-       goto badsock;
-#endif
     case O_SEEK:
        if ((arg[1].arg_type & A_MASK) == A_WORD)
            stab = arg[1].arg_ptr.arg_stab;
@@ -1059,7 +1117,7 @@ register int sp;
     case O_RETURN:
        tmps = "_SUB_";         /* just fake up a "last _SUB_" */
        optype = O_LAST;
-       if (wantarray == G_ARRAY) {
+       if (curcsv->wantarray == G_ARRAY) {
            lastretstr = Nullstr;
            lastspbase = arglast[1];
            lastsize = arglast[2] - arglast[1];
@@ -1118,8 +1176,17 @@ register int sp;
        longjmp(top_env, 1);
     case O_INDEX:
        tmps = str_get(st[1]);
+       if (maxarg < 3)
+           anum = 0;
+       else {
+           anum = (int) str_gnum(st[3]) - arybase;
+           if (anum < 0)
+               anum = 0;
+           else if (anum > st[1]->str_cur)
+               anum = st[1]->str_cur;
+       }
 #ifndef lint
-       if (!(tmps2 = fbminstr((unsigned char*)tmps,
+       if (!(tmps2 = fbminstr((unsigned char*)tmps + anum,
          (unsigned char*)tmps + st[1]->str_cur, st[2])))
 #else
        if (tmps2 = fbminstr(Null(unsigned char*),Null(unsigned char*),Nullstr))
@@ -1131,8 +1198,17 @@ register int sp;
     case O_RINDEX:
        tmps = str_get(st[1]);
        tmps2 = str_get(st[2]);
+       if (maxarg < 3)
+           anum = st[1]->str_cur;
+       else {
+           anum = (int) str_gnum(st[3]) - arybase + st[2]->str_cur;
+           if (anum < 0)
+               anum = 0;
+           else if (anum > st[1]->str_cur)
+               anum = st[1]->str_cur;
+       }
 #ifndef lint
-       if (!(tmps2 = rninstr(tmps,  tmps  + st[1]->str_cur,
+       if (!(tmps2 = rninstr(tmps,  tmps  + anum,
                              tmps2, tmps2 + st[2]->str_cur)))
 #else
        if (tmps2 = rninstr(Nullch,Nullch,Nullch,Nullch))
@@ -1370,8 +1446,11 @@ register int sp;
     case O_FORK:
 #ifdef FORK
        anum = fork();
-       if (!anum && (tmpstab = stabent("$",allstabs)))
-           str_numset(STAB_STR(tmpstab),(double)getpid());
+       if (!anum) {
+           if (tmpstab = stabent("$",allstabs))
+               str_numset(STAB_STR(tmpstab),(double)getpid());
+           hclear(pidstatus);  /* no kids, so don't wait for 'em */
+       }
        value = (double)anum;
        goto donumset;
 #else
@@ -1392,6 +1471,20 @@ register int sp;
        fatal("Unsupported function wait");
        break;
 #endif
+    case O_WAITPID:
+#ifdef WAITPID
+#ifndef lint
+       anum = (int)str_gnum(st[1]);
+       optype = (int)str_gnum(st[2]);
+       anum = wait4pid(anum, &argflags,optype);
+       value = (double)anum;
+#endif
+       statusvalue = (unsigned short)argflags;
+       goto donumset;
+#else
+       fatal("Unsupported function wait");
+       break;
+#endif
     case O_SYSTEM:
 #ifdef FORK
 #ifdef TAINT
@@ -1412,15 +1505,14 @@ register int sp;
 #ifndef lint
            ihand = signal(SIGINT, SIG_IGN);
            qhand = signal(SIGQUIT, SIG_IGN);
-           while ((argtype = wait(&argflags)) != anum && argtype >= 0)
-               pidgone(argtype,argflags);
+           argtype = wait4pid(anum, &argflags, 0);
 #else
            ihand = qhand = 0;
 #endif
            (void)signal(SIGINT, ihand);
            (void)signal(SIGQUIT, qhand);
            statusvalue = (unsigned short)argflags;
-           if (argtype == -1)
+           if (argtype < 0)
                value = -1.0;
            else {
                value = (double)((unsigned int)argflags & 0xffff);
@@ -1446,7 +1538,7 @@ register int sp;
        }
        goto donumset;
 #endif /* FORK */
-    case O_EXEC:
+    case O_EXEC_OP:
        if ((arg[1].arg_type & A_MASK) == A_STAB)
            value = (double)do_aexec(st[1],arglast);
        else if (arglast[2] - arglast[1] != 1)
@@ -1463,7 +1555,7 @@ register int sp;
        argtype = 3;
 
       snarfnum:
-       anum = 0;
+       tmplong = 0;
        if (maxarg < 1)
            tmps = str_get(stab_val(defstab));
        else
@@ -1478,15 +1570,15 @@ register int sp;
                /* FALL THROUGH */
            case '0': case '1': case '2': case '3': case '4':
            case '5': case '6': case '7':
-               anum <<= argtype;
-               anum += *tmps++ & 15;
+               tmplong <<= argtype;
+               tmplong += *tmps++ & 15;
                break;
            case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
            case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
                if (argtype != 4)
                    goto out;
-               anum <<= 4;
-               anum += (*tmps++ & 7) + 9;
+               tmplong <<= 4;
+               tmplong += (*tmps++ & 7) + 9;
                break;
            case 'x':
                argtype = 4;
@@ -1495,7 +1587,7 @@ register int sp;
            }
        }
       out:
-       value = (double)anum;
+       value = (double)tmplong;
        goto donumset;
     case O_CHOWN:
 #ifdef CHOWN
@@ -1535,6 +1627,54 @@ register int sp;
        fatal("Unsupported function umask");
        break;
 #endif
+#ifdef SYSVIPC
+    case O_MSGGET:
+    case O_SHMGET:
+    case O_SEMGET:
+       if ((anum = do_ipcget(optype, arglast)) == -1)
+           goto say_undef;
+       value = (double)anum;
+       goto donumset;
+    case O_MSGCTL:
+    case O_SHMCTL:
+    case O_SEMCTL:
+       anum = do_ipcctl(optype, arglast);
+       if (anum == -1)
+           goto say_undef;
+       if (anum != 0) {
+           value = (double)anum;
+           goto donumset;
+       }
+       str_set(str,"0 but true");
+       STABSET(str);
+       break;
+    case O_MSGSND:
+       value = (double)(do_msgsnd(arglast) >= 0);
+       goto donumset;
+    case O_MSGRCV:
+       value = (double)(do_msgrcv(arglast) >= 0);
+       goto donumset;
+    case O_SEMOP:
+       value = (double)(do_semop(arglast) >= 0);
+       goto donumset;
+    case O_SHMREAD:
+    case O_SHMWRITE:
+       value = (double)(do_shmio(optype, arglast) >= 0);
+       goto donumset;
+#else /* not SYSVIPC */
+    case O_MSGGET:
+    case O_MSGCTL:
+    case O_MSGSND:
+    case O_MSGRCV:
+    case O_SEMGET:
+    case O_SEMCTL:
+    case O_SEMOP:
+    case O_SHMGET:
+    case O_SHMCTL:
+    case O_SHMREAD:
+    case O_SHMWRITE:
+       fatal("System V IPC is not implemented on this machine");
+#endif /* not SYSVIPC */
     case O_RENAME:
        tmps = str_get(st[1]);
        tmps2 = str_get(st[2]);
@@ -1604,6 +1744,10 @@ register int sp;
 #endif
                if (instr(buf,"cannot make"))
                    errno = EEXIST;
+               else if (instr(buf,"existing file"))
+                   errno = EEXIST;
+               else if (instr(buf,"ile exists"))
+                   errno = EEXIST;
                else if (instr(buf,"non-exist"))
                    errno = ENOENT;
                else if (instr(buf,"does not exist"))
@@ -1769,13 +1913,13 @@ register int sp;
        if (arglast[2] - arglast[1] != 1)
            do_unshift(ary,arglast);
        else {
-           str = Str_new(52,0);                /* must copy the STR */
-           str_sset(str,st[2]);
+           STR *tmpstr = Str_new(52,0);        /* must copy the STR */
+           str_sset(tmpstr,st[2]);
            aunshift(ary,1);
-           (void)astore(ary,0,str);
+           (void)astore(ary,0,tmpstr);
        }
        value = (double)(ary->ary_fill + 1);
-       break;
+       goto donumset;
 
     case O_REQUIRE:
     case O_DOFILE:
@@ -1789,7 +1933,7 @@ register int sp;
        tainted |= tmpstr->str_tainted;
        taintproper("Insecure dependency in eval");
 #endif
-       sp = do_eval(tmpstr, optype, arg[2].arg_ptr.arg_hash,
+       sp = do_eval(tmpstr, optype, curcmd->c_stash,
            gimme,arglast);
        goto array_return;
 
@@ -1846,6 +1990,22 @@ register int sp;
        value = (double)statcache.st_size;
        goto donumset;
 
+    case O_FTMTIME:
+       if (mystat(arg,st[1]) < 0)
+           goto say_undef;
+       value = (double)(basetime - statcache.st_mtime) / 86400.0;
+       goto donumset;
+    case O_FTATIME:
+       if (mystat(arg,st[1]) < 0)
+           goto say_undef;
+       value = (double)(basetime - statcache.st_atime) / 86400.0;
+       goto donumset;
+    case O_FTCTIME:
+       if (mystat(arg,st[1]) < 0)
+           goto say_undef;
+       value = (double)(basetime - statcache.st_ctime) / 86400.0;
+       goto donumset;
+
     case O_FTSOCK:
 #ifdef S_IFSOCK
        anum = S_IFSOCK;
@@ -2116,6 +2276,8 @@ register int sp;
            stab = arg[1].arg_ptr.arg_stab;
        else
            stab = stabent(str_get(st[1]),TRUE);
+       if (!stab)
+           goto say_undef;
        sp = do_getsockname(optype,stab,arglast);
        goto array_return;
 
@@ -2250,6 +2412,8 @@ register int sp;
            stab = arg[1].arg_ptr.arg_stab;
        else
            stab = stabent(str_get(st[1]),TRUE);
+       if (!stab)
+           goto say_undef;
        sp = do_dirop(optype,stab,gimme,arglast);
        goto array_return;
     case O_SYSCALL:
index 256548d..dd91c28 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 30
+#define PATCHLEVEL 31