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);
723 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
724 /* code courtesy of William Kucharski */
727 I32 my_chsize(fd, length)
728 I32 fd; /* file descriptor */
729 Off_t length; /* length to set file to */
734 if (PerlLIO_fstat(fd, &filebuf) < 0)
737 if (filebuf.st_size < length) {
739 /* extend file length */
741 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
744 /* write a "0" byte */
746 if ((PerlLIO_write(fd, "", 1)) != 1)
750 /* truncate length */
755 fl.l_type = F_WRLCK; /* write lock on file space */
758 * This relies on the UNDOCUMENTED F_FREESP argument to
759 * fcntl(2), which truncates the file so that it ends at the
760 * position indicated by fl.l_start.
762 * Will minor miracles never cease?
765 if (fcntl(fd, F_FREESP, &fl) < 0)
772 #endif /* F_FREESP */
775 do_print(register SV *sv, PerlIO *fp)
780 /* assuming fp is checked earlier */
786 if (SvIOK(sv) && SvIVX(sv) != 0) {
787 PerlIO_printf(fp, ofmt, (double)SvIVX(sv));
788 return !PerlIO_error(fp);
790 if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
791 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
792 PerlIO_printf(fp, ofmt, SvNVX(sv));
793 return !PerlIO_error(fp);
796 switch (SvTYPE(sv)) {
805 PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
806 return !PerlIO_error(fp);
810 tmps = SvPV(sv, len);
813 if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
815 return !PerlIO_error(fp);
825 if (op->op_flags & OPf_REF) {
827 tmpgv = cGVOP->op_gv;
830 if (io && IoIFP(io)) {
832 sv_setpv(statname,"");
834 return (laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache));
840 warn("Stat on unopened file <%s>",
843 sv_setpv(statname,"");
844 return (laststatval = -1);
851 if (SvTYPE(sv) == SVt_PVGV) {
855 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
856 tmpgv = (GV*)SvRV(sv);
862 sv_setpv(statname, s);
864 laststatval = PerlLIO_stat(s, &statcache);
865 if (laststatval < 0 && dowarn && strchr(s, '\n'))
866 warn(warn_nl, "stat");
876 if (op->op_flags & OPf_REF) {
878 if (cGVOP->op_gv == defgv) {
879 if (laststype != OP_LSTAT)
880 croak("The stat preceding -l _ wasn't an lstat");
883 croak("You can't use -l on a filehandle");
886 laststype = OP_LSTAT;
890 sv_setpv(statname,SvPV(sv, na));
892 laststatval = PerlLIO_lstat(SvPV(sv, na),&statcache);
894 laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
896 if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
897 warn(warn_nl, "lstat");
902 do_aexec(SV *really, register SV **mark, register SV **sp)
909 New(401,Argv, sp - mark + 1, char*);
911 while (++mark <= sp) {
913 *a++ = SvPVx(*mark, na);
918 if (*Argv[0] != '/') /* will execvp use PATH? */
919 TAINT_ENV(); /* testing IFS here is overkill, probably */
920 if (really && *(tmps = SvPV(really, na)))
921 PerlProc_execvp(tmps,Argv);
923 PerlProc_execvp(Argv[0],Argv);
925 warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
936 Argv = Null(char **);
944 #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
953 while (*cmd && isSPACE(*cmd))
956 /* save an extra exec if possible */
959 if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) {
977 PerlProc_execl(cshname,"csh", flags,ncmd,(char*)0);
985 /* see if there are shell metacharacters in it */
987 if (*cmd == '.' && isSPACE(cmd[1]))
990 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
993 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
997 for (s = cmd; *s; s++) {
998 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
999 if (*s == '\n' && !s[1]) {
1004 PerlProc_execl(sh_path, "sh", "-c", cmd, (char*)0);
1009 New(402,Argv, (s - cmd) / 2 + 2, char*);
1010 Cmd = savepvn(cmd, s-cmd);
1012 for (s = Cmd; *s;) {
1013 while (*s && isSPACE(*s)) s++;
1016 while (*s && !isSPACE(*s)) s++;
1022 PerlProc_execvp(Argv[0],Argv);
1023 if (errno == ENOEXEC) { /* for system V NIH syndrome */
1028 warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
1034 #endif /* OS2 || WIN32 */
1037 apply(I32 type, register SV **mark, register SV **sp)
1042 register I32 tot = 0;
1045 SV **oldmark = mark;
1047 #define APPLY_TAINT_PROPER() \
1048 if (!(tainting && tainted)) {} else { goto taint_proper; }
1050 /* This is a first heuristic; it doesn't catch tainting magic. */
1052 while (++mark <= sp) {
1053 if (SvTAINTED(*mark)) {
1063 APPLY_TAINT_PROPER();
1066 APPLY_TAINT_PROPER();
1068 while (++mark <= sp) {
1069 char *name = SvPVx(*mark, na);
1070 APPLY_TAINT_PROPER();
1071 if (PerlLIO_chmod(name, val))
1079 APPLY_TAINT_PROPER();
1080 if (sp - mark > 2) {
1081 val = SvIVx(*++mark);
1082 val2 = SvIVx(*++mark);
1083 APPLY_TAINT_PROPER();
1085 while (++mark <= sp) {
1086 char *name = SvPVx(*mark, na);
1087 APPLY_TAINT_PROPER();
1088 if (chown(name, val, val2))
1097 APPLY_TAINT_PROPER();
1100 s = SvPVx(*++mark, na);
1102 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1104 if (!(val = whichsig(s)))
1105 croak("Unrecognized signal name \"%s\"",s);
1109 APPLY_TAINT_PROPER();
1112 /* kill() doesn't do process groups (job trees?) under VMS */
1113 if (val < 0) val = -val;
1114 if (val == SIGKILL) {
1115 # include <starlet.h>
1116 /* Use native sys$delprc() to insure that target process is
1117 * deleted; supervisor-mode images don't pay attention to
1118 * CRTL's emulation of Unix-style signals and kill()
1120 while (++mark <= sp) {
1121 I32 proc = SvIVx(*mark);
1122 register unsigned long int __vmssts;
1123 APPLY_TAINT_PROPER();
1124 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1128 case SS$_NOSUCHNODE:
1129 SETERRNO(ESRCH,__vmssts);
1132 SETERRNO(EPERM,__vmssts);
1135 SETERRNO(EVMSERR,__vmssts);
1144 while (++mark <= sp) {
1145 I32 proc = SvIVx(*mark);
1146 APPLY_TAINT_PROPER();
1148 if (PerlProc_killpg(proc,val)) /* BSD */
1150 if (PerlProc_kill(-proc,val)) /* SYSV */
1156 while (++mark <= sp) {
1157 I32 proc = SvIVx(*mark);
1158 APPLY_TAINT_PROPER();
1159 if (PerlProc_kill(proc, val))
1167 APPLY_TAINT_PROPER();
1169 while (++mark <= sp) {
1170 s = SvPVx(*mark, na);
1171 APPLY_TAINT_PROPER();
1172 if (euid || unsafe) {
1176 else { /* don't let root wipe out directories without -U */
1178 if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1180 if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
1193 APPLY_TAINT_PROPER();
1194 if (sp - mark > 2) {
1195 #if defined(I_UTIME) || defined(VMS)
1196 struct utimbuf utbuf;
1204 Zero(&utbuf, sizeof utbuf, char);
1206 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
1207 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
1209 utbuf.actime = SvIVx(*++mark); /* time accessed */
1210 utbuf.modtime = SvIVx(*++mark); /* time modified */
1212 APPLY_TAINT_PROPER();
1214 while (++mark <= sp) {
1215 char *name = SvPVx(*mark, na);
1216 APPLY_TAINT_PROPER();
1217 if (PerlLIO_utime(name, &utbuf))
1230 return 0; /* this should never happen */
1232 #undef APPLY_TAINT_PROPER
1235 /* Do the permissions allow some operation? Assumes statcache already set. */
1236 #ifndef VMS /* VMS' cando is in vms.c */
1238 cando(I32 bit, I32 effective, register struct stat *statbufp)
1241 /* [Comments and code from Len Reed]
1242 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1243 * to write-protected files. The execute permission bit is set
1244 * by the Miscrosoft C library stat() function for the following:
1249 * All files and directories are readable.
1250 * Directories and special files, e.g. "CON", cannot be
1252 * [Comment by Tom Dinger -- a directory can have the write-protect
1253 * bit set in the file system, but DOS permits changes to
1254 * the directory anyway. In addition, all bets are off
1255 * here for networked software, such as Novell and
1259 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1260 * too so it will actually look into the files for magic numbers
1262 return (bit & statbufp->st_mode) ? TRUE : FALSE;
1264 #else /* ! DOSISH */
1265 if ((effective ? euid : uid) == 0) { /* root is special */
1266 if (bit == S_IXUSR) {
1267 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1271 return TRUE; /* root reads and writes anything */
1274 if (statbufp->st_uid == (effective ? euid : uid) ) {
1275 if (statbufp->st_mode & bit)
1276 return TRUE; /* ok as "user" */
1278 else if (ingroup((I32)statbufp->st_gid,effective)) {
1279 if (statbufp->st_mode & bit >> 3)
1280 return TRUE; /* ok as "group" */
1282 else if (statbufp->st_mode & bit >> 6)
1283 return TRUE; /* ok as "other" */
1285 #endif /* ! DOSISH */
1290 ingroup(I32 testgid, I32 effective)
1292 if (testgid == (effective ? egid : gid))
1294 #ifdef HAS_GETGROUPS
1299 Groups_t gary[NGROUPS];
1302 anum = getgroups(NGROUPS,gary);
1304 if (gary[anum] == testgid)
1311 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1314 do_ipcget(I32 optype, SV **mark, SV **sp)
1320 key = (key_t)SvNVx(*++mark);
1321 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1322 flags = SvIVx(*++mark);
1328 return msgget(key, flags);
1332 return semget(key, n, flags);
1336 return shmget(key, n, flags);
1338 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1340 croak("%s not implemented", op_desc[optype]);
1343 return -1; /* should never happen */
1346 #if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */
1347 /* Solaris manpage says that it uses (like linux)
1348 int semctl (int semid, int semnum, int cmd, union semun arg)
1349 but the system include files do not define union semun !!!!
1353 struct semid_ds *buf;
1359 do_ipcctl(I32 optype, SV **mark, SV **sp)
1364 I32 id, n, cmd, infosize, getinfo;
1366 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1367 /* XXX Need metaconfig test */
1368 union semun unsemds;
1371 id = SvIVx(*++mark);
1372 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1373 cmd = SvIVx(*++mark);
1376 getinfo = (cmd == IPC_STAT);
1382 if (cmd == IPC_STAT || cmd == IPC_SET)
1383 infosize = sizeof(struct msqid_ds);
1388 if (cmd == IPC_STAT || cmd == IPC_SET)
1389 infosize = sizeof(struct shmid_ds);
1394 if (cmd == IPC_STAT || cmd == IPC_SET)
1395 infosize = sizeof(struct semid_ds);
1396 else if (cmd == GETALL || cmd == SETALL)
1398 struct semid_ds semds;
1399 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1400 /* XXX Need metaconfig test */
1401 /* linux and Solaris2 uses :
1402 int semctl (int semid, int semnum, int cmd, union semun arg)
1405 struct semid_ds *buf;
1411 if (semctl(id, 0, IPC_STAT, semun) == -1)
1413 if (semctl(id, 0, IPC_STAT, &semds) == -1)
1416 getinfo = (cmd == GETALL);
1417 infosize = semds.sem_nsems * sizeof(short);
1418 /* "short" is technically wrong but much more portable
1419 than guessing about u_?short(_t)? */
1423 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1425 croak("%s not implemented", op_desc[optype]);
1434 SvPV_force(astr, len);
1435 a = SvGROW(astr, infosize+1);
1439 a = SvPV(astr, len);
1440 if (len != infosize)
1441 croak("Bad arg length for %s, is %lu, should be %ld",
1442 op_desc[optype], (unsigned long)len, (long)infosize);
1448 a = (char *)i; /* ouch */
1455 ret = msgctl(id, cmd, (struct msqid_ds *)a);
1460 #if defined(__linux__) || (defined(__sun) && defined(__svr4__))
1461 /* XXX Need metaconfig test */
1462 unsemds.buf = (struct semid_ds *)a;
1463 ret = semctl(id, n, cmd, unsemds);
1465 ret = semctl(id, n, cmd, (struct semid_ds *)a);
1471 ret = shmctl(id, cmd, (struct shmid_ds *)a);
1475 if (getinfo && ret >= 0) {
1476 SvCUR_set(astr, infosize);
1477 *SvEND(astr) = '\0';
1484 do_msgsnd(SV **mark, SV **sp)
1490 I32 id, msize, flags;
1493 id = SvIVx(*++mark);
1495 flags = SvIVx(*++mark);
1496 mbuf = SvPV(mstr, len);
1497 if ((msize = len - sizeof(long)) < 0)
1498 croak("Arg too short for msgsnd");
1500 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
1502 croak("msgsnd not implemented");
1507 do_msgrcv(SV **mark, SV **sp)
1514 I32 id, msize, flags, ret;
1517 id = SvIVx(*++mark);
1519 msize = SvIVx(*++mark);
1520 mtype = (long)SvIVx(*++mark);
1521 flags = SvIVx(*++mark);
1522 if (SvTHINKFIRST(mstr)) {
1523 if (SvREADONLY(mstr))
1524 croak("Can't msgrcv to readonly var");
1528 SvPV_force(mstr, len);
1529 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1532 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
1534 SvCUR_set(mstr, sizeof(long)+ret);
1535 *SvEND(mstr) = '\0';
1539 croak("msgrcv not implemented");
1544 do_semop(SV **mark, SV **sp)
1553 id = SvIVx(*++mark);
1555 opbuf = SvPV(opstr, opsize);
1556 if (opsize < sizeof(struct sembuf)
1557 || (opsize % sizeof(struct sembuf)) != 0) {
1558 SETERRNO(EINVAL,LIB$_INVARG);
1562 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
1564 croak("semop not implemented");
1569 do_shmio(I32 optype, SV **mark, SV **sp)
1575 I32 id, mpos, msize;
1577 struct shmid_ds shmds;
1579 id = SvIVx(*++mark);
1581 mpos = SvIVx(*++mark);
1582 msize = SvIVx(*++mark);
1584 if (shmctl(id, IPC_STAT, &shmds) == -1)
1586 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
1587 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
1590 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
1591 if (shm == (char *)-1) /* I hate System V IPC, I really do */
1593 if (optype == OP_SHMREAD) {
1594 SvPV_force(mstr, len);
1595 mbuf = SvGROW(mstr, msize+1);
1597 Copy(shm + mpos, mbuf, msize, char);
1598 SvCUR_set(mstr, msize);
1599 *SvEND(mstr) = '\0';
1605 mbuf = SvPV(mstr, len);
1606 if ((n = len) > msize)
1608 Copy(mbuf, shm + mpos, n, char);
1610 memzero(shm + mpos + n, msize - n);
1614 croak("shm I/O not implemented");
1618 #endif /* SYSV IPC */