See patch #29.
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
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
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
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
-/* $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
*
* 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
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));
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));
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;
}
}
else {
retval = (int)str_gnum(argstr);
+#ifdef MSDOS
+ s = (char*)(long)retval; /* ouch */
+#else
s = (char*)retval; /* ouch */
+#endif
}
#ifndef lint
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;
}
}
#if !defined(TRUNCATE) && !defined(CHSIZE) && defined(F_FREESP)
- /* code courtesy of Pim Zandbergen */
+ /* code courtesy of William Kucharski */
#define CHSIZE
int chsize(fd, length)
}
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)))
#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));
#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 */
-/* $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
*
* 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
*
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)
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;
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;
}
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];
str_2static(str_nmake(0.0)));
#endif
return sp;
+#endif
}
int
-/* $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
*
* 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
*
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);
}
}
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");
}
-/* $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
*
* 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
static STIO *stio;
static struct lstring *lstr;
static int old_record_separator;
-extern int wantarray;
double sin(), cos(), atan2(), pow();
case O_ITEM:
if (gimme == G_ARRAY)
goto array_return;
+ /* FALL THROUGH */
+ case O_SCALAR:
STR_SSET(str,st[1]);
STABSET(str);
break;
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]);
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;
stab_io(defoutstab) = stio_new();
curoutstab = defoutstab;
}
- str_set(str, tmps);
STABSET(str);
break;
case O_WRITE:
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;
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:
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 */
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;
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;
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:
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) {
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");
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:
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;
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;
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;
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];
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))
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))
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
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
#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);
}
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)
argtype = 3;
snarfnum:
- anum = 0;
+ tmplong = 0;
if (maxarg < 1)
tmps = str_get(stab_val(defstab));
else
/* 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;
}
}
out:
- value = (double)anum;
+ value = (double)tmplong;
goto donumset;
case O_CHOWN:
#ifdef CHOWN
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]);
#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"))
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:
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;
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;
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;
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:
-#define PATCHLEVEL 30
+#define PATCHLEVEL 31
projects / p5sagit/p5-mst-13.2.git / commitdiff