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