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