From: Larry Wall Date: Tue, 16 Oct 1990 02:30:59 +0000 (+0000) Subject: perl 3.0 patch #31 patch #29, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c2ab57d4ffc80c0e2a9e968e66e52c289ac9ed45;p=p5sagit%2Fp5-mst-13.2.git perl 3.0 patch #31 patch #29, continued See patch #29. --- diff --git a/MANIFEST b/MANIFEST index 74327df..ecc18be 100644 --- 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 --- 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 @@ -75,6 +83,13 @@ #include #endif +#ifdef SYSVIPC +#include +#include +#include +#include +#endif + #ifdef I_PWD #include #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 */ diff --git a/dolist.c b/dolist.c index dbdcaa7..fa970a1 100644 --- 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 --- 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 --- 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: diff --git a/patchlevel.h b/patchlevel.h index 256548d..dd91c28 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 30 +#define PATCHLEVEL 31