3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "Far below them they saw the white waters pour into a foaming bowl, and
12 * then swirl darkly about a deep oval basin in the rocks, until they found
13 * their way out again through a narrow gate, and flowed away, fuming and
14 * chattering, into calmer and more level reaches."
20 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
30 # ifndef HAS_SHMAT_PROTOTYPE
31 extern Shmat_t shmat _((int, char *, int));
37 # if defined(_MSC_VER) || defined(__MINGW32__)
38 # include <sys/utime.h>
51 # define OPEN_EXCL O_EXCL
56 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
60 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
65 #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
66 # include <sys/socket.h>
70 # include <net/errno.h>
75 /* Put this after #includes because <unistd.h> defines _XOPEN_*. */
77 # if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
78 # define Sock_size_t Size_t
80 # define Sock_size_t int
85 do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp)
87 register IO *io = GvIOn(gv);
88 PerlIO *saveifp = Nullfp;
89 PerlIO *saveofp = Nullfp;
95 bool was_fdopen = FALSE;
97 forkprocess = 1; /* assume true if no fork */
100 fd = PerlIO_fileno(IoIFP(io));
101 if (IoTYPE(io) == '-')
103 else if (fd <= maxsysfd) {
106 savetype = IoTYPE(io);
109 else if (IoTYPE(io) == '|')
110 result = PerlProc_pclose(IoIFP(io));
111 else if (IoIFP(io) != IoOFP(io)) {
113 result = PerlIO_close(IoOFP(io));
114 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
117 result = PerlIO_close(IoIFP(io));
120 result = PerlIO_close(IoIFP(io));
121 if (result == EOF && fd > maxsysfd)
122 PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
124 IoOFP(io) = IoIFP(io) = Nullfp;
128 result = rawmode & 3;
129 IoTYPE(io) = "<>++"[result];
130 writing = (result > 0);
131 fd = PerlLIO_open3(name, rawmode, rawperm);
139 else if (rawmode & O_APPEND)
140 fpmode = (result == 1) ? "a" : "a+";
143 fpmode = (result == 1) ? "w" : "r+";
144 fp = PerlIO_fdopen(fd, fpmode);
151 char mode[3]; /* stdio file mode ("r\0" or "r+\0") */
154 myname = savepvn(name, len);
157 while (len && isSPACE(name[len-1]))
160 mode[0] = mode[1] = mode[2] = '\0';
162 if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
170 for (name++; isSPACE(*name); name++) ;
173 TAINT_PROPER("piped open");
174 if (name[strlen(name)-1] == '|') {
175 name[strlen(name)-1] = '\0' ;
177 warn("Can't do bidirectional pipe");
179 fp = PerlProc_popen(name,"w");
182 else if (*name == '>') {
183 TAINT_PROPER("open");
186 mode[0] = IoTYPE(io) = 'a';
201 if (!*name && supplied_fp)
205 for (; isSPACE(*name); name++) ;
210 gv = gv_fetchpv(name,FALSE,SVt_PVIO);
214 SETERRNO(EINVAL,SS$_IVCHAN);
219 fd = PerlIO_fileno(IoIFP(thatio));
220 if (IoTYPE(thatio) == 's')
227 fd = PerlLIO_dup(fd);
230 if (!(fp = PerlIO_fdopen(fd,mode))) {
238 for (; isSPACE(*name); name++) ;
239 if (strEQ(name,"-")) {
240 fp = PerlIO_stdout();
244 fp = PerlIO_open(name,mode);
248 else if (*name == '<') {
250 for (name++; isSPACE(*name); name++) ;
254 if (strEQ(name,"-")) {
259 fp = PerlIO_open(name,mode);
261 else if (name[len-1] == '|') {
263 while (len && isSPACE(name[len-1]))
266 for (; isSPACE(*name); name++) ;
269 TAINT_PROPER("piped open");
270 fp = PerlProc_popen(name,"r");
276 for (; isSPACE(*name); name++) ;
277 if (strEQ(name,"-")) {
282 fp = PerlIO_open(name,"r");
286 if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
287 warn(warn_nl, "open");
291 IoTYPE(io) != '|' && IoTYPE(io) != '-') {
293 if (PerlLIO_fstat(PerlIO_fileno(fp),&statbuf) < 0) {
294 (void)PerlIO_close(fp);
297 if (S_ISSOCK(statbuf.st_mode))
298 IoTYPE(io) = 's'; /* in case a socket was passed in to us */
302 !(statbuf.st_mode & S_IFMT)
308 Sock_size_t buflen = sizeof tmpbuf;
309 if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
311 || errno != ENOTSOCK)
312 IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
313 /* but some return 0 for streams too, sigh */
317 if (saveifp) { /* must use old fp? */
318 fd = PerlIO_fileno(saveifp);
320 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
321 if (saveofp != saveifp) { /* was a socket? */
322 PerlIO_close(saveofp);
327 if (fd != PerlIO_fileno(fp)) {
331 PerlLIO_dup2(PerlIO_fileno(fp), fd);
332 sv = *av_fetch(fdpid,PerlIO_fileno(fp),TRUE);
333 (void)SvUPGRADE(sv, SVt_IV);
336 sv = *av_fetch(fdpid,fd,TRUE);
337 (void)SvUPGRADE(sv, SVt_IV);
346 #if defined(HAS_FCNTL) && defined(F_SETFD)
347 fd = PerlIO_fileno(fp);
348 fcntl(fd,F_SETFD,fd > maxsysfd);
353 if (IoTYPE(io) == 's'
354 || (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) {
355 if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
369 IoTYPE(io) = savetype;
374 nextargv(register GV *gv)
377 #ifndef FLEXFILENAMES
385 argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
386 if (filemode & (S_ISUID|S_ISGID)) {
387 PerlIO_flush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */
389 (void)fchmod(lastfd,filemode);
391 (void)PerlLIO_chmod(oldname,filemode);
395 while (av_len(GvAV(gv)) >= 0) {
398 sv = av_shift(GvAV(gv));
400 sv_setsv(GvSV(gv),sv);
401 SvSETMAGIC(GvSV(gv));
402 oldname = SvPVx(GvSV(gv), oldlen);
403 if (do_open(gv,oldname,oldlen,inplace!=0,0,0,Nullfp)) {
405 TAINT_PROPER("inplace open");
406 if (oldlen == 1 && *oldname == '-') {
407 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
408 return IoIFP(GvIOp(gv));
410 #ifndef FLEXFILENAMES
411 filedev = statbuf.st_dev;
412 fileino = statbuf.st_ino;
414 filemode = statbuf.st_mode;
415 fileuid = statbuf.st_uid;
416 filegid = statbuf.st_gid;
417 if (!S_ISREG(filemode)) {
418 warn("Can't do inplace edit: %s is not a regular file",
425 add_suffix(sv,inplace);
427 sv_catpv(sv,inplace);
429 #ifndef FLEXFILENAMES
430 if (PerlLIO_stat(SvPVX(sv),&statbuf) >= 0
431 && statbuf.st_dev == filedev
432 && statbuf.st_ino == fileino
434 || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
437 warn("Can't do inplace edit: %s would not be uniq",
445 if (PerlLIO_rename(oldname,SvPVX(sv)) < 0) {
446 warn("Can't rename %s to %s: %s, skipping file",
447 oldname, SvPVX(sv), Strerror(errno) );
453 (void)PerlLIO_unlink(SvPVX(sv));
454 (void)PerlLIO_rename(oldname,SvPVX(sv));
455 do_open(gv,SvPVX(sv),SvCUR(sv),inplace!=0,0,0,Nullfp);
458 (void)UNLINK(SvPVX(sv));
459 if (link(oldname,SvPVX(sv)) < 0) {
460 warn("Can't rename %s to %s: %s, skipping file",
461 oldname, SvPVX(sv), Strerror(errno) );
465 (void)UNLINK(oldname);
469 #if !defined(DOSISH) && !defined(AMIGAOS)
470 # ifndef VMS /* Don't delete; use automatic file versioning */
471 if (UNLINK(oldname) < 0) {
472 warn("Can't remove %s: %s, skipping file",
473 oldname, Strerror(errno) );
479 croak("Can't do inplace edit without backup");
483 sv_setpvn(sv,">",!inplace);
484 sv_catpvn(sv,oldname,oldlen);
485 SETERRNO(0,0); /* in case sprintf set errno */
486 if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),inplace!=0,
487 O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
488 warn("Can't do inplace edit on %s: %s",
489 oldname, Strerror(errno) );
493 setdefout(argvoutgv);
494 lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv)));
495 (void)PerlLIO_fstat(lastfd,&statbuf);
497 (void)fchmod(lastfd,filemode);
499 # if !(defined(WIN32) && defined(__BORLANDC__))
500 /* Borland runtime creates a readonly file! */
501 (void)PerlLIO_chmod(oldname,filemode);
504 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
506 (void)fchown(lastfd,fileuid,filegid);
509 (void)PerlLIO_chown(oldname,fileuid,filegid);
514 return IoIFP(GvIOp(gv));
517 PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
518 SvPV(sv, na), Strerror(errno));
521 (void)do_close(argvoutgv,FALSE);
522 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
529 do_pipe(SV *sv, GV *rgv, GV *wgv)
548 if (PerlProc_pipe(fd) < 0)
550 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
551 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
552 IoIFP(wstio) = IoOFP(wstio);
555 if (!IoIFP(rstio) || !IoOFP(wstio)) {
556 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
557 else PerlLIO_close(fd[0]);
558 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
559 else PerlLIO_close(fd[1]);
563 sv_setsv(sv,&sv_yes);
567 sv_setsv(sv,&sv_undef);
572 /* explicit renamed to avoid C++ conflict -- kja */
574 do_close(GV *gv, bool not_implicit)
581 if (!gv || SvTYPE(gv) != SVt_PVGV) {
582 SETERRNO(EBADF,SS$_IVCHAN);
586 if (!io) { /* never opened */
587 if (dowarn && not_implicit)
588 warn("Close on unopened file <%s>",GvENAME(gv));
589 SETERRNO(EBADF,SS$_IVCHAN);
592 retval = io_close(io);
596 IoLINES_LEFT(io) = IoPAGE_LEN(io);
609 if (IoTYPE(io) == '|') {
610 status = PerlProc_pclose(IoIFP(io));
611 STATUS_NATIVE_SET(status);
612 retval = (STATUS_POSIX == 0);
614 else if (IoTYPE(io) == '-')
617 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
618 retval = (PerlIO_close(IoOFP(io)) != EOF);
619 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
622 retval = (PerlIO_close(IoIFP(io)) != EOF);
624 IoOFP(io) = IoIFP(io) = Nullfp;
627 SETERRNO(EBADF,SS$_IVCHAN);
647 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
648 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
649 return FALSE; /* this is the most usual case */
652 ch = PerlIO_getc(IoIFP(io));
654 (void)PerlIO_ungetc(IoIFP(io),ch);
657 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
658 if (PerlIO_get_cnt(IoIFP(io)) < -1)
659 PerlIO_set_cnt(IoIFP(io),-1);
661 if (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
662 if (!nextargv(argvgv)) /* get another fp handy */
666 return TRUE; /* normal fp, definitely end of file */
677 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
678 #ifdef ULTRIX_STDIO_BOTCH
680 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
682 return PerlIO_tell(fp);
685 warn("tell() on unopened file");
686 SETERRNO(EBADF,RMS$_IFI);
691 do_seek(GV *gv, long int pos, int whence)
696 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
697 #ifdef ULTRIX_STDIO_BOTCH
699 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
701 return PerlIO_seek(fp, pos, whence) >= 0;
704 warn("seek() on unopened file");
705 SETERRNO(EBADF,RMS$_IFI);
710 do_sysseek(GV *gv, long int pos, int whence)
715 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
716 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
718 warn("sysseek() on unopened file");
719 SETERRNO(EBADF,RMS$_IFI);
724 do_binmode(PerlIO *fp, int iotype, int flag)
727 croak("panic: unsetting binmode"); /* Not implemented yet */
730 if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
735 if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
736 #if defined(WIN32) && defined(__BORLANDC__)
737 /* The translation mode of the stream is maintained independent
738 * of the translation mode of the fd in the Borland RTL (heavy
739 * digging through their runtime sources reveal). User has to
740 * set the mode explicitly for the stream (though they don't
741 * document this anywhere). GSAR 97-5-24
743 PerlIO_seek(fp,0L,0);
744 ((FILE*)fp)->flags |= _F_BIN;
752 #if defined(USEMYBINMODE)
753 if (my_binmode(fp,iotype) != NULL)
763 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
764 /* code courtesy of William Kucharski */
767 I32 my_chsize(fd, length)
768 I32 fd; /* file descriptor */
769 Off_t length; /* length to set file to */
774 if (PerlLIO_fstat(fd, &filebuf) < 0)
777 if (filebuf.st_size < length) {
779 /* extend file length */
781 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
784 /* write a "0" byte */
786 if ((PerlLIO_write(fd, "", 1)) != 1)
790 /* truncate length */
795 fl.l_type = F_WRLCK; /* write lock on file space */
798 * This relies on the UNDOCUMENTED F_FREESP argument to
799 * fcntl(2), which truncates the file so that it ends at the
800 * position indicated by fl.l_start.
802 * Will minor miracles never cease?
805 if (fcntl(fd, F_FREESP, &fl) < 0)
812 #endif /* F_FREESP */
815 do_print(register SV *sv, PerlIO *fp)
820 /* assuming fp is checked earlier */
826 if (SvIOK(sv) && SvIVX(sv) != 0) {
827 PerlIO_printf(fp, ofmt, (double)SvIVX(sv));
828 return !PerlIO_error(fp);
830 if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
831 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
832 PerlIO_printf(fp, ofmt, SvNVX(sv));
833 return !PerlIO_error(fp);
836 switch (SvTYPE(sv)) {
845 PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
846 return !PerlIO_error(fp);
850 tmps = SvPV(sv, len);
853 if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
855 return !PerlIO_error(fp);
865 if (op->op_flags & OPf_REF) {
867 tmpgv = cGVOP->op_gv;
870 if (io && IoIFP(io)) {
872 sv_setpv(statname,"");
874 return (laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache));
880 warn("Stat on unopened file <%s>",
883 sv_setpv(statname,"");
884 return (laststatval = -1);
891 if (SvTYPE(sv) == SVt_PVGV) {
895 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
896 tmpgv = (GV*)SvRV(sv);
902 sv_setpv(statname, s);
904 laststatval = PerlLIO_stat(s, &statcache);
905 if (laststatval < 0 && dowarn && strchr(s, '\n'))
906 warn(warn_nl, "stat");
916 if (op->op_flags & OPf_REF) {
918 if (cGVOP->op_gv == defgv) {
919 if (laststype != OP_LSTAT)
920 croak("The stat preceding -l _ wasn't an lstat");
923 croak("You can't use -l on a filehandle");
926 laststype = OP_LSTAT;
930 sv_setpv(statname,SvPV(sv, na));
932 laststatval = PerlLIO_lstat(SvPV(sv, na),&statcache);
934 laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
936 if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
937 warn(warn_nl, "lstat");
942 do_aexec(SV *really, register SV **mark, register SV **sp)
949 New(401,Argv, sp - mark + 1, char*);
951 while (++mark <= sp) {
953 *a++ = SvPVx(*mark, na);
958 if (*Argv[0] != '/') /* will execvp use PATH? */
959 TAINT_ENV(); /* testing IFS here is overkill, probably */
960 if (really && *(tmps = SvPV(really, na)))
961 PerlProc_execvp(tmps,Argv);
963 PerlProc_execvp(Argv[0],Argv);
965 warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
976 Argv = Null(char **);
984 #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
993 while (*cmd && isSPACE(*cmd))
996 /* save an extra exec if possible */
999 if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) {
1015 if (s[-1] == '\'') {
1017 PerlProc_execl(cshname,"csh", flags,ncmd,(char*)0);
1025 /* see if there are shell metacharacters in it */
1027 if (*cmd == '.' && isSPACE(cmd[1]))
1030 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1033 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1037 for (s = cmd; *s; s++) {
1038 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1039 if (*s == '\n' && !s[1]) {
1044 PerlProc_execl(sh_path, "sh", "-c", cmd, (char*)0);
1049 New(402,Argv, (s - cmd) / 2 + 2, char*);
1050 Cmd = savepvn(cmd, s-cmd);
1052 for (s = Cmd; *s;) {
1053 while (*s && isSPACE(*s)) s++;
1056 while (*s && !isSPACE(*s)) s++;
1062 PerlProc_execvp(Argv[0],Argv);
1063 if (errno == ENOEXEC) { /* for system V NIH syndrome */
1068 warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
1074 #endif /* OS2 || WIN32 */
1077 apply(I32 type, register SV **mark, register SV **sp)
1082 register I32 tot = 0;
1085 SV **oldmark = mark;
1087 #define APPLY_TAINT_PROPER() \
1089 if (tainting && tainted) { goto taint_proper_label; } \
1092 /* This is a first heuristic; it doesn't catch tainting magic. */
1094 while (++mark <= sp) {
1095 if (SvTAINTED(*mark)) {
1105 APPLY_TAINT_PROPER();
1108 APPLY_TAINT_PROPER();
1110 while (++mark <= sp) {
1111 char *name = SvPVx(*mark, na);
1112 APPLY_TAINT_PROPER();
1113 if (PerlLIO_chmod(name, val))
1121 APPLY_TAINT_PROPER();
1122 if (sp - mark > 2) {
1123 val = SvIVx(*++mark);
1124 val2 = SvIVx(*++mark);
1125 APPLY_TAINT_PROPER();
1127 while (++mark <= sp) {
1128 char *name = SvPVx(*mark, na);
1129 APPLY_TAINT_PROPER();
1130 if (PerlLIO_chown(name, val, val2))
1139 APPLY_TAINT_PROPER();
1142 s = SvPVx(*++mark, na);
1144 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1146 if (!(val = whichsig(s)))
1147 croak("Unrecognized signal name \"%s\"",s);
1151 APPLY_TAINT_PROPER();
1154 /* kill() doesn't do process groups (job trees?) under VMS */
1155 if (val < 0) val = -val;
1156 if (val == SIGKILL) {
1157 # include <starlet.h>
1158 /* Use native sys$delprc() to insure that target process is
1159 * deleted; supervisor-mode images don't pay attention to
1160 * CRTL's emulation of Unix-style signals and kill()
1162 while (++mark <= sp) {
1163 I32 proc = SvIVx(*mark);
1164 register unsigned long int __vmssts;
1165 APPLY_TAINT_PROPER();
1166 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1170 case SS$_NOSUCHNODE:
1171 SETERRNO(ESRCH,__vmssts);
1174 SETERRNO(EPERM,__vmssts);
1177 SETERRNO(EVMSERR,__vmssts);
1186 while (++mark <= sp) {
1187 I32 proc = SvIVx(*mark);
1188 APPLY_TAINT_PROPER();
1190 if (PerlProc_killpg(proc,val)) /* BSD */
1192 if (PerlProc_kill(-proc,val)) /* SYSV */
1198 while (++mark <= sp) {
1199 I32 proc = SvIVx(*mark);
1200 APPLY_TAINT_PROPER();
1201 if (PerlProc_kill(proc, val))
1209 APPLY_TAINT_PROPER();
1211 while (++mark <= sp) {
1212 s = SvPVx(*mark, na);
1213 APPLY_TAINT_PROPER();
1214 if (euid || unsafe) {
1218 else { /* don't let root wipe out directories without -U */
1220 if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1222 if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1235 APPLY_TAINT_PROPER();
1236 if (sp - mark > 2) {
1237 #if defined(I_UTIME) || defined(VMS)
1238 struct utimbuf utbuf;
1246 Zero(&utbuf, sizeof utbuf, char);
1248 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
1249 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
1251 utbuf.actime = SvIVx(*++mark); /* time accessed */
1252 utbuf.modtime = SvIVx(*++mark); /* time modified */
1254 APPLY_TAINT_PROPER();
1256 while (++mark <= sp) {
1257 char *name = SvPVx(*mark, na);
1258 APPLY_TAINT_PROPER();
1259 if (PerlLIO_utime(name, &utbuf))
1272 return 0; /* this should never happen */
1274 #undef APPLY_TAINT_PROPER
1277 /* Do the permissions allow some operation? Assumes statcache already set. */
1278 #ifndef VMS /* VMS' cando is in vms.c */
1280 cando(I32 bit, I32 effective, register struct stat *statbufp)
1283 /* [Comments and code from Len Reed]
1284 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1285 * to write-protected files. The execute permission bit is set
1286 * by the Miscrosoft C library stat() function for the following:
1291 * All files and directories are readable.
1292 * Directories and special files, e.g. "CON", cannot be
1294 * [Comment by Tom Dinger -- a directory can have the write-protect
1295 * bit set in the file system, but DOS permits changes to
1296 * the directory anyway. In addition, all bets are off
1297 * here for networked software, such as Novell and
1301 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1302 * too so it will actually look into the files for magic numbers
1304 return (bit & statbufp->st_mode) ? TRUE : FALSE;
1306 #else /* ! DOSISH */
1307 if ((effective ? euid : uid) == 0) { /* root is special */
1308 if (bit == S_IXUSR) {
1309 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1313 return TRUE; /* root reads and writes anything */
1316 if (statbufp->st_uid == (effective ? euid : uid) ) {
1317 if (statbufp->st_mode & bit)
1318 return TRUE; /* ok as "user" */
1320 else if (ingroup((I32)statbufp->st_gid,effective)) {
1321 if (statbufp->st_mode & bit >> 3)
1322 return TRUE; /* ok as "group" */
1324 else if (statbufp->st_mode & bit >> 6)
1325 return TRUE; /* ok as "other" */
1327 #endif /* ! DOSISH */
1332 ingroup(I32 testgid, I32 effective)
1334 if (testgid == (effective ? egid : gid))
1336 #ifdef HAS_GETGROUPS
1341 Groups_t gary[NGROUPS];
1344 anum = getgroups(NGROUPS,gary);
1346 if (gary[anum] == testgid)
1353 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1356 do_ipcget(I32 optype, SV **mark, SV **sp)
1362 key = (key_t)SvNVx(*++mark);
1363 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1364 flags = SvIVx(*++mark);
1370 return msgget(key, flags);
1374 return semget(key, n, flags);
1378 return shmget(key, n, flags);
1380 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1382 croak("%s not implemented", op_desc[optype]);
1385 return -1; /* should never happen */
1388 #if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */
1389 /* Solaris manpage says that it uses (like linux)
1390 int semctl (int semid, int semnum, int cmd, union semun arg)
1391 but the system include files do not define union semun !!!!
1392 Note: Linux/glibc *does* declare union semun in <sys/sem_buf.h>
1393 but, unlike the older Linux libc and Solaris, it has an extra
1394 struct seminfo * on the end.
1398 struct semid_ds *buf;
1404 do_ipcctl(I32 optype, SV **mark, SV **sp)
1409 I32 id, n, cmd, infosize, getinfo;
1411 /* XXX REALLY need metaconfig test */
1412 /* linux and Solaris2 use:
1413 int semctl (int semid, int semnum, int cmd, union semun arg)
1415 int semctl (int semid, int semnum, int cmd, struct semid_ds *arg);
1416 Solaris and Linux (pre-glibc) use
1419 struct semid_ds *buf;
1422 but Solaris doesn't declare it in a header file (we declared it
1423 explicitly earlier). Linux/glibc declares a *different* union semun
1424 so we just refer to "union semun" here.
1427 #if defined(__linux__) || (defined(__sun__) && defined(__svr4__))
1428 # define SEMCTL_SEMUN
1429 union semun unsemds, semun;
1432 id = SvIVx(*++mark);
1433 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1434 cmd = SvIVx(*++mark);
1437 getinfo = (cmd == IPC_STAT);
1443 if (cmd == IPC_STAT || cmd == IPC_SET)
1444 infosize = sizeof(struct msqid_ds);
1449 if (cmd == IPC_STAT || cmd == IPC_SET)
1450 infosize = sizeof(struct shmid_ds);
1455 if (cmd == IPC_STAT || cmd == IPC_SET)
1456 infosize = sizeof(struct semid_ds);
1457 else if (cmd == GETALL || cmd == SETALL)
1459 struct semid_ds semds;
1462 if (semctl(id, 0, IPC_STAT, semun) == -1)
1464 if (semctl(id, 0, IPC_STAT, &semds) == -1)
1467 getinfo = (cmd == GETALL);
1468 infosize = semds.sem_nsems * sizeof(short);
1469 /* "short" is technically wrong but much more portable
1470 than guessing about u_?short(_t)? */
1474 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1476 croak("%s not implemented", op_desc[optype]);
1485 SvPV_force(astr, len);
1486 a = SvGROW(astr, infosize+1);
1490 a = SvPV(astr, len);
1491 if (len != infosize)
1492 croak("Bad arg length for %s, is %lu, should be %ld",
1493 op_desc[optype], (unsigned long)len, (long)infosize);
1499 a = (char *)i; /* ouch */
1506 ret = msgctl(id, cmd, (struct msqid_ds *)a);
1512 /* XXX Need metaconfig test */
1513 unsemds.buf = (struct semid_ds *)a;
1514 ret = semctl(id, n, cmd, unsemds);
1516 ret = semctl(id, n, cmd, (struct semid_ds *)a);
1522 ret = shmctl(id, cmd, (struct shmid_ds *)a);
1526 if (getinfo && ret >= 0) {
1527 SvCUR_set(astr, infosize);
1528 *SvEND(astr) = '\0';
1535 do_msgsnd(SV **mark, SV **sp)
1541 I32 id, msize, flags;
1544 id = SvIVx(*++mark);
1546 flags = SvIVx(*++mark);
1547 mbuf = SvPV(mstr, len);
1548 if ((msize = len - sizeof(long)) < 0)
1549 croak("Arg too short for msgsnd");
1551 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
1553 croak("msgsnd not implemented");
1558 do_msgrcv(SV **mark, SV **sp)
1565 I32 id, msize, flags, ret;
1568 id = SvIVx(*++mark);
1570 msize = SvIVx(*++mark);
1571 mtype = (long)SvIVx(*++mark);
1572 flags = SvIVx(*++mark);
1573 if (SvTHINKFIRST(mstr)) {
1574 if (SvREADONLY(mstr))
1575 croak("Can't msgrcv to readonly var");
1579 SvPV_force(mstr, len);
1580 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1583 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
1585 SvCUR_set(mstr, sizeof(long)+ret);
1586 *SvEND(mstr) = '\0';
1590 croak("msgrcv not implemented");
1595 do_semop(SV **mark, SV **sp)
1604 id = SvIVx(*++mark);
1606 opbuf = SvPV(opstr, opsize);
1607 if (opsize < sizeof(struct sembuf)
1608 || (opsize % sizeof(struct sembuf)) != 0) {
1609 SETERRNO(EINVAL,LIB$_INVARG);
1613 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
1615 croak("semop not implemented");
1620 do_shmio(I32 optype, SV **mark, SV **sp)
1626 I32 id, mpos, msize;
1628 struct shmid_ds shmds;
1630 id = SvIVx(*++mark);
1632 mpos = SvIVx(*++mark);
1633 msize = SvIVx(*++mark);
1635 if (shmctl(id, IPC_STAT, &shmds) == -1)
1637 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
1638 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
1641 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
1642 if (shm == (char *)-1) /* I hate System V IPC, I really do */
1644 if (optype == OP_SHMREAD) {
1645 SvPV_force(mstr, len);
1646 mbuf = SvGROW(mstr, msize+1);
1648 Copy(shm + mpos, mbuf, msize, char);
1649 SvCUR_set(mstr, msize);
1650 *SvEND(mstr) = '\0';
1656 mbuf = SvPV(mstr, len);
1657 if ((n = len) > msize)
1659 Copy(mbuf, shm + mpos, n, char);
1661 memzero(shm + mpos + n, msize - n);
1665 croak("shm I/O not implemented");
1669 #endif /* SYSV IPC */