X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=271218f563f41accaa60262c9193cc2d6ba681fb;hb=46124e9ee58ad41479e5b089638f6c263bbddcb7;hp=e93c305e7c0da91077bbb26550685f02a8604ff0;hpb=6e21c824d91ef0b4ae60b95b347e344e5bb4d38a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doio.c b/doio.c index e93c305..271218f 100644 --- a/doio.c +++ b/doio.c @@ -1,43 +1,22 @@ -/* $RCSfile: doio.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 10:53:39 $ +/* doio.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1997, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: doio.c,v $ - * Revision 4.0.1.2 91/06/07 10:53:39 lwall - * patch4: new copyright notice - * patch4: system fd's are now treated specially - * patch4: added $^F variable to specify maximum system fd, default 2 - * patch4: character special files now opened with bidirectional stdio buffers - * patch4: taintchecks could improperly modify parent in vfork() - * patch4: many, many itty-bitty portability fixes - * - * Revision 4.0.1.1 91/04/11 17:41:06 lwall - * patch1: hopefully straightened out some of the Xenix mess - * - * Revision 4.0 91/03/20 01:07:06 lwall - * 4.0 baseline. - * + */ + +/* + * "Far below them they saw the white waters pour into a foaming bowl, and + * then swirl darkly about a deep oval basin in the rocks, until they found + * their way out again through a narrow gate, and flowed away, fuming and + * chattering, into calmer and more level reaches." */ #include "EXTERN.h" #include "perl.h" -#ifdef HAS_SOCKET -#include -#include -#endif - -#ifdef HAS_SELECT -#ifdef I_SYS_SELECT -#ifndef I_SYS_TIME -#include -#endif -#endif -#endif - #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) #include #ifdef HAS_MSG @@ -48,524 +27,676 @@ #endif #ifdef HAS_SHM #include +# ifndef HAS_SHMAT_PROTOTYPE + extern Shmat_t shmat _((int, char *, int)); +# endif #endif #endif -#ifdef I_PWD -#include -#endif -#ifdef I_GRP -#include -#endif #ifdef I_UTIME -#include +# if defined(_MSC_VER) || defined(__MINGW32__) +# include +# else +# include +# endif #endif + #ifdef I_FCNTL #include #endif #ifdef I_SYS_FILE #include #endif +#ifdef O_EXCL +# define OPEN_EXCL O_EXCL +#else +# define OPEN_EXCL 0 +#endif + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#include +#endif -int laststatval = -1; -int laststype = O_STAT; +/* XXX If this causes problems, set i_unistd=undef in the hint file. */ +#ifdef I_UNISTD +# include +#endif + +#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ +# include +# include +# ifndef ENOTSOCK +# ifdef I_NET_ERRNO +# include +# endif +# endif +#endif + +/* Put this after #includes because defines _XOPEN_*. */ +#ifndef Sock_size_t +# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__) +# define Sock_size_t Size_t +# else +# define Sock_size_t int +# endif +#endif bool -do_open(stab,name,len) -STAB *stab; -register char *name; -int len; +do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp) { - FILE *fp; - register STIO *stio = stab_io(stab); - char *myname = savestr(name); - int result; - int fd; - int writing = 0; - char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ - FILE *saveifp = Nullfp; - FILE *saveofp = Nullfp; + register IO *io = GvIOn(gv); + PerlIO *saveifp = Nullfp; + PerlIO *saveofp = Nullfp; char savetype = ' '; + int writing = 0; + PerlIO *fp; + int fd; + int result; + bool was_fdopen = FALSE; + + PL_forkprocess = 1; /* assume true if no fork */ - name = myname; - forkprocess = 1; /* assume true if no fork */ - while (len && isspace(name[len-1])) - name[--len] = '\0'; - if (!stio) - stio = stab_io(stab) = stio_new(); - else if (stio->ifp) { - fd = fileno(stio->ifp); - if (stio->type == '-') + if (IoIFP(io)) { + fd = PerlIO_fileno(IoIFP(io)); + if (IoTYPE(io) == '-') result = 0; - else if (fd <= maxsysfd) { - saveifp = stio->ifp; - saveofp = stio->ofp; - savetype = stio->type; + else if (fd <= PL_maxsysfd) { + saveifp = IoIFP(io); + saveofp = IoOFP(io); + savetype = IoTYPE(io); result = 0; } - else if (stio->type == '|') - result = mypclose(stio->ifp); - else if (stio->ifp != stio->ofp) { - if (stio->ofp) { - result = fclose(stio->ofp); - fclose(stio->ifp); /* clear stdio, fd already closed */ + else if (IoTYPE(io) == '|') + result = PerlProc_pclose(IoIFP(io)); + else if (IoIFP(io) != IoOFP(io)) { + if (IoOFP(io)) { + result = PerlIO_close(IoOFP(io)); + PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ } else - result = fclose(stio->ifp); + result = PerlIO_close(IoIFP(io)); } else - result = fclose(stio->ifp); - if (result == EOF && fd > maxsysfd) - fprintf(stderr,"Warning: unable to close filehandle %s properly.\n", - stab_name(stab)); - stio->ofp = stio->ifp = Nullfp; - } - if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */ - mode[1] = *name++; - mode[2] = '\0'; - --len; - writing = 1; - } - else { - mode[1] = '\0'; - } - stio->type = *name; - if (*name == '|') { - for (name++; isspace(*name); name++) ; -#ifdef TAINT - taintenv(); - taintproper("Insecure dependency in piped open"); + result = PerlIO_close(IoIFP(io)); + if (result == EOF && fd > PL_maxsysfd) + PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n", + GvENAME(gv)); + IoOFP(io) = IoIFP(io) = Nullfp; + } + + if (as_raw) { +#ifndef O_ACCMODE +#define O_ACCMODE 3 /* Assume traditional implementation */ +#endif + switch (result = rawmode & O_ACCMODE) { + case O_RDONLY: + IoTYPE(io) = '<'; + break; + case O_WRONLY: + IoTYPE(io) = '>'; + break; + case O_RDWR: + default: + IoTYPE(io) = '+'; + break; + } + + writing = (result > 0); + fd = PerlLIO_open3(name, rawmode, rawperm); + + if (fd == -1) + fp = NULL; + else { + char *fpmode; + if (result == O_RDONLY) + fpmode = "r"; +#ifdef O_APPEND + else if (rawmode & O_APPEND) + fpmode = (result == O_WRONLY) ? "a" : "a+"; #endif - fp = mypopen(name,"w"); - writing = 1; + else + fpmode = (result == O_WRONLY) ? "w" : "r+"; + fp = PerlIO_fdopen(fd, fpmode); + if (!fp) + PerlLIO_close(fd); + } } - else if (*name == '>') { -#ifdef TAINT - taintproper("Insecure dependency in open"); -#endif - name++; - if (*name == '>') { - mode[0] = stio->type = 'a'; - name++; + else { + char *myname; + char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ + int dodup; + + myname = savepvn(name, len); + SAVEFREEPV(myname); + name = myname; + while (len && isSPACE(name[len-1])) + name[--len] = '\0'; + + mode[0] = mode[1] = mode[2] = '\0'; + IoTYPE(io) = *name; + if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */ + mode[1] = *name++; + --len; + writing = 1; } - else - mode[0] = 'w'; - writing = 1; - if (*name == '&') { - duplicity: + + if (*name == '|') { + /*SUPPRESS 530*/ + for (name++; isSPACE(*name); name++) ; + if (strNE(name,"-")) + TAINT_ENV(); + TAINT_PROPER("piped open"); + if (name[strlen(name)-1] == '|') { + dTHR; + name[strlen(name)-1] = '\0' ; + if (ckWARN(WARN_PIPE)) + warner(WARN_PIPE, "Can't do bidirectional pipe"); + } + fp = PerlProc_popen(name,"w"); + writing = 1; + } + else if (*name == '>') { + TAINT_PROPER("open"); name++; - while (isspace(*name)) + if (*name == '>') { + mode[0] = IoTYPE(io) = 'a'; name++; - if (isdigit(*name)) - fd = atoi(name); - else { - stab = stabent(name,FALSE); - if (!stab || !stab_io(stab)) { -#ifdef EINVAL - errno = EINVAL; -#endif - goto say_false; - } - if (stab_io(stab) && stab_io(stab)->ifp) { - fd = fileno(stab_io(stab)->ifp); - if (stab_io(stab)->type == 's') - stio->type = 's'; - } - else - fd = -1; - } - if (!(fp = fdopen(fd = dup(fd),mode))) { - close(fd); } - } - else { - while (isspace(*name)) + else + mode[0] = 'w'; + writing = 1; + + if (*name == '&') { + duplicity: + dodup = 1; name++; - if (strEQ(name,"-")) { - fp = stdout; - stio->type = '-'; + if (*name == '=') { + dodup = 0; + name++; + } + if (!*name && supplied_fp) + fp = supplied_fp; + else { + /*SUPPRESS 530*/ + for (; isSPACE(*name); name++) ; + if (isDIGIT(*name)) + fd = atoi(name); + else { + IO* thatio; + gv = gv_fetchpv(name,FALSE,SVt_PVIO); + thatio = GvIO(gv); + if (!thatio) { +#ifdef EINVAL + SETERRNO(EINVAL,SS$_IVCHAN); +#endif + goto say_false; + } + if (IoIFP(thatio)) { + fd = PerlIO_fileno(IoIFP(thatio)); + if (IoTYPE(thatio) == 's') + IoTYPE(io) = 's'; + } + else + fd = -1; + } + if (dodup) + fd = PerlLIO_dup(fd); + else + was_fdopen = TRUE; + if (!(fp = PerlIO_fdopen(fd,mode))) { + if (dodup) + PerlLIO_close(fd); + } + } } - else { - fp = fopen(name,mode); + else { + /*SUPPRESS 530*/ + for (; isSPACE(*name); name++) ; + if (strEQ(name,"-")) { + fp = PerlIO_stdout(); + IoTYPE(io) = '-'; + } + else { + fp = PerlIO_open(name,mode); + } } } - } - else { - if (*name == '<') { + else if (*name == '<') { + /*SUPPRESS 530*/ + for (name++; isSPACE(*name); name++) ; mode[0] = 'r'; - name++; - while (isspace(*name)) - name++; if (*name == '&') goto duplicity; if (strEQ(name,"-")) { - fp = stdin; - stio->type = '-'; + fp = PerlIO_stdin(); + IoTYPE(io) = '-'; } else - fp = fopen(name,mode); + fp = PerlIO_open(name,mode); } - else if (name[len-1] == '|') { -#ifdef TAINT - taintenv(); - taintproper("Insecure dependency in piped open"); -#endif + else if (len > 1 && name[len-1] == '|') { name[--len] = '\0'; - while (len && isspace(name[len-1])) + while (len && isSPACE(name[len-1])) name[--len] = '\0'; - for (; isspace(*name); name++) ; - fp = mypopen(name,"r"); - stio->type = '|'; + /*SUPPRESS 530*/ + for (; isSPACE(*name); name++) ; + if (strNE(name,"-")) + TAINT_ENV(); + TAINT_PROPER("piped open"); + fp = PerlProc_popen(name,"r"); + IoTYPE(io) = '|'; } else { - stio->type = '<'; - for (; isspace(*name); name++) ; + IoTYPE(io) = '<'; + /*SUPPRESS 530*/ + for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { - fp = stdin; - stio->type = '-'; + fp = PerlIO_stdin(); + IoTYPE(io) = '-'; } else - fp = fopen(name,"r"); + fp = PerlIO_open(name,"r"); } } - Safefree(myname); - if (!fp) + if (!fp) { + dTHR; + if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n')) + warner(WARN_NEWLINE, warn_nl, "open"); goto say_false; - if (stio->type && - stio->type != '|' && stio->type != '-') { - if (fstat(fileno(fp),&statbuf) < 0) { - (void)fclose(fp); + } + if (IoTYPE(io) && + IoTYPE(io) != '|' && IoTYPE(io) != '-') { + dTHR; + if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) { + (void)PerlIO_close(fp); goto say_false; } - if (S_ISSOCK(statbuf.st_mode) || (S_ISCHR(statbuf.st_mode) && writing)) - stio->type = 's'; /* in case a socket was passed in to us */ + if (S_ISSOCK(PL_statbuf.st_mode)) + IoTYPE(io) = 's'; /* in case a socket was passed in to us */ +#ifdef HAS_SOCKET + else if ( #ifdef S_IFMT - else if (!(statbuf.st_mode & S_IFMT)) - stio->type = 's'; /* some OS's return 0 on fstat()ed socket */ + !(PL_statbuf.st_mode & S_IFMT) +#else + !PL_statbuf.st_mode +#endif + ) { + char tmpbuf[256]; + Sock_size_t buflen = sizeof tmpbuf; + if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf, + &buflen) >= 0 + || errno != ENOTSOCK) + IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */ + /* but some return 0 for streams too, sigh */ + } #endif } -#if defined(HAS_FCNTL) && defined(F_SETFD) - fd = fileno(fp); - fcntl(fd,F_SETFD,fd > maxsysfd); -#endif if (saveifp) { /* must use old fp? */ - fd = fileno(saveifp); + fd = PerlIO_fileno(saveifp); if (saveofp) { - fflush(saveofp); /* emulate fclose() */ + PerlIO_flush(saveofp); /* emulate PerlIO_close() */ if (saveofp != saveifp) { /* was a socket? */ - fclose(saveofp); - Safefree(saveofp); + PerlIO_close(saveofp); + if (fd > 2) + Safefree(saveofp); } } - if (fd != fileno(fp)) { - dup2(fileno(fp), fd); - fclose(fp); + if (fd != PerlIO_fileno(fp)) { + int pid; + SV *sv; + + PerlLIO_dup2(PerlIO_fileno(fp), fd); + sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); + (void)SvUPGRADE(sv, SVt_IV); + pid = SvIVX(sv); + SvIVX(sv) = 0; + sv = *av_fetch(PL_fdpid,fd,TRUE); + (void)SvUPGRADE(sv, SVt_IV); + SvIVX(sv) = pid; + if (!was_fdopen) + PerlIO_close(fp); + } fp = saveifp; + PerlIO_clearerr(fp); } - stio->ifp = fp; +#if defined(HAS_FCNTL) && defined(F_SETFD) + fd = PerlIO_fileno(fp); + fcntl(fd,F_SETFD,fd > PL_maxsysfd); +#endif + IoIFP(io) = fp; if (writing) { - if (stio->type != 's') - stio->ofp = fp; - else - if (!(stio->ofp = fdopen(fileno(fp),"w"))) { - fclose(fp); - stio->ifp = Nullfp; + dTHR; + if (IoTYPE(io) == 's' + || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) { + if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) { + PerlIO_close(fp); + IoIFP(io) = Nullfp; goto say_false; } + } + else + IoOFP(io) = fp; } return TRUE; say_false: - stio->ifp = saveifp; - stio->ofp = saveofp; - stio->type = savetype; + IoIFP(io) = saveifp; + IoOFP(io) = saveofp; + IoTYPE(io) = savetype; return FALSE; } -FILE * -nextargv(stab) -register STAB *stab; +PerlIO * +nextargv(register GV *gv) { - register STR *str; + register SV *sv; +#ifndef FLEXFILENAMES int filedev; int fileino; +#endif int fileuid; int filegid; - static int filemode = 0; - static int lastfd; - static char *oldname; - - if (!argvoutstab) - argvoutstab = stabent("ARGVOUT",TRUE); - if (filemode & (S_ISUID|S_ISGID)) { - fflush(stab_io(argvoutstab)->ifp); /* chmod must follow last write */ + + if (!PL_argvoutgv) + PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); + if (PL_filemode & (S_ISUID|S_ISGID)) { + PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD - (void)fchmod(lastfd,filemode); + (void)fchmod(PL_lastfd,PL_filemode); #else - (void)chmod(oldname,filemode); -#endif - } - filemode = 0; - while (alen(stab_xarray(stab)) >= 0) { - str = ashift(stab_xarray(stab)); - str_sset(stab_val(stab),str); - STABSET(stab_val(stab)); - oldname = str_get(stab_val(stab)); - if (do_open(stab,oldname,stab_val(stab)->str_cur)) { - if (inplace) { -#ifdef TAINT - taintproper("Insecure dependency in inplace open"); -#endif - if (strEQ(oldname,"-")) { - str_free(str); - defoutstab = stabent("STDOUT",TRUE); - return stab_io(stab)->ifp; + (void)PerlLIO_chmod(PL_oldname,PL_filemode); +#endif + } + PL_filemode = 0; + while (av_len(GvAV(gv)) >= 0) { + dTHR; + STRLEN oldlen; + sv = av_shift(GvAV(gv)); + SAVEFREESV(sv); + sv_setsv(GvSV(gv),sv); + SvSETMAGIC(GvSV(gv)); + PL_oldname = SvPVx(GvSV(gv), oldlen); + if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) { + if (PL_inplace) { + TAINT_PROPER("inplace open"); + if (oldlen == 1 && *PL_oldname == '-') { + setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); + return IoIFP(GvIOp(gv)); } - filedev = statbuf.st_dev; - fileino = statbuf.st_ino; - filemode = statbuf.st_mode; - fileuid = statbuf.st_uid; - filegid = statbuf.st_gid; - if (!S_ISREG(filemode)) { +#ifndef FLEXFILENAMES + filedev = PL_statbuf.st_dev; + fileino = PL_statbuf.st_ino; +#endif + PL_filemode = PL_statbuf.st_mode; + fileuid = PL_statbuf.st_uid; + filegid = PL_statbuf.st_gid; + if (!S_ISREG(PL_filemode)) { warn("Can't do inplace edit: %s is not a regular file", - oldname ); - do_close(stab,FALSE); - str_free(str); + PL_oldname ); + do_close(gv,FALSE); continue; } - if (*inplace) { -#ifdef SUFFIX - add_suffix(str,inplace); -#else - str_cat(str,inplace); -#endif + if (*PL_inplace) { + char *star = strchr(PL_inplace, '*'); + if (star) { + char *begin = PL_inplace; + sv_setpvn(sv, "", 0); + do { + sv_catpvn(sv, begin, star - begin); + sv_catpvn(sv, PL_oldname, oldlen); + begin = ++star; + } while ((star = strchr(begin, '*'))); + if (*begin) + sv_catpv(sv,begin); + } + else { + sv_catpv(sv,PL_inplace); + } #ifndef FLEXFILENAMES - if (stat(str->str_ptr,&statbuf) >= 0 - && statbuf.st_dev == filedev - && statbuf.st_ino == fileino ) { - warn("Can't do inplace edit: %s > 14 characters", - str->str_ptr ); - do_close(stab,FALSE); - str_free(str); + if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0 + && PL_statbuf.st_dev == filedev + && PL_statbuf.st_ino == fileino +#ifdef DJGPP + || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0 +#endif + ) { + warn("Can't do inplace edit: %s would not be uniq", + SvPVX(sv) ); + do_close(gv,FALSE); continue; } #endif #ifdef HAS_RENAME -#ifndef MSDOS - if (rename(oldname,str->str_ptr) < 0) { +#ifndef DOSISH + if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { warn("Can't rename %s to %s: %s, skipping file", - oldname, str->str_ptr, strerror(errno) ); - do_close(stab,FALSE); - str_free(str); + PL_oldname, SvPVX(sv), Strerror(errno) ); + do_close(gv,FALSE); continue; } #else - do_close(stab,FALSE); - (void)unlink(str->str_ptr); - (void)rename(oldname,str->str_ptr); - do_open(stab,str->str_ptr,stab_val(stab)->str_cur); -#endif /* MSDOS */ + do_close(gv,FALSE); + (void)PerlLIO_unlink(SvPVX(sv)); + (void)PerlLIO_rename(PL_oldname,SvPVX(sv)); + do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp); +#endif /* DOSISH */ #else - (void)UNLINK(str->str_ptr); - if (link(oldname,str->str_ptr) < 0) { + (void)UNLINK(SvPVX(sv)); + if (link(PL_oldname,SvPVX(sv)) < 0) { warn("Can't rename %s to %s: %s, skipping file", - oldname, str->str_ptr, strerror(errno) ); - do_close(stab,FALSE); - str_free(str); + PL_oldname, SvPVX(sv), Strerror(errno) ); + do_close(gv,FALSE); continue; } - (void)UNLINK(oldname); + (void)UNLINK(PL_oldname); #endif } else { -#ifndef MSDOS - if (UNLINK(oldname) < 0) { - warn("Can't rename %s to %s: %s, skipping file", - oldname, str->str_ptr, strerror(errno) ); - do_close(stab,FALSE); - str_free(str); +#if !defined(DOSISH) && !defined(AMIGAOS) +# ifndef VMS /* Don't delete; use automatic file versioning */ + if (UNLINK(PL_oldname) < 0) { + warn("Can't remove %s: %s, skipping file", + PL_oldname, Strerror(errno) ); + do_close(gv,FALSE); continue; } +# endif #else - fatal("Can't do inplace edit without backup"); + croak("Can't do inplace edit without backup"); #endif } - str_nset(str,">",1); - str_cat(str,oldname); - errno = 0; /* in case sprintf set errno */ - if (!do_open(argvoutstab,str->str_ptr,str->str_cur)) { + sv_setpvn(sv,">",!PL_inplace); + sv_catpvn(sv,PL_oldname,oldlen); + SETERRNO(0,0); /* in case sprintf set errno */ +#ifdef VMS + if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, + O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) { +#else + if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, + O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) { +#endif warn("Can't do inplace edit on %s: %s", - oldname, strerror(errno) ); - do_close(stab,FALSE); - str_free(str); + PL_oldname, Strerror(errno) ); + do_close(gv,FALSE); continue; } - defoutstab = argvoutstab; - lastfd = fileno(stab_io(argvoutstab)->ifp); - (void)fstat(lastfd,&statbuf); + setdefout(PL_argvoutgv); + PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); + (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf); #ifdef HAS_FCHMOD - (void)fchmod(lastfd,filemode); + (void)fchmod(PL_lastfd,PL_filemode); #else - (void)chmod(oldname,filemode); +# if !(defined(WIN32) && defined(__BORLANDC__)) + /* Borland runtime creates a readonly file! */ + (void)PerlLIO_chmod(PL_oldname,PL_filemode); +# endif #endif - if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) { + if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) { #ifdef HAS_FCHOWN - (void)fchown(lastfd,fileuid,filegid); + (void)fchown(PL_lastfd,fileuid,filegid); #else #ifdef HAS_CHOWN - (void)chown(oldname,fileuid,filegid); + (void)PerlLIO_chown(PL_oldname,fileuid,filegid); #endif #endif } } - str_free(str); - return stab_io(stab)->ifp; + return IoIFP(GvIOp(gv)); } else - fprintf(stderr,"Can't open %s: %s\n",str_get(str), strerror(errno)); - str_free(str); + PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n", + SvPV(sv, PL_na), Strerror(errno)); } - if (inplace) { - (void)do_close(argvoutstab,FALSE); - defoutstab = stabent("STDOUT",TRUE); + if (PL_inplace) { + (void)do_close(PL_argvoutgv,FALSE); + setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); } return Nullfp; } #ifdef HAS_PIPE void -do_pipe(str, rstab, wstab) -STR *str; -STAB *rstab; -STAB *wstab; +do_pipe(SV *sv, GV *rgv, GV *wgv) { - register STIO *rstio; - register STIO *wstio; + register IO *rstio; + register IO *wstio; int fd[2]; - if (!rstab) + if (!rgv) goto badexit; - if (!wstab) + if (!wgv) goto badexit; - rstio = stab_io(rstab); - wstio = stab_io(wstab); + rstio = GvIOn(rgv); + wstio = GvIOn(wgv); - if (!rstio) - rstio = stab_io(rstab) = stio_new(); - else if (rstio->ifp) - do_close(rstab,FALSE); - if (!wstio) - wstio = stab_io(wstab) = stio_new(); - else if (wstio->ifp) - do_close(wstab,FALSE); + if (IoIFP(rstio)) + do_close(rgv,FALSE); + if (IoIFP(wstio)) + do_close(wgv,FALSE); - if (pipe(fd) < 0) + if (PerlProc_pipe(fd) < 0) goto badexit; - rstio->ifp = fdopen(fd[0], "r"); - wstio->ofp = fdopen(fd[1], "w"); - wstio->ifp = wstio->ofp; - rstio->type = '<'; - wstio->type = '>'; - if (!rstio->ifp || !wstio->ofp) { - if (rstio->ifp) fclose(rstio->ifp); - else close(fd[0]); - if (wstio->ofp) fclose(wstio->ofp); - else close(fd[1]); + IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); + IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); + IoIFP(wstio) = IoOFP(wstio); + IoTYPE(rstio) = '<'; + IoTYPE(wstio) = '>'; + if (!IoIFP(rstio) || !IoOFP(wstio)) { + if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio)); + else PerlLIO_close(fd[0]); + if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio)); + else PerlLIO_close(fd[1]); goto badexit; } - str_sset(str,&str_yes); + sv_setsv(sv,&PL_sv_yes); return; badexit: - str_sset(str,&str_undef); + sv_setsv(sv,&PL_sv_undef); return; } #endif +/* explicit renamed to avoid C++ conflict -- kja */ bool -do_close(stab,explicit) -STAB *stab; -bool explicit; +do_close(GV *gv, bool not_implicit) { - bool retval = FALSE; - register STIO *stio; - int status; - - if (!stab) - stab = argvstab; - if (!stab) + bool retval; + IO *io; + + if (!gv) + gv = PL_argvgv; + if (!gv || SvTYPE(gv) != SVt_PVGV) { + if (not_implicit) + SETERRNO(EBADF,SS$_IVCHAN); return FALSE; - stio = stab_io(stab); - if (!stio) { /* never opened */ - if (dowarn && explicit) - warn("Close on unopened file <%s>",stab_name(stab)); + } + io = GvIO(gv); + if (!io) { /* never opened */ + if (not_implicit) { + dTHR; + if (ckWARN(WARN_UNOPENED)) + warner(WARN_UNOPENED, + "Close on unopened file <%s>",GvENAME(gv)); + SETERRNO(EBADF,SS$_IVCHAN); + } return FALSE; } - if (stio->ifp) { - if (stio->type == '|') { - status = mypclose(stio->ifp); - retval = (status == 0); - statusvalue = (unsigned short)status & 0xffff; + retval = io_close(io); + if (not_implicit) { + IoLINES(io) = 0; + IoPAGE(io) = 0; + IoLINES_LEFT(io) = IoPAGE_LEN(io); + } + IoTYPE(io) = ' '; + return retval; +} + +bool +io_close(IO *io) +{ + bool retval = FALSE; + int status; + + if (IoIFP(io)) { + if (IoTYPE(io) == '|') { + status = PerlProc_pclose(IoIFP(io)); + STATUS_NATIVE_SET(status); + retval = (STATUS_POSIX == 0); } - else if (stio->type == '-') + else if (IoTYPE(io) == '-') retval = TRUE; else { - if (stio->ofp && stio->ofp != stio->ifp) { /* a socket */ - retval = (fclose(stio->ofp) != EOF); - fclose(stio->ifp); /* clear stdio, fd already closed */ + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ + retval = (PerlIO_close(IoOFP(io)) != EOF); + PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ } else - retval = (fclose(stio->ifp) != EOF); + retval = (PerlIO_close(IoIFP(io)) != EOF); } - stio->ofp = stio->ifp = Nullfp; + IoOFP(io) = IoIFP(io) = Nullfp; + } + else { + SETERRNO(EBADF,SS$_IVCHAN); } - if (explicit) - stio->lines = 0; - stio->type = ' '; + return retval; } bool -do_eof(stab) -STAB *stab; +do_eof(GV *gv) { - register STIO *stio; + dTHR; + register IO *io; int ch; - if (!stab) { /* eof() */ - if (argvstab) - stio = stab_io(argvstab); - else - return TRUE; - } - else - stio = stab_io(stab); + io = GvIO(gv); - if (!stio) + if (!io) return TRUE; - while (stio->ifp) { + while (IoIFP(io)) { -#ifdef STDSTDIO /* (the code works without this) */ - if (stio->ifp->_cnt > 0) /* cheat a little, since */ - return FALSE; /* this is the most usual case */ -#endif + if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ + if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ + return FALSE; /* this is the most usual case */ + } - ch = getc(stio->ifp); + ch = PerlIO_getc(IoIFP(io)); if (ch != EOF) { - (void)ungetc(ch, stio->ifp); + (void)PerlIO_ungetc(IoIFP(io),ch); return FALSE; } -#ifdef STDSTDIO - if (stio->ifp->_cnt < -1) - stio->ifp->_cnt = -1; -#endif - if (!stab) { /* not necessarily a real EOF yet? */ - if (!nextargv(argvstab)) /* get another fp handy */ + if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { + if (PerlIO_get_cnt(IoIFP(io)) < -1) + PerlIO_set_cnt(IoIFP(io),-1); + } + if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ + if (!nextargv(PL_argvgv)) /* get another fp handy */ return TRUE; } else @@ -575,245 +706,130 @@ STAB *stab; } long -do_tell(stab) -STAB *stab; +do_tell(GV *gv) { - register STIO *stio; - - if (!stab) - goto phooey; - - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto phooey; + register IO *io; + register PerlIO *fp; - if (feof(stio->ifp)) - (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */ - - return ftell(stio->ifp); - -phooey: - if (dowarn) - warn("tell() on unopened file"); + if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { +#ifdef ULTRIX_STDIO_BOTCH + if (PerlIO_eof(fp)) + (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ +#endif + return PerlIO_tell(fp); + } + { + dTHR; + if (ckWARN(WARN_UNOPENED)) + warner(WARN_UNOPENED, "tell() on unopened file"); + } + SETERRNO(EBADF,RMS$_IFI); return -1L; } bool -do_seek(stab, pos, whence) -STAB *stab; -long pos; -int whence; +do_seek(GV *gv, long int pos, int whence) { - register STIO *stio; - - if (!stab) - goto nuts; + register IO *io; + register PerlIO *fp; - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto nuts; - - if (feof(stio->ifp)) - (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */ - - return fseek(stio->ifp, pos, whence) >= 0; - -nuts: - if (dowarn) - warn("seek() on unopened file"); + if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { +#ifdef ULTRIX_STDIO_BOTCH + if (PerlIO_eof(fp)) + (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ +#endif + return PerlIO_seek(fp, pos, whence) >= 0; + } + { + dTHR; + if (ckWARN(WARN_UNOPENED)) + warner(WARN_UNOPENED, "seek() on unopened file"); + } + SETERRNO(EBADF,RMS$_IFI); return FALSE; } -int -do_ctl(optype,stab,func,argstr) -int optype; -STAB *stab; -int func; -STR *argstr; +long +do_sysseek(GV *gv, long int pos, int whence) { - register STIO *stio; - register char *s; - int retval; - - if (!stab || !argstr) - return -1; - stio = stab_io(stab); - if (!stio) - return -1; - - if (argstr->str_pok || !argstr->str_nok) { - if (!argstr->str_pok) - s = str_get(argstr); - -#ifdef IOCPARM_MASK -#ifndef IOCPARM_LEN -#define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK) -#endif -#endif -#ifdef IOCPARM_LEN - retval = IOCPARM_LEN(func); /* on BSDish systes we're safe */ -#else - retval = 256; /* otherwise guess at what's safe */ -#endif - if (argstr->str_cur < retval) { - Str_Grow(argstr,retval+1); - argstr->str_cur = retval; - } + register IO *io; + register PerlIO *fp; - s = argstr->str_ptr; - s[argstr->str_cur] = 17; /* a little sanity check here */ - } - else { - retval = (int)str_gnum(argstr); -#ifdef MSDOS - s = (char*)(long)retval; /* ouch */ -#else - s = (char*)retval; /* ouch */ -#endif - } - -#ifndef lint - if (optype == O_IOCTL) - retval = ioctl(fileno(stio->ifp), func, s); - else -#ifdef MSDOS - fatal("fcntl is not implemented"); -#else -#ifdef HAS_FCNTL - retval = fcntl(fileno(stio->ifp), func, s); -#else - fatal("fcntl is not implemented"); -#endif -#endif -#else /* lint */ - retval = 0; -#endif /* lint */ - - if (argstr->str_pok) { - if (s[argstr->str_cur] != 17) - fatal("Return value overflowed string"); - s[argstr->str_cur] = 0; /* put our null back */ + if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) + return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence); + { + dTHR; + if (ckWARN(WARN_UNOPENED)) + warner(WARN_UNOPENED, "sysseek() on unopened file"); } - return retval; + SETERRNO(EBADF,RMS$_IFI); + return -1L; } int -do_stat(str,arg,gimme,arglast) -STR *str; -register ARG *arg; -int gimme; -int *arglast; +do_binmode(PerlIO *fp, int iotype, int flag) { - register ARRAY *ary = stack; - register int sp = arglast[0] + 1; - int max = 13; - - if ((arg[1].arg_type & A_MASK) == A_WORD) { - tmpstab = arg[1].arg_ptr.arg_stab; - if (tmpstab != defstab) { - laststype = O_STAT; - statstab = tmpstab; - str_set(statname,""); - if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp || - fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) { - max = 0; - laststatval = -1; - } - } - else if (laststatval < 0) - max = 0; + if (flag != TRUE) + croak("panic: unsetting binmode"); /* Not implemented yet */ +#ifdef DOSISH +#ifdef atarist + if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) + return 1; + else + return 0; +#else + if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) { +#if defined(WIN32) && defined(__BORLANDC__) + /* The translation mode of the stream is maintained independent + * of the translation mode of the fd in the Borland RTL (heavy + * digging through their runtime sources reveal). User has to + * set the mode explicitly for the stream (though they don't + * document this anywhere). GSAR 97-5-24 + */ + PerlIO_seek(fp,0L,0); + ((FILE*)fp)->flags |= _F_BIN; +#endif + return 1; } - else { - str_set(statname,str_get(ary->ary_array[sp])); - statstab = Nullstab; -#ifdef HAS_LSTAT - laststype = arg->arg_type; - if (arg->arg_type == O_LSTAT) - laststatval = lstat(str_get(statname),&statcache); - else + else + return 0; #endif - laststatval = stat(str_get(statname),&statcache); - if (laststatval < 0) - max = 0; - } - - if (gimme != G_ARRAY) { - if (max) - str_sset(str,&str_yes); - else - str_sset(str,&str_undef); - STABSET(str); - ary->ary_array[sp] = str; - return sp; - } - sp--; - if (max) { -#ifndef lint - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_dev))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_ino))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_mode))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_nlink))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_uid))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_gid))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_rdev))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_size))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_atime))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_mtime))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_ctime))); -#ifdef STATBLOCKS - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_blksize))); - (void)astore(ary,++sp, - str_2mortal(str_nmake((double)statcache.st_blocks))); #else - (void)astore(ary,++sp, - str_2mortal(str_make("",0))); - (void)astore(ary,++sp, - str_2mortal(str_make("",0))); +#if defined(USEMYBINMODE) + if (my_binmode(fp,iotype) != NULL) + return 1; + else + return 0; +#else + return 1; +#endif #endif -#else /* lint */ - (void)astore(ary,++sp,str_nmake(0.0)); -#endif /* lint */ - } - return sp; } #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) /* code courtesy of William Kucharski */ #define HAS_CHSIZE -int chsize(fd, length) -int fd; /* file descriptor */ -off_t length; /* length to set file to */ +I32 my_chsize(fd, length) +I32 fd; /* file descriptor */ +Off_t length; /* length to set file to */ { - extern long lseek(); struct flock fl; struct stat filebuf; - if (fstat(fd, &filebuf) < 0) + if (PerlLIO_fstat(fd, &filebuf) < 0) return -1; if (filebuf.st_size < length) { /* extend file length */ - if ((lseek(fd, (length - 1), 0)) < 0) + if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) return -1; /* write a "0" byte */ - if ((write(fd, "", 1)) != 1) + if ((PerlLIO_write(fd, "", 1)) != 1) return -1; } else { @@ -833,1535 +849,437 @@ off_t length; /* length to set file to */ */ if (fcntl(fd, F_FREESP, &fl) < 0) - return -1; - - } - - return 0; -} -#endif /* F_FREESP */ - -int -do_truncate(str,arg,gimme,arglast) -STR *str; -register ARG *arg; -int gimme; -int *arglast; -{ - register ARRAY *ary = stack; - register int sp = arglast[0] + 1; - off_t len = (off_t)str_gnum(ary->ary_array[sp+1]); - int result = 1; - STAB *tmpstab; - -#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) -#ifdef HAS_TRUNCATE - if ((arg[1].arg_type & A_MASK) == A_WORD) { - tmpstab = arg[1].arg_ptr.arg_stab; - if (!stab_io(tmpstab) || - ftruncate(fileno(stab_io(tmpstab)->ifp), len) < 0) - result = 0; - } - else if (truncate(str_get(ary->ary_array[sp]), len) < 0) - result = 0; -#else - if ((arg[1].arg_type & A_MASK) == A_WORD) { - tmpstab = arg[1].arg_ptr.arg_stab; - if (!stab_io(tmpstab) || - chsize(fileno(stab_io(tmpstab)->ifp), len) < 0) - result = 0; - } - else { - int tmpfd; - - if ((tmpfd = open(str_get(ary->ary_array[sp]), 0)) < 0) - result = 0; - else { - if (chsize(tmpfd, len) < 0) - result = 0; - close(tmpfd); - } - } -#endif - - if (result) - str_sset(str,&str_yes); - else - str_sset(str,&str_undef); - STABSET(str); - ary->ary_array[sp] = str; - return sp; -#else - fatal("truncate not implemented"); -#endif -} - -int -looks_like_number(str) -STR *str; -{ - register char *s; - register char *send; - - if (!str->str_pok) - return TRUE; - s = str->str_ptr; - send = s + str->str_cur; - while (isspace(*s)) - s++; - if (s >= send) - return FALSE; - if (*s == '+' || *s == '-') - s++; - while (isdigit(*s)) - s++; - if (s == send) - return TRUE; - if (*s == '.') - s++; - else if (s == str->str_ptr) - return FALSE; - while (isdigit(*s)) - s++; - if (s == send) - return TRUE; - if (*s == 'e' || *s == 'E') { - s++; - if (*s == '+' || *s == '-') - s++; - while (isdigit(*s)) - s++; - } - while (isspace(*s)) - s++; - if (s >= send) - return TRUE; - return FALSE; -} - -bool -do_print(str,fp) -register STR *str; -FILE *fp; -{ - register char *tmps; - - if (!fp) { - if (dowarn) - warn("print to unopened file"); - return FALSE; - } - if (!str) - return TRUE; - if (ofmt && - ((str->str_nok && str->str_u.str_nval != 0.0) - || (looks_like_number(str) && str_gnum(str) != 0.0) ) ) { - fprintf(fp, ofmt, str->str_u.str_nval); - return !ferror(fp); - } - else { - tmps = str_get(str); - if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'B' && tmps[3] == '\0' - && str->str_cur == sizeof(STBP) && strlen(tmps) < str->str_cur) { - STR *tmpstr = str_mortal(&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))) - return FALSE; - } - return TRUE; -} - -bool -do_aprint(arg,fp,arglast) -register ARG *arg; -register FILE *fp; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register int retval; - register int items = arglast[2] - sp; - - if (!fp) { - if (dowarn) - warn("print to unopened file"); - return FALSE; - } - st += ++sp; - if (arg->arg_type == O_PRTF) { - do_sprintf(arg->arg_ptr.arg_str,items,st); - retval = do_print(arg->arg_ptr.arg_str,fp); - } - else { - retval = (items <= 0); - for (; items > 0; items--,st++) { - if (retval && ofslen) { - if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) { - retval = FALSE; - break; - } - } - if (!(retval = do_print(*st, fp))) - break; - } - if (retval && orslen) - if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp)) - retval = FALSE; - } - return retval; -} - -int -mystat(arg,str) -ARG *arg; -STR *str; -{ - STIO *stio; - - laststype = O_STAT; - if (arg[1].arg_type & A_DONT) { - stio = stab_io(arg[1].arg_ptr.arg_stab); - if (stio && stio->ifp) { - statstab = arg[1].arg_ptr.arg_stab; - str_set(statname,""); - return (laststatval = fstat(fileno(stio->ifp), &statcache)); - } - else { - if (arg[1].arg_ptr.arg_stab == defstab) - return laststatval; - if (dowarn) - warn("Stat on unopened file <%s>", - stab_name(arg[1].arg_ptr.arg_stab)); - statstab = Nullstab; - str_set(statname,""); - return (laststatval = -1); - } - } - else { - statstab = Nullstab; - str_set(statname,str_get(str)); - return (laststatval = stat(str_get(str),&statcache)); - } -} - -int -mylstat(arg,str) -ARG *arg; -STR *str; -{ - if (arg[1].arg_type & A_DONT) { - if (arg[1].arg_ptr.arg_stab == defstab) { - if (laststype != O_LSTAT) - fatal("The stat preceding -l _ wasn't an lstat"); - return laststatval; - } - fatal("You can't use -l on a filehandle"); - } - - laststype = O_LSTAT; - statstab = Nullstab; - str_set(statname,str_get(str)); -#ifdef HAS_LSTAT - return (laststatval = lstat(str_get(str),&statcache)); -#else - return (laststatval = stat(str_get(str),&statcache)); -#endif -} - -STR * -do_fttext(arg,str) -register ARG *arg; -STR *str; -{ - int i; - int len; - int odd = 0; - STDCHAR tbuf[512]; - register STDCHAR *s; - register STIO *stio; - - if (arg[1].arg_type & A_DONT) { - if (arg[1].arg_ptr.arg_stab == defstab) { - if (statstab) - stio = stab_io(statstab); - else { - str = statname; - goto really_filename; - } - } - else { - statstab = arg[1].arg_ptr.arg_stab; - str_set(statname,""); - stio = stab_io(statstab); - } - if (stio && stio->ifp) { -#ifdef STDSTDIO - fstat(fileno(stio->ifp),&statcache); - if (stio->ifp->_cnt <= 0) { - i = getc(stio->ifp); - if (i != EOF) - (void)ungetc(i,stio->ifp); - } - if (stio->ifp->_cnt <= 0) /* null file is anything */ - return &str_yes; - len = stio->ifp->_cnt + (stio->ifp->_ptr - stio->ifp->_base); - s = stio->ifp->_base; -#else - fatal("-T and -B not implemented on filehandles\n"); -#endif - } - else { - if (dowarn) - warn("Test on unopened file <%s>", - stab_name(arg[1].arg_ptr.arg_stab)); - return &str_undef; - } - } - else { - statstab = Nullstab; - str_set(statname,str_get(str)); - really_filename: - i = open(str_get(str),0); - if (i < 0) - return &str_undef; - fstat(i,&statcache); - len = read(i,tbuf,512); - (void)close(i); - if (len <= 0) /* null file is anything */ - return &str_yes; - s = tbuf; - } - - /* now scan s to look for textiness */ - - for (i = 0; i < len; i++,s++) { - if (!*s) { /* null never allowed in text */ - odd += len; - break; - } - else if (*s & 128) - odd++; - else if (*s < 32 && - *s != '\n' && *s != '\r' && *s != '\b' && - *s != '\t' && *s != '\f' && *s != 27) - odd++; - } - - if ((odd * 10 > len) == (arg->arg_type == O_FTTEXT)) /* allow 10% odd */ - return &str_no; - else - return &str_yes; -} - -bool -do_aexec(really,arglast) -STR *really; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register int items = arglast[2] - sp; - register char **a; - char **argv; - char *tmps; - - if (items) { - New(401,argv, items+1, char*); - a = argv; - for (st += ++sp; items > 0; items--,st++) { - if (*st) - *a++ = str_get(*st); - else - *a++ = ""; - } - *a = Nullch; -#ifdef TAINT - if (*argv[0] != '/') /* will execvp use PATH? */ - taintenv(); /* testing IFS here is overkill, probably */ -#endif - if (really && *(tmps = str_get(really))) - execvp(tmps,argv); - else - execvp(argv[0],argv); - Safefree(argv); - } - return FALSE; -} - -static char **Argv = Null(char **); -static char *Cmd = Nullch; - -void -do_execfree() -{ - if (Argv) { - Safefree(Argv); - Argv = Null(char **); - } - if (Cmd) { - Safefree(Cmd); - Cmd = Nullch; - } -} - -bool -do_exec(cmd) -char *cmd; -{ - register char **a; - register char *s; - char flags[10]; - - /* save an extra exec if possible */ - -#ifdef CSH - if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) { - strcpy(flags,"-c"); - s = cmd+cshlen+3; - if (*s == 'f') { - s++; - strcat(flags,"f"); - } - if (*s == ' ') - s++; - if (*s++ == '\'') { - char *ncmd = s; - - while (*s) - s++; - if (s[-1] == '\n') - *--s = '\0'; - if (s[-1] == '\'') { - *--s = '\0'; - execl(cshname,"csh", flags,ncmd,(char*)0); - *s = '\''; - return FALSE; - } - } - } -#endif /* CSH */ - - /* see if there are shell metacharacters in it */ - - for (s = cmd; *s && isalpha(*s); s++) ; /* catch VAR=val gizmo */ - if (*s == '=') - goto doshell; - for (s = cmd; *s; s++) { - if (*s != ' ' && !isalpha(*s) && index("$&*(){}[]'\";\\|?<>~`\n",*s)) { - if (*s == '\n' && !s[1]) { - *s = '\0'; - break; - } - doshell: - execl("/bin/sh","sh","-c",cmd,(char*)0); - return FALSE; - } - } - New(402,Argv, (s - cmd) / 2 + 2, char*); - Cmd = nsavestr(cmd, s-cmd); - a = Argv; - for (s = Cmd; *s;) { - while (*s && isspace(*s)) s++; - if (*s) - *(a++) = s; - while (*s && !isspace(*s)) s++; - if (*s) - *s++ = '\0'; - } - *a = Nullch; - if (Argv[0]) { - execvp(Argv[0],Argv); - if (errno == ENOEXEC) { /* for system V NIH syndrome */ - do_execfree(); - goto doshell; - } - } - do_execfree(); - return FALSE; -} - -#ifdef HAS_SOCKET -int -do_socket(stab, arglast) -STAB *stab; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register STIO *stio; - int domain, type, protocol, fd; - - if (!stab) - return FALSE; - - stio = stab_io(stab); - if (!stio) - stio = stab_io(stab) = stio_new(); - else if (stio->ifp) - do_close(stab,FALSE); - - domain = (int)str_gnum(st[++sp]); - type = (int)str_gnum(st[++sp]); - protocol = (int)str_gnum(st[++sp]); -#ifdef TAINT - taintproper("Insecure dependency in socket"); -#endif - fd = socket(domain,type,protocol); - if (fd < 0) - return FALSE; - stio->ifp = fdopen(fd, "r"); /* stdio gets confused about sockets */ - stio->ofp = fdopen(fd, "w"); - stio->type = 's'; - if (!stio->ifp || !stio->ofp) { - if (stio->ifp) fclose(stio->ifp); - if (stio->ofp) fclose(stio->ofp); - if (!stio->ifp && !stio->ofp) close(fd); - return FALSE; - } - - return TRUE; -} - -int -do_bind(stab, arglast) -STAB *stab; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register STIO *stio; - char *addr; - - if (!stab) - goto nuts; - - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto nuts; - - addr = str_get(st[++sp]); -#ifdef TAINT - taintproper("Insecure dependency in bind"); -#endif - return bind(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0; - -nuts: - if (dowarn) - warn("bind() on closed fd"); - return FALSE; - -} - -int -do_connect(stab, arglast) -STAB *stab; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register STIO *stio; - char *addr; - - if (!stab) - goto nuts; - - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto nuts; - - addr = str_get(st[++sp]); -#ifdef TAINT - taintproper("Insecure dependency in connect"); -#endif - return connect(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0; - -nuts: - if (dowarn) - warn("connect() on closed fd"); - return FALSE; - -} - -int -do_listen(stab, arglast) -STAB *stab; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register STIO *stio; - int backlog; - - if (!stab) - goto nuts; - - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto nuts; - - backlog = (int)str_gnum(st[++sp]); - return listen(fileno(stio->ifp), backlog) >= 0; - -nuts: - if (dowarn) - warn("listen() on closed fd"); - return FALSE; -} - -void -do_accept(str, nstab, gstab) -STR *str; -STAB *nstab; -STAB *gstab; -{ - register STIO *nstio; - register STIO *gstio; - int len = sizeof buf; - int fd; - - if (!nstab) - goto badexit; - if (!gstab) - goto nuts; - - gstio = stab_io(gstab); - nstio = stab_io(nstab); - - if (!gstio || !gstio->ifp) - goto nuts; - if (!nstio) - nstio = stab_io(nstab) = stio_new(); - else if (nstio->ifp) - do_close(nstab,FALSE); - - fd = accept(fileno(gstio->ifp),(struct sockaddr *)buf,&len); - if (fd < 0) - goto badexit; - nstio->ifp = fdopen(fd, "r"); - nstio->ofp = fdopen(fd, "w"); - nstio->type = 's'; - if (!nstio->ifp || !nstio->ofp) { - if (nstio->ifp) fclose(nstio->ifp); - if (nstio->ofp) fclose(nstio->ofp); - if (!nstio->ifp && !nstio->ofp) close(fd); - goto badexit; - } - - str_nset(str, buf, len); - return; - -nuts: - if (dowarn) - warn("accept() on closed fd"); -badexit: - str_sset(str,&str_undef); - return; -} - -int -do_shutdown(stab, arglast) -STAB *stab; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register STIO *stio; - int how; - - if (!stab) - goto nuts; - - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto nuts; - - how = (int)str_gnum(st[++sp]); - return shutdown(fileno(stio->ifp), how) >= 0; - -nuts: - if (dowarn) - warn("shutdown() on closed fd"); - return FALSE; - -} - -int -do_sopt(optype, stab, arglast) -int optype; -STAB *stab; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register STIO *stio; - int fd; - int lvl; - int optname; - - if (!stab) - goto nuts; - - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto nuts; - - fd = fileno(stio->ifp); - lvl = (int)str_gnum(st[sp+1]); - optname = (int)str_gnum(st[sp+2]); - switch (optype) { - case O_GSOCKOPT: - st[sp] = str_2mortal(str_new(257)); - st[sp]->str_cur = 256; - st[sp]->str_pok = 1; - if (getsockopt(fd, lvl, optname, st[sp]->str_ptr, &st[sp]->str_cur) < 0) - goto nuts; - break; - case O_SSOCKOPT: - st[sp] = st[sp+3]; - if (setsockopt(fd, lvl, optname, st[sp]->str_ptr, st[sp]->str_cur) < 0) - goto nuts; - st[sp] = &str_yes; - break; - } - - return sp; - -nuts: - if (dowarn) - warn("[gs]etsockopt() on closed fd"); - st[sp] = &str_undef; - return sp; - -} - -int -do_getsockname(optype, stab, arglast) -int optype; -STAB *stab; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register STIO *stio; - int fd; - - if (!stab) - goto nuts; - - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto nuts; - - st[sp] = str_2mortal(str_new(257)); - st[sp]->str_cur = 256; - st[sp]->str_pok = 1; - fd = fileno(stio->ifp); - switch (optype) { - case O_GETSOCKNAME: - if (getsockname(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0) - goto nuts2; - break; - case O_GETPEERNAME: - if (getpeername(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0) - goto nuts2; - break; - } - - return sp; - -nuts: - if (dowarn) - warn("get{sock,peer}name() on closed fd"); -nuts2: - st[sp] = &str_undef; - return sp; - -} - -int -do_ghent(which,gimme,arglast) -int which; -int gimme; -int *arglast; -{ - register ARRAY *ary = stack; - register int sp = arglast[0]; - register char **elem; - register STR *str; - struct hostent *gethostbyname(); - struct hostent *gethostbyaddr(); -#ifdef HAS_GETHOSTENT - struct hostent *gethostent(); -#endif - struct hostent *hent; - unsigned long len; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_mortal(&str_undef)); - return sp; - } - - if (which == O_GHBYNAME) { - char *name = str_get(ary->ary_array[sp+1]); - - hent = gethostbyname(name); - } - else if (which == O_GHBYADDR) { - STR *addrstr = ary->ary_array[sp+1]; - int addrtype = (int)str_gnum(ary->ary_array[sp+2]); - char *addr = str_get(addrstr); - - hent = gethostbyaddr(addr,addrstr->str_cur,addrtype); - } - else -#ifdef HAS_GETHOSTENT - hent = gethostent(); -#else - fatal("gethostent not implemented"); -#endif - if (hent) { -#ifndef lint - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, hent->h_name); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - for (elem = hent->h_aliases; *elem; elem++) { - str_cat(str, *elem); - if (elem[1]) - str_ncat(str," ",1); - } - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_numset(str, (double)hent->h_addrtype); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - len = hent->h_length; - str_numset(str, (double)len); -#ifdef h_addr - for (elem = hent->h_addr_list; *elem; elem++) { - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_nset(str, *elem, len); - } -#else - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_nset(str, hent->h_addr, len); -#endif /* h_addr */ -#else /* lint */ - elem = Nullch; - elem = elem; - (void)astore(ary, ++sp, str_mortal(&str_no)); -#endif /* lint */ - } - - return sp; -} - -int -do_gnent(which,gimme,arglast) -int which; -int gimme; -int *arglast; -{ - register ARRAY *ary = stack; - register int sp = arglast[0]; - register char **elem; - register STR *str; - struct netent *getnetbyname(); - struct netent *getnetbyaddr(); - struct netent *getnetent(); - struct netent *nent; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_mortal(&str_undef)); - return sp; - } - - if (which == O_GNBYNAME) { - char *name = str_get(ary->ary_array[sp+1]); - - nent = getnetbyname(name); - } - else if (which == O_GNBYADDR) { - unsigned long addr = U_L(str_gnum(ary->ary_array[sp+1])); - int addrtype = (int)str_gnum(ary->ary_array[sp+2]); + return -1; - nent = getnetbyaddr((long)addr,addrtype); - } - else - nent = getnetent(); - - if (nent) { -#ifndef lint - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, nent->n_name); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - for (elem = nent->n_aliases; *elem; elem++) { - str_cat(str, *elem); - if (elem[1]) - str_ncat(str," ",1); - } - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_numset(str, (double)nent->n_addrtype); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_numset(str, (double)nent->n_net); -#else /* lint */ - elem = Nullch; - elem = elem; - (void)astore(ary, ++sp, str_mortal(&str_no)); -#endif /* lint */ } - return sp; + return 0; } +#endif /* F_FREESP */ -int -do_gpent(which,gimme,arglast) -int which; -int gimme; -int *arglast; +bool +do_print(register SV *sv, PerlIO *fp) { - register ARRAY *ary = stack; - register int sp = arglast[0]; - register char **elem; - register STR *str; - struct protoent *getprotobyname(); - struct protoent *getprotobynumber(); - struct protoent *getprotoent(); - struct protoent *pent; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_mortal(&str_undef)); - return sp; - } - - if (which == O_GPBYNAME) { - char *name = str_get(ary->ary_array[sp+1]); - - pent = getprotobyname(name); - } - else if (which == O_GPBYNUMBER) { - int proto = (int)str_gnum(ary->ary_array[sp+1]); + register char *tmps; + STRLEN len; - pent = getprotobynumber(proto); + /* assuming fp is checked earlier */ + if (!sv) + return TRUE; + if (PL_ofmt) { + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvIOK(sv) && SvIVX(sv) != 0) { + PerlIO_printf(fp, PL_ofmt, (double)SvIVX(sv)); + return !PerlIO_error(fp); + } + if ( (SvNOK(sv) && SvNVX(sv) != 0.0) + || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) { + PerlIO_printf(fp, PL_ofmt, SvNVX(sv)); + return !PerlIO_error(fp); + } } - else - pent = getprotoent(); - - if (pent) { -#ifndef lint - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, pent->p_name); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - for (elem = pent->p_aliases; *elem; elem++) { - str_cat(str, *elem); - if (elem[1]) - str_ncat(str," ",1); + switch (SvTYPE(sv)) { + case SVt_NULL: + { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, warn_uninit); + } + return TRUE; + case SVt_IV: + if (SvIOK(sv)) { + if (SvGMAGICAL(sv)) + mg_get(sv); + PerlIO_printf(fp, "%ld", (long)SvIVX(sv)); + return !PerlIO_error(fp); } - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_numset(str, (double)pent->p_proto); -#else /* lint */ - elem = Nullch; - elem = elem; - (void)astore(ary, ++sp, str_mortal(&str_no)); -#endif /* lint */ + /* FALL THROUGH */ + default: + tmps = SvPV(sv, len); + break; } - - return sp; + if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp))) + return FALSE; + return !PerlIO_error(fp); } -int -do_gsent(which,gimme,arglast) -int which; -int gimme; -int *arglast; +I32 +my_stat(ARGSproto) { - register ARRAY *ary = stack; - register int sp = arglast[0]; - register char **elem; - register STR *str; - struct servent *getservbyname(); - struct servent *getservbynumber(); - struct servent *getservent(); - struct servent *sent; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_mortal(&str_undef)); - return sp; - } - - if (which == O_GSBYNAME) { - char *name = str_get(ary->ary_array[sp+1]); - char *proto = str_get(ary->ary_array[sp+2]); - - if (proto && !*proto) - proto = Nullch; - - sent = getservbyname(name,proto); - } - else if (which == O_GSBYPORT) { - int port = (int)str_gnum(ary->ary_array[sp+1]); - char *proto = str_get(ary->ary_array[sp+2]); - - sent = getservbyport(port,proto); - } - else - sent = getservent(); - if (sent) { -#ifndef lint - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, sent->s_name); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - for (elem = sent->s_aliases; *elem; elem++) { - str_cat(str, *elem); - if (elem[1]) - str_ncat(str," ",1); + djSP; + IO *io; + GV* tmpgv; + + if (PL_op->op_flags & OPf_REF) { + EXTEND(SP,1); + tmpgv = cGVOP->op_gv; + do_fstat: + io = GvIO(tmpgv); + if (io && IoIFP(io)) { + PL_statgv = tmpgv; + sv_setpv(PL_statname,""); + PL_laststype = OP_STAT; + return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache)); + } + else { + if (tmpgv == PL_defgv) + return PL_laststatval; + if (ckWARN(WARN_UNOPENED)) + warner(WARN_UNOPENED, "Stat on unopened file <%s>", + GvENAME(tmpgv)); + PL_statgv = Nullgv; + sv_setpv(PL_statname,""); + return (PL_laststatval = -1); } - (void)astore(ary, ++sp, str = str_mortal(&str_no)); -#ifdef HAS_NTOHS - str_numset(str, (double)ntohs(sent->s_port)); -#else - str_numset(str, (double)(sent->s_port)); -#endif - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, sent->s_proto); -#else /* lint */ - elem = Nullch; - elem = elem; - (void)astore(ary, ++sp, str_mortal(&str_no)); -#endif /* lint */ } + else { + SV* sv = POPs; + char *s; + PUTBACK; + if (SvTYPE(sv) == SVt_PVGV) { + tmpgv = (GV*)sv; + goto do_fstat; + } + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + tmpgv = (GV*)SvRV(sv); + goto do_fstat; + } - return sp; + s = SvPV(sv, PL_na); + PL_statgv = Nullgv; + sv_setpv(PL_statname, s); + PL_laststype = OP_STAT; + PL_laststatval = PerlLIO_stat(s, &PL_statcache); + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n')) + warner(WARN_NEWLINE, warn_nl, "stat"); + return PL_laststatval; + } } -#endif /* HAS_SOCKET */ - -#ifdef HAS_SELECT -int -do_select(gimme,arglast) -int gimme; -int *arglast; +I32 +my_lstat(ARGSproto) { - register STR **st = stack->ary_array; - register int sp = arglast[0]; - register int i; - register int j; - register char *s; - register STR *str; - double value; - int maxlen = 0; - int nfound; - struct timeval timebuf; - struct timeval *tbuf = &timebuf; - int growsize; -#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 - int masksize; - int offset; - char *fd_sets[4]; - int k; - -#if BYTEORDER & 0xf0000 -#define ORDERBYTE (0x88888888 - BYTEORDER) -#else -#define ORDERBYTE (0x4444 - BYTEORDER) -#endif - -#endif - - for (i = 1; i <= 3; i++) { - j = st[sp+i]->str_cur; - if (maxlen < j) - maxlen = j; + djSP; + SV *sv; + if (PL_op->op_flags & OPf_REF) { + EXTEND(SP,1); + if (cGVOP->op_gv == PL_defgv) { + if (PL_laststype != OP_LSTAT) + croak("The stat preceding -l _ wasn't an lstat"); + return PL_laststatval; + } + croak("You can't use -l on a filehandle"); } -#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 - growsize = maxlen; /* little endians can use vecs directly */ + PL_laststype = OP_LSTAT; + PL_statgv = Nullgv; + sv = POPs; + PUTBACK; + sv_setpv(PL_statname,SvPV(sv, PL_na)); +#ifdef HAS_LSTAT + PL_laststatval = PerlLIO_lstat(SvPV(sv, PL_na),&PL_statcache); #else -#ifdef NFDBITS - -#ifndef NBBY -#define NBBY 8 + PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache); #endif + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n')) + warner(WARN_NEWLINE, warn_nl, "lstat"); + return PL_laststatval; +} - masksize = NFDBITS / NBBY; -#else - masksize = sizeof(long); /* documented int, everyone seems to use long */ -#endif - growsize = maxlen + (masksize - (maxlen % masksize)); - Zero(&fd_sets[0], 4, char*); -#endif +bool +do_aexec(SV *really, register SV **mark, register SV **sp) +{ + register char **a; + char *tmps; - for (i = 1; i <= 3; i++) { - str = st[sp+i]; - j = str->str_len; - if (j < growsize) { - if (str->str_pok) { - Str_Grow(str,growsize); - s = str_get(str) + j; - while (++j <= growsize) { - *s++ = '\0'; - } - } - else if (str->str_ptr) { - Safefree(str->str_ptr); - str->str_ptr = Nullch; - } - } -#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 - s = str->str_ptr; - if (s) { - New(403, fd_sets[i], growsize, char); - for (offset = 0; offset < growsize; offset += masksize) { - for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) - fd_sets[i][j+offset] = s[(k % masksize) + offset]; - } - } -#endif - } - str = st[sp+4]; - if (str->str_nok || str->str_pok) { - value = str_gnum(str); - if (value < 0.0) - value = 0.0; - timebuf.tv_sec = (long)value; - value -= (double)timebuf.tv_sec; - timebuf.tv_usec = (long)(value * 1000000.0); - } - else - tbuf = Null(struct timeval*); - -#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 - nfound = select( - maxlen * 8, - st[sp+1]->str_ptr, - st[sp+2]->str_ptr, - st[sp+3]->str_ptr, - tbuf); -#else - nfound = select( - maxlen * 8, - fd_sets[1], - fd_sets[2], - fd_sets[3], - tbuf); - for (i = 1; i <= 3; i++) { - if (fd_sets[i]) { - str = st[sp+i]; - s = str->str_ptr; - for (offset = 0; offset < growsize; offset += masksize) { - for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) - s[(k % masksize) + offset] = fd_sets[i][j+offset]; - } + if (sp > mark) { + dTHR; + New(401,PL_Argv, sp - mark + 1, char*); + a = PL_Argv; + while (++mark <= sp) { + if (*mark) + *a++ = SvPVx(*mark, PL_na); + else + *a++ = ""; } + *a = Nullch; + if (*PL_Argv[0] != '/') /* will execvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ + if (really && *(tmps = SvPV(really, PL_na))) + PerlProc_execvp(tmps,PL_Argv); + else + PerlProc_execvp(PL_Argv[0],PL_Argv); + if (ckWARN(WARN_EXEC)) + warner(WARN_EXEC, "Can't exec \"%s\": %s", + PL_Argv[0], Strerror(errno)); } -#endif - - st[++sp] = str_mortal(&str_no); - str_numset(st[sp], (double)nfound); - if (gimme == G_ARRAY && tbuf) { - value = (double)(timebuf.tv_sec) + - (double)(timebuf.tv_usec) / 1000000.0; - st[++sp] = str_mortal(&str_no); - str_numset(st[sp], value); - } - return sp; + do_execfree(); + return FALSE; } -#endif /* SELECT */ -#ifdef HAS_SOCKET -int -do_spair(stab1, stab2, arglast) -STAB *stab1; -STAB *stab2; -int *arglast; +void +do_execfree(void) { - register STR **st = stack->ary_array; - register int sp = arglast[2]; - register STIO *stio1; - register STIO *stio2; - int domain, type, protocol, fd[2]; - - if (!stab1 || !stab2) - return FALSE; - - stio1 = stab_io(stab1); - stio2 = stab_io(stab2); - if (!stio1) - stio1 = stab_io(stab1) = stio_new(); - else if (stio1->ifp) - do_close(stab1,FALSE); - if (!stio2) - stio2 = stab_io(stab2) = stio_new(); - else if (stio2->ifp) - do_close(stab2,FALSE); - - domain = (int)str_gnum(st[++sp]); - type = (int)str_gnum(st[++sp]); - protocol = (int)str_gnum(st[++sp]); -#ifdef TAINT - taintproper("Insecure dependency in socketpair"); -#endif -#ifdef HAS_SOCKETPAIR - if (socketpair(domain,type,protocol,fd) < 0) - return FALSE; -#else - fatal("Socketpair unimplemented"); -#endif - stio1->ifp = fdopen(fd[0], "r"); - stio1->ofp = fdopen(fd[0], "w"); - stio1->type = 's'; - stio2->ifp = fdopen(fd[1], "r"); - stio2->ofp = fdopen(fd[1], "w"); - stio2->type = 's'; - if (!stio1->ifp || !stio1->ofp || !stio2->ifp || !stio2->ofp) { - if (stio1->ifp) fclose(stio1->ifp); - if (stio1->ofp) fclose(stio1->ofp); - if (!stio1->ifp && !stio1->ofp) close(fd[0]); - if (stio2->ifp) fclose(stio2->ifp); - if (stio2->ofp) fclose(stio2->ofp); - if (!stio2->ifp && !stio2->ofp) close(fd[1]); - return FALSE; + if (PL_Argv) { + Safefree(PL_Argv); + PL_Argv = Null(char **); + } + if (PL_Cmd) { + Safefree(PL_Cmd); + PL_Cmd = Nullch; } - - return TRUE; } -#endif /* HAS_SOCKET */ +#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) -int -do_gpwent(which,gimme,arglast) -int which; -int gimme; -int *arglast; +bool +do_exec(char *cmd) { -#ifdef I_PWD - register ARRAY *ary = stack; - register int sp = arglast[0]; - register STR *str; - struct passwd *getpwnam(); - struct passwd *getpwuid(); - struct passwd *getpwent(); - struct passwd *pwent; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_mortal(&str_undef)); - return sp; - } + register char **a; + register char *s; + char flags[10]; - if (which == O_GPWNAM) { - char *name = str_get(ary->ary_array[sp+1]); + while (*cmd && isSPACE(*cmd)) + cmd++; - pwent = getpwnam(name); - } - else if (which == O_GPWUID) { - int uid = (int)str_gnum(ary->ary_array[sp+1]); + /* save an extra exec if possible */ - pwent = getpwuid(uid); - } - else - pwent = getpwent(); - - if (pwent) { - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, pwent->pw_name); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, pwent->pw_passwd); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_numset(str, (double)pwent->pw_uid); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_numset(str, (double)pwent->pw_gid); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); -#ifdef PWCHANGE - str_numset(str, (double)pwent->pw_change); -#else -#ifdef PWQUOTA - str_numset(str, (double)pwent->pw_quota); -#else -#ifdef PWAGE - str_set(str, pwent->pw_age); -#endif -#endif -#endif - (void)astore(ary, ++sp, str = str_mortal(&str_no)); -#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_mortal(&str_no)); - str_set(str, pwent->pw_gecos); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, pwent->pw_dir); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, pwent->pw_shell); -#ifdef PWEXPIRE - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_numset(str, (double)pwent->pw_expire); -#endif +#ifdef CSH + if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) { + strcpy(flags,"-c"); + s = cmd+PL_cshlen+3; + if (*s == 'f') { + s++; + strcat(flags,"f"); + } + if (*s == ' ') + s++; + if (*s++ == '\'') { + char *ncmd = s; + + while (*s) + s++; + if (s[-1] == '\n') + *--s = '\0'; + if (s[-1] == '\'') { + *--s = '\0'; + PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0); + *s = '\''; + return FALSE; + } + } } +#endif /* CSH */ - return sp; -#else - fatal("password routines not implemented"); -#endif -} + /* see if there are shell metacharacters in it */ -int -do_ggrent(which,gimme,arglast) -int which; -int gimme; -int *arglast; -{ -#ifdef I_GRP - register ARRAY *ary = stack; - register int sp = arglast[0]; - register char **elem; - register STR *str; - struct group *getgrnam(); - struct group *getgrgid(); - struct group *getgrent(); - struct group *grent; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_mortal(&str_undef)); - return sp; - } + if (*cmd == '.' && isSPACE(cmd[1])) + goto doshell; - if (which == O_GGRNAM) { - char *name = str_get(ary->ary_array[sp+1]); + if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) + goto doshell; - grent = getgrnam(name); - } - else if (which == O_GGRGID) { - int gid = (int)str_gnum(ary->ary_array[sp+1]); + for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ + if (*s == '=') + goto doshell; - grent = getgrgid(gid); - } - else - grent = getgrent(); - - if (grent) { - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, grent->gr_name); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_set(str, grent->gr_passwd); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - str_numset(str, (double)grent->gr_gid); - (void)astore(ary, ++sp, str = str_mortal(&str_no)); - for (elem = grent->gr_mem; *elem; elem++) { - str_cat(str, *elem); - if (elem[1]) - str_ncat(str," ",1); + for (s = cmd; *s; s++) { + if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { + if (*s == '\n' && !s[1]) { + *s = '\0'; + break; + } + doshell: + PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0); + return FALSE; } } - return sp; -#else - fatal("group routines not implemented"); -#endif -} - -int -do_dirop(optype,stab,gimme,arglast) -int optype; -STAB *stab; -int gimme; -int *arglast; -{ -#if defined(DIRENT) && defined(HAS_READDIR) - register ARRAY *ary = stack; - register STR **st = ary->ary_array; - register int sp = arglast[1]; - register STIO *stio; - long along; -#ifndef telldir - long telldir(); -#endif -#ifndef apollo - struct DIRENT *readdir(); -#endif - register struct DIRENT *dp; - - if (!stab) - goto nope; - if (!(stio = stab_io(stab))) - stio = stab_io(stab) = stio_new(); - if (!stio->dirp && optype != O_OPEN_DIR) - goto nope; - st[sp] = &str_yes; - switch (optype) { - case O_OPEN_DIR: - if (stio->dirp) - closedir(stio->dirp); - if (!(stio->dirp = opendir(str_get(st[sp+1])))) - goto nope; - break; - case O_READDIR: - if (gimme == G_ARRAY) { - --sp; - while (dp = readdir(stio->dirp)) { -#ifdef DIRNAMLEN - (void)astore(ary,++sp, - str_2mortal(str_make(dp->d_name,dp->d_namlen))); -#else - (void)astore(ary,++sp, - str_2mortal(str_make(dp->d_name,0))); -#endif - } + New(402,PL_Argv, (s - cmd) / 2 + 2, char*); + PL_Cmd = savepvn(cmd, s-cmd); + a = PL_Argv; + for (s = PL_Cmd; *s;) { + while (*s && isSPACE(*s)) s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) s++; + if (*s) + *s++ = '\0'; + } + *a = Nullch; + if (PL_Argv[0]) { + PerlProc_execvp(PL_Argv[0],PL_Argv); + if (errno == ENOEXEC) { /* for system V NIH syndrome */ + do_execfree(); + goto doshell; } - else { - if (!(dp = readdir(stio->dirp))) - goto nope; - st[sp] = str_mortal(&str_undef); -#ifdef DIRNAMLEN - str_nset(st[sp], dp->d_name, dp->d_namlen); -#else - str_set(st[sp], dp->d_name); -#endif + { + dTHR; + if (ckWARN(WARN_EXEC)) + warner(WARN_EXEC, "Can't exec \"%s\": %s", + PL_Argv[0], Strerror(errno)); } - break; -#if MACH - case O_TELLDIR: - case O_SEEKDIR: - goto nope; -#else - case O_TELLDIR: - st[sp] = str_mortal(&str_undef); - str_numset(st[sp], (double)telldir(stio->dirp)); - break; - case O_SEEKDIR: - st[sp] = str_mortal(&str_undef); - along = (long)str_gnum(st[sp+1]); - (void)seekdir(stio->dirp,along); - break; -#endif - case O_REWINDDIR: - st[sp] = str_mortal(&str_undef); - (void)rewinddir(stio->dirp); - break; - case O_CLOSEDIR: - st[sp] = str_mortal(&str_undef); - (void)closedir(stio->dirp); - stio->dirp = 0; - break; } - return sp; - -nope: - st[sp] = &str_undef; - return sp; - -#else - fatal("Unimplemented directory operation"); -#endif + do_execfree(); + return FALSE; } -apply(type,arglast) -int type; -int *arglast; +#endif /* OS2 || WIN32 */ + +I32 +apply(I32 type, register SV **mark, register SV **sp) { - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register int items = arglast[2] - sp; - register int val; - register int val2; - register int tot = 0; + dTHR; + register I32 val; + register I32 val2; + register I32 tot = 0; + char *what; char *s; - -#ifdef TAINT - for (st += ++sp; items--; st++) - tainted |= (*st)->str_tainted; - st = stack->ary_array; - sp = arglast[1]; - items = arglast[2] - sp; -#endif + SV **oldmark = mark; + +#define APPLY_TAINT_PROPER() \ + STMT_START { \ + if (PL_tainting && PL_tainted) { goto taint_proper_label; } \ + } STMT_END + + /* This is a first heuristic; it doesn't catch tainting magic. */ + if (PL_tainting) { + while (++mark <= sp) { + if (SvTAINTED(*mark)) { + TAINT; + break; + } + } + mark = oldmark; + } switch (type) { - case O_CHMOD: -#ifdef TAINT - taintproper("Insecure dependency in chmod"); -#endif - if (--items > 0) { - tot = items; - val = (int)str_gnum(st[++sp]); - while (items--) { - if (chmod(str_get(st[++sp]),val)) + case OP_CHMOD: + what = "chmod"; + APPLY_TAINT_PROPER(); + if (++mark <= sp) { + val = SvIVx(*mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { + char *name = SvPVx(*mark, PL_na); + APPLY_TAINT_PROPER(); + if (PerlLIO_chmod(name, val)) tot--; } } break; #ifdef HAS_CHOWN - case O_CHOWN: -#ifdef TAINT - taintproper("Insecure dependency in chown"); -#endif - if (items > 2) { - items -= 2; - tot = items; - val = (int)str_gnum(st[++sp]); - val2 = (int)str_gnum(st[++sp]); - while (items--) { - if (chown(str_get(st[++sp]),val,val2)) + case OP_CHOWN: + what = "chown"; + APPLY_TAINT_PROPER(); + if (sp - mark > 2) { + val = SvIVx(*++mark); + val2 = SvIVx(*++mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { + char *name = SvPVx(*mark, PL_na); + APPLY_TAINT_PROPER(); + if (PerlLIO_chown(name, val, val2)) tot--; } } break; #endif +/* +XXX Should we make lchown() directly available from perl? +For now, we'll let Configure test for HAS_LCHOWN, but do +nothing in the core. + --AD 5/1998 +*/ #ifdef HAS_KILL - case O_KILL: -#ifdef TAINT - taintproper("Insecure dependency in kill"); -#endif - if (--items > 0) { - tot = items; - s = str_get(st[++sp]); - if (isupper(*s)) { - if (*s == 'S' && s[1] == 'I' && s[2] == 'G') - s += 3; - if (!(val = whichsig(s))) - fatal("Unrecognized signal name \"%s\"",s); + case OP_KILL: + what = "kill"; + APPLY_TAINT_PROPER(); + if (mark == sp) + break; + s = SvPVx(*++mark, PL_na); + if (isUPPER(*s)) { + if (*s == 'S' && s[1] == 'I' && s[2] == 'G') + s += 3; + if (!(val = whichsig(s))) + croak("Unrecognized signal name \"%s\"",s); + } + else + val = SvIVx(*mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; +#ifdef VMS + /* kill() doesn't do process groups (job trees?) under VMS */ + if (val < 0) val = -val; + if (val == SIGKILL) { +# include + /* Use native sys$delprc() to insure that target process is + * deleted; supervisor-mode images don't pay attention to + * CRTL's emulation of Unix-style signals and kill() + */ + while (++mark <= sp) { + I32 proc = SvIVx(*mark); + register unsigned long int __vmssts; + APPLY_TAINT_PROPER(); + if (!((__vmssts = sys$delprc(&proc,0)) & 1)) { + tot--; + switch (__vmssts) { + case SS$_NONEXPR: + case SS$_NOSUCHNODE: + SETERRNO(ESRCH,__vmssts); + break; + case SS$_NOPRIV: + SETERRNO(EPERM,__vmssts); + break; + default: + SETERRNO(EVMSERR,__vmssts); + } + } } - else - val = (int)str_gnum(st[sp]); - if (val < 0) { - val = -val; - while (items--) { - int proc = (int)str_gnum(st[++sp]); + break; + } +#endif + if (val < 0) { + val = -val; + while (++mark <= sp) { + I32 proc = SvIVx(*mark); + APPLY_TAINT_PROPER(); #ifdef HAS_KILLPG - if (killpg(proc,val)) /* BSD */ + if (PerlProc_killpg(proc,val)) /* BSD */ #else - if (kill(-proc,val)) /* SYSV */ + if (PerlProc_kill(-proc,val)) /* SYSV */ #endif - tot--; - } + tot--; } - else { - while (items--) { - if (kill((int)(str_gnum(st[++sp])),val)) - tot--; - } + } + else { + while (++mark <= sp) { + I32 proc = SvIVx(*mark); + APPLY_TAINT_PROPER(); + if (PerlProc_kill(proc, val)) + tot--; } } break; #endif - case O_UNLINK: -#ifdef TAINT - taintproper("Insecure dependency in unlink"); -#endif - tot = items; - while (items--) { - s = str_get(st[++sp]); - if (euid || unsafe) { + case OP_UNLINK: + what = "unlink"; + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { + s = SvPVx(*mark, PL_na); + APPLY_TAINT_PROPER(); + if (PL_euid || PL_unsafe) { if (UNLINK(s)) tot--; } else { /* don't let root wipe out directories without -U */ #ifdef HAS_LSTAT - if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) + if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode)) #else - if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) + if (PerlLIO_stat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode)) #endif tot--; else { @@ -2371,12 +1289,12 @@ int *arglast; } } break; - case O_UTIME: -#ifdef TAINT - taintproper("Insecure dependency in utime"); -#endif - if (items > 2) { -#ifdef I_UTIME +#ifdef HAS_UTIME + case OP_UTIME: + what = "utime"; + APPLY_TAINT_PROPER(); + if (sp - mark > 2) { +#if defined(I_UTIME) || defined(VMS) struct utimbuf utbuf; #else struct { @@ -2386,33 +1304,42 @@ int *arglast; #endif Zero(&utbuf, sizeof utbuf, char); - utbuf.actime = (long)str_gnum(st[++sp]); /* time accessed */ - utbuf.modtime = (long)str_gnum(st[++sp]); /* time modified */ - items -= 2; -#ifndef lint - tot = items; - while (items--) { - if (utime(str_get(st[++sp]),&utbuf)) +#ifdef BIG_TIME + utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */ + utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */ +#else + utbuf.actime = SvIVx(*++mark); /* time accessed */ + utbuf.modtime = SvIVx(*++mark); /* time modified */ +#endif + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { + char *name = SvPVx(*mark, PL_na); + APPLY_TAINT_PROPER(); + if (PerlLIO_utime(name, &utbuf)) tot--; } -#endif } else - items = 0; + tot = 0; break; +#endif } return tot; + + taint_proper_label: + TAINT_PROPER(what); + return 0; /* this should never happen */ + +#undef APPLY_TAINT_PROPER } /* Do the permissions allow some operation? Assumes statcache already set. */ - -int -cando(bit, effective, statbufp) -int bit; -int effective; -register struct stat *statbufp; +#ifndef VMS /* VMS' cando is in vms.c */ +I32 +cando(I32 bit, I32 effective, register struct stat *statbufp) { -#ifdef MSDOS +#ifdef DOSISH /* [Comments and code from Len Reed] * MS-DOS "user" is similar to UNIX's "superuser," but can't write * to write-protected files. The execute permission bit is set @@ -2431,10 +1358,13 @@ register struct stat *statbufp; * Sun's PC-NFS.] */ + /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat + * too so it will actually look into the files for magic numbers + */ return (bit & statbufp->st_mode) ? TRUE : FALSE; -#else /* ! MSDOS */ - if ((effective ? euid : uid) == 0) { /* root is special */ +#else /* ! DOSISH */ + if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */ if (bit == S_IXUSR) { if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) return TRUE; @@ -2443,34 +1373,33 @@ register struct stat *statbufp; return TRUE; /* root reads and writes anything */ return FALSE; } - if (statbufp->st_uid == (effective ? euid : uid) ) { + if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) { if (statbufp->st_mode & bit) return TRUE; /* ok as "user" */ } - else if (ingroup((int)statbufp->st_gid,effective)) { + else if (ingroup((I32)statbufp->st_gid,effective)) { if (statbufp->st_mode & bit >> 3) return TRUE; /* ok as "group" */ } else if (statbufp->st_mode & bit >> 6) return TRUE; /* ok as "other" */ return FALSE; -#endif /* ! MSDOS */ +#endif /* ! DOSISH */ } +#endif /* ! VMS */ -int -ingroup(testgid,effective) -int testgid; -int effective; +I32 +ingroup(I32 testgid, I32 effective) { - if (testgid == (effective ? egid : gid)) + if (testgid == (effective ? PL_egid : PL_gid)) return TRUE; #ifdef HAS_GETGROUPS #ifndef NGROUPS #define NGROUPS 32 #endif { - GROUPSTYPE gary[NGROUPS]; - int anum; + Groups_t gary[NGROUPS]; + I32 anum; anum = getgroups(NGROUPS,gary); while (--anum >= 0) @@ -2483,85 +1412,82 @@ int effective; #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) -int -do_ipcget(optype, arglast) -int optype; -int *arglast; +I32 +do_ipcget(I32 optype, SV **mark, SV **sp) { - register STR **st = stack->ary_array; - register int sp = arglast[0]; + dTHR; key_t key; - int n, flags; + I32 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; + key = (key_t)SvNVx(*++mark); + n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark); + flags = SvIVx(*++mark); + SETERRNO(0,0); switch (optype) { #ifdef HAS_MSG - case O_MSGGET: + case OP_MSGGET: return msgget(key, flags); #endif #ifdef HAS_SEM - case O_SEMGET: + case OP_SEMGET: return semget(key, n, flags); #endif #ifdef HAS_SHM - case O_SHMGET: + case OP_SHMGET: return shmget(key, n, flags); #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: - fatal("%s not implemented", opname[optype]); + croak("%s not implemented", op_desc[optype]); #endif } return -1; /* should never happen */ } -int -do_ipcctl(optype, arglast) -int optype; -int *arglast; +I32 +do_ipcctl(I32 optype, SV **mark, SV **sp) { - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *astr; + dTHR; + SV *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]; + I32 id, n, cmd, infosize, getinfo; + I32 ret = -1; + id = SvIVx(*++mark); + n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; + cmd = SvIVx(*++mark); + astr = *++mark; infosize = 0; getinfo = (cmd == IPC_STAT); switch (optype) { #ifdef HAS_MSG - case O_MSGCTL: + case OP_MSGCTL: if (cmd == IPC_STAT || cmd == IPC_SET) infosize = sizeof(struct msqid_ds); break; #endif #ifdef HAS_SHM - case O_SHMCTL: + case OP_SHMCTL: if (cmd == IPC_STAT || cmd == IPC_SET) infosize = sizeof(struct shmid_ds); break; #endif #ifdef HAS_SEM - case O_SEMCTL: + case OP_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; + union semun semun; + + semun.buf = &semds; getinfo = (cmd == GETALL); + if (Semctl(id, 0, IPC_STAT, semun) == -1) + return -1; infosize = semds.sem_nsems * sizeof(short); /* "short" is technically wrong but much more portable than guessing about u_?short(_t)? */ @@ -2570,198 +1496,196 @@ int *arglast; #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: - fatal("%s not implemented", opname[optype]); + croak("%s not implemented", op_desc[optype]); #endif } if (infosize) { + STRLEN len; if (getinfo) { - STR_GROW(astr, infosize+1); - a = str_get(astr); + SvPV_force(astr, len); + a = SvGROW(astr, infosize+1); } else { - a = str_get(astr); - if (astr->str_cur != infosize) - { - errno = EINVAL; - return -1; - } + a = SvPV(astr, len); + if (len != infosize) + croak("Bad arg length for %s, is %lu, should be %ld", + op_desc[optype], (unsigned long)len, (long)infosize); } } else { - int i = (int)str_gnum(astr); + IV i = SvIV(astr); a = (char *)i; /* ouch */ } - errno = 0; + SETERRNO(0,0); switch (optype) { #ifdef HAS_MSG - case O_MSGCTL: - ret = msgctl(id, cmd, a); + case OP_MSGCTL: + ret = msgctl(id, cmd, (struct msqid_ds *)a); break; #endif #ifdef HAS_SEM - case O_SEMCTL: - ret = semctl(id, n, cmd, a); + case OP_SEMCTL: { + union semun unsemds; + + unsemds.buf = (struct semid_ds *)a; + ret = Semctl(id, n, cmd, unsemds); + } break; #endif #ifdef HAS_SHM - case O_SHMCTL: - ret = shmctl(id, cmd, a); + case OP_SHMCTL: + ret = shmctl(id, cmd, (struct shmid_ds *)a); break; #endif } if (getinfo && ret >= 0) { - astr->str_cur = infosize; - astr->str_ptr[infosize] = '\0'; + SvCUR_set(astr, infosize); + *SvEND(astr) = '\0'; + SvSETMAGIC(astr); } return ret; } -int -do_msgsnd(arglast) -int *arglast; +I32 +do_msgsnd(SV **mark, SV **sp) { #ifdef HAS_MSG - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *mstr; + dTHR; + SV *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); + I32 id, msize, flags; + STRLEN len; + + id = SvIVx(*++mark); + mstr = *++mark; + flags = SvIVx(*++mark); + mbuf = SvPV(mstr, len); + if ((msize = len - sizeof(long)) < 0) + croak("Arg too short for msgsnd"); + SETERRNO(0,0); + return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); #else - fatal("msgsnd not implemented"); + croak("msgsnd not implemented"); #endif } -int -do_msgrcv(arglast) -int *arglast; +I32 +do_msgrcv(SV **mark, SV **sp) { #ifdef HAS_MSG - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *mstr; + dTHR; + SV *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); + I32 id, msize, flags, ret; + STRLEN len; + + id = SvIVx(*++mark); + mstr = *++mark; + msize = SvIVx(*++mark); + mtype = (long)SvIVx(*++mark); + flags = SvIVx(*++mark); + if (SvTHINKFIRST(mstr)) { + if (SvREADONLY(mstr)) + croak("Can't msgrcv to readonly var"); + if (SvROK(mstr)) + sv_unref(mstr); + } + SvPV_force(mstr, len); + mbuf = SvGROW(mstr, sizeof(long)+msize+1); + + SETERRNO(0,0); + ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); if (ret >= 0) { - mstr->str_cur = sizeof(long)+ret; - mstr->str_ptr[sizeof(long)+ret] = '\0'; + SvCUR_set(mstr, sizeof(long)+ret); + *SvEND(mstr) = '\0'; } return ret; #else - fatal("msgrcv not implemented"); + croak("msgrcv not implemented"); #endif } -int -do_semop(arglast) -int *arglast; +I32 +do_semop(SV **mark, SV **sp) { #ifdef HAS_SEM - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *opstr; + dTHR; + SV *opstr; char *opbuf; - int id, opsize; + I32 id; + STRLEN opsize; - id = (int)str_gnum(st[++sp]); - opstr = st[++sp]; - opbuf = str_get(opstr); - opsize = opstr->str_cur; + id = SvIVx(*++mark); + opstr = *++mark; + opbuf = SvPV(opstr, opsize); if (opsize < sizeof(struct sembuf) || (opsize % sizeof(struct sembuf)) != 0) { - errno = EINVAL; + SETERRNO(EINVAL,LIB$_INVARG); return -1; } - errno = 0; + SETERRNO(0,0); return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf)); #else - fatal("semop not implemented"); + croak("semop not implemented"); #endif } -int -do_shmio(optype, arglast) -int optype; -int *arglast; +I32 +do_shmio(I32 optype, SV **mark, SV **sp) { #ifdef HAS_SHM - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *mstr; + dTHR; + SV *mstr; char *mbuf, *shm; - int id, mpos, msize; + I32 id, mpos, msize; + STRLEN len; struct shmid_ds shmds; -#ifndef VOIDSHMAT - extern char *shmat(); -#endif - id = (int)str_gnum(st[++sp]); - mstr = st[++sp]; - mpos = (int)str_gnum(st[++sp]); - msize = (int)str_gnum(st[++sp]); - errno = 0; + id = SvIVx(*++mark); + mstr = *++mark; + mpos = SvIVx(*++mark); + msize = SvIVx(*++mark); + SETERRNO(0,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 */ + SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */ return -1; } - shm = (char*)shmat(id, (char*)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0); + shm = (char *)shmat(id, (char*)NULL, (optype == OP_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'; + if (optype == OP_SHMREAD) { + SvPV_force(mstr, len); + mbuf = SvGROW(mstr, msize+1); + + Copy(shm + mpos, mbuf, msize, char); + SvCUR_set(mstr, msize); + *SvEND(mstr) = '\0'; + SvSETMAGIC(mstr); } else { - int n; + I32 n; - if ((n = mstr->str_cur) > msize) + mbuf = SvPV(mstr, len); + if ((n = len) > msize) n = msize; - bcopy(mbuf, shm + mpos, n); + Copy(mbuf, shm + mpos, n, char); if (n < msize) - bzero(shm + mpos + n, msize - n); + memzero(shm + mpos + n, msize - n); } return shmdt(shm); #else - fatal("shm I/O not implemented"); + croak("shm I/O not implemented"); #endif } #endif /* SYSV IPC */ +