X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=664bd15a80ad2436c1600b359182ff5fbfdf5a38;hb=2aea4d4064eddefd1fbe7babfc1d07fc273740b9;hp=54d01cfa811e9f29c6110d169876abc68a608267;hpb=e5d73d7778736a8bd9f7f44aad5289ad2c783a16;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doio.c b/doio.c index 54d01cf..664bd15 100644 --- a/doio.c +++ b/doio.c @@ -1,493 +1,724 @@ -/* $Header: doio.c,v 3.0.1.12 90/10/20 02:04:18 lwall Locked $ +/* doio.c * - * Copyright (c) 1989, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * - * You may distribute under the terms of the GNU General Public License - * as specified in the README file that comes with the perl 3.0 kit. + * 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 3.0.1.12 90/10/20 02:04:18 lwall - * patch37: split out separate Sys V IPC features - * - * 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 - * - * Revision 3.0.1.9 90/08/09 02:56:19 lwall - * patch19: various MSDOS and OS/2 patches folded in - * patch19: prints now check error status better - * patch19: printing a list with null elements only printed front of list - * patch19: on machines with vfork child would allocate memory in parent - * patch19: getsockname and getpeername gave bogus warning on error - * patch19: MACH doesn't have seekdir or telldir - * - * Revision 3.0.1.8 90/03/27 15:44:02 lwall - * patch16: MSDOS support - * patch16: support for machines that can't cast negative floats to unsigned ints - * patch16: system() can lose arguments passed to shell scripts on SysV machines - * - * Revision 3.0.1.7 90/03/14 12:26:24 lwall - * patch15: commands involving execs could cause malloc arena corruption - * - * Revision 3.0.1.6 90/03/12 16:30:07 lwall - * patch13: system 'FOO=bar command' didn't invoke sh as it should - * - * Revision 3.0.1.5 90/02/28 17:01:36 lwall - * patch9: open(FOO,"$filename\0") will now protect trailing spaces in filename - * patch9: removed obsolete checks to avoid opening block devices - * patch9: removed references to acusec and modusec that some utime.h's have - * patch9: added pipe function - * - * Revision 3.0.1.4 89/12/21 19:55:10 lwall - * patch7: select now works on big-endian machines - * patch7: errno may now be a macro with an lvalue - * patch7: ANSI strerror() is now supported - * patch7: Configure now detects DG/UX thingies like [sg]etpgrp2 and utime.h - * - * Revision 3.0.1.3 89/11/17 15:13:06 lwall - * patch5: some systems have symlink() but not lstat() - * patch5: some systems have dirent.h but not readdir() - * - * Revision 3.0.1.2 89/11/11 04:25:51 lwall - * patch2: orthogonalized the file modes some so we can have <& +<& etc. - * patch2: do_open() now detects sockets passed to process from parent - * patch2: fd's above 2 are now closed on exec - * patch2: csh code can now use csh from other than /bin - * patch2: getsockopt, get{sock,peer}name didn't define result properly - * patch2: warn("shutdown") was replicated - * patch2: gethostbyname was misdeclared - * patch2: telldir() is sometimes a macro - * - * Revision 3.0.1.1 89/10/26 23:10:05 lwall - * patch1: Configure now checks for BSD shadow passwords - * - * Revision 3.0 89/10/18 15:10:54 lwall - * 3.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 SOCKET -#include -#include -#endif - -#if defined(SELECT) && (defined(M_UNIX) || defined(M_XENIX)) -#include -#endif - -#ifdef SYSVIPC +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) +#ifndef HAS_SEM #include -#ifdef IPCMSG -#include #endif -#ifdef IPCSEM -#include +#ifdef HAS_MSG +#include #endif -#ifdef IPCSHM +#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 + +/* 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; + register IO *io = GvIOn(gv); + PerlIO *saveifp = Nullfp; + PerlIO *saveofp = Nullfp; + char savetype = ' '; int writing = 0; - char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ - - 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 == '|') - result = mypclose(stio->ifp); - else if (stio->type == '-') + PerlIO *fp; + int fd; + int result; + bool was_fdopen = FALSE; + + PL_forkprocess = 1; /* assume true if no fork */ + + if (IoIFP(io)) { + fd = PerlIO_fileno(IoIFP(io)); + if (IoTYPE(io) == '-') result = 0; - else if (stio->ifp != stio->ofp) { - if (stio->ofp) { - result = fclose(stio->ofp); - fclose(stio->ifp); /* clear stdio, fd already closed */ + else if (fd <= PL_maxsysfd) { + saveifp = IoIFP(io); + saveofp = IoOFP(io); + savetype = IoTYPE(io); + result = 0; + } + 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 > 2) - 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'; + 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; } - stio->type = *name; - if (*name == '|') { - for (name++; isspace(*name); name++) ; -#ifdef TAINT - taintenv(); - taintproper("Insecure dependency in piped open"); -#endif - fp = mypopen(name,"w"); - writing = 1; - } - else if (*name == '>') { -#ifdef TAINT - taintproper("Insecure dependency in open"); + + if (as_raw) { +#if defined(O_LARGEFILE) + rawmode |= O_LARGEFILE; #endif - name++; - if (*name == '>') { - mode[0] = stio->type = 'a'; - name++; + +#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; } - else - mode[0] = 'w'; - writing = 1; - if (*name == '&') { - duplicity: + + 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 + else + fpmode = (result == O_WRONLY) ? "w" : "r+"; + fp = PerlIO_fdopen(fd, fpmode); + if (!fp) + PerlLIO_close(fd); + } + } + 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; + } + + if (*name == '|') { + /*SUPPRESS 530*/ + for (name++; isSPACE(*name); name++) ; + if (*name == '\0') { /* command is missing 19990114 */ + dTHR; + if (ckWARN(WARN_PIPE)) + warner(WARN_PIPE, "Missing command in piped open"); + errno = EPIPE; + goto say_false; + } + 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)) - return 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; } - fp = fdopen(dup(fd),mode); - } - 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 (*name == '\0') { /* command is missing 19990114 */ + dTHR; + if (ckWARN(WARN_PIPE)) + warner(WARN_PIPE, "Missing command in piped open"); + errno = EPIPE; + goto say_false; + } + 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) - return FALSE; - if (stio->type && - stio->type != '|' && stio->type != '-') { - if (fstat(fileno(fp),&statbuf) < 0) { - (void)fclose(fp); - return FALSE; + if (!fp) { + dTHR; + if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n')) + warner(WARN_NEWLINE, PL_warn_nl, "open"); + goto say_false; + } + 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(PL_statbuf.st_mode)) + IoTYPE(io) = 's'; /* in case a socket was passed in to us */ +#ifdef HAS_SOCKET + else if ( +#ifdef S_IFMT + !(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 */ } - result = (statbuf.st_mode & S_IFMT); -#ifdef S_IFSOCK - if (result == S_IFSOCK || result == 0) - stio->type = 's'; /* in case a socket was passed in to us */ #endif } -#if defined(FCNTL) && defined(F_SETFD) - fd = fileno(fp); - fcntl(fd,F_SETFD,fd >= 3); + if (saveifp) { /* must use old fp? */ + fd = PerlIO_fileno(saveifp); + if (saveofp) { + PerlIO_flush(saveofp); /* emulate PerlIO_close() */ + if (saveofp != saveifp) { /* was a socket? */ + PerlIO_close(saveofp); + if (fd > 2) + Safefree(saveofp); + } + } + 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); + } +#if defined(HAS_FCNTL) && defined(F_SETFD) + { + int save_errno = errno; + fd = PerlIO_fileno(fp); + fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */ + errno = save_errno; + } #endif - stio->ifp = fp; + IoIFP(io) = fp; if (writing) { - if (stio->type != 's') - stio->ofp = fp; + 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 - stio->ofp = fdopen(fileno(fp),"w"); + IoOFP(io) = fp; } return TRUE; + +say_false: + 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; - char *oldname; - int filemode,fileuid,filegid; - - 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 - filemode = statbuf.st_mode; - fileuid = statbuf.st_uid; - filegid = statbuf.st_gid; - if (*inplace) { -#ifdef SUFFIX - add_suffix(str,inplace); + register SV *sv; +#ifndef FLEXFILENAMES + int filedev; + int fileino; +#endif + Uid_t fileuid; + Gid_t filegid; + + 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(PL_lastfd,PL_filemode); #else - str_cat(str,inplace); -#endif -#ifdef RENAME -#ifndef MSDOS - (void)rename(oldname,str->str_ptr); + (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)); + } +#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", + PL_oldname ); + do_close(gv,FALSE); + continue; + } + 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 (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 unique", + SvPVX(sv) ); + do_close(gv,FALSE); + continue; + } +#endif +#ifdef HAS_RENAME +#ifndef DOSISH + if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { + warn("Can't rename %s to %s: %s, skipping file", + 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); - (void)link(oldname,str->str_ptr); - (void)UNLINK(oldname); + (void)UNLINK(SvPVX(sv)); + if (link(PL_oldname,SvPVX(sv)) < 0) { + warn("Can't rename %s to %s: %s, skipping file", + PL_oldname, SvPVX(sv), Strerror(errno) ); + do_close(gv,FALSE); + continue; + } + (void)UNLINK(PL_oldname); #endif } else { -#ifndef MSDOS - (void)UNLINK(oldname); +#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)) - fatal("Can't do inplace edit"); - defoutstab = argvoutstab; -#ifdef FCHMOD - (void)fchmod(fileno(stab_io(argvoutstab)->ifp),filemode); + 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 - (void)chmod(oldname,filemode); + if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, + O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) { #endif -#ifdef FCHOWN - (void)fchown(fileno(stab_io(argvoutstab)->ifp),fileuid,filegid); + warn("Can't do inplace edit on %s: %s", + PL_oldname, Strerror(errno) ); + do_close(gv,FALSE); + continue; + } + setdefout(PL_argvoutgv); + PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); + (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf); +#ifdef HAS_FCHMOD + (void)fchmod(PL_lastfd,PL_filemode); +#else +# if !(defined(WIN32) && defined(__BORLANDC__)) + /* Borland runtime creates a readonly file! */ + (void)PerlLIO_chmod(PL_oldname,PL_filemode); +# endif +#endif + if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) { +#ifdef HAS_FCHOWN + (void)fchown(PL_lastfd,fileuid,filegid); #else -#ifdef CHOWN - (void)chown(oldname,fileuid,filegid); +#ifdef HAS_CHOWN + (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\n",str_get(str)); - str_free(str); + PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n", + SvPV(sv, oldlen), 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 PIPE +#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; + 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; - rstio->ifp = fdopen(fd[0], "r"); - wstio->ofp = fdopen(fd[1], "w"); - wstio->ifp = wstio->ofp; - rstio->type = '<'; - wstio->type = '>'; + } - 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; } - 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 @@ -496,1746 +727,586 @@ STAB *stab; return TRUE; } -long -do_tell(stab) -STAB *stab; -{ - register STIO *stio; - - if (!stab) - goto phooey; - - stio = stab_io(stab); - if (!stio || !stio->ifp) - goto phooey; - - 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"); - return -1L; -} - -bool -do_seek(stab, pos, whence) -STAB *stab; -long pos; -int whence; -{ - register STIO *stio; - - if (!stab) - goto nuts; - - 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"); - return FALSE; -} - -int -do_ctl(optype,stab,func,argstr) -int optype; -STAB *stab; -int func; -STR *argstr; +Off_t +do_tell(GV *gv) { - 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); + register IO *io; + register PerlIO *fp; -#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; - } - - 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 */ + 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); } - -#ifndef lint - if (optype == O_IOCTL) - retval = ioctl(fileno(stio->ifp), func, s); - else -#ifdef I_FCNTL - retval = fcntl(fileno(stio->ifp), func, s); -#else - fatal("fcntl is not implemented"); -#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 */ + { + dTHR; + if (ckWARN(WARN_UNOPENED)) + warner(WARN_UNOPENED, "tell() on unopened file"); } - return retval; + SETERRNO(EBADF,RMS$_IFI); + return (Off_t)-1; } -int -do_stat(str,arg,gimme,arglast) -STR *str; -register ARG *arg; -int gimme; -int *arglast; +bool +do_seek(GV *gv, Off_t pos, int whence) { - register ARRAY *ary = stack; - register int sp = arglast[0] + 1; - int max = 13; - register int i; - - if ((arg[1].arg_type & A_MASK) == A_WORD) { - tmpstab = arg[1].arg_ptr.arg_stab; - if (tmpstab != defstab) { - statstab = tmpstab; - str_set(statname,""); - if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp || - fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) { - max = 0; - } - } - } - else { - str_sset(statname,ary->ary_array[sp]); - statstab = Nullstab; -#ifdef LSTAT - if (arg->arg_type == O_LSTAT) - i = lstat(str_get(statname),&statcache); - else -#endif - i = stat(str_get(statname),&statcache); - if (i < 0) - max = 0; - } + register IO *io; + register PerlIO *fp; - 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; + 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; } - sp--; - if (max) { -#ifndef lint - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_dev))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_ino))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_mode))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_nlink))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_uid))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_gid))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_rdev))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_size))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_atime))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_mtime))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_ctime))); -#ifdef STATBLOCKS - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_blksize))); - (void)astore(ary,++sp, - str_2static(str_nmake((double)statcache.st_blocks))); -#else - (void)astore(ary,++sp, - str_2static(str_make("",0))); - (void)astore(ary,++sp, - str_2static(str_make("",0))); -#endif -#else /* lint */ - (void)astore(ary,++sp,str_nmake(0.0)); -#endif /* lint */ + { + dTHR; + if (ckWARN(WARN_UNOPENED)) + warner(WARN_UNOPENED, "seek() on unopened file"); } - return sp; + SETERRNO(EBADF,RMS$_IFI); + return FALSE; } -#if !defined(TRUNCATE) && !defined(CHSIZE) && defined(F_FREESP) - /* code courtesy of William Kucharski */ -#define CHSIZE - -int chsize(fd, length) -int fd; /* file descriptor */ -off_t length; /* length to set file to */ +Off_t +do_sysseek(GV *gv, Off_t pos, int whence) { - extern long lseek(); - struct flock fl; - struct stat filebuf; - - if (fstat(fd, &filebuf) < 0) - return -1; - - if (filebuf.st_size < length) { - - /* extend file length */ - - if ((lseek(fd, (length - 1), 0)) < 0) - return -1; - - /* write a "0" byte */ - - if ((write(fd, "", 1)) != 1) - return -1; - } - else { - /* truncate length */ - - fl.l_whence = 0; - fl.l_len = 0; - fl.l_start = length; - fl.l_type = F_WRLCK; /* write lock on file space */ - - /* - * This relies on the UNDOCUMENTED F_FREESP argument to - * fcntl(2), which truncates the file so that it ends at the - * position indicated by fl.l_start. - * - * Will minor miracles never cease? - */ - - if (fcntl(fd, F_FREESP, &fl) < 0) - return -1; + register IO *io; + register PerlIO *fp; + 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 0; + SETERRNO(EBADF,RMS$_IFI); + return -1L; } -#endif /* F_FREESP */ int -do_truncate(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; - off_t len = (off_t)str_gnum(ary->ary_array[sp+1]); - int result = 1; - STAB *tmpstab; - -#if defined(TRUNCATE) || defined(CHSIZE) -#ifdef 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; + if (flag != TRUE) + croak("panic: unsetting binmode"); /* Not implemented yet */ +#ifdef DOSISH +#if defined(atarist) || defined(__MINT__) + if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) + return 1; + else + return 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); - } + 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 + return 0; #endif - - if (result) - str_sset(str,&str_yes); +#else +#if defined(USEMYBINMODE) + if (my_binmode(fp,iotype) != NULL) + return 1; else - str_sset(str,&str_undef); - STABSET(str); - ary->ary_array[sp] = str; - return sp; + return 0; #else - fatal("truncate not implemented"); + return 1; +#endif #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; -} +#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) + /* code courtesy of William Kucharski */ +#define HAS_CHSIZE -bool -do_print(str,fp) -register STR *str; -FILE *fp; +I32 my_chsize(fd, length) +I32 fd; /* file descriptor */ +Off_t length; /* length to set file to */ { - 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_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))) - 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; - - 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 fstat(fileno(stio->ifp), &statcache); - } - else { - if (arg[1].arg_ptr.arg_stab == defstab) - return 0; - if (dowarn) - warn("Stat on unopened file <%s>", - stab_name(arg[1].arg_ptr.arg_stab)); - statstab = Nullstab; - str_set(statname,""); - return -1; - } - } - else { - statstab = Nullstab; - str_sset(statname,str); - return stat(str_get(str),&statcache); - } -} - -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_sset(statname,str); - really_filename: - i = open(str_get(str),0); - if (i < 0) - return &str_undef; - fstat(i,&statcache); - len = read(i,tbuf,512); - if (len <= 0) /* null file is anything */ - return &str_yes; - (void)close(i); - 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; - -int -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]; - -#ifdef TAINT - taintenv(); - taintproper("Insecure dependency in exec"); -#endif - - /* 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 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'; - - 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),buf,&len); - if (fd < 0) - goto badexit; - nstio->ifp = fdopen(fd, "r"); - nstio->ofp = fdopen(fd, "w"); - nstio->type = 's'; - - 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_2static(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_2static(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 GETHOSTENT - struct hostent *gethostent(); -#endif - struct hostent *hent; - unsigned long len; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_static(&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 GETHOSTENT - hent = gethostent(); -#else - fatal("gethostent not implemented"); -#endif - if (hent) { -#ifndef lint - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, hent->h_name); - (void)astore(ary, ++sp, str = str_static(&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_static(&str_no)); - str_numset(str, (double)hent->h_addrtype); - (void)astore(ary, ++sp, str = str_static(&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_static(&str_no)); - str_nset(str, *elem, len); - } -#else - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_nset(str, hent->h_addr, len); -#endif /* h_addr */ -#else /* lint */ - elem = Nullch; - elem = elem; - (void)astore(ary, ++sp, str_static(&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_static(&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) { - STR *addrstr = ary->ary_array[sp+1]; - int addrtype = (int)str_gnum(ary->ary_array[sp+2]); - char *addr = str_get(addrstr); - - nent = getnetbyaddr(addr,addrtype); - } - else - nent = getnetent(); - - if (nent) { -#ifndef lint - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, nent->n_name); - (void)astore(ary, ++sp, str = str_static(&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_static(&str_no)); - str_numset(str, (double)nent->n_addrtype); - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_numset(str, (double)nent->n_net); -#else /* lint */ - elem = Nullch; - elem = elem; - (void)astore(ary, ++sp, str_static(&str_no)); -#endif /* lint */ - } - - return sp; -} - -int -do_gpent(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 protoent *getprotobyname(); - struct protoent *getprotobynumber(); - struct protoent *getprotoent(); - struct protoent *pent; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_static(&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]); - - pent = getprotobynumber(proto); - } - else - pent = getprotoent(); - - if (pent) { -#ifndef lint - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, pent->p_name); - (void)astore(ary, ++sp, str = str_static(&str_no)); - for (elem = pent->p_aliases; *elem; elem++) { - str_cat(str, *elem); - if (elem[1]) - str_ncat(str," ",1); - } - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_numset(str, (double)pent->p_proto); -#else /* lint */ - elem = Nullch; - elem = elem; - (void)astore(ary, ++sp, str_static(&str_no)); -#endif /* lint */ - } + struct flock fl; + struct stat filebuf; - return sp; -} + if (PerlLIO_fstat(fd, &filebuf) < 0) + return -1; -int -do_gsent(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 servent *getservbyname(); - struct servent *getservbynumber(); - struct servent *getservent(); - struct servent *sent; - - if (gimme != G_ARRAY) { - astore(ary, ++sp, str_static(&str_undef)); - return sp; - } + if (filebuf.st_size < length) { - if (which == O_GSBYNAME) { - char *name = str_get(ary->ary_array[sp+1]); - char *proto = str_get(ary->ary_array[sp+2]); + /* extend file length */ - if (proto && !*proto) - proto = Nullch; + if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) + return -1; - 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]); + /* write a "0" byte */ - sent = getservbyport(port,proto); - } - else - sent = getservent(); - if (sent) { -#ifndef lint - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, sent->s_name); - (void)astore(ary, ++sp, str = str_static(&str_no)); - for (elem = sent->s_aliases; *elem; elem++) { - str_cat(str, *elem); - if (elem[1]) - str_ncat(str," ",1); - } - (void)astore(ary, ++sp, str = str_static(&str_no)); -#ifdef NTOHS - str_numset(str, (double)ntohs(sent->s_port)); -#else - str_numset(str, (double)(sent->s_port)); -#endif - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, sent->s_proto); -#else /* lint */ - elem = Nullch; - elem = elem; - (void)astore(ary, ++sp, str_static(&str_no)); -#endif /* lint */ + if ((PerlLIO_write(fd, "", 1)) != 1) + return -1; } + else { + /* truncate length */ - return sp; -} - -#endif /* SOCKET */ + fl.l_whence = 0; + fl.l_len = 0; + fl.l_start = length; + fl.l_type = F_WRLCK; /* write lock on file space */ -#ifdef SELECT -int -do_select(gimme,arglast) -int gimme; -int *arglast; -{ - 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 + /* + * This relies on the UNDOCUMENTED F_FREESP argument to + * fcntl(2), which truncates the file so that it ends at the + * position indicated by fl.l_start. + * + * Will minor miracles never cease? + */ -#endif + if (fcntl(fd, F_FREESP, &fl) < 0) + return -1; - for (i = 1; i <= 3; i++) { - j = st[sp+i]->str_cur; - if (maxlen < j) - maxlen = j; } -#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 - growsize = maxlen; /* little endians can use vecs directly */ -#else -#ifdef NFDBITS - -#ifndef NBBY -#define NBBY 8 -#endif + return 0; +} +#endif /* F_FREESP */ - 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_print(register SV *sv, PerlIO *fp) +{ + register char *tmps; + STRLEN len; - 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; - } + /* 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 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]; - } + 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); } -#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); + switch (SvTYPE(sv)) { + case SVt_NULL: + { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, PL_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); + } + /* FALL THROUGH */ + default: + tmps = SvPV(sv, len); + break; } - 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 (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp))) + return FALSE; + return !PerlIO_error(fp); +} + +I32 +my_stat(ARGSproto) +{ + 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); } } -#endif + else { + SV* sv = POPs; + char *s; + STRLEN n_a; + 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; + } - st[++sp] = str_static(&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_static(&str_no); - str_numset(st[sp], value); + s = SvPV(sv, n_a); + 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, PL_warn_nl, "stat"); + return PL_laststatval; } - return sp; } -#endif /* SELECT */ -#ifdef SOCKET -int -do_spair(stab1, stab2, arglast) -STAB *stab1; -STAB *stab2; -int *arglast; +I32 +my_lstat(ARGSproto) { - 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; + djSP; + SV *sv; + STRLEN n_a; + 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"); + } - 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 SOCKETPAIR - if (socketpair(domain,type,protocol,fd) < 0) - return FALSE; + PL_laststype = OP_LSTAT; + PL_statgv = Nullgv; + sv = POPs; + PUTBACK; + sv_setpv(PL_statname,SvPV(sv, n_a)); +#ifdef HAS_LSTAT + PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache); #else - fatal("Socketpair unimplemented"); + PL_laststatval = PerlLIO_stat(SvPV(sv, n_a),&PL_statcache); #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'; - - return TRUE; + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) + warner(WARN_NEWLINE, PL_warn_nl, "lstat"); + return PL_laststatval; } -#endif /* SOCKET */ - -int -do_gpwent(which,gimme,arglast) -int which; -int gimme; -int *arglast; +bool +do_aexec(SV *really, register SV **mark, register SV **sp) { -#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_static(&str_undef)); - return sp; - } - - if (which == O_GPWNAM) { - char *name = str_get(ary->ary_array[sp+1]); - - pwent = getpwnam(name); + register char **a; + char *tmps; + STRLEN n_a; + + if (sp > mark) { + dTHR; + New(401,PL_Argv, sp - mark + 1, char*); + a = PL_Argv; + while (++mark <= sp) { + if (*mark) + *a++ = SvPVx(*mark, n_a); + 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, n_a))) + 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)); } - else if (which == O_GPWUID) { - int uid = (int)str_gnum(ary->ary_array[sp+1]); + do_execfree(); + return FALSE; +} - pwent = getpwuid(uid); +void +do_execfree(void) +{ + if (PL_Argv) { + Safefree(PL_Argv); + PL_Argv = Null(char **); } - else - pwent = getpwent(); - - if (pwent) { - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, pwent->pw_name); - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, pwent->pw_passwd); - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_numset(str, (double)pwent->pw_uid); - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_numset(str, (double)pwent->pw_gid); - (void)astore(ary, ++sp, str = str_static(&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_static(&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_static(&str_no)); - str_set(str, pwent->pw_gecos); - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, pwent->pw_dir); - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, pwent->pw_shell); -#ifdef PWEXPIRE - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_numset(str, (double)pwent->pw_expire); -#endif + if (PL_Cmd) { + Safefree(PL_Cmd); + PL_Cmd = Nullch; } - - return sp; -#else - fatal("password routines not implemented"); -#endif } -int -do_ggrent(which,gimme,arglast) -int which; -int gimme; -int *arglast; +#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) + +bool +do_exec(char *cmd) { -#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_static(&str_undef)); - return sp; - } + register char **a; + register char *s; + char flags[10]; - if (which == O_GGRNAM) { - char *name = str_get(ary->ary_array[sp+1]); + while (*cmd && isSPACE(*cmd)) + cmd++; - grent = getgrnam(name); - } - else if (which == O_GGRGID) { - int gid = (int)str_gnum(ary->ary_array[sp+1]); + /* save an extra exec if possible */ - grent = getgrgid(gid); - } - else - grent = getgrent(); - - if (grent) { - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, grent->gr_name); - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_set(str, grent->gr_passwd); - (void)astore(ary, ++sp, str = str_static(&str_no)); - str_numset(str, (double)grent->gr_gid); - (void)astore(ary, ++sp, str = str_static(&str_no)); - for (elem = grent->gr_mem; *elem; elem++) { - str_cat(str, *elem); - if (elem[1]) - str_ncat(str," ",1); +#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("group routines not implemented"); -#endif -} + /* see if there are shell metacharacters in it */ -int -do_dirop(optype,stab,gimme,arglast) -int optype; -STAB *stab; -int gimme; -int *arglast; -{ -#if defined(DIRENT) && defined(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 - struct DIRENT *readdir(); - register struct DIRENT *dp; - - if (!stab) - goto nope; - if (!(stio = stab_io(stab))) - stio = stab_io(stab) = stio_new(); - if (!stio->dirp && optype != O_OPENDIR) - goto nope; - st[sp] = &str_yes; - switch (optype) { - case O_OPENDIR: - 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_2static(str_make(dp->d_name,dp->d_namlen))); -#else - (void)astore(ary,++sp, - str_2static(str_make(dp->d_name,0))); -#endif + if (*cmd == '.' && isSPACE(cmd[1])) + goto doshell; + + if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) + goto doshell; + + for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ + if (*s == '=') + goto doshell; + + 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; } - else { - if (!(dp = readdir(stio->dirp))) - goto nope; - st[sp] = str_static(&str_undef); -#ifdef DIRNAMLEN - str_nset(st[sp], dp->d_name, dp->d_namlen); -#else - str_set(st[sp], dp->d_name); -#endif - } - break; -#if MACH - case O_TELLDIR: - case O_SEEKDIR: - goto nope; -#else - case O_TELLDIR: - st[sp] = str_static(&str_undef); - str_numset(st[sp], (double)telldir(stio->dirp)); - break; - case O_SEEKDIR: - st[sp] = str_static(&str_undef); - along = (long)str_gnum(st[sp+1]); - (void)seekdir(stio->dirp,along); - break; -#endif - case O_REWINDDIR: - st[sp] = str_static(&str_undef); - (void)rewinddir(stio->dirp); - break; - case O_CLOSEDIR: - st[sp] = str_static(&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 + 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; + } + { + dTHR; + if (ckWARN(WARN_EXEC)) + warner(WARN_EXEC, "Can't exec \"%s\": %s", + PL_Argv[0], Strerror(errno)); + } + } + 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; + STRLEN n_a; + +#define APPLY_TAINT_PROPER() \ + STMT_START { \ + if (PL_tainted) { TAINT_PROPER(what); } \ + } 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, n_a); + APPLY_TAINT_PROPER(); + if (PerlLIO_chmod(name, val)) tot--; } } break; -#ifdef 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)) +#ifdef HAS_CHOWN + 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, n_a); + APPLY_TAINT_PROPER(); + if (PerlLIO_chown(name, val, val2)) tot--; } } break; #endif -#ifdef 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); +/* +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 OP_KILL: + what = "kill"; + APPLY_TAINT_PROPER(); + if (mark == sp) + break; + s = SvPVx(*++mark, n_a); + 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]); -#ifdef KILLPG - if (killpg(proc,val)) /* BSD */ + break; + } +#endif + if (val < 0) { + val = -val; + while (++mark <= sp) { + I32 proc = SvIVx(*mark); + APPLY_TAINT_PROPER(); +#ifdef HAS_KILLPG + 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, n_a); + APPLY_TAINT_PROPER(); + if (PL_euid || PL_unsafe) { if (UNLINK(s)) tot--; } else { /* don't let root wipe out directories without -U */ -#ifdef LSTAT - if (lstat(s,&statbuf) < 0 || +#ifdef HAS_LSTAT + if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode)) #else - if (stat(s,&statbuf) < 0 || + if (PerlLIO_stat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode)) #endif - (statbuf.st_mode & S_IFMT) == S_IFDIR ) tot--; else { if (UNLINK(s)) @@ -2244,84 +1315,113 @@ 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 { - long actime; - long modtime; + Time_t actime; + Time_t modtime; } utbuf; #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 = (Time_t)SvIVx(*++mark); /* time accessed */ + utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */ +#endif + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { + char *name = SvPVx(*mark, n_a); + APPLY_TAINT_PROPER(); + if (PerlLIO_utime(name, &utbuf)) tot--; } -#endif } else - items = 0; + tot = 0; break; +#endif } return tot; + +#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) { - if ((effective ? euid : uid) == 0) { /* root is special */ - if (bit == S_IEXEC) { - if (statbufp->st_mode & 0111 || - (statbufp->st_mode & S_IFMT) == S_IFDIR ) +#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 + * by the Miscrosoft C library stat() function for the following: + * .exe files + * .com files + * .bat files + * directories + * All files and directories are readable. + * Directories and special files, e.g. "CON", cannot be + * write-protected. + * [Comment by Tom Dinger -- a directory can have the write-protect + * bit set in the file system, but DOS permits changes to + * the directory anyway. In addition, all bets are off + * here for networked software, such as Novell and + * 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 /* ! 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; } else 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 /* ! 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 GETGROUPS +#ifdef HAS_GETGROUPS #ifndef NGROUPS #define NGROUPS 32 #endif { - GIDTYPE gary[NGROUPS]; - int anum; + Groups_t gary[NGROUPS]; + I32 anum; anum = getgroups(NGROUPS,gary); while (--anum >= 0) @@ -2332,283 +1432,286 @@ int effective; return FALSE; } -#ifdef SYSVIPC +#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 IPCMSG - case O_MSGGET: +#ifdef HAS_MSG + case OP_MSGGET: return msgget(key, flags); #endif -#ifdef IPCSEM - case O_SEMGET: +#ifdef HAS_SEM + case OP_SEMGET: return semget(key, n, flags); #endif -#ifdef IPCSHM - case O_SHMGET: +#ifdef HAS_SHM + case OP_SHMGET: return shmget(key, n, flags); #endif -#if !defined(IPCMSG) || !defined(IPCSEM) || !defined(IPCSHM) +#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: - fatal("%s not implemented", opname[optype]); + croak("%s not implemented", PL_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 IPCMSG - case O_MSGCTL: +#ifdef HAS_MSG + case OP_MSGCTL: if (cmd == IPC_STAT || cmd == IPC_SET) infosize = sizeof(struct msqid_ds); break; #endif -#ifdef IPCSHM - case O_SHMCTL: +#ifdef HAS_SHM + case OP_SHMCTL: if (cmd == IPC_STAT || cmd == IPC_SET) infosize = sizeof(struct shmid_ds); break; #endif -#ifdef IPCSEM - case O_SEMCTL: +#ifdef HAS_SEM + case OP_SEMCTL: +#ifdef 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); - infosize = semds.sem_nsems * sizeof(ushort); + 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)? */ } +#else + croak("%s not implemented", PL_op_desc[optype]); +#endif break; #endif -#if !defined(IPCMSG) || !defined(IPCSEM) || !defined(IPCSHM) +#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: - fatal("%s not implemented", opname[optype]); + croak("%s not implemented", PL_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", + PL_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 IPCMSG - case O_MSGCTL: - ret = msgctl(id, cmd, a); +#ifdef HAS_MSG + case OP_MSGCTL: + ret = msgctl(id, cmd, (struct msqid_ds *)a); break; #endif -#ifdef IPCSEM - case O_SEMCTL: - ret = semctl(id, n, cmd, a); +#ifdef HAS_SEM + case OP_SEMCTL: { +#ifdef Semctl + union semun unsemds; + + unsemds.buf = (struct semid_ds *)a; + ret = Semctl(id, n, cmd, unsemds); +#else + croak("%s not implemented", PL_op_desc[optype]); +#endif + } break; #endif -#ifdef IPCSHM - case O_SHMCTL: - ret = shmctl(id, cmd, a); +#ifdef HAS_SHM + 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 IPCMSG - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *mstr; +#ifdef HAS_MSG + 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 IPCMSG - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *mstr; +#ifdef HAS_MSG + 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); + 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 IPCSEM - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *opstr; +#ifdef HAS_SEM + 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; - return semop(id, opbuf, opsize/sizeof(struct sembuf)); + 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 IPCSHM - register STR **st = stack->ary_array; - register int sp = arglast[0]; - STR *mstr; +#ifdef HAS_SHM + dTHR; + SV *mstr; char *mbuf, *shm; - int id, mpos, msize; + I32 id, mpos, msize; + STRLEN len; 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; + 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 = 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 /* SYSVIPC */ +#endif /* SYSV IPC */ +