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)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);
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() \
1088 if (!(tainting && tainted)) {} else { goto taint_proper; }
1090 /* This is a first heuristic; it doesn't catch tainting magic. */
1092 while (++mark <= sp) {
1093 if (SvTAINTED(*mark)) {
1103 APPLY_TAINT_PROPER();
1106 APPLY_TAINT_PROPER();
1108 while (++mark <= sp) {
1109 char *name = SvPVx(*mark, na);
1110 APPLY_TAINT_PROPER();
1111 if (PerlLIO_chmod(name, val))
1119 APPLY_TAINT_PROPER();
1120 if (sp - mark > 2) {
1121 val = SvIVx(*++mark);
1122 val2 = SvIVx(*++mark);
1123 APPLY_TAINT_PROPER();
1125 while (++mark <= sp) {
1126 char *name = SvPVx(*mark, na);
1127 APPLY_TAINT_PROPER();
1128 if (chown(name, val, val2))
1137 APPLY_TAINT_PROPER();
1140 s = SvPVx(*++mark, na);
1142 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1144 if (!(val = whichsig(s)))
1145 croak("Unrecognized signal name \"%s\"",s);
1149 APPLY_TAINT_PROPER();
1152 /* kill() doesn't do process groups (job trees?) under VMS */
1153 if (val < 0) val = -val;
1154 if (val == SIGKILL) {
1155 # include <starlet.h>
1156 /* Use native sys$delprc() to insure that target process is
1157 * deleted; supervisor-mode images don't pay attention to
1158 * CRTL's emulation of Unix-style signals and kill()
1160 while (++mark <= sp) {
1161 I32 proc = SvIVx(*mark);
1162 register unsigned long int __vmssts;
1163 APPLY_TAINT_PROPER();
1164 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1168 case SS$_NOSUCHNODE:
1169 SETERRNO(ESRCH,__vmssts);
1172 SETERRNO(EPERM,__vmssts);
1175 SETERRNO(EVMSERR,__vmssts);
1184 while (++mark <= sp) {
1185 I32 proc = SvIVx(*mark);
1186 APPLY_TAINT_PROPER();
1188 if (PerlProc_killpg(proc,val)) /* BSD */
1190 if (PerlProc_kill(-proc,val)) /* SYSV */
1196 while (++mark <= sp) {
1197 I32 proc = SvIVx(*mark);
1198 APPLY_TAINT_PROPER();
1199 if (PerlProc_kill(proc, val))
1207 APPLY_TAINT_PROPER();
1209 while (++mark <= sp) {
1210 s = SvPVx(*mark, na);
1211 APPLY_TAINT_PROPER();
1212 if (euid || unsafe) {
1216 else { /* don't let root wipe out directories without -U */
1218 if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1220 if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1233 APPLY_TAINT_PROPER();
1234 if (sp - mark > 2) {
1235 #if defined(I_UTIME) || defined(VMS)
1236 struct utimbuf utbuf;
1244 Zero(&utbuf, sizeof utbuf, char);
1246 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
1247 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
1249 utbuf.actime = SvIVx(*++mark); /* time accessed */
1250 utbuf.modtime = SvIVx(*++mark); /* time modified */
1252 APPLY_TAINT_PROPER();
1254 while (++mark <= sp) {
1255 char *name = SvPVx(*mark, na);
1256 APPLY_TAINT_PROPER();
1257 if (PerlLIO_utime(name, &utbuf))
1270 return 0; /* this should never happen */
1272 #undef APPLY_TAINT_PROPER
1275 /* Do the permissions allow some operation? Assumes statcache already set. */
1276 #ifndef VMS /* VMS' cando is in vms.c */
1278 cando(I32 bit, I32 effective, register struct stat *statbufp)
1281 /* [Comments and code from Len Reed]
1282 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1283 * to write-protected files. The execute permission bit is set
1284 * by the Miscrosoft C library stat() function for the following:
1289 * All files and directories are readable.
1290 * Directories and special files, e.g. "CON", cannot be
1292 * [Comment by Tom Dinger -- a directory can have the write-protect
1293 * bit set in the file system, but DOS permits changes to
1294 * the directory anyway. In addition, all bets are off
1295 * here for networked software, such as Novell and
1299 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1300 * too so it will actually look into the files for magic numbers
1302 return (bit & statbufp->st_mode) ? TRUE : FALSE;
1304 #else /* ! DOSISH */
1305 if ((effective ? euid : uid) == 0) { /* root is special */
1306 if (bit == S_IXUSR) {
1307 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1311 return TRUE; /* root reads and writes anything */
1314 if (statbufp->st_uid == (effective ? euid : uid) ) {
1315 if (statbufp->st_mode & bit)
1316 return TRUE; /* ok as "user" */
1318 else if (ingroup((I32)statbufp->st_gid,effective)) {
1319 if (statbufp->st_mode & bit >> 3)
1320 return TRUE; /* ok as "group" */
1322 else if (statbufp->st_mode & bit >> 6)
1323 return TRUE; /* ok as "other" */
1325 #endif /* ! DOSISH */
1330 ingroup(I32 testgid, I32 effective)
1332 if (testgid == (effective ? egid : gid))
1334 #ifdef HAS_GETGROUPS
1339 Groups_t gary[NGROUPS];
1342 anum = getgroups(NGROUPS,gary);
1344 if (gary[anum] == testgid)
1351 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1354 do_ipcget(I32 optype, SV **mark, SV **sp)
1360 key = (key_t)SvNVx(*++mark);
1361 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1362 flags = SvIVx(*++mark);
1368 return msgget(key, flags);
1372 return semget(key, n, flags);
1376 return shmget(key, n, flags);
1378 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1380 croak("%s not implemented", op_desc[optype]);
1383 return -1; /* should never happen */
1386 #if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */
1387 /* Solaris manpage says that it uses (like linux)
1388 int semctl (int semid, int semnum, int cmd, union semun arg)
1389 but the system include files do not define union semun !!!!
1393 struct semid_ds *buf;
1399 do_ipcctl(I32 optype, SV **mark, SV **sp)
1404 I32 id, n, cmd, infosize, getinfo;
1406 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1407 /* XXX Need metaconfig test */
1408 union semun unsemds;
1411 id = SvIVx(*++mark);
1412 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1413 cmd = SvIVx(*++mark);
1416 getinfo = (cmd == IPC_STAT);
1422 if (cmd == IPC_STAT || cmd == IPC_SET)
1423 infosize = sizeof(struct msqid_ds);
1428 if (cmd == IPC_STAT || cmd == IPC_SET)
1429 infosize = sizeof(struct shmid_ds);
1434 if (cmd == IPC_STAT || cmd == IPC_SET)
1435 infosize = sizeof(struct semid_ds);
1436 else if (cmd == GETALL || cmd == SETALL)
1438 struct semid_ds semds;
1439 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1440 /* XXX Need metaconfig test */
1441 /* linux and Solaris2 uses :
1442 int semctl (int semid, int semnum, int cmd, union semun arg)
1445 struct semid_ds *buf;
1451 if (semctl(id, 0, IPC_STAT, semun) == -1)
1453 if (semctl(id, 0, IPC_STAT, &semds) == -1)
1456 getinfo = (cmd == GETALL);
1457 infosize = semds.sem_nsems * sizeof(short);
1458 /* "short" is technically wrong but much more portable
1459 than guessing about u_?short(_t)? */
1463 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1465 croak("%s not implemented", op_desc[optype]);
1474 SvPV_force(astr, len);
1475 a = SvGROW(astr, infosize+1);
1479 a = SvPV(astr, len);
1480 if (len != infosize)
1481 croak("Bad arg length for %s, is %lu, should be %ld",
1482 op_desc[optype], (unsigned long)len, (long)infosize);
1488 a = (char *)i; /* ouch */
1495 ret = msgctl(id, cmd, (struct msqid_ds *)a);
1500 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1501 /* XXX Need metaconfig test */
1502 unsemds.buf = (struct semid_ds *)a;
1503 ret = semctl(id, n, cmd, unsemds);
1505 ret = semctl(id, n, cmd, (struct semid_ds *)a);
1511 ret = shmctl(id, cmd, (struct shmid_ds *)a);
1515 if (getinfo && ret >= 0) {
1516 SvCUR_set(astr, infosize);
1517 *SvEND(astr) = '\0';
1524 do_msgsnd(SV **mark, SV **sp)
1530 I32 id, msize, flags;
1533 id = SvIVx(*++mark);
1535 flags = SvIVx(*++mark);
1536 mbuf = SvPV(mstr, len);
1537 if ((msize = len - sizeof(long)) < 0)
1538 croak("Arg too short for msgsnd");
1540 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
1542 croak("msgsnd not implemented");
1547 do_msgrcv(SV **mark, SV **sp)
1554 I32 id, msize, flags, ret;
1557 id = SvIVx(*++mark);
1559 msize = SvIVx(*++mark);
1560 mtype = (long)SvIVx(*++mark);
1561 flags = SvIVx(*++mark);
1562 if (SvTHINKFIRST(mstr)) {
1563 if (SvREADONLY(mstr))
1564 croak("Can't msgrcv to readonly var");
1568 SvPV_force(mstr, len);
1569 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1572 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
1574 SvCUR_set(mstr, sizeof(long)+ret);
1575 *SvEND(mstr) = '\0';
1579 croak("msgrcv not implemented");
1584 do_semop(SV **mark, SV **sp)
1593 id = SvIVx(*++mark);
1595 opbuf = SvPV(opstr, opsize);
1596 if (opsize < sizeof(struct sembuf)
1597 || (opsize % sizeof(struct sembuf)) != 0) {
1598 SETERRNO(EINVAL,LIB$_INVARG);
1602 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
1604 croak("semop not implemented");
1609 do_shmio(I32 optype, SV **mark, SV **sp)
1615 I32 id, mpos, msize;
1617 struct shmid_ds shmds;
1619 id = SvIVx(*++mark);
1621 mpos = SvIVx(*++mark);
1622 msize = SvIVx(*++mark);
1624 if (shmctl(id, IPC_STAT, &shmds) == -1)
1626 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
1627 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
1630 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
1631 if (shm == (char *)-1) /* I hate System V IPC, I really do */
1633 if (optype == OP_SHMREAD) {
1634 SvPV_force(mstr, len);
1635 mbuf = SvGROW(mstr, msize+1);
1637 Copy(shm + mpos, mbuf, msize, char);
1638 SvCUR_set(mstr, msize);
1639 *SvEND(mstr) = '\0';
1645 mbuf = SvPV(mstr, len);
1646 if ((n = len) > msize)
1648 Copy(mbuf, shm + mpos, n, char);
1650 memzero(shm + mpos + n, msize - n);
1654 croak("shm I/O not implemented");
1658 #endif /* SYSV IPC */