This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't use setjmp() and longjmp() in complex exprs
[perl5.git] / doio.c
CommitLineData
a0d0e21e 1/* doio.c
a687059c 2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
a687059c 4 *
6e21c824
LW
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.
a687059c 7 *
a0d0e21e
LW
8 */
9
10/*
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."
a687059c
LW
15 */
16
17#include "EXTERN.h"
18#include "perl.h"
19
fe14fcc3 20#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 21#include <sys/ipc.h>
fe14fcc3 22#ifdef HAS_MSG
c2ab57d4 23#include <sys/msg.h>
e5d73d77 24#endif
fe14fcc3 25#ifdef HAS_SEM
c2ab57d4 26#include <sys/sem.h>
e5d73d77 27#endif
fe14fcc3 28#ifdef HAS_SHM
c2ab57d4 29#include <sys/shm.h>
a0d0e21e
LW
30# ifndef HAS_SHMAT_PROTOTYPE
31 extern Shmat_t shmat _((int, char *, int));
32# endif
c2ab57d4 33#endif
e5d73d77 34#endif
c2ab57d4 35
663a0e37 36#ifdef I_UTIME
3fe9a6f1
PP
37# ifdef WIN32
38# include <sys/utime.h>
39# else
40# include <utime.h>
41# endif
663a0e37 42#endif
ff8e2863
LW
43#ifdef I_FCNTL
44#include <fcntl.h>
45#endif
fe14fcc3
LW
46#ifdef I_SYS_FILE
47#include <sys/file.h>
48#endif
a687059c 49
76121258
PP
50#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
51#include <signal.h>
52#endif
53
54/* XXX If this causes problems, set i_unistd=undef in the hint file. */
55#ifdef I_UNISTD
56# include <unistd.h>
57#endif
58
232e078e
AD
59#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
60# include <sys/socket.h>
61# include <netdb.h>
62# ifndef ENOTSOCK
63# ifdef I_NET_ERRNO
64# include <net/errno.h>
65# endif
66# endif
67#endif
68
a687059c 69bool
c07a80fd 70do_open(gv,name,len,as_raw,rawmode,rawperm,supplied_fp)
79072805 71GV *gv;
a687059c 72register char *name;
79072805 73I32 len;
c07a80fd
PP
74int as_raw;
75int rawmode, rawperm;
760ac839 76PerlIO *supplied_fp;
a687059c 77{
a0d0e21e 78 register IO *io = GvIOn(gv);
760ac839
LW
79 PerlIO *saveifp = Nullfp;
80 PerlIO *saveofp = Nullfp;
6e21c824 81 char savetype = ' ';
c07a80fd 82 int writing = 0;
760ac839 83 PerlIO *fp;
c07a80fd
PP
84 int fd;
85 int result;
a687059c 86
a687059c 87 forkprocess = 1; /* assume true if no fork */
c07a80fd 88
a0d0e21e 89 if (IoIFP(io)) {
760ac839 90 fd = PerlIO_fileno(IoIFP(io));
8990e307 91 if (IoTYPE(io) == '-')
c2ab57d4 92 result = 0;
6e21c824 93 else if (fd <= maxsysfd) {
8990e307
LW
94 saveifp = IoIFP(io);
95 saveofp = IoOFP(io);
96 savetype = IoTYPE(io);
6e21c824
LW
97 result = 0;
98 }
8990e307
LW
99 else if (IoTYPE(io) == '|')
100 result = my_pclose(IoIFP(io));
101 else if (IoIFP(io) != IoOFP(io)) {
102 if (IoOFP(io)) {
760ac839
LW
103 result = PerlIO_close(IoOFP(io));
104 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
105 }
106 else
760ac839 107 result = PerlIO_close(IoIFP(io));
a687059c 108 }
a687059c 109 else
760ac839 110 result = PerlIO_close(IoIFP(io));
6e21c824 111 if (result == EOF && fd > maxsysfd)
760ac839 112 PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
79072805 113 GvENAME(gv));
8990e307 114 IoOFP(io) = IoIFP(io) = Nullfp;
a687059c 115 }
c07a80fd
PP
116
117 if (as_raw) {
118 result = rawmode & 3;
119 IoTYPE(io) = "<>++"[result];
120 writing = (result > 0);
121 fd = open(name, rawmode, rawperm);
122 if (fd == -1)
123 fp = NULL;
124 else {
360e5741
CS
125 char *fpmode;
126 if (result == 0)
127 fpmode = "r";
128#ifdef O_APPEND
129 else if (rawmode & O_APPEND)
130 fpmode = (result == 1) ? "a" : "a+";
131#endif
132 else
133 fpmode = (result == 1) ? "w" : "r+";
134 fp = PerlIO_fdopen(fd, fpmode);
c07a80fd
PP
135 if (!fp)
136 close(fd);
137 }
a687059c 138 }
c07a80fd
PP
139 else {
140 char *myname;
141 char mode[3]; /* stdio file mode ("r\0" or "r+\0") */
142 int dodup;
143
144 myname = savepvn(name, len);
145 SAVEFREEPV(myname);
146 name = myname;
147 while (len && isSPACE(name[len-1]))
148 name[--len] = '\0';
149
150 mode[0] = mode[1] = mode[2] = '\0';
151 IoTYPE(io) = *name;
152 if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
153 mode[1] = *name++;
154 --len;
155 writing = 1;
a687059c 156 }
c07a80fd
PP
157
158 if (*name == '|') {
159 /*SUPPRESS 530*/
160 for (name++; isSPACE(*name); name++) ;
161 if (strNE(name,"-"))
162 TAINT_ENV();
163 TAINT_PROPER("piped open");
164 if (dowarn && name[strlen(name)-1] == '|')
165 warn("Can't do bidirectional pipe");
166 fp = my_popen(name,"w");
167 writing = 1;
168 }
169 else if (*name == '>') {
170 TAINT_PROPER("open");
bf38876a 171 name++;
c07a80fd
PP
172 if (*name == '>') {
173 mode[0] = IoTYPE(io) = 'a';
bf38876a 174 name++;
a0d0e21e 175 }
c07a80fd
PP
176 else
177 mode[0] = 'w';
178 writing = 1;
179
180 if (*name == '&') {
181 duplicity:
182 dodup = 1;
183 name++;
184 if (*name == '=') {
185 dodup = 0;
a0d0e21e 186 name++;
c07a80fd
PP
187 }
188 if (!*name && supplied_fp)
189 fp = supplied_fp;
a0d0e21e 190 else {
c07a80fd
PP
191 /*SUPPRESS 530*/
192 for (; isSPACE(*name); name++) ;
193 if (isDIGIT(*name))
194 fd = atoi(name);
195 else {
196 IO* thatio;
197 gv = gv_fetchpv(name,FALSE,SVt_PVIO);
198 thatio = GvIO(gv);
199 if (!thatio) {
6e21c824 200#ifdef EINVAL
c07a80fd 201 SETERRNO(EINVAL,SS$_IVCHAN);
6e21c824 202#endif
c07a80fd
PP
203 goto say_false;
204 }
205 if (IoIFP(thatio)) {
760ac839 206 fd = PerlIO_fileno(IoIFP(thatio));
c07a80fd
PP
207 if (IoTYPE(thatio) == 's')
208 IoTYPE(io) = 's';
209 }
210 else
211 fd = -1;
a0d0e21e 212 }
fec02dd3 213 if (dodup)
c07a80fd 214 fd = dup(fd);
760ac839 215 if (!(fp = PerlIO_fdopen(fd,mode))) {
c07a80fd
PP
216 if (dodup)
217 close(fd);
517844ec 218 }
c07a80fd 219 }
bf38876a 220 }
c07a80fd
PP
221 else {
222 /*SUPPRESS 530*/
223 for (; isSPACE(*name); name++) ;
224 if (strEQ(name,"-")) {
760ac839 225 fp = PerlIO_stdout();
c07a80fd
PP
226 IoTYPE(io) = '-';
227 }
228 else {
760ac839 229 fp = PerlIO_open(name,mode);
c07a80fd 230 }
bf38876a
LW
231 }
232 }
c07a80fd
PP
233 else if (*name == '<') {
234 /*SUPPRESS 530*/
235 for (name++; isSPACE(*name); name++) ;
bf38876a 236 mode[0] = 'r';
bf38876a
LW
237 if (*name == '&')
238 goto duplicity;
a687059c 239 if (strEQ(name,"-")) {
760ac839 240 fp = PerlIO_stdin();
8990e307 241 IoTYPE(io) = '-';
a687059c 242 }
bf38876a 243 else
760ac839 244 fp = PerlIO_open(name,mode);
a687059c
LW
245 }
246 else if (name[len-1] == '|') {
a687059c 247 name[--len] = '\0';
99b89507 248 while (len && isSPACE(name[len-1]))
a687059c 249 name[--len] = '\0';
99b89507
LW
250 /*SUPPRESS 530*/
251 for (; isSPACE(*name); name++) ;
79072805
LW
252 if (strNE(name,"-"))
253 TAINT_ENV();
254 TAINT_PROPER("piped open");
255 fp = my_popen(name,"r");
8990e307 256 IoTYPE(io) = '|';
a687059c
LW
257 }
258 else {
8990e307 259 IoTYPE(io) = '<';
99b89507
LW
260 /*SUPPRESS 530*/
261 for (; isSPACE(*name); name++) ;
a687059c 262 if (strEQ(name,"-")) {
760ac839 263 fp = PerlIO_stdin();
8990e307 264 IoTYPE(io) = '-';
a687059c
LW
265 }
266 else
760ac839 267 fp = PerlIO_open(name,"r");
a687059c
LW
268 }
269 }
bee1dbe2 270 if (!fp) {
8990e307 271 if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
bee1dbe2 272 warn(warn_nl, "open");
6e21c824 273 goto say_false;
bee1dbe2 274 }
8990e307
LW
275 if (IoTYPE(io) &&
276 IoTYPE(io) != '|' && IoTYPE(io) != '-') {
760ac839
LW
277 if (Fstat(PerlIO_fileno(fp),&statbuf) < 0) {
278 (void)PerlIO_close(fp);
6e21c824 279 goto say_false;
a687059c 280 }
1462b684 281 if (S_ISSOCK(statbuf.st_mode))
8990e307 282 IoTYPE(io) = 's'; /* in case a socket was passed in to us */
99b89507
LW
283#ifdef HAS_SOCKET
284 else if (
c623bd54 285#ifdef S_IFMT
99b89507
LW
286 !(statbuf.st_mode & S_IFMT)
287#else
288 !statbuf.st_mode
289#endif
290 ) {
a0d0e21e 291 int buflen = sizeof tokenbuf;
760ac839 292 if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tokenbuf, &buflen) >= 0
bee1dbe2 293 || errno != ENOTSOCK)
8990e307 294 IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
99b89507
LW
295 /* but some return 0 for streams too, sigh */
296 }
bf38876a 297#endif
a687059c 298 }
6e21c824 299 if (saveifp) { /* must use old fp? */
760ac839 300 fd = PerlIO_fileno(saveifp);
6e21c824 301 if (saveofp) {
760ac839 302 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
6e21c824 303 if (saveofp != saveifp) { /* was a socket? */
760ac839 304 PerlIO_close(saveofp);
99b89507
LW
305 if (fd > 2)
306 Safefree(saveofp);
6e21c824
LW
307 }
308 }
760ac839 309 if (fd != PerlIO_fileno(fp)) {
bee1dbe2 310 int pid;
79072805 311 SV *sv;
bee1dbe2 312
760ac839
LW
313 dup2(PerlIO_fileno(fp), fd);
314 sv = *av_fetch(fdpid,PerlIO_fileno(fp),TRUE);
a0d0e21e 315 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2
LW
316 pid = SvIVX(sv);
317 SvIVX(sv) = 0;
79072805 318 sv = *av_fetch(fdpid,fd,TRUE);
a0d0e21e 319 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2 320 SvIVX(sv) = pid;
760ac839 321 PerlIO_close(fp);
bee1dbe2 322
6e21c824
LW
323 }
324 fp = saveifp;
760ac839 325 PerlIO_clearerr(fp);
6e21c824 326 }
a0d0e21e 327#if defined(HAS_FCNTL) && defined(F_SETFD)
760ac839 328 fd = PerlIO_fileno(fp);
a0d0e21e 329 fcntl(fd,F_SETFD,fd > maxsysfd);
1462b684 330#endif
8990e307 331 IoIFP(io) = fp;
bf38876a 332 if (writing) {
8990e307
LW
333 if (IoTYPE(io) == 's'
334 || (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) {
760ac839
LW
335 if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
336 PerlIO_close(fp);
8990e307 337 IoIFP(io) = Nullfp;
6e21c824 338 goto say_false;
fe14fcc3 339 }
1462b684
LW
340 }
341 else
8990e307 342 IoOFP(io) = fp;
bf38876a 343 }
a687059c 344 return TRUE;
6e21c824
LW
345
346say_false:
8990e307
LW
347 IoIFP(io) = saveifp;
348 IoOFP(io) = saveofp;
349 IoTYPE(io) = savetype;
6e21c824 350 return FALSE;
a687059c
LW
351}
352
760ac839 353PerlIO *
79072805
LW
354nextargv(gv)
355register GV *gv;
a687059c 356{
79072805 357 register SV *sv;
99b89507 358#ifndef FLEXFILENAMES
c623bd54
LW
359 int filedev;
360 int fileino;
99b89507 361#endif
c623bd54
LW
362 int fileuid;
363 int filegid;
fe14fcc3 364
79072805 365 if (!argvoutgv)
85e6fe83 366 argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
fe14fcc3 367 if (filemode & (S_ISUID|S_ISGID)) {
760ac839 368 PerlIO_flush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */
fe14fcc3
LW
369#ifdef HAS_FCHMOD
370 (void)fchmod(lastfd,filemode);
371#else
372 (void)chmod(oldname,filemode);
373#endif
374 }
375 filemode = 0;
79072805 376 while (av_len(GvAV(gv)) >= 0) {
463ee0b2 377 STRLEN len;
79072805 378 sv = av_shift(GvAV(gv));
8990e307 379 SAVEFREESV(sv);
79072805
LW
380 sv_setsv(GvSV(gv),sv);
381 SvSETMAGIC(GvSV(gv));
463ee0b2 382 oldname = SvPVx(GvSV(gv), len);
c07a80fd 383 if (do_open(gv,oldname,len,FALSE,0,0,Nullfp)) {
a687059c 384 if (inplace) {
79072805 385 TAINT_PROPER("inplace open");
c623bd54 386 if (strEQ(oldname,"-")) {
4633a7c4 387 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a0d0e21e 388 return IoIFP(GvIOp(gv));
c623bd54 389 }
99b89507 390#ifndef FLEXFILENAMES
c623bd54
LW
391 filedev = statbuf.st_dev;
392 fileino = statbuf.st_ino;
99b89507 393#endif
a687059c
LW
394 filemode = statbuf.st_mode;
395 fileuid = statbuf.st_uid;
396 filegid = statbuf.st_gid;
c623bd54
LW
397 if (!S_ISREG(filemode)) {
398 warn("Can't do inplace edit: %s is not a regular file",
399 oldname );
79072805 400 do_close(gv,FALSE);
c623bd54
LW
401 continue;
402 }
a687059c 403 if (*inplace) {
ff8e2863 404#ifdef SUFFIX
79072805 405 add_suffix(sv,inplace);
ff8e2863 406#else
79072805 407 sv_catpv(sv,inplace);
ff8e2863 408#endif
c623bd54 409#ifndef FLEXFILENAMES
a0d0e21e 410 if (Stat(SvPVX(sv),&statbuf) >= 0
c623bd54
LW
411 && statbuf.st_dev == filedev
412 && statbuf.st_ino == fileino ) {
413 warn("Can't do inplace edit: %s > 14 characters",
463ee0b2 414 SvPVX(sv) );
79072805 415 do_close(gv,FALSE);
c623bd54
LW
416 continue;
417 }
418#endif
fe14fcc3 419#ifdef HAS_RENAME
bee1dbe2 420#ifndef DOSISH
463ee0b2 421 if (rename(oldname,SvPVX(sv)) < 0) {
c623bd54 422 warn("Can't rename %s to %s: %s, skipping file",
2304df62 423 oldname, SvPVX(sv), Strerror(errno) );
79072805 424 do_close(gv,FALSE);
c623bd54
LW
425 continue;
426 }
a687059c 427#else
79072805 428 do_close(gv,FALSE);
463ee0b2
LW
429 (void)unlink(SvPVX(sv));
430 (void)rename(oldname,SvPVX(sv));
1193dd27 431 do_open(gv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp);
55497cff 432#endif /* DOSISH */
ff8e2863 433#else
463ee0b2
LW
434 (void)UNLINK(SvPVX(sv));
435 if (link(oldname,SvPVX(sv)) < 0) {
c623bd54 436 warn("Can't rename %s to %s: %s, skipping file",
2304df62 437 oldname, SvPVX(sv), Strerror(errno) );
79072805 438 do_close(gv,FALSE);
c623bd54
LW
439 continue;
440 }
a687059c
LW
441 (void)UNLINK(oldname);
442#endif
443 }
444 else {
a8c18271 445#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 446# ifndef VMS /* Don't delete; use automatic file versioning */
fe14fcc3
LW
447 if (UNLINK(oldname) < 0) {
448 warn("Can't rename %s to %s: %s, skipping file",
2304df62 449 oldname, SvPVX(sv), Strerror(errno) );
79072805 450 do_close(gv,FALSE);
fe14fcc3
LW
451 continue;
452 }
edc7bc49 453# endif
ff8e2863 454#else
463ee0b2 455 croak("Can't do inplace edit without backup");
ff8e2863 456#endif
a687059c
LW
457 }
458
79072805
LW
459 sv_setpvn(sv,">",1);
460 sv_catpv(sv,oldname);
748a9306 461 SETERRNO(0,0); /* in case sprintf set errno */
c07a80fd 462 if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp)) {
c623bd54 463 warn("Can't do inplace edit on %s: %s",
2304df62 464 oldname, Strerror(errno) );
79072805 465 do_close(gv,FALSE);
fe14fcc3
LW
466 continue;
467 }
4633a7c4 468 setdefout(argvoutgv);
760ac839 469 lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv)));
a0d0e21e 470 (void)Fstat(lastfd,&statbuf);
fe14fcc3
LW
471#ifdef HAS_FCHMOD
472 (void)fchmod(lastfd,filemode);
a687059c
LW
473#else
474 (void)chmod(oldname,filemode);
475#endif
fe14fcc3
LW
476 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
477#ifdef HAS_FCHOWN
478 (void)fchown(lastfd,fileuid,filegid);
a687059c 479#else
fe14fcc3
LW
480#ifdef HAS_CHOWN
481 (void)chown(oldname,fileuid,filegid);
a687059c 482#endif
b1248f16 483#endif
fe14fcc3 484 }
a687059c 485 }
a0d0e21e 486 return IoIFP(GvIOp(gv));
a687059c
LW
487 }
488 else
760ac839 489 PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",SvPV(sv, na), Strerror(errno));
a687059c
LW
490 }
491 if (inplace) {
79072805 492 (void)do_close(argvoutgv,FALSE);
4633a7c4 493 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a687059c
LW
494 }
495 return Nullfp;
496}
497
fe14fcc3 498#ifdef HAS_PIPE
afd9f252 499void
79072805
LW
500do_pipe(sv, rgv, wgv)
501SV *sv;
502GV *rgv;
503GV *wgv;
afd9f252 504{
79072805
LW
505 register IO *rstio;
506 register IO *wstio;
afd9f252
LW
507 int fd[2];
508
79072805 509 if (!rgv)
afd9f252 510 goto badexit;
79072805 511 if (!wgv)
afd9f252
LW
512 goto badexit;
513
a0d0e21e
LW
514 rstio = GvIOn(rgv);
515 wstio = GvIOn(wgv);
afd9f252 516
a0d0e21e 517 if (IoIFP(rstio))
79072805 518 do_close(rgv,FALSE);
a0d0e21e 519 if (IoIFP(wstio))
79072805 520 do_close(wgv,FALSE);
afd9f252
LW
521
522 if (pipe(fd) < 0)
523 goto badexit;
760ac839
LW
524 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
525 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
8990e307
LW
526 IoIFP(wstio) = IoOFP(wstio);
527 IoTYPE(rstio) = '<';
528 IoTYPE(wstio) = '>';
529 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 530 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
fe14fcc3 531 else close(fd[0]);
760ac839 532 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
fe14fcc3
LW
533 else close(fd[1]);
534 goto badexit;
535 }
afd9f252 536
79072805 537 sv_setsv(sv,&sv_yes);
afd9f252
LW
538 return;
539
540badexit:
79072805 541 sv_setsv(sv,&sv_undef);
afd9f252
LW
542 return;
543}
b1248f16 544#endif
afd9f252 545
517844ec 546/* explicit renamed to avoid C++ conflict -- kja */
a687059c 547bool
a0d0e21e 548#ifndef CAN_PROTOTYPE
517844ec 549do_close(gv,not_implicit)
79072805 550GV *gv;
517844ec 551bool not_implicit;
8990e307 552#else
517844ec 553do_close(GV *gv, bool not_implicit)
a0d0e21e 554#endif /* CAN_PROTOTYPE */
a687059c 555{
1193dd27
IZ
556 bool retval;
557 IO *io;
a687059c 558
79072805
LW
559 if (!gv)
560 gv = argvgv;
a0d0e21e 561 if (!gv || SvTYPE(gv) != SVt_PVGV) {
748a9306 562 SETERRNO(EBADF,SS$_IVCHAN);
c2ab57d4 563 return FALSE;
99b89507 564 }
79072805
LW
565 io = GvIO(gv);
566 if (!io) { /* never opened */
517844ec 567 if (dowarn && not_implicit)
79072805 568 warn("Close on unopened file <%s>",GvENAME(gv));
a687059c
LW
569 return FALSE;
570 }
1193dd27 571 retval = io_close(io);
517844ec 572 if (not_implicit) {
1193dd27
IZ
573 IoLINES(io) = 0;
574 IoPAGE(io) = 0;
575 IoLINES_LEFT(io) = IoPAGE_LEN(io);
576 }
577 IoTYPE(io) = ' ';
578 return retval;
579}
580
581bool
582io_close(io)
583IO* io;
584{
585 bool retval = FALSE;
586 int status;
587
8990e307
LW
588 if (IoIFP(io)) {
589 if (IoTYPE(io) == '|') {
590 status = my_pclose(IoIFP(io));
f86702cc 591 STATUS_NATIVE_SET(status);
1e422769 592 retval = (STATUS_POSIX == 0);
a687059c 593 }
8990e307 594 else if (IoTYPE(io) == '-')
a687059c
LW
595 retval = TRUE;
596 else {
8990e307 597 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
760ac839
LW
598 retval = (PerlIO_close(IoOFP(io)) != EOF);
599 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
600 }
601 else
760ac839 602 retval = (PerlIO_close(IoIFP(io)) != EOF);
a687059c 603 }
8990e307 604 IoOFP(io) = IoIFP(io) = Nullfp;
79072805 605 }
1193dd27 606
a687059c
LW
607 return retval;
608}
609
610bool
79072805
LW
611do_eof(gv)
612GV *gv;
a687059c 613{
79072805 614 register IO *io;
a687059c
LW
615 int ch;
616
79072805 617 io = GvIO(gv);
a687059c 618
79072805 619 if (!io)
a687059c
LW
620 return TRUE;
621
8990e307 622 while (IoIFP(io)) {
a687059c 623
760ac839
LW
624 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
625 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
626 return FALSE; /* this is the most usual case */
627 }
a687059c 628
760ac839 629 ch = PerlIO_getc(IoIFP(io));
a687059c 630 if (ch != EOF) {
760ac839 631 (void)PerlIO_ungetc(IoIFP(io),ch);
a687059c
LW
632 return FALSE;
633 }
760ac839
LW
634 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
635 if (PerlIO_get_cnt(IoIFP(io)) < -1)
636 PerlIO_set_cnt(IoIFP(io),-1);
637 }
8990e307 638 if (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
79072805 639 if (!nextargv(argvgv)) /* get another fp handy */
a687059c
LW
640 return TRUE;
641 }
642 else
643 return TRUE; /* normal fp, definitely end of file */
644 }
645 return TRUE;
646}
647
648long
79072805
LW
649do_tell(gv)
650GV *gv;
a687059c 651{
79072805 652 register IO *io;
a687059c 653
79072805 654 if (!gv)
a687059c
LW
655 goto phooey;
656
79072805 657 io = GvIO(gv);
8990e307 658 if (!io || !IoIFP(io))
a687059c
LW
659 goto phooey;
660
bee1dbe2 661#ifdef ULTRIX_STDIO_BOTCH
760ac839
LW
662 if (PerlIO_eof(IoIFP(io)))
663 (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 664#endif
a687059c 665
760ac839 666 return PerlIO_tell(IoIFP(io));
a687059c
LW
667
668phooey:
669 if (dowarn)
670 warn("tell() on unopened file");
748a9306 671 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
672 return -1L;
673}
674
675bool
79072805
LW
676do_seek(gv, pos, whence)
677GV *gv;
a687059c
LW
678long pos;
679int whence;
680{
79072805 681 register IO *io;
a687059c 682
79072805 683 if (!gv)
a687059c
LW
684 goto nuts;
685
79072805 686 io = GvIO(gv);
8990e307 687 if (!io || !IoIFP(io))
a687059c
LW
688 goto nuts;
689
bee1dbe2 690#ifdef ULTRIX_STDIO_BOTCH
760ac839
LW
691 if (PerlIO_eof(IoIFP(io)))
692 (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 693#endif
a687059c 694
760ac839 695 return PerlIO_seek(IoIFP(io), pos, whence) >= 0;
a687059c
LW
696
697nuts:
698 if (dowarn)
699 warn("seek() on unopened file");
748a9306 700 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
701 return FALSE;
702}
703
a0d0e21e 704#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
c2ab57d4 705 /* code courtesy of William Kucharski */
fe14fcc3 706#define HAS_CHSIZE
6eb13c3b 707
517844ec 708I32 my_chsize(fd, length)
79072805 709I32 fd; /* file descriptor */
85e6fe83 710Off_t length; /* length to set file to */
6eb13c3b
LW
711{
712 extern long lseek();
713 struct flock fl;
714 struct stat filebuf;
715
a0d0e21e 716 if (Fstat(fd, &filebuf) < 0)
6eb13c3b
LW
717 return -1;
718
719 if (filebuf.st_size < length) {
720
721 /* extend file length */
722
723 if ((lseek(fd, (length - 1), 0)) < 0)
724 return -1;
725
726 /* write a "0" byte */
727
728 if ((write(fd, "", 1)) != 1)
729 return -1;
730 }
731 else {
732 /* truncate length */
733
734 fl.l_whence = 0;
735 fl.l_len = 0;
736 fl.l_start = length;
a0d0e21e 737 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
738
739 /*
a0d0e21e 740 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
741 * fcntl(2), which truncates the file so that it ends at the
742 * position indicated by fl.l_start.
743 *
744 * Will minor miracles never cease?
745 */
746
a0d0e21e 747 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
748 return -1;
749
750 }
751
752 return 0;
753}
a0d0e21e 754#endif /* F_FREESP */
ff8e2863 755
a687059c 756bool
79072805
LW
757do_print(sv,fp)
758register SV *sv;
760ac839 759PerlIO *fp;
a687059c
LW
760{
761 register char *tmps;
463ee0b2 762 STRLEN len;
a687059c 763
79072805
LW
764 /* assuming fp is checked earlier */
765 if (!sv)
766 return TRUE;
767 if (ofmt) {
8990e307 768 if (SvGMAGICAL(sv))
79072805 769 mg_get(sv);
463ee0b2 770 if (SvIOK(sv) && SvIVX(sv) != 0) {
760ac839
LW
771 PerlIO_printf(fp, ofmt, (double)SvIVX(sv));
772 return !PerlIO_error(fp);
79072805 773 }
463ee0b2 774 if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
79072805 775 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
760ac839
LW
776 PerlIO_printf(fp, ofmt, SvNVX(sv));
777 return !PerlIO_error(fp);
79072805 778 }
a687059c 779 }
79072805
LW
780 switch (SvTYPE(sv)) {
781 case SVt_NULL:
8990e307
LW
782 if (dowarn)
783 warn(warn_uninit);
ff8e2863 784 return TRUE;
79072805 785 case SVt_IV:
a0d0e21e
LW
786 if (SvIOK(sv)) {
787 if (SvGMAGICAL(sv))
788 mg_get(sv);
760ac839
LW
789 PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
790 return !PerlIO_error(fp);
a0d0e21e
LW
791 }
792 /* FALL THROUGH */
79072805 793 default:
463ee0b2 794 tmps = SvPV(sv, len);
79072805 795 break;
ff8e2863 796 }
760ac839 797 if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
a687059c 798 return FALSE;
760ac839 799 return !PerlIO_error(fp);
a687059c
LW
800}
801
79072805
LW
802I32
803my_stat(ARGS)
804dARGS
a687059c 805{
79072805
LW
806 dSP;
807 IO *io;
748a9306 808 GV* tmpgv;
79072805 809
a0d0e21e 810 if (op->op_flags & OPf_REF) {
79072805 811 EXTEND(sp,1);
748a9306
LW
812 tmpgv = cGVOP->op_gv;
813 do_fstat:
814 io = GvIO(tmpgv);
8990e307 815 if (io && IoIFP(io)) {
748a9306 816 statgv = tmpgv;
79072805
LW
817 sv_setpv(statname,"");
818 laststype = OP_STAT;
760ac839 819 return (laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache));
a687059c
LW
820 }
821 else {
748a9306 822 if (tmpgv == defgv)
57ebbfd0 823 return laststatval;
a687059c
LW
824 if (dowarn)
825 warn("Stat on unopened file <%s>",
748a9306 826 GvENAME(tmpgv));
79072805
LW
827 statgv = Nullgv;
828 sv_setpv(statname,"");
57ebbfd0 829 return (laststatval = -1);
a687059c
LW
830 }
831 }
832 else {
748a9306 833 SV* sv = POPs;
79072805 834 PUTBACK;
748a9306
LW
835 if (SvTYPE(sv) == SVt_PVGV) {
836 tmpgv = (GV*)sv;
837 goto do_fstat;
838 }
839 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
840 tmpgv = (GV*)SvRV(sv);
841 goto do_fstat;
842 }
843
79072805 844 statgv = Nullgv;
463ee0b2 845 sv_setpv(statname,SvPV(sv, na));
79072805 846 laststype = OP_STAT;
a0d0e21e 847 laststatval = Stat(SvPV(sv, na),&statcache);
463ee0b2 848 if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
bee1dbe2
LW
849 warn(warn_nl, "stat");
850 return laststatval;
a687059c
LW
851 }
852}
853
79072805
LW
854I32
855my_lstat(ARGS)
856dARGS
c623bd54 857{
79072805
LW
858 dSP;
859 SV *sv;
a0d0e21e 860 if (op->op_flags & OPf_REF) {
79072805
LW
861 EXTEND(sp,1);
862 if (cGVOP->op_gv == defgv) {
863 if (laststype != OP_LSTAT)
463ee0b2 864 croak("The stat preceding -l _ wasn't an lstat");
fe14fcc3
LW
865 return laststatval;
866 }
463ee0b2 867 croak("You can't use -l on a filehandle");
fe14fcc3 868 }
c623bd54 869
79072805
LW
870 laststype = OP_LSTAT;
871 statgv = Nullgv;
872 sv = POPs;
873 PUTBACK;
463ee0b2 874 sv_setpv(statname,SvPV(sv, na));
fe14fcc3 875#ifdef HAS_LSTAT
463ee0b2 876 laststatval = lstat(SvPV(sv, na),&statcache);
c623bd54 877#else
a0d0e21e 878 laststatval = Stat(SvPV(sv, na),&statcache);
c623bd54 879#endif
463ee0b2 880 if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
bee1dbe2
LW
881 warn(warn_nl, "lstat");
882 return laststatval;
c623bd54
LW
883}
884
a687059c 885bool
79072805
LW
886do_aexec(really,mark,sp)
887SV *really;
888register SV **mark;
889register SV **sp;
a687059c 890{
a687059c 891 register char **a;
a687059c
LW
892 char *tmps;
893
79072805
LW
894 if (sp > mark) {
895 New(401,Argv, sp - mark + 1, char*);
bee1dbe2 896 a = Argv;
79072805
LW
897 while (++mark <= sp) {
898 if (*mark)
463ee0b2 899 *a++ = SvPVx(*mark, na);
a687059c
LW
900 else
901 *a++ = "";
902 }
903 *a = Nullch;
bee1dbe2 904 if (*Argv[0] != '/') /* will execvp use PATH? */
79072805 905 TAINT_ENV(); /* testing IFS here is overkill, probably */
463ee0b2 906 if (really && *(tmps = SvPV(really, na)))
bee1dbe2 907 execvp(tmps,Argv);
a687059c 908 else
bee1dbe2 909 execvp(Argv[0],Argv);
a0d0e21e
LW
910 if (dowarn)
911 warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
a687059c 912 }
bee1dbe2 913 do_execfree();
a687059c
LW
914 return FALSE;
915}
916
fe14fcc3 917void
ff8e2863
LW
918do_execfree()
919{
920 if (Argv) {
921 Safefree(Argv);
922 Argv = Null(char **);
923 }
924 if (Cmd) {
925 Safefree(Cmd);
926 Cmd = Nullch;
927 }
928}
929
760ac839
LW
930#ifndef OS2
931
a687059c
LW
932bool
933do_exec(cmd)
934char *cmd;
935{
936 register char **a;
937 register char *s;
a687059c
LW
938 char flags[10];
939
748a9306
LW
940 while (*cmd && isSPACE(*cmd))
941 cmd++;
942
a687059c
LW
943 /* save an extra exec if possible */
944
bf38876a
LW
945#ifdef CSH
946 if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) {
a687059c 947 strcpy(flags,"-c");
bf38876a 948 s = cmd+cshlen+3;
a687059c
LW
949 if (*s == 'f') {
950 s++;
951 strcat(flags,"f");
952 }
953 if (*s == ' ')
954 s++;
955 if (*s++ == '\'') {
956 char *ncmd = s;
957
958 while (*s)
959 s++;
960 if (s[-1] == '\n')
961 *--s = '\0';
962 if (s[-1] == '\'') {
963 *--s = '\0';
bf38876a 964 execl(cshname,"csh", flags,ncmd,(char*)0);
a687059c
LW
965 *s = '\'';
966 return FALSE;
967 }
968 }
969 }
bf38876a 970#endif /* CSH */
a687059c
LW
971
972 /* see if there are shell metacharacters in it */
973
748a9306
LW
974 if (*cmd == '.' && isSPACE(cmd[1]))
975 goto doshell;
976
977 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
978 goto doshell;
979
99b89507 980 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
63f2c1e1
LW
981 if (*s == '=')
982 goto doshell;
748a9306 983
a687059c 984 for (s = cmd; *s; s++) {
93a17b20 985 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
986 if (*s == '\n' && !s[1]) {
987 *s = '\0';
988 break;
989 }
990 doshell:
ff68c719 991 execl(sh_path, "sh", "-c", cmd, (char*)0);
a687059c
LW
992 return FALSE;
993 }
994 }
748a9306 995
ff8e2863 996 New(402,Argv, (s - cmd) / 2 + 2, char*);
a0d0e21e 997 Cmd = savepvn(cmd, s-cmd);
ff8e2863
LW
998 a = Argv;
999 for (s = Cmd; *s;) {
99b89507 1000 while (*s && isSPACE(*s)) s++;
a687059c
LW
1001 if (*s)
1002 *(a++) = s;
99b89507 1003 while (*s && !isSPACE(*s)) s++;
a687059c
LW
1004 if (*s)
1005 *s++ = '\0';
1006 }
1007 *a = Nullch;
ff8e2863
LW
1008 if (Argv[0]) {
1009 execvp(Argv[0],Argv);
b1248f16 1010 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1011 do_execfree();
a687059c 1012 goto doshell;
b1248f16 1013 }
a0d0e21e
LW
1014 if (dowarn)
1015 warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
a687059c 1016 }
ff8e2863 1017 do_execfree();
a687059c
LW
1018 return FALSE;
1019}
1020
55497cff 1021#endif /* OS2 */
760ac839 1022
79072805
LW
1023I32
1024apply(type,mark,sp)
1025I32 type;
1026register SV **mark;
1027register SV **sp;
a687059c 1028{
79072805
LW
1029 register I32 val;
1030 register I32 val2;
1031 register I32 tot = 0;
a687059c 1032 char *s;
79072805 1033 SV **oldmark = mark;
a687059c 1034
463ee0b2
LW
1035 if (tainting) {
1036 while (++mark <= sp) {
bbce6d69
PP
1037 if (SvTAINTED(*mark)) {
1038 TAINT;
1039 break;
1040 }
463ee0b2
LW
1041 }
1042 mark = oldmark;
1043 }
a687059c 1044 switch (type) {
79072805
LW
1045 case OP_CHMOD:
1046 TAINT_PROPER("chmod");
1047 if (++mark <= sp) {
1048 tot = sp - mark;
463ee0b2 1049 val = SvIVx(*mark);
79072805 1050 while (++mark <= sp) {
463ee0b2 1051 if (chmod(SvPVx(*mark, na),val))
a687059c
LW
1052 tot--;
1053 }
1054 }
1055 break;
fe14fcc3 1056#ifdef HAS_CHOWN
79072805
LW
1057 case OP_CHOWN:
1058 TAINT_PROPER("chown");
1059 if (sp - mark > 2) {
463ee0b2
LW
1060 val = SvIVx(*++mark);
1061 val2 = SvIVx(*++mark);
a0d0e21e 1062 tot = sp - mark;
79072805 1063 while (++mark <= sp) {
463ee0b2 1064 if (chown(SvPVx(*mark, na),val,val2))
a687059c
LW
1065 tot--;
1066 }
1067 }
1068 break;
b1248f16 1069#endif
fe14fcc3 1070#ifdef HAS_KILL
79072805
LW
1071 case OP_KILL:
1072 TAINT_PROPER("kill");
55497cff
PP
1073 if (mark == sp)
1074 break;
463ee0b2 1075 s = SvPVx(*++mark, na);
79072805
LW
1076 tot = sp - mark;
1077 if (isUPPER(*s)) {
1078 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1079 s += 3;
1080 if (!(val = whichsig(s)))
463ee0b2 1081 croak("Unrecognized signal name \"%s\"",s);
79072805
LW
1082 }
1083 else
463ee0b2 1084 val = SvIVx(*mark);
3595fcef
PP
1085#ifdef VMS
1086 /* kill() doesn't do process groups (job trees?) under VMS */
1087 if (val < 0) val = -val;
1088 if (val == SIGKILL) {
1089# include <starlet.h>
1090 /* Use native sys$delprc() to insure that target process is
1091 * deleted; supervisor-mode images don't pay attention to
1092 * CRTL's emulation of Unix-style signals and kill()
1093 */
1094 while (++mark <= sp) {
1095 I32 proc = SvIVx(*mark);
1096 register unsigned long int __vmssts;
1097 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1098 tot--;
1099 switch (__vmssts) {
1100 case SS$_NONEXPR:
1101 case SS$_NOSUCHNODE:
1102 SETERRNO(ESRCH,__vmssts);
1103 break;
1104 case SS$_NOPRIV:
1105 SETERRNO(EPERM,__vmssts);
1106 break;
1107 default:
1108 SETERRNO(EVMSERR,__vmssts);
1109 }
1110 }
1111 }
1112 break;
1113 }
1114#endif
79072805
LW
1115 if (val < 0) {
1116 val = -val;
1117 while (++mark <= sp) {
463ee0b2 1118 I32 proc = SvIVx(*mark);
fe14fcc3 1119#ifdef HAS_KILLPG
79072805 1120 if (killpg(proc,val)) /* BSD */
a687059c 1121#else
79072805 1122 if (kill(-proc,val)) /* SYSV */
a687059c 1123#endif
79072805 1124 tot--;
a687059c 1125 }
79072805
LW
1126 }
1127 else {
1128 while (++mark <= sp) {
463ee0b2 1129 if (kill(SvIVx(*mark),val))
79072805 1130 tot--;
a687059c
LW
1131 }
1132 }
1133 break;
b1248f16 1134#endif
79072805
LW
1135 case OP_UNLINK:
1136 TAINT_PROPER("unlink");
1137 tot = sp - mark;
1138 while (++mark <= sp) {
463ee0b2 1139 s = SvPVx(*mark, na);
a687059c
LW
1140 if (euid || unsafe) {
1141 if (UNLINK(s))
1142 tot--;
1143 }
1144 else { /* don't let root wipe out directories without -U */
fe14fcc3 1145#ifdef HAS_LSTAT
c623bd54 1146 if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
a687059c 1147#else
a0d0e21e 1148 if (Stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
a687059c 1149#endif
a687059c
LW
1150 tot--;
1151 else {
1152 if (UNLINK(s))
1153 tot--;
1154 }
1155 }
1156 }
1157 break;
a0d0e21e 1158#ifdef HAS_UTIME
79072805
LW
1159 case OP_UTIME:
1160 TAINT_PROPER("utime");
1161 if (sp - mark > 2) {
748a9306 1162#if defined(I_UTIME) || defined(VMS)
663a0e37
LW
1163 struct utimbuf utbuf;
1164#else
a687059c 1165 struct {
663a0e37
LW
1166 long actime;
1167 long modtime;
a687059c 1168 } utbuf;
663a0e37 1169#endif
a687059c 1170
afd9f252 1171 Zero(&utbuf, sizeof utbuf, char);
517844ec
PP
1172#ifdef BIG_TIME
1173 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
1174 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
1175#else
463ee0b2
LW
1176 utbuf.actime = SvIVx(*++mark); /* time accessed */
1177 utbuf.modtime = SvIVx(*++mark); /* time modified */
517844ec 1178#endif
79072805
LW
1179 tot = sp - mark;
1180 while (++mark <= sp) {
463ee0b2 1181 if (utime(SvPVx(*mark, na),&utbuf))
a687059c
LW
1182 tot--;
1183 }
a687059c
LW
1184 }
1185 else
79072805 1186 tot = 0;
a687059c 1187 break;
a0d0e21e 1188#endif
a687059c
LW
1189 }
1190 return tot;
1191}
1192
1193/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1194#ifndef VMS /* VMS' cando is in vms.c */
79072805 1195I32
a687059c 1196cando(bit, effective, statbufp)
79072805
LW
1197I32 bit;
1198I32 effective;
a687059c
LW
1199register struct stat *statbufp;
1200{
bee1dbe2 1201#ifdef DOSISH
fe14fcc3
LW
1202 /* [Comments and code from Len Reed]
1203 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1204 * to write-protected files. The execute permission bit is set
1205 * by the Miscrosoft C library stat() function for the following:
1206 * .exe files
1207 * .com files
1208 * .bat files
1209 * directories
1210 * All files and directories are readable.
1211 * Directories and special files, e.g. "CON", cannot be
1212 * write-protected.
1213 * [Comment by Tom Dinger -- a directory can have the write-protect
1214 * bit set in the file system, but DOS permits changes to
1215 * the directory anyway. In addition, all bets are off
1216 * here for networked software, such as Novell and
1217 * Sun's PC-NFS.]
1218 */
1219
bee1dbe2
LW
1220 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1221 * too so it will actually look into the files for magic numbers
1222 */
fe14fcc3
LW
1223 return (bit & statbufp->st_mode) ? TRUE : FALSE;
1224
55497cff 1225#else /* ! DOSISH */
a687059c 1226 if ((effective ? euid : uid) == 0) { /* root is special */
c623bd54
LW
1227 if (bit == S_IXUSR) {
1228 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1229 return TRUE;
1230 }
1231 else
1232 return TRUE; /* root reads and writes anything */
1233 return FALSE;
1234 }
1235 if (statbufp->st_uid == (effective ? euid : uid) ) {
1236 if (statbufp->st_mode & bit)
1237 return TRUE; /* ok as "user" */
1238 }
79072805 1239 else if (ingroup((I32)statbufp->st_gid,effective)) {
a687059c
LW
1240 if (statbufp->st_mode & bit >> 3)
1241 return TRUE; /* ok as "group" */
1242 }
1243 else if (statbufp->st_mode & bit >> 6)
1244 return TRUE; /* ok as "other" */
1245 return FALSE;
55497cff 1246#endif /* ! DOSISH */
a687059c 1247}
a0d0e21e 1248#endif /* ! VMS */
a687059c 1249
79072805 1250I32
a687059c 1251ingroup(testgid,effective)
79072805
LW
1252I32 testgid;
1253I32 effective;
a687059c
LW
1254{
1255 if (testgid == (effective ? egid : gid))
1256 return TRUE;
fe14fcc3 1257#ifdef HAS_GETGROUPS
a687059c
LW
1258#ifndef NGROUPS
1259#define NGROUPS 32
1260#endif
1261 {
a0d0e21e 1262 Groups_t gary[NGROUPS];
79072805 1263 I32 anum;
a687059c
LW
1264
1265 anum = getgroups(NGROUPS,gary);
1266 while (--anum >= 0)
1267 if (gary[anum] == testgid)
1268 return TRUE;
1269 }
1270#endif
1271 return FALSE;
1272}
c2ab57d4 1273
fe14fcc3 1274#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 1275
79072805
LW
1276I32
1277do_ipcget(optype, mark, sp)
1278I32 optype;
1279SV **mark;
1280SV **sp;
c2ab57d4 1281{
c2ab57d4 1282 key_t key;
79072805 1283 I32 n, flags;
c2ab57d4 1284
463ee0b2
LW
1285 key = (key_t)SvNVx(*++mark);
1286 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1287 flags = SvIVx(*++mark);
748a9306 1288 SETERRNO(0,0);
c2ab57d4
LW
1289 switch (optype)
1290 {
fe14fcc3 1291#ifdef HAS_MSG
79072805 1292 case OP_MSGGET:
c2ab57d4 1293 return msgget(key, flags);
e5d73d77 1294#endif
fe14fcc3 1295#ifdef HAS_SEM
79072805 1296 case OP_SEMGET:
c2ab57d4 1297 return semget(key, n, flags);
e5d73d77 1298#endif
fe14fcc3 1299#ifdef HAS_SHM
79072805 1300 case OP_SHMGET:
c2ab57d4 1301 return shmget(key, n, flags);
e5d73d77 1302#endif
fe14fcc3 1303#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1304 default:
c07a80fd 1305 croak("%s not implemented", op_desc[optype]);
e5d73d77 1306#endif
c2ab57d4
LW
1307 }
1308 return -1; /* should never happen */
1309}
1310
79072805
LW
1311I32
1312do_ipcctl(optype, mark, sp)
1313I32 optype;
1314SV **mark;
1315SV **sp;
c2ab57d4 1316{
79072805 1317 SV *astr;
c2ab57d4 1318 char *a;
a0d0e21e
LW
1319 I32 id, n, cmd, infosize, getinfo;
1320 I32 ret = -1;
c2ab57d4 1321
463ee0b2
LW
1322 id = SvIVx(*++mark);
1323 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1324 cmd = SvIVx(*++mark);
79072805 1325 astr = *++mark;
c2ab57d4
LW
1326 infosize = 0;
1327 getinfo = (cmd == IPC_STAT);
1328
1329 switch (optype)
1330 {
fe14fcc3 1331#ifdef HAS_MSG
79072805 1332 case OP_MSGCTL:
c2ab57d4
LW
1333 if (cmd == IPC_STAT || cmd == IPC_SET)
1334 infosize = sizeof(struct msqid_ds);
1335 break;
e5d73d77 1336#endif
fe14fcc3 1337#ifdef HAS_SHM
79072805 1338 case OP_SHMCTL:
c2ab57d4
LW
1339 if (cmd == IPC_STAT || cmd == IPC_SET)
1340 infosize = sizeof(struct shmid_ds);
1341 break;
e5d73d77 1342#endif
fe14fcc3 1343#ifdef HAS_SEM
79072805 1344 case OP_SEMCTL:
c2ab57d4
LW
1345 if (cmd == IPC_STAT || cmd == IPC_SET)
1346 infosize = sizeof(struct semid_ds);
1347 else if (cmd == GETALL || cmd == SETALL)
1348 {
1349 struct semid_ds semds;
1350 if (semctl(id, 0, IPC_STAT, &semds) == -1)
1351 return -1;
1352 getinfo = (cmd == GETALL);
6e21c824
LW
1353 infosize = semds.sem_nsems * sizeof(short);
1354 /* "short" is technically wrong but much more portable
1355 than guessing about u_?short(_t)? */
c2ab57d4
LW
1356 }
1357 break;
e5d73d77 1358#endif
fe14fcc3 1359#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1360 default:
c07a80fd 1361 croak("%s not implemented", op_desc[optype]);
e5d73d77 1362#endif
c2ab57d4
LW
1363 }
1364
1365 if (infosize)
1366 {
a0d0e21e 1367 STRLEN len;
c2ab57d4
LW
1368 if (getinfo)
1369 {
a0d0e21e
LW
1370 SvPV_force(astr, len);
1371 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
1372 }
1373 else
1374 {
463ee0b2
LW
1375 a = SvPV(astr, len);
1376 if (len != infosize)
9607fc9c
PP
1377 croak("Bad arg length for %s, is %lu, should be %ld",
1378 op_desc[optype], (unsigned long)len, (long)infosize);
c2ab57d4
LW
1379 }
1380 }
1381 else
1382 {
c030ccd9 1383 IV i = SvIV(astr);
c2ab57d4
LW
1384 a = (char *)i; /* ouch */
1385 }
748a9306 1386 SETERRNO(0,0);
c2ab57d4
LW
1387 switch (optype)
1388 {
fe14fcc3 1389#ifdef HAS_MSG
79072805 1390 case OP_MSGCTL:
bee1dbe2 1391 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 1392 break;
e5d73d77 1393#endif
fe14fcc3 1394#ifdef HAS_SEM
79072805
LW
1395 case OP_SEMCTL:
1396 ret = semctl(id, n, cmd, (struct semid_ds *)a);
c2ab57d4 1397 break;
e5d73d77 1398#endif
fe14fcc3 1399#ifdef HAS_SHM
79072805 1400 case OP_SHMCTL:
bee1dbe2 1401 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 1402 break;
e5d73d77 1403#endif
c2ab57d4
LW
1404 }
1405 if (getinfo && ret >= 0) {
79072805
LW
1406 SvCUR_set(astr, infosize);
1407 *SvEND(astr) = '\0';
a0d0e21e 1408 SvSETMAGIC(astr);
c2ab57d4
LW
1409 }
1410 return ret;
1411}
1412
79072805
LW
1413I32
1414do_msgsnd(mark, sp)
1415SV **mark;
1416SV **sp;
c2ab57d4 1417{
fe14fcc3 1418#ifdef HAS_MSG
79072805 1419 SV *mstr;
c2ab57d4 1420 char *mbuf;
79072805 1421 I32 id, msize, flags;
463ee0b2 1422 STRLEN len;
c2ab57d4 1423
463ee0b2 1424 id = SvIVx(*++mark);
79072805 1425 mstr = *++mark;
463ee0b2
LW
1426 flags = SvIVx(*++mark);
1427 mbuf = SvPV(mstr, len);
1428 if ((msize = len - sizeof(long)) < 0)
1429 croak("Arg too short for msgsnd");
748a9306 1430 SETERRNO(0,0);
bee1dbe2 1431 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 1432#else
463ee0b2 1433 croak("msgsnd not implemented");
e5d73d77 1434#endif
c2ab57d4
LW
1435}
1436
79072805
LW
1437I32
1438do_msgrcv(mark, sp)
1439SV **mark;
1440SV **sp;
c2ab57d4 1441{
fe14fcc3 1442#ifdef HAS_MSG
79072805 1443 SV *mstr;
c2ab57d4
LW
1444 char *mbuf;
1445 long mtype;
79072805 1446 I32 id, msize, flags, ret;
463ee0b2 1447 STRLEN len;
79072805 1448
463ee0b2 1449 id = SvIVx(*++mark);
79072805 1450 mstr = *++mark;
463ee0b2
LW
1451 msize = SvIVx(*++mark);
1452 mtype = (long)SvIVx(*++mark);
1453 flags = SvIVx(*++mark);
ed6116ce
LW
1454 if (SvTHINKFIRST(mstr)) {
1455 if (SvREADONLY(mstr))
1456 croak("Can't msgrcv to readonly var");
1457 if (SvROK(mstr))
1458 sv_unref(mstr);
1459 }
a0d0e21e
LW
1460 SvPV_force(mstr, len);
1461 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1462
748a9306 1463 SETERRNO(0,0);
bee1dbe2 1464 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 1465 if (ret >= 0) {
79072805
LW
1466 SvCUR_set(mstr, sizeof(long)+ret);
1467 *SvEND(mstr) = '\0';
c2ab57d4
LW
1468 }
1469 return ret;
e5d73d77 1470#else
463ee0b2 1471 croak("msgrcv not implemented");
e5d73d77 1472#endif
c2ab57d4
LW
1473}
1474
79072805
LW
1475I32
1476do_semop(mark, sp)
1477SV **mark;
1478SV **sp;
c2ab57d4 1479{
fe14fcc3 1480#ifdef HAS_SEM
79072805 1481 SV *opstr;
c2ab57d4 1482 char *opbuf;
463ee0b2
LW
1483 I32 id;
1484 STRLEN opsize;
c2ab57d4 1485
463ee0b2 1486 id = SvIVx(*++mark);
79072805 1487 opstr = *++mark;
463ee0b2 1488 opbuf = SvPV(opstr, opsize);
c2ab57d4
LW
1489 if (opsize < sizeof(struct sembuf)
1490 || (opsize % sizeof(struct sembuf)) != 0) {
748a9306 1491 SETERRNO(EINVAL,LIB$_INVARG);
c2ab57d4
LW
1492 return -1;
1493 }
748a9306 1494 SETERRNO(0,0);
6e21c824 1495 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
e5d73d77 1496#else
463ee0b2 1497 croak("semop not implemented");
e5d73d77 1498#endif
c2ab57d4
LW
1499}
1500
79072805
LW
1501I32
1502do_shmio(optype, mark, sp)
1503I32 optype;
1504SV **mark;
1505SV **sp;
c2ab57d4 1506{
fe14fcc3 1507#ifdef HAS_SHM
79072805 1508 SV *mstr;
c2ab57d4 1509 char *mbuf, *shm;
79072805 1510 I32 id, mpos, msize;
463ee0b2 1511 STRLEN len;
c2ab57d4 1512 struct shmid_ds shmds;
c2ab57d4 1513
463ee0b2 1514 id = SvIVx(*++mark);
79072805 1515 mstr = *++mark;
463ee0b2
LW
1516 mpos = SvIVx(*++mark);
1517 msize = SvIVx(*++mark);
748a9306 1518 SETERRNO(0,0);
c2ab57d4
LW
1519 if (shmctl(id, IPC_STAT, &shmds) == -1)
1520 return -1;
1521 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
748a9306 1522 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
1523 return -1;
1524 }
a0d0e21e 1525 shm = (Shmat_t)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
1526 if (shm == (char *)-1) /* I hate System V IPC, I really do */
1527 return -1;
79072805 1528 if (optype == OP_SHMREAD) {
a0d0e21e
LW
1529 SvPV_force(mstr, len);
1530 mbuf = SvGROW(mstr, msize+1);
1531
bee1dbe2 1532 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
1533 SvCUR_set(mstr, msize);
1534 *SvEND(mstr) = '\0';
a0d0e21e 1535 SvSETMAGIC(mstr);
c2ab57d4
LW
1536 }
1537 else {
79072805 1538 I32 n;
c2ab57d4 1539
a0d0e21e 1540 mbuf = SvPV(mstr, len);
463ee0b2 1541 if ((n = len) > msize)
c2ab57d4 1542 n = msize;
bee1dbe2 1543 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 1544 if (n < msize)
bee1dbe2 1545 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
1546 }
1547 return shmdt(shm);
e5d73d77 1548#else
463ee0b2 1549 croak("shm I/O not implemented");
e5d73d77 1550#endif
c2ab57d4
LW
1551}
1552
fe14fcc3 1553#endif /* SYSV IPC */