This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Lexical use open ... support:
[perl5.git] / doio.c
CommitLineData
a0d0e21e 1/* doio.c
a687059c 2 *
3818b22b 3 * Copyright (c) 1991-2000, 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"
864dbfa3 18#define PERL_IN_DOIO_C
a687059c
LW
19#include "perl.h"
20
fe14fcc3 21#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
aec308ec 22#ifndef HAS_SEM
c2ab57d4 23#include <sys/ipc.h>
aec308ec 24#endif
fe14fcc3 25#ifdef HAS_MSG
c2ab57d4 26#include <sys/msg.h>
e5d73d77 27#endif
fe14fcc3 28#ifdef HAS_SHM
c2ab57d4 29#include <sys/shm.h>
a0d0e21e 30# ifndef HAS_SHMAT_PROTOTYPE
20ce7b12 31 extern Shmat_t shmat (int, char *, int);
a0d0e21e 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
85aff577
CS
44#ifdef O_EXCL
45# define OPEN_EXCL O_EXCL
46#else
47# define OPEN_EXCL 0
48#endif
a687059c 49
76121258
PP
50#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
51#include <signal.h>
52#endif
53
54/* XXX If this causes problems, set i_unistd=undef in the hint file. */
55#ifdef I_UNISTD
56# include <unistd.h>
57#endif
58
a687059c 59bool
6170680b
IZ
60Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
61 int rawmode, int rawperm, PerlIO *supplied_fp)
62{
63 return do_open9(gv, name, len, as_raw, rawmode, rawperm,
64 supplied_fp, Nullsv, 0);
65}
66
67bool
68Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
69 int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
70 I32 num_svs)
a687059c 71{
a0d0e21e 72 register IO *io = GvIOn(gv);
760ac839
LW
73 PerlIO *saveifp = Nullfp;
74 PerlIO *saveofp = Nullfp;
9f37169a 75 char savetype = IoTYPE_CLOSED;
c07a80fd 76 int writing = 0;
760ac839 77 PerlIO *fp;
c07a80fd
PP
78 int fd;
79 int result;
3500f679 80 bool was_fdopen = FALSE;
16fe6d59 81 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
b931b1d9
NIS
82 char *type = NULL;
83 char *deftype = NULL;
84 char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
a687059c 85
b931b1d9 86 Zero(mode,sizeof(mode),char);
3280af22 87 PL_forkprocess = 1; /* assume true if no fork */
c07a80fd 88
b931b1d9 89 /* Collect default raw/crlf info from the op */
16fe6d59
GS
90 if (PL_op && PL_op->op_type == OP_OPEN) {
91 /* set up disciplines */
92 U8 flags = PL_op->op_private;
93 in_raw = (flags & OPpOPEN_IN_RAW);
94 in_crlf = (flags & OPpOPEN_IN_CRLF);
95 out_raw = (flags & OPpOPEN_OUT_RAW);
96 out_crlf = (flags & OPpOPEN_OUT_CRLF);
97 }
98
b931b1d9 99 /* If currently open - close before we re-open */
a0d0e21e 100 if (IoIFP(io)) {
760ac839 101 fd = PerlIO_fileno(IoIFP(io));
50952442 102 if (IoTYPE(io) == IoTYPE_STD)
c2ab57d4 103 result = 0;
3280af22 104 else if (fd <= PL_maxsysfd) {
8990e307
LW
105 saveifp = IoIFP(io);
106 saveofp = IoOFP(io);
107 savetype = IoTYPE(io);
6e21c824
LW
108 result = 0;
109 }
50952442 110 else if (IoTYPE(io) == IoTYPE_PIPE)
3028581b 111 result = PerlProc_pclose(IoIFP(io));
8990e307
LW
112 else if (IoIFP(io) != IoOFP(io)) {
113 if (IoOFP(io)) {
760ac839 114 result = PerlIO_close(IoOFP(io));
6170680b 115 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
116 }
117 else
760ac839 118 result = PerlIO_close(IoIFP(io));
a687059c 119 }
a687059c 120 else
760ac839 121 result = PerlIO_close(IoIFP(io));
3280af22 122 if (result == EOF && fd > PL_maxsysfd)
bf49b057 123 PerlIO_printf(Perl_error_log,
6170680b
IZ
124 "Warning: unable to close filehandle %s properly.\n",
125 GvENAME(gv));
8990e307 126 IoOFP(io) = IoIFP(io) = Nullfp;
a687059c 127 }
c07a80fd
PP
128
129 if (as_raw) {
b931b1d9
NIS
130 /* sysopen style args, i.e. integer mode and permissions */
131
09458382 132#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
5ff3f7a4
GS
133 rawmode |= O_LARGEFILE;
134#endif
135
9d116dd7
JH
136#ifndef O_ACCMODE
137#define O_ACCMODE 3 /* Assume traditional implementation */
138#endif
5ff3f7a4 139
9d116dd7
JH
140 switch (result = rawmode & O_ACCMODE) {
141 case O_RDONLY:
50952442 142 IoTYPE(io) = IoTYPE_RDONLY;
9d116dd7
JH
143 break;
144 case O_WRONLY:
50952442 145 IoTYPE(io) = IoTYPE_WRONLY;
9d116dd7
JH
146 break;
147 case O_RDWR:
148 default:
50952442 149 IoTYPE(io) = IoTYPE_RDWR;
9d116dd7
JH
150 break;
151 }
152
c07a80fd 153 writing = (result > 0);
3028581b 154 fd = PerlLIO_open3(name, rawmode, rawperm);
9d116dd7 155
c07a80fd
PP
156 if (fd == -1)
157 fp = NULL;
158 else {
16fe6d59 159 STRLEN ix = 0;
b931b1d9
NIS
160 if (result == O_RDONLY) {
161 mode[ix++] = 'r';
162 }
360e5741 163#ifdef O_APPEND
16fe6d59 164 else if (rawmode & O_APPEND) {
b931b1d9 165 mode[ix++] = 'a';
16fe6d59 166 if (result != O_WRONLY)
b931b1d9 167 mode[ix++] = '+';
16fe6d59 168 }
360e5741 169#endif
16fe6d59
GS
170 else {
171 if (result == O_WRONLY)
b931b1d9 172 mode[ix++] = 'w';
16fe6d59 173 else {
b931b1d9
NIS
174 mode[ix++] = 'r';
175 mode[ix++] = '+';
16fe6d59
GS
176 }
177 }
178 if (rawmode & O_BINARY)
b931b1d9
NIS
179 mode[ix++] = 'b';
180 mode[ix] = '\0';
181 fp = PerlIO_fdopen(fd, mode);
c07a80fd 182 if (!fp)
3028581b 183 PerlLIO_close(fd);
c07a80fd 184 }
a687059c 185 }
c07a80fd 186 else {
b931b1d9 187 /* Regular (non-sys) open */
faecd977 188 char *oname = name;
faecd977 189 STRLEN olen = len;
b931b1d9
NIS
190 char *tend;
191 int dodup = 0;
c07a80fd 192
faecd977 193 type = savepvn(name, len);
b931b1d9 194 tend = type+len;
faecd977 195 SAVEFREEPV(type);
b931b1d9
NIS
196 /* Loose trailing white space */
197 while (tend > type && isSPACE(tend[-1]))
198 *tend-- = '\0';
6170680b 199 if (num_svs) {
b931b1d9 200 /* New style explict name, type is just mode and discipline/layer info */
faecd977
GS
201 STRLEN l;
202 name = SvPV(svs, l) ;
203 len = (I32)l;
204 name = savepvn(name, len);
205 SAVEFREEPV(name);
b931b1d9
NIS
206 /*SUPPRESS 530*/
207 for (; isSPACE(*type); type++) ;
6170680b 208 }
faecd977 209 else {
faecd977 210 name = type;
b931b1d9 211 len = tend-type;
faecd977 212 }
6170680b 213 IoTYPE(io) = *type;
b931b1d9 214 if (*type == IoTYPE_RDWR && (!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE)) { /* scary */
6170680b 215 mode[1] = *type++;
c07a80fd 216 writing = 1;
a687059c 217 }
c07a80fd 218
9f37169a 219 if (*type == IoTYPE_PIPE) {
b931b1d9
NIS
220 if (num_svs) {
221 if (type[1] != IoTYPE_STD) {
222 unknown_desr:
223 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
224 }
225 type++;
6170680b 226 }
c07a80fd 227 /*SUPPRESS 530*/
b931b1d9 228 for (type++; isSPACE(*type); type++) ;
faecd977 229 if (!num_svs) {
6170680b 230 name = type;
b931b1d9 231 len = tend-type;
faecd977 232 }
06eaf0bc
GS
233 if (*name == '\0') { /* command is missing 19990114 */
234 dTHR;
235 if (ckWARN(WARN_PIPE))
cea2e8a9 236 Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
06eaf0bc
GS
237 errno = EPIPE;
238 goto say_false;
239 }
6170680b 240 if (strNE(name,"-") || num_svs)
c07a80fd
PP
241 TAINT_ENV();
242 TAINT_PROPER("piped open");
b931b1d9 243 if (!num_svs && name[len-1] == '|') {
d008e5eb 244 dTHR;
faecd977 245 name[--len] = '\0' ;
599cee73 246 if (ckWARN(WARN_PIPE))
9a7dcd9c 247 Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
7b8d334a 248 }
a1d180c4 249 mode[0] = 'w';
c07a80fd 250 writing = 1;
a1d180c4
NIS
251 if (out_raw)
252 strcat(mode, "b");
253 else if (out_crlf)
254 strcat(mode, "t");
255 fp = PerlProc_popen(name,mode);
c07a80fd 256 }
9f37169a 257 else if (*type == IoTYPE_WRONLY) {
c07a80fd 258 TAINT_PROPER("open");
6170680b 259 type++;
9f37169a
JH
260 if (*type == IoTYPE_WRONLY) {
261 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
50952442 262 mode[0] = IoTYPE(io) = IoTYPE_APPEND;
6170680b 263 type++;
a0d0e21e 264 }
c07a80fd
PP
265 else
266 mode[0] = 'w';
267 writing = 1;
268
16fe6d59
GS
269 if (out_raw)
270 strcat(mode, "b");
271 else if (out_crlf)
272 strcat(mode, "t");
273
6170680b
IZ
274 if (*type == '&') {
275 name = type;
c07a80fd 276 duplicity:
b931b1d9
NIS
277 if (num_svs)
278 goto unknown_desr;
c07a80fd
PP
279 dodup = 1;
280 name++;
281 if (*name == '=') {
282 dodup = 0;
a0d0e21e 283 name++;
c07a80fd
PP
284 }
285 if (!*name && supplied_fp)
286 fp = supplied_fp;
a0d0e21e 287 else {
c07a80fd
PP
288 /*SUPPRESS 530*/
289 for (; isSPACE(*name); name++) ;
290 if (isDIGIT(*name))
291 fd = atoi(name);
292 else {
293 IO* thatio;
294 gv = gv_fetchpv(name,FALSE,SVt_PVIO);
295 thatio = GvIO(gv);
296 if (!thatio) {
6e21c824 297#ifdef EINVAL
c07a80fd 298 SETERRNO(EINVAL,SS$_IVCHAN);
6e21c824 299#endif
c07a80fd
PP
300 goto say_false;
301 }
302 if (IoIFP(thatio)) {
54195c32 303 PerlIO *fp = IoIFP(thatio);
7211d486
JH
304 /* Flush stdio buffer before dup. --mjd
305 * Unfortunately SEEK_CURing 0 seems to
306 * be optimized away on most platforms;
307 * only Solaris and Linux seem to flush
308 * on that. --jhi */
2c534a3f
NC
309#ifdef USE_SFIO
310 /* sfio fails to clear error on next
311 sfwrite, contrary to documentation.
312 -- Nick Clark */
313 if (PerlIO_seek(fp, 0, SEEK_CUR) == -1)
314 PerlIO_clearerr(fp);
315#endif
7211d486
JH
316 /* On the other hand, do all platforms
317 * take gracefully to flushing a read-only
318 * filehandle? Perhaps we should do
319 * fsetpos(src)+fgetpos(dst)? --nik */
320 PerlIO_flush(fp);
54195c32 321 fd = PerlIO_fileno(fp);
0759c907
JH
322 /* When dup()ing STDIN, STDOUT or STDERR
323 * explicitly set appropriate access mode */
324 if (IoIFP(thatio) == PerlIO_stdout()
325 || IoIFP(thatio) == PerlIO_stderr())
326 IoTYPE(io) = IoTYPE_WRONLY;
327 else if (IoIFP(thatio) == PerlIO_stdin())
328 IoTYPE(io) = IoTYPE_RDONLY;
329 /* When dup()ing a socket, say result is
330 * one as well */
331 else if (IoTYPE(thatio) == IoTYPE_SOCKET)
50952442 332 IoTYPE(io) = IoTYPE_SOCKET;
c07a80fd
PP
333 }
334 else
335 fd = -1;
a0d0e21e 336 }
fec02dd3 337 if (dodup)
3028581b 338 fd = PerlLIO_dup(fd);
3500f679
RS
339 else
340 was_fdopen = TRUE;
760ac839 341 if (!(fp = PerlIO_fdopen(fd,mode))) {
c07a80fd 342 if (dodup)
3028581b 343 PerlLIO_close(fd);
faecd977 344 }
c07a80fd 345 }
bf38876a 346 }
c07a80fd
PP
347 else {
348 /*SUPPRESS 530*/
6170680b 349 for (; isSPACE(*type); type++) ;
b931b1d9
NIS
350 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
351 /*SUPPRESS 530*/
352 type++;
760ac839 353 fp = PerlIO_stdout();
50952442 354 IoTYPE(io) = IoTYPE_STD;
c07a80fd
PP
355 }
356 else {
6170680b 357 fp = PerlIO_open((num_svs ? name : type), mode);
c07a80fd 358 }
bf38876a
LW
359 }
360 }
9f37169a 361 else if (*type == IoTYPE_RDONLY) {
c07a80fd 362 /*SUPPRESS 530*/
6170680b 363 for (type++; isSPACE(*type); type++) ;
bf38876a 364 mode[0] = 'r';
16fe6d59
GS
365 if (in_raw)
366 strcat(mode, "b");
367 else if (in_crlf)
368 strcat(mode, "t");
369
6170680b
IZ
370 if (*type == '&') {
371 name = type;
bf38876a 372 goto duplicity;
6170680b 373 }
b931b1d9
NIS
374 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
375 /*SUPPRESS 530*/
376 type++;
760ac839 377 fp = PerlIO_stdin();
50952442 378 IoTYPE(io) = IoTYPE_STD;
a687059c 379 }
bf38876a 380 else
6170680b 381 fp = PerlIO_open((num_svs ? name : type), mode);
a687059c 382 }
b931b1d9
NIS
383 else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
384 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
6170680b 385 if (num_svs) {
b931b1d9 386 type += 2; /* skip over '-|' */
6170680b
IZ
387 }
388 else {
b931b1d9
NIS
389 *--tend = '\0';
390 while (tend > type && isSPACE(tend[-1]))
391 *--tend = '\0';
6170680b
IZ
392 /*SUPPRESS 530*/
393 for (; isSPACE(*type); type++) ;
394 name = type;
b931b1d9 395 len = tend-type;
6170680b 396 }
06eaf0bc
GS
397 if (*name == '\0') { /* command is missing 19990114 */
398 dTHR;
399 if (ckWARN(WARN_PIPE))
cea2e8a9 400 Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
06eaf0bc
GS
401 errno = EPIPE;
402 goto say_false;
403 }
6170680b 404 if (strNE(name,"-") || num_svs)
79072805
LW
405 TAINT_ENV();
406 TAINT_PROPER("piped open");
a1d180c4
NIS
407 mode[0] = 'r';
408 if (in_raw)
409 strcat(mode, "b");
410 else if (in_crlf)
411 strcat(mode, "t");
412 fp = PerlProc_popen(name,mode);
50952442 413 IoTYPE(io) = IoTYPE_PIPE;
a687059c
LW
414 }
415 else {
6170680b
IZ
416 if (num_svs)
417 goto unknown_desr;
418 name = type;
50952442 419 IoTYPE(io) = IoTYPE_RDONLY;
99b89507
LW
420 /*SUPPRESS 530*/
421 for (; isSPACE(*name); name++) ;
a687059c 422 if (strEQ(name,"-")) {
760ac839 423 fp = PerlIO_stdin();
50952442 424 IoTYPE(io) = IoTYPE_STD;
a687059c 425 }
16fe6d59 426 else {
a1d180c4 427 mode[0] = 'r';
16fe6d59 428 if (in_raw)
a1d180c4 429 strcat(mode, "b");
16fe6d59 430 else if (in_crlf)
a1d180c4 431 strcat(mode, "t");
16fe6d59
GS
432 fp = PerlIO_open(name,mode);
433 }
a687059c
LW
434 }
435 }
bee1dbe2 436 if (!fp) {
d008e5eb 437 dTHR;
50952442 438 if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n'))
cea2e8a9 439 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
6e21c824 440 goto say_false;
bee1dbe2 441 }
8990e307 442 if (IoTYPE(io) &&
50952442 443 IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
96827780 444 dTHR;
3280af22 445 if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
760ac839 446 (void)PerlIO_close(fp);
6e21c824 447 goto say_false;
a687059c 448 }
3280af22 449 if (S_ISSOCK(PL_statbuf.st_mode))
50952442 450 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
99b89507
LW
451#ifdef HAS_SOCKET
452 else if (
c623bd54 453#ifdef S_IFMT
3280af22 454 !(PL_statbuf.st_mode & S_IFMT)
99b89507 455#else
b28d0864 456 !PL_statbuf.st_mode
99b89507 457#endif
0759c907
JH
458 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */
459 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */
460 ) { /* on OS's that return 0 on fstat()ed pipe */
96827780
MB
461 char tmpbuf[256];
462 Sock_size_t buflen = sizeof tmpbuf;
3028581b 463 if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
d574b85e
CS
464 &buflen) >= 0
465 || errno != ENOTSOCK)
50952442 466 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
99b89507
LW
467 /* but some return 0 for streams too, sigh */
468 }
bf38876a 469#endif
a687059c 470 }
6e21c824 471 if (saveifp) { /* must use old fp? */
760ac839 472 fd = PerlIO_fileno(saveifp);
6e21c824 473 if (saveofp) {
760ac839 474 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
6e21c824 475 if (saveofp != saveifp) { /* was a socket? */
760ac839 476 PerlIO_close(saveofp);
99b89507
LW
477 if (fd > 2)
478 Safefree(saveofp);
6e21c824
LW
479 }
480 }
760ac839 481 if (fd != PerlIO_fileno(fp)) {
d8a83dd3 482 Pid_t pid;
79072805 483 SV *sv;
bee1dbe2 484
3028581b 485 PerlLIO_dup2(PerlIO_fileno(fp), fd);
4755096e 486 LOCK_FDPID_MUTEX;
3280af22 487 sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
a0d0e21e 488 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2
LW
489 pid = SvIVX(sv);
490 SvIVX(sv) = 0;
3280af22 491 sv = *av_fetch(PL_fdpid,fd,TRUE);
4755096e 492 UNLOCK_FDPID_MUTEX;
a0d0e21e 493 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2 494 SvIVX(sv) = pid;
3500f679
RS
495 if (!was_fdopen)
496 PerlIO_close(fp);
bee1dbe2 497
6e21c824
LW
498 }
499 fp = saveifp;
760ac839 500 PerlIO_clearerr(fp);
6e21c824 501 }
a0d0e21e 502#if defined(HAS_FCNTL) && defined(F_SETFD)
a8710ca1
GS
503 {
504 int save_errno = errno;
505 fd = PerlIO_fileno(fp);
506 fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
507 errno = save_errno;
508 }
1462b684 509#endif
8990e307 510 IoIFP(io) = fp;
b931b1d9
NIS
511 if (!num_svs) {
512 /* Need to supply default type info from open.pm */
ac27b0f5 513 SV *layers = PL_curcop->cop_io;
b931b1d9 514 type = NULL;
ac27b0f5
NIS
515 if (layers) {
516 STRLEN len;
517 type = SvPV(layers,len);
518 if (type && mode[0] != 'r') {
519 /* Skip to write part */
520 char *s = strchr(type,0);
521 if (s && (s-type) < len) {
522 type = s+1;
523 }
524 }
525 }
526 else if (O_BINARY != O_TEXT) {
527 type = ":crlf";
528 }
b931b1d9
NIS
529 }
530 if (type) {
531 while (isSPACE(*type)) type++;
532 if (*type) {
ac27b0f5
NIS
533 if (PerlIO_apply_layers(aTHX_ IoIFP(io),mode,type) != 0) {
534 goto say_false;
535 }
b931b1d9
NIS
536 }
537 }
538
684bef36 539 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 540 if (writing) {
96827780 541 dTHR;
50952442
JH
542 if (IoTYPE(io) == IoTYPE_SOCKET
543 || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) )
16fe6d59 544 {
b931b1d9 545 mode[0] = 'w';
16fe6d59 546 if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) {
760ac839 547 PerlIO_close(fp);
8990e307 548 IoIFP(io) = Nullfp;
6e21c824 549 goto say_false;
fe14fcc3 550 }
ac27b0f5
NIS
551 if (type && *type) {
552 if (PerlIO_apply_layers(aTHX_ IoOFP(io),mode,type) != 0) {
553 PerlIO_close(IoOFP(io));
554 PerlIO_close(fp);
555 IoIFP(io) = Nullfp;
556 IoOFP(io) = Nullfp;
557 goto say_false;
558 }
559 }
1462b684
LW
560 }
561 else
8990e307 562 IoOFP(io) = fp;
bf38876a 563 }
a687059c 564 return TRUE;
6e21c824
LW
565
566say_false:
8990e307
LW
567 IoIFP(io) = saveifp;
568 IoOFP(io) = saveofp;
569 IoTYPE(io) = savetype;
6e21c824 570 return FALSE;
a687059c
LW
571}
572
760ac839 573PerlIO *
864dbfa3 574Perl_nextargv(pTHX_ register GV *gv)
a687059c 575{
79072805 576 register SV *sv;
99b89507 577#ifndef FLEXFILENAMES
c623bd54
LW
578 int filedev;
579 int fileino;
99b89507 580#endif
761237fe
JB
581 Uid_t fileuid;
582 Gid_t filegid;
18708f5a 583 IO *io = GvIOp(gv);
fe14fcc3 584
3280af22
NIS
585 if (!PL_argvoutgv)
586 PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
18708f5a
GS
587 if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
588 IoFLAGS(io) &= ~IOf_START;
7a1c5554
GS
589 if (PL_inplace) {
590 if (!PL_argvout_stack)
591 PL_argvout_stack = newAV();
18708f5a 592 av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv));
7a1c5554 593 }
18708f5a 594 }
3280af22
NIS
595 if (PL_filemode & (S_ISUID|S_ISGID)) {
596 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
fe14fcc3 597#ifdef HAS_FCHMOD
3280af22 598 (void)fchmod(PL_lastfd,PL_filemode);
fe14fcc3 599#else
b28d0864 600 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
fe14fcc3
LW
601#endif
602 }
3280af22 603 PL_filemode = 0;
79072805 604 while (av_len(GvAV(gv)) >= 0) {
11343788 605 dTHR;
85aff577 606 STRLEN oldlen;
79072805 607 sv = av_shift(GvAV(gv));
8990e307 608 SAVEFREESV(sv);
79072805
LW
609 sv_setsv(GvSV(gv),sv);
610 SvSETMAGIC(GvSV(gv));
3280af22 611 PL_oldname = SvPVx(GvSV(gv), oldlen);
9d116dd7 612 if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
3280af22 613 if (PL_inplace) {
79072805 614 TAINT_PROPER("inplace open");
3280af22 615 if (oldlen == 1 && *PL_oldname == '-') {
4633a7c4 616 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a0d0e21e 617 return IoIFP(GvIOp(gv));
c623bd54 618 }
99b89507 619#ifndef FLEXFILENAMES
b28d0864
NIS
620 filedev = PL_statbuf.st_dev;
621 fileino = PL_statbuf.st_ino;
99b89507 622#endif
3280af22
NIS
623 PL_filemode = PL_statbuf.st_mode;
624 fileuid = PL_statbuf.st_uid;
625 filegid = PL_statbuf.st_gid;
626 if (!S_ISREG(PL_filemode)) {
0453d815
PM
627 if (ckWARN_d(WARN_INPLACE))
628 Perl_warner(aTHX_ WARN_INPLACE,
629 "Can't do inplace edit: %s is not a regular file",
630 PL_oldname );
79072805 631 do_close(gv,FALSE);
c623bd54
LW
632 continue;
633 }
3280af22
NIS
634 if (*PL_inplace) {
635 char *star = strchr(PL_inplace, '*');
2d259d92 636 if (star) {
3280af22 637 char *begin = PL_inplace;
2d259d92
CK
638 sv_setpvn(sv, "", 0);
639 do {
640 sv_catpvn(sv, begin, star - begin);
3280af22 641 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK
642 begin = ++star;
643 } while ((star = strchr(begin, '*')));
3d66d7bb
GS
644 if (*begin)
645 sv_catpv(sv,begin);
2d259d92
CK
646 }
647 else {
3280af22 648 sv_catpv(sv,PL_inplace);
2d259d92 649 }
c623bd54 650#ifndef FLEXFILENAMES
b28d0864
NIS
651 if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
652 && PL_statbuf.st_dev == filedev
653 && PL_statbuf.st_ino == fileino
39e571d4
ML
654#ifdef DJGPP
655 || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
656#endif
f248d071
GS
657 )
658 {
659 if (ckWARN_d(WARN_INPLACE))
660 Perl_warner(aTHX_ WARN_INPLACE,
661 "Can't do inplace edit: %s would not be unique",
662 SvPVX(sv));
79072805 663 do_close(gv,FALSE);
c623bd54
LW
664 continue;
665 }
666#endif
fe14fcc3 667#ifdef HAS_RENAME
d308986b 668#if !defined(DOSISH) && !defined(__CYGWIN__)
3280af22 669 if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
0453d815 670 if (ckWARN_d(WARN_INPLACE))
a1d180c4 671 Perl_warner(aTHX_ WARN_INPLACE,
0453d815
PM
672 "Can't rename %s to %s: %s, skipping file",
673 PL_oldname, SvPVX(sv), Strerror(errno) );
79072805 674 do_close(gv,FALSE);
c623bd54
LW
675 continue;
676 }
a687059c 677#else
79072805 678 do_close(gv,FALSE);
3028581b 679 (void)PerlLIO_unlink(SvPVX(sv));
b28d0864 680 (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
9d116dd7 681 do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
55497cff 682#endif /* DOSISH */
ff8e2863 683#else
463ee0b2 684 (void)UNLINK(SvPVX(sv));
b28d0864 685 if (link(PL_oldname,SvPVX(sv)) < 0) {
0453d815
PM
686 if (ckWARN_d(WARN_INPLACE))
687 Perl_warner(aTHX_ WARN_INPLACE,
688 "Can't rename %s to %s: %s, skipping file",
689 PL_oldname, SvPVX(sv), Strerror(errno) );
79072805 690 do_close(gv,FALSE);
c623bd54
LW
691 continue;
692 }
b28d0864 693 (void)UNLINK(PL_oldname);
a687059c
LW
694#endif
695 }
696 else {
a8c18271 697#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 698# ifndef VMS /* Don't delete; use automatic file versioning */
3280af22 699 if (UNLINK(PL_oldname) < 0) {
0453d815
PM
700 if (ckWARN_d(WARN_INPLACE))
701 Perl_warner(aTHX_ WARN_INPLACE,
702 "Can't remove %s: %s, skipping file",
703 PL_oldname, Strerror(errno) );
79072805 704 do_close(gv,FALSE);
fe14fcc3
LW
705 continue;
706 }
edc7bc49 707# endif
ff8e2863 708#else
cea2e8a9 709 Perl_croak(aTHX_ "Can't do inplace edit without backup");
ff8e2863 710#endif
a687059c
LW
711 }
712
3280af22
NIS
713 sv_setpvn(sv,">",!PL_inplace);
714 sv_catpvn(sv,PL_oldname,oldlen);
748a9306 715 SETERRNO(0,0); /* in case sprintf set errno */
4119ab01
HM
716#ifdef VMS
717 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
18708f5a 718 O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp))
4119ab01 719#else
3280af22 720 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
18708f5a 721 O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp))
4119ab01 722#endif
18708f5a 723 {
0453d815
PM
724 if (ckWARN_d(WARN_INPLACE))
725 Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s",
726 PL_oldname, Strerror(errno) );
79072805 727 do_close(gv,FALSE);
fe14fcc3
LW
728 continue;
729 }
3280af22
NIS
730 setdefout(PL_argvoutgv);
731 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
732 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
fe14fcc3 733#ifdef HAS_FCHMOD
3280af22 734 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 735#else
3e3baf6d
TB
736# if !(defined(WIN32) && defined(__BORLANDC__))
737 /* Borland runtime creates a readonly file! */
b28d0864 738 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
3e3baf6d 739# endif
a687059c 740#endif
3280af22 741 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
fe14fcc3 742#ifdef HAS_FCHOWN
3280af22 743 (void)fchown(PL_lastfd,fileuid,filegid);
a687059c 744#else
fe14fcc3 745#ifdef HAS_CHOWN
b28d0864 746 (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
a687059c 747#endif
b1248f16 748#endif
fe14fcc3 749 }
a687059c 750 }
a0d0e21e 751 return IoIFP(GvIOp(gv));
a687059c 752 }
4d61ec05
GS
753 else {
754 dTHR;
755 if (ckWARN_d(WARN_INPLACE)) {
6af84f9f
GS
756 int eno = errno;
757 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
758 && !S_ISREG(PL_statbuf.st_mode))
759 {
4d61ec05
GS
760 Perl_warner(aTHX_ WARN_INPLACE,
761 "Can't do inplace edit: %s is not a regular file",
9a7dcd9c 762 PL_oldname);
6af84f9f 763 }
4d61ec05 764 else
9a7dcd9c 765 Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s",
6af84f9f 766 PL_oldname, Strerror(eno));
4d61ec05
GS
767 }
768 }
a687059c 769 }
18708f5a
GS
770 if (io && (IoFLAGS(io) & IOf_ARGV))
771 IoFLAGS(io) |= IOf_START;
3280af22
NIS
772 if (PL_inplace) {
773 (void)do_close(PL_argvoutgv,FALSE);
7a1c5554
GS
774 if (io && (IoFLAGS(io) & IOf_ARGV)
775 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
776 {
18708f5a
GS
777 GV *oldout = (GV*)av_pop(PL_argvout_stack);
778 setdefout(oldout);
779 SvREFCNT_dec(oldout);
780 return Nullfp;
781 }
4633a7c4 782 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a687059c
LW
783 }
784 return Nullfp;
785}
786
fe14fcc3 787#ifdef HAS_PIPE
afd9f252 788void
864dbfa3 789Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
afd9f252 790{
79072805
LW
791 register IO *rstio;
792 register IO *wstio;
afd9f252
LW
793 int fd[2];
794
79072805 795 if (!rgv)
afd9f252 796 goto badexit;
79072805 797 if (!wgv)
afd9f252
LW
798 goto badexit;
799
a0d0e21e
LW
800 rstio = GvIOn(rgv);
801 wstio = GvIOn(wgv);
afd9f252 802
a0d0e21e 803 if (IoIFP(rstio))
79072805 804 do_close(rgv,FALSE);
a0d0e21e 805 if (IoIFP(wstio))
79072805 806 do_close(wgv,FALSE);
afd9f252 807
3028581b 808 if (PerlProc_pipe(fd) < 0)
afd9f252 809 goto badexit;
760ac839
LW
810 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
811 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
8990e307 812 IoIFP(wstio) = IoOFP(wstio);
50952442
JH
813 IoTYPE(rstio) = IoTYPE_RDONLY;
814 IoTYPE(wstio) = IoTYPE_WRONLY;
8990e307 815 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 816 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
3028581b 817 else PerlLIO_close(fd[0]);
760ac839 818 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
3028581b 819 else PerlLIO_close(fd[1]);
fe14fcc3
LW
820 goto badexit;
821 }
afd9f252 822
3280af22 823 sv_setsv(sv,&PL_sv_yes);
afd9f252
LW
824 return;
825
826badexit:
3280af22 827 sv_setsv(sv,&PL_sv_undef);
afd9f252
LW
828 return;
829}
b1248f16 830#endif
afd9f252 831
517844ec 832/* explicit renamed to avoid C++ conflict -- kja */
a687059c 833bool
864dbfa3 834Perl_do_close(pTHX_ GV *gv, bool not_implicit)
a687059c 835{
1193dd27
IZ
836 bool retval;
837 IO *io;
a687059c 838
79072805 839 if (!gv)
3280af22 840 gv = PL_argvgv;
a0d0e21e 841 if (!gv || SvTYPE(gv) != SVt_PVGV) {
1d2dff63
GS
842 if (not_implicit)
843 SETERRNO(EBADF,SS$_IVCHAN);
c2ab57d4 844 return FALSE;
99b89507 845 }
79072805
LW
846 io = GvIO(gv);
847 if (!io) { /* never opened */
1d2dff63 848 if (not_implicit) {
d008e5eb 849 dTHR;
2dd78f96
JH
850 if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
851 report_evil_fh(gv, io, PL_op->op_type);
1d2dff63
GS
852 SETERRNO(EBADF,SS$_IVCHAN);
853 }
a687059c
LW
854 return FALSE;
855 }
f2b5be74 856 retval = io_close(io, not_implicit);
517844ec 857 if (not_implicit) {
1193dd27
IZ
858 IoLINES(io) = 0;
859 IoPAGE(io) = 0;
860 IoLINES_LEFT(io) = IoPAGE_LEN(io);
861 }
50952442 862 IoTYPE(io) = IoTYPE_CLOSED;
1193dd27
IZ
863 return retval;
864}
865
866bool
f2b5be74 867Perl_io_close(pTHX_ IO *io, bool not_implicit)
1193dd27
IZ
868{
869 bool retval = FALSE;
870 int status;
871
8990e307 872 if (IoIFP(io)) {
50952442 873 if (IoTYPE(io) == IoTYPE_PIPE) {
3028581b 874 status = PerlProc_pclose(IoIFP(io));
f2b5be74
GS
875 if (not_implicit) {
876 STATUS_NATIVE_SET(status);
877 retval = (STATUS_POSIX == 0);
878 }
879 else {
880 retval = (status != -1);
881 }
a687059c 882 }
50952442 883 else if (IoTYPE(io) == IoTYPE_STD)
a687059c
LW
884 retval = TRUE;
885 else {
8990e307 886 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
760ac839
LW
887 retval = (PerlIO_close(IoOFP(io)) != EOF);
888 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
889 }
890 else
760ac839 891 retval = (PerlIO_close(IoIFP(io)) != EOF);
a687059c 892 }
8990e307 893 IoOFP(io) = IoIFP(io) = Nullfp;
79072805 894 }
f2b5be74 895 else if (not_implicit) {
20408e3c
GS
896 SETERRNO(EBADF,SS$_IVCHAN);
897 }
1193dd27 898
a687059c
LW
899 return retval;
900}
901
902bool
864dbfa3 903Perl_do_eof(pTHX_ GV *gv)
a687059c 904{
11343788 905 dTHR;
79072805 906 register IO *io;
a687059c
LW
907 int ch;
908
79072805 909 io = GvIO(gv);
a687059c 910
79072805 911 if (!io)
a687059c 912 return TRUE;
af8c498a 913 else if (ckWARN(WARN_IO)
50952442 914 && (IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
af8c498a
GS
915 || IoIFP(io) == PerlIO_stderr()))
916 {
2dd78f96 917 /* integrate to report_evil_fh()? */
a1d180c4 918 char *name = NULL;
2dd78f96
JH
919 if (isGV(gv)) {
920 SV* sv = sv_newmortal();
921 gv_efullname4(sv, gv, Nullch, FALSE);
922 name = SvPV_nolen(sv);
923 }
924 if (name && *name)
925 Perl_warner(aTHX_ WARN_IO,
926 "Filehandle %s opened only for output", name);
927 else
928 Perl_warner(aTHX_ WARN_IO,
929 "Filehandle opened only for output");
af8c498a 930 }
a687059c 931
8990e307 932 while (IoIFP(io)) {
a687059c 933
760ac839 934 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
a20bf0c3 935 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
760ac839
LW
936 return FALSE; /* this is the most usual case */
937 }
a687059c 938
760ac839 939 ch = PerlIO_getc(IoIFP(io));
a687059c 940 if (ch != EOF) {
760ac839 941 (void)PerlIO_ungetc(IoIFP(io),ch);
a687059c
LW
942 return FALSE;
943 }
760ac839 944 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
a20bf0c3
JH
945 if (PerlIO_get_cnt(IoIFP(io)) < -1)
946 PerlIO_set_cnt(IoIFP(io),-1);
760ac839 947 }
533c011a 948 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
3280af22 949 if (!nextargv(PL_argvgv)) /* get another fp handy */
a687059c
LW
950 return TRUE;
951 }
952 else
953 return TRUE; /* normal fp, definitely end of file */
954 }
955 return TRUE;
956}
957
5ff3f7a4 958Off_t
864dbfa3 959Perl_do_tell(pTHX_ GV *gv)
a687059c 960{
79072805 961 register IO *io;
96e4d5b1 962 register PerlIO *fp;
a687059c 963
96e4d5b1 964 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 965#ifdef ULTRIX_STDIO_BOTCH
96e4d5b1
PP
966 if (PerlIO_eof(fp))
967 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 968#endif
8903cb82 969 return PerlIO_tell(fp);
96e4d5b1 970 }
d008e5eb
GS
971 {
972 dTHR;
2dd78f96
JH
973 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
974 report_evil_fh(gv, io, PL_op->op_type);
d008e5eb 975 }
748a9306 976 SETERRNO(EBADF,RMS$_IFI);
5ff3f7a4 977 return (Off_t)-1;
a687059c
LW
978}
979
980bool
864dbfa3 981Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 982{
79072805 983 register IO *io;
137443ea 984 register PerlIO *fp;
a687059c 985
137443ea 986 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 987#ifdef ULTRIX_STDIO_BOTCH
137443ea
PP
988 if (PerlIO_eof(fp))
989 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 990#endif
8903cb82 991 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 992 }
d008e5eb
GS
993 {
994 dTHR;
2dd78f96
JH
995 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
996 report_evil_fh(gv, io, PL_op->op_type);
d008e5eb 997 }
748a9306 998 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
999 return FALSE;
1000}
1001
97cc44eb 1002Off_t
864dbfa3 1003Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82
PP
1004{
1005 register IO *io;
1006 register PerlIO *fp;
1007
1008 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
3028581b 1009 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
d008e5eb
GS
1010 {
1011 dTHR;
2dd78f96
JH
1012 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1013 report_evil_fh(gv, io, PL_op->op_type);
d008e5eb 1014 }
8903cb82 1015 SETERRNO(EBADF,RMS$_IFI);
d9b3e12d 1016 return (Off_t)-1;
8903cb82
PP
1017}
1018
6ff81951 1019int
16fe6d59
GS
1020Perl_mode_from_discipline(pTHX_ SV *discp)
1021{
1022 int mode = O_BINARY;
1023 if (discp) {
1024 STRLEN len;
1025 char *s = SvPV(discp,len);
1026 while (*s) {
1027 if (*s == ':') {
1028 switch (s[1]) {
1029 case 'r':
1030 if (len > 3 && strnEQ(s+1, "raw", 3)
1031 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1032 {
1033 mode = O_BINARY;
1034 s += 4;
1035 len -= 4;
1036 break;
1037 }
1038 /* FALL THROUGH */
1039 case 'c':
1040 if (len > 4 && strnEQ(s+1, "crlf", 4)
1041 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1042 {
1043 mode = O_TEXT;
1044 s += 5;
1045 len -= 5;
1046 break;
1047 }
1048 /* FALL THROUGH */
1049 default:
1050 goto fail_discipline;
1051 }
1052 }
1053 else if (isSPACE(*s)) {
1054 ++s;
1055 --len;
1056 }
1057 else {
1058 char *end;
1059fail_discipline:
1060 end = strchr(s+1, ':');
1061 if (!end)
1062 end = s+len;
1063 Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s);
1064 }
1065 }
1066 }
1067 return mode;
1068}
1069
1070int
1071Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
6ff81951 1072{
6ff81951 1073#ifdef DOSISH
16fe6d59
GS
1074# if defined(atarist) || defined(__MINT__)
1075 if (!PerlIO_flush(fp)) {
1076 if (mode & O_BINARY)
1077 ((FILE*)fp)->_flag |= _IOBIN;
1078 else
1079 ((FILE*)fp)->_flag &= ~ _IOBIN;
6ff81951 1080 return 1;
16fe6d59
GS
1081 }
1082 return 0;
1083# else
1084 if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) {
1085# if defined(WIN32) && defined(__BORLANDC__)
6ff81951
GS
1086 /* The translation mode of the stream is maintained independent
1087 * of the translation mode of the fd in the Borland RTL (heavy
1088 * digging through their runtime sources reveal). User has to
1089 * set the mode explicitly for the stream (though they don't
1090 * document this anywhere). GSAR 97-5-24
1091 */
1092 PerlIO_seek(fp,0L,0);
16fe6d59
GS
1093 if (mode & O_BINARY)
1094 ((FILE*)fp)->flags |= _F_BIN;
1095 else
1096 ((FILE*)fp)->flags &= ~ _F_BIN;
1097# endif
6ff81951
GS
1098 return 1;
1099 }
1100 else
1101 return 0;
16fe6d59 1102# endif
6ff81951 1103#else
16fe6d59
GS
1104# if defined(USEMYBINMODE)
1105 if (my_binmode(fp, iotype, mode) != FALSE)
6ff81951
GS
1106 return 1;
1107 else
1108 return 0;
16fe6d59 1109# else
6ff81951 1110 return 1;
16fe6d59 1111# endif
6ff81951
GS
1112#endif
1113}
1114
a0d0e21e 1115#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
c2ab57d4 1116 /* code courtesy of William Kucharski */
fe14fcc3 1117#define HAS_CHSIZE
6eb13c3b 1118
517844ec 1119I32 my_chsize(fd, length)
79072805 1120I32 fd; /* file descriptor */
85e6fe83 1121Off_t length; /* length to set file to */
6eb13c3b 1122{
6eb13c3b
LW
1123 struct flock fl;
1124 struct stat filebuf;
1125
3028581b 1126 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
1127 return -1;
1128
1129 if (filebuf.st_size < length) {
1130
1131 /* extend file length */
1132
3028581b 1133 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
1134 return -1;
1135
1136 /* write a "0" byte */
1137
3028581b 1138 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
1139 return -1;
1140 }
1141 else {
1142 /* truncate length */
1143
1144 fl.l_whence = 0;
1145 fl.l_len = 0;
1146 fl.l_start = length;
a0d0e21e 1147 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
1148
1149 /*
a0d0e21e 1150 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
1151 * fcntl(2), which truncates the file so that it ends at the
1152 * position indicated by fl.l_start.
1153 *
1154 * Will minor miracles never cease?
1155 */
1156
a0d0e21e 1157 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
1158 return -1;
1159
1160 }
1161
1162 return 0;
1163}
a0d0e21e 1164#endif /* F_FREESP */
ff8e2863 1165
a687059c 1166bool
864dbfa3 1167Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
a687059c
LW
1168{
1169 register char *tmps;
463ee0b2 1170 STRLEN len;
a687059c 1171
79072805
LW
1172 /* assuming fp is checked earlier */
1173 if (!sv)
1174 return TRUE;
3280af22 1175 if (PL_ofmt) {
8990e307 1176 if (SvGMAGICAL(sv))
79072805 1177 mg_get(sv);
463ee0b2 1178 if (SvIOK(sv) && SvIVX(sv) != 0) {
65202027 1179 PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
760ac839 1180 return !PerlIO_error(fp);
79072805 1181 }
463ee0b2 1182 if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
79072805 1183 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
3280af22 1184 PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
760ac839 1185 return !PerlIO_error(fp);
79072805 1186 }
a687059c 1187 }
79072805
LW
1188 switch (SvTYPE(sv)) {
1189 case SVt_NULL:
d008e5eb
GS
1190 {
1191 dTHR;
1192 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 1193 report_uninit();
d008e5eb 1194 }
ff8e2863 1195 return TRUE;
79072805 1196 case SVt_IV:
a0d0e21e
LW
1197 if (SvIOK(sv)) {
1198 if (SvGMAGICAL(sv))
1199 mg_get(sv);
cf2093f6 1200 if (SvIsUV(sv))
57def98f 1201 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
cf2093f6 1202 else
57def98f 1203 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
760ac839 1204 return !PerlIO_error(fp);
a0d0e21e
LW
1205 }
1206 /* FALL THROUGH */
79072805 1207 default:
fba9e08b 1208#if 0
4b3603a4
JH
1209 /* XXX Fix this when the I/O disciplines arrive. XXX */
1210 if (DO_UTF8(sv))
1211 sv_utf8_downgrade(sv, FALSE);
fba9e08b 1212#endif
463ee0b2 1213 tmps = SvPV(sv, len);
79072805 1214 break;
ff8e2863 1215 }
94e4c244
JH
1216 /* To detect whether the process is about to overstep its
1217 * filesize limit we would need getrlimit(). We could then
1218 * also transparently raise the limit with setrlimit() --
1219 * but only until the system hard limit/the filesystem limit,
c5dd3cdd
JH
1220 * at which we would get EPERM. Note that when using buffered
1221 * io the write failure can be delayed until the flush/close. --jhi */
a21ac455 1222 if (len && (PerlIO_write(fp,tmps,len) == 0))
a687059c 1223 return FALSE;
760ac839 1224 return !PerlIO_error(fp);
a687059c
LW
1225}
1226
79072805 1227I32
cea2e8a9 1228Perl_my_stat(pTHX)
a687059c 1229{
4e35701f 1230 djSP;
79072805 1231 IO *io;
2dd78f96 1232 GV* gv;
79072805 1233
533c011a 1234 if (PL_op->op_flags & OPf_REF) {
924508f0 1235 EXTEND(SP,1);
2dd78f96 1236 gv = cGVOP_gv;
748a9306 1237 do_fstat:
2dd78f96 1238 io = GvIO(gv);
8990e307 1239 if (io && IoIFP(io)) {
2dd78f96 1240 PL_statgv = gv;
3280af22
NIS
1241 sv_setpv(PL_statname,"");
1242 PL_laststype = OP_STAT;
1243 return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
a687059c
LW
1244 }
1245 else {
2dd78f96 1246 if (gv == PL_defgv)
3280af22 1247 return PL_laststatval;
2dd78f96
JH
1248 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1249 report_evil_fh(gv, io, PL_op->op_type);
3280af22
NIS
1250 PL_statgv = Nullgv;
1251 sv_setpv(PL_statname,"");
1252 return (PL_laststatval = -1);
a687059c
LW
1253 }
1254 }
1255 else {
748a9306 1256 SV* sv = POPs;
4b74e3fb 1257 char *s;
2d8e6c8d 1258 STRLEN n_a;
79072805 1259 PUTBACK;
748a9306 1260 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 1261 gv = (GV*)sv;
748a9306
LW
1262 goto do_fstat;
1263 }
1264 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 1265 gv = (GV*)SvRV(sv);
748a9306
LW
1266 goto do_fstat;
1267 }
1268
2d8e6c8d 1269 s = SvPV(sv, n_a);
3280af22
NIS
1270 PL_statgv = Nullgv;
1271 sv_setpv(PL_statname, s);
1272 PL_laststype = OP_STAT;
1273 PL_laststatval = PerlLIO_stat(s, &PL_statcache);
599cee73 1274 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
cea2e8a9 1275 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
3280af22 1276 return PL_laststatval;
a687059c
LW
1277 }
1278}
1279
79072805 1280I32
cea2e8a9 1281Perl_my_lstat(pTHX)
c623bd54 1282{
4e35701f 1283 djSP;
79072805 1284 SV *sv;
2d8e6c8d 1285 STRLEN n_a;
533c011a 1286 if (PL_op->op_flags & OPf_REF) {
924508f0 1287 EXTEND(SP,1);
638eceb6 1288 if (cGVOP_gv == PL_defgv) {
3280af22 1289 if (PL_laststype != OP_LSTAT)
cea2e8a9 1290 Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
3280af22 1291 return PL_laststatval;
fe14fcc3 1292 }
cea2e8a9 1293 Perl_croak(aTHX_ "You can't use -l on a filehandle");
fe14fcc3 1294 }
c623bd54 1295
3280af22
NIS
1296 PL_laststype = OP_LSTAT;
1297 PL_statgv = Nullgv;
79072805
LW
1298 sv = POPs;
1299 PUTBACK;
2d8e6c8d 1300 sv_setpv(PL_statname,SvPV(sv, n_a));
2d8e6c8d 1301 PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
2d8e6c8d 1302 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 1303 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "lstat");
3280af22 1304 return PL_laststatval;
c623bd54
LW
1305}
1306
a687059c 1307bool
864dbfa3 1308Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
a687059c 1309{
d5a9bfb0
IZ
1310 return do_aexec5(really, mark, sp, 0, 0);
1311}
1312
1313bool
2aa1486d
GS
1314Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
1315 int fd, int do_report)
d5a9bfb0 1316{
cd39f2b6
JH
1317#ifdef MACOS_TRADITIONAL
1318 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1319#else
a687059c 1320 register char **a;
a687059c 1321 char *tmps;
2d8e6c8d 1322 STRLEN n_a;
a687059c 1323
79072805 1324 if (sp > mark) {
11343788 1325 dTHR;
3280af22
NIS
1326 New(401,PL_Argv, sp - mark + 1, char*);
1327 a = PL_Argv;
79072805
LW
1328 while (++mark <= sp) {
1329 if (*mark)
2d8e6c8d 1330 *a++ = SvPVx(*mark, n_a);
a687059c
LW
1331 else
1332 *a++ = "";
1333 }
1334 *a = Nullch;
3280af22 1335 if (*PL_Argv[0] != '/') /* will execvp use PATH? */
79072805 1336 TAINT_ENV(); /* testing IFS here is overkill, probably */
2d8e6c8d 1337 if (really && *(tmps = SvPV(really, n_a)))
3280af22 1338 PerlProc_execvp(tmps,PL_Argv);
a687059c 1339 else
3280af22 1340 PerlProc_execvp(PL_Argv[0],PL_Argv);
599cee73 1341 if (ckWARN(WARN_EXEC))
a1d180c4 1342 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
599cee73 1343 PL_Argv[0], Strerror(errno));
d5a9bfb0
IZ
1344 if (do_report) {
1345 int e = errno;
1346
1347 PerlLIO_write(fd, (void*)&e, sizeof(int));
1348 PerlLIO_close(fd);
1349 }
a687059c 1350 }
bee1dbe2 1351 do_execfree();
cd39f2b6 1352#endif
a687059c
LW
1353 return FALSE;
1354}
1355
fe14fcc3 1356void
864dbfa3 1357Perl_do_execfree(pTHX)
ff8e2863 1358{
3280af22
NIS
1359 if (PL_Argv) {
1360 Safefree(PL_Argv);
1361 PL_Argv = Null(char **);
ff8e2863 1362 }
3280af22
NIS
1363 if (PL_Cmd) {
1364 Safefree(PL_Cmd);
1365 PL_Cmd = Nullch;
ff8e2863
LW
1366 }
1367}
1368
cd39f2b6 1369#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 1370
a687059c 1371bool
864dbfa3 1372Perl_do_exec(pTHX_ char *cmd)
a687059c 1373{
e446cec8
IZ
1374 return do_exec3(cmd,0,0);
1375}
1376
1377bool
864dbfa3 1378Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
e446cec8 1379{
a687059c
LW
1380 register char **a;
1381 register char *s;
a687059c
LW
1382 char flags[10];
1383
748a9306
LW
1384 while (*cmd && isSPACE(*cmd))
1385 cmd++;
1386
a687059c
LW
1387 /* save an extra exec if possible */
1388
bf38876a 1389#ifdef CSH
3280af22 1390 if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
a687059c 1391 strcpy(flags,"-c");
3280af22 1392 s = cmd+PL_cshlen+3;
a687059c
LW
1393 if (*s == 'f') {
1394 s++;
1395 strcat(flags,"f");
1396 }
1397 if (*s == ' ')
1398 s++;
1399 if (*s++ == '\'') {
1400 char *ncmd = s;
1401
1402 while (*s)
1403 s++;
1404 if (s[-1] == '\n')
1405 *--s = '\0';
1406 if (s[-1] == '\'') {
1407 *--s = '\0';
3280af22 1408 PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
a687059c
LW
1409 *s = '\'';
1410 return FALSE;
1411 }
1412 }
1413 }
bf38876a 1414#endif /* CSH */
a687059c
LW
1415
1416 /* see if there are shell metacharacters in it */
1417
748a9306
LW
1418 if (*cmd == '.' && isSPACE(cmd[1]))
1419 goto doshell;
1420
1421 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1422 goto doshell;
1423
c170e444 1424 for (s = cmd; *s && isALNUM(*s); s++) ; /* catch VAR=val gizmo */
63f2c1e1
LW
1425 if (*s == '=')
1426 goto doshell;
748a9306 1427
a687059c 1428 for (s = cmd; *s; s++) {
93a17b20 1429 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1430 if (*s == '\n' && !s[1]) {
1431 *s = '\0';
1432 break;
1433 }
603a98b0
IZ
1434 /* handle the 2>&1 construct at the end */
1435 if (*s == '>' && s[1] == '&' && s[2] == '1'
1436 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1437 && (!s[3] || isSPACE(s[3])))
1438 {
1439 char *t = s + 3;
1440
1441 while (*t && isSPACE(*t))
1442 ++t;
1443 if (!*t && (dup2(1,2) != -1)) {
1444 s[-2] = '\0';
1445 break;
1446 }
1447 }
a687059c 1448 doshell:
3280af22 1449 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
a687059c
LW
1450 return FALSE;
1451 }
1452 }
748a9306 1453
3280af22
NIS
1454 New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
1455 PL_Cmd = savepvn(cmd, s-cmd);
1456 a = PL_Argv;
1457 for (s = PL_Cmd; *s;) {
99b89507 1458 while (*s && isSPACE(*s)) s++;
a687059c
LW
1459 if (*s)
1460 *(a++) = s;
99b89507 1461 while (*s && !isSPACE(*s)) s++;
a687059c
LW
1462 if (*s)
1463 *s++ = '\0';
1464 }
1465 *a = Nullch;
3280af22
NIS
1466 if (PL_Argv[0]) {
1467 PerlProc_execvp(PL_Argv[0],PL_Argv);
b1248f16 1468 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1469 do_execfree();
a687059c 1470 goto doshell;
b1248f16 1471 }
d008e5eb
GS
1472 {
1473 dTHR;
e446cec8
IZ
1474 int e = errno;
1475
d008e5eb 1476 if (ckWARN(WARN_EXEC))
a1d180c4 1477 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
d008e5eb 1478 PL_Argv[0], Strerror(errno));
e446cec8
IZ
1479 if (do_report) {
1480 PerlLIO_write(fd, (void*)&e, sizeof(int));
1481 PerlLIO_close(fd);
1482 }
d008e5eb 1483 }
a687059c 1484 }
ff8e2863 1485 do_execfree();
a687059c
LW
1486 return FALSE;
1487}
1488
6890e559 1489#endif /* OS2 || WIN32 */
760ac839 1490
79072805 1491I32
864dbfa3 1492Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
a687059c 1493{
11343788 1494 dTHR;
79072805
LW
1495 register I32 val;
1496 register I32 val2;
1497 register I32 tot = 0;
20408e3c 1498 char *what;
a687059c 1499 char *s;
79072805 1500 SV **oldmark = mark;
2d8e6c8d 1501 STRLEN n_a;
a687059c 1502
20408e3c 1503#define APPLY_TAINT_PROPER() \
3280af22 1504 STMT_START { \
17406bd6 1505 if (PL_tainted) { TAINT_PROPER(what); } \
873ef191 1506 } STMT_END
20408e3c
GS
1507
1508 /* This is a first heuristic; it doesn't catch tainting magic. */
3280af22 1509 if (PL_tainting) {
463ee0b2 1510 while (++mark <= sp) {
bbce6d69
PP
1511 if (SvTAINTED(*mark)) {
1512 TAINT;
1513 break;
1514 }
463ee0b2
LW
1515 }
1516 mark = oldmark;
1517 }
a687059c 1518 switch (type) {
79072805 1519 case OP_CHMOD:
20408e3c
GS
1520 what = "chmod";
1521 APPLY_TAINT_PROPER();
79072805 1522 if (++mark <= sp) {
463ee0b2 1523 val = SvIVx(*mark);
20408e3c
GS
1524 APPLY_TAINT_PROPER();
1525 tot = sp - mark;
79072805 1526 while (++mark <= sp) {
2d8e6c8d 1527 char *name = SvPVx(*mark, n_a);
20408e3c
GS
1528 APPLY_TAINT_PROPER();
1529 if (PerlLIO_chmod(name, val))
a687059c
LW
1530 tot--;
1531 }
1532 }
1533 break;
fe14fcc3 1534#ifdef HAS_CHOWN
79072805 1535 case OP_CHOWN:
20408e3c
GS
1536 what = "chown";
1537 APPLY_TAINT_PROPER();
79072805 1538 if (sp - mark > 2) {
463ee0b2
LW
1539 val = SvIVx(*++mark);
1540 val2 = SvIVx(*++mark);
20408e3c 1541 APPLY_TAINT_PROPER();
a0d0e21e 1542 tot = sp - mark;
79072805 1543 while (++mark <= sp) {
2d8e6c8d 1544 char *name = SvPVx(*mark, n_a);
20408e3c 1545 APPLY_TAINT_PROPER();
36660982 1546 if (PerlLIO_chown(name, val, val2))
a687059c
LW
1547 tot--;
1548 }
1549 }
1550 break;
b1248f16 1551#endif
a1d180c4 1552/*
dd64f1c3
AD
1553XXX Should we make lchown() directly available from perl?
1554For now, we'll let Configure test for HAS_LCHOWN, but do
1555nothing in the core.
1556 --AD 5/1998
1557*/
fe14fcc3 1558#ifdef HAS_KILL
79072805 1559 case OP_KILL:
20408e3c
GS
1560 what = "kill";
1561 APPLY_TAINT_PROPER();
55497cff
PP
1562 if (mark == sp)
1563 break;
2d8e6c8d 1564 s = SvPVx(*++mark, n_a);
79072805
LW
1565 if (isUPPER(*s)) {
1566 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1567 s += 3;
1568 if (!(val = whichsig(s)))
cea2e8a9 1569 Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
79072805
LW
1570 }
1571 else
463ee0b2 1572 val = SvIVx(*mark);
20408e3c
GS
1573 APPLY_TAINT_PROPER();
1574 tot = sp - mark;
3595fcef
PP
1575#ifdef VMS
1576 /* kill() doesn't do process groups (job trees?) under VMS */
1577 if (val < 0) val = -val;
1578 if (val == SIGKILL) {
1579# include <starlet.h>
1580 /* Use native sys$delprc() to insure that target process is
1581 * deleted; supervisor-mode images don't pay attention to
1582 * CRTL's emulation of Unix-style signals and kill()
1583 */
1584 while (++mark <= sp) {
1585 I32 proc = SvIVx(*mark);
1586 register unsigned long int __vmssts;
20408e3c 1587 APPLY_TAINT_PROPER();
3595fcef
PP
1588 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1589 tot--;
1590 switch (__vmssts) {
1591 case SS$_NONEXPR:
1592 case SS$_NOSUCHNODE:
1593 SETERRNO(ESRCH,__vmssts);
1594 break;
1595 case SS$_NOPRIV:
1596 SETERRNO(EPERM,__vmssts);
1597 break;
1598 default:
1599 SETERRNO(EVMSERR,__vmssts);
1600 }
1601 }
1602 }
1603 break;
1604 }
1605#endif
79072805
LW
1606 if (val < 0) {
1607 val = -val;
1608 while (++mark <= sp) {
463ee0b2 1609 I32 proc = SvIVx(*mark);
20408e3c 1610 APPLY_TAINT_PROPER();
fe14fcc3 1611#ifdef HAS_KILLPG
3028581b 1612 if (PerlProc_killpg(proc,val)) /* BSD */
a687059c 1613#else
3028581b 1614 if (PerlProc_kill(-proc,val)) /* SYSV */
a687059c 1615#endif
79072805 1616 tot--;
a687059c 1617 }
79072805
LW
1618 }
1619 else {
1620 while (++mark <= sp) {
20408e3c
GS
1621 I32 proc = SvIVx(*mark);
1622 APPLY_TAINT_PROPER();
1623 if (PerlProc_kill(proc, val))
79072805 1624 tot--;
a687059c
LW
1625 }
1626 }
1627 break;
b1248f16 1628#endif
79072805 1629 case OP_UNLINK:
20408e3c
GS
1630 what = "unlink";
1631 APPLY_TAINT_PROPER();
79072805
LW
1632 tot = sp - mark;
1633 while (++mark <= sp) {
2d8e6c8d 1634 s = SvPVx(*mark, n_a);
20408e3c 1635 APPLY_TAINT_PROPER();
3280af22 1636 if (PL_euid || PL_unsafe) {
a687059c
LW
1637 if (UNLINK(s))
1638 tot--;
1639 }
1640 else { /* don't let root wipe out directories without -U */
3280af22 1641 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
a687059c
LW
1642 tot--;
1643 else {
1644 if (UNLINK(s))
1645 tot--;
1646 }
1647 }
1648 }
1649 break;
a0d0e21e 1650#ifdef HAS_UTIME
79072805 1651 case OP_UTIME:
20408e3c
GS
1652 what = "utime";
1653 APPLY_TAINT_PROPER();
79072805 1654 if (sp - mark > 2) {
748a9306 1655#if defined(I_UTIME) || defined(VMS)
663a0e37
LW
1656 struct utimbuf utbuf;
1657#else
a687059c 1658 struct {
dd2821f6
GS
1659 Time_t actime;
1660 Time_t modtime;
a687059c 1661 } utbuf;
663a0e37 1662#endif
a687059c 1663
afd9f252 1664 Zero(&utbuf, sizeof utbuf, char);
517844ec 1665#ifdef BIG_TIME
dd2821f6
GS
1666 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
1667 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
517844ec 1668#else
dd2821f6
GS
1669 utbuf.actime = (Time_t)SvIVx(*++mark); /* time accessed */
1670 utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */
517844ec 1671#endif
20408e3c 1672 APPLY_TAINT_PROPER();
79072805
LW
1673 tot = sp - mark;
1674 while (++mark <= sp) {
2d8e6c8d 1675 char *name = SvPVx(*mark, n_a);
20408e3c
GS
1676 APPLY_TAINT_PROPER();
1677 if (PerlLIO_utime(name, &utbuf))
a687059c
LW
1678 tot--;
1679 }
a687059c
LW
1680 }
1681 else
79072805 1682 tot = 0;
a687059c 1683 break;
a0d0e21e 1684#endif
a687059c
LW
1685 }
1686 return tot;
20408e3c 1687
20408e3c 1688#undef APPLY_TAINT_PROPER
a687059c
LW
1689}
1690
1691/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1692#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae
JH
1693bool
1694Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
1695/* Note: we use `effective' both for uids and gids.
1696 * Here we are betting on Uid_t being equal or wider than Gid_t. */
a687059c 1697{
bee1dbe2 1698#ifdef DOSISH
fe14fcc3
LW
1699 /* [Comments and code from Len Reed]
1700 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1701 * to write-protected files. The execute permission bit is set
1702 * by the Miscrosoft C library stat() function for the following:
1703 * .exe files
1704 * .com files
1705 * .bat files
1706 * directories
1707 * All files and directories are readable.
1708 * Directories and special files, e.g. "CON", cannot be
1709 * write-protected.
1710 * [Comment by Tom Dinger -- a directory can have the write-protect
1711 * bit set in the file system, but DOS permits changes to
1712 * the directory anyway. In addition, all bets are off
1713 * here for networked software, such as Novell and
1714 * Sun's PC-NFS.]
1715 */
1716
bee1dbe2
LW
1717 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1718 * too so it will actually look into the files for magic numbers
1719 */
7f4774ae 1720 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 1721
55497cff 1722#else /* ! DOSISH */
3280af22 1723 if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */
7f4774ae 1724 if (mode == S_IXUSR) {
c623bd54 1725 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1726 return TRUE;
1727 }
1728 else
1729 return TRUE; /* root reads and writes anything */
1730 return FALSE;
1731 }
3280af22 1732 if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
7f4774ae 1733 if (statbufp->st_mode & mode)
a687059c
LW
1734 return TRUE; /* ok as "user" */
1735 }
d8eceb89 1736 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 1737 if (statbufp->st_mode & mode >> 3)
a687059c
LW
1738 return TRUE; /* ok as "group" */
1739 }
7f4774ae 1740 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
1741 return TRUE; /* ok as "other" */
1742 return FALSE;
55497cff 1743#endif /* ! DOSISH */
a687059c 1744}
a0d0e21e 1745#endif /* ! VMS */
a687059c 1746
d8eceb89
JH
1747bool
1748Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
a687059c 1749{
cd39f2b6
JH
1750#ifdef MACOS_TRADITIONAL
1751 /* This is simply not correct for AppleShare, but fix it yerself. */
1752 return TRUE;
1753#else
3280af22 1754 if (testgid == (effective ? PL_egid : PL_gid))
a687059c 1755 return TRUE;
fe14fcc3 1756#ifdef HAS_GETGROUPS
a687059c
LW
1757#ifndef NGROUPS
1758#define NGROUPS 32
1759#endif
1760 {
a0d0e21e 1761 Groups_t gary[NGROUPS];
79072805 1762 I32 anum;
a687059c
LW
1763
1764 anum = getgroups(NGROUPS,gary);
1765 while (--anum >= 0)
1766 if (gary[anum] == testgid)
1767 return TRUE;
1768 }
1769#endif
1770 return FALSE;
cd39f2b6 1771#endif
a687059c 1772}
c2ab57d4 1773
fe14fcc3 1774#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 1775
79072805 1776I32
864dbfa3 1777Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 1778{
11343788 1779 dTHR;
c2ab57d4 1780 key_t key;
79072805 1781 I32 n, flags;
c2ab57d4 1782
463ee0b2
LW
1783 key = (key_t)SvNVx(*++mark);
1784 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1785 flags = SvIVx(*++mark);
748a9306 1786 SETERRNO(0,0);
c2ab57d4
LW
1787 switch (optype)
1788 {
fe14fcc3 1789#ifdef HAS_MSG
79072805 1790 case OP_MSGGET:
c2ab57d4 1791 return msgget(key, flags);
e5d73d77 1792#endif
fe14fcc3 1793#ifdef HAS_SEM
79072805 1794 case OP_SEMGET:
c2ab57d4 1795 return semget(key, n, flags);
e5d73d77 1796#endif
fe14fcc3 1797#ifdef HAS_SHM
79072805 1798 case OP_SHMGET:
c2ab57d4 1799 return shmget(key, n, flags);
e5d73d77 1800#endif
fe14fcc3 1801#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1802 default:
cea2e8a9 1803 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 1804#endif
c2ab57d4
LW
1805 }
1806 return -1; /* should never happen */
1807}
1808
79072805 1809I32
864dbfa3 1810Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 1811{
11343788 1812 dTHR;
79072805 1813 SV *astr;
c2ab57d4 1814 char *a;
a0d0e21e
LW
1815 I32 id, n, cmd, infosize, getinfo;
1816 I32 ret = -1;
c2ab57d4 1817
463ee0b2
LW
1818 id = SvIVx(*++mark);
1819 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1820 cmd = SvIVx(*++mark);
79072805 1821 astr = *++mark;
c2ab57d4
LW
1822 infosize = 0;
1823 getinfo = (cmd == IPC_STAT);
1824
1825 switch (optype)
1826 {
fe14fcc3 1827#ifdef HAS_MSG
79072805 1828 case OP_MSGCTL:
c2ab57d4
LW
1829 if (cmd == IPC_STAT || cmd == IPC_SET)
1830 infosize = sizeof(struct msqid_ds);
1831 break;
e5d73d77 1832#endif
fe14fcc3 1833#ifdef HAS_SHM
79072805 1834 case OP_SHMCTL:
c2ab57d4
LW
1835 if (cmd == IPC_STAT || cmd == IPC_SET)
1836 infosize = sizeof(struct shmid_ds);
1837 break;
e5d73d77 1838#endif
fe14fcc3 1839#ifdef HAS_SEM
79072805 1840 case OP_SEMCTL:
39398f3f 1841#ifdef Semctl
c2ab57d4
LW
1842 if (cmd == IPC_STAT || cmd == IPC_SET)
1843 infosize = sizeof(struct semid_ds);
1844 else if (cmd == GETALL || cmd == SETALL)
1845 {
8e591e46 1846 struct semid_ds semds;
bd89102f 1847 union semun semun;
e6f0bdd6
GS
1848#ifdef EXTRA_F_IN_SEMUN_BUF
1849 semun.buff = &semds;
1850#else
84902520 1851 semun.buf = &semds;
e6f0bdd6 1852#endif
c2ab57d4 1853 getinfo = (cmd == GETALL);
9b89d93d
GB
1854 if (Semctl(id, 0, IPC_STAT, semun) == -1)
1855 return -1;
6e21c824
LW
1856 infosize = semds.sem_nsems * sizeof(short);
1857 /* "short" is technically wrong but much more portable
1858 than guessing about u_?short(_t)? */
c2ab57d4 1859 }
39398f3f 1860#else
cea2e8a9 1861 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 1862#endif
c2ab57d4 1863 break;
e5d73d77 1864#endif
fe14fcc3 1865#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1866 default:
cea2e8a9 1867 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 1868#endif
c2ab57d4
LW
1869 }
1870
1871 if (infosize)
1872 {
a0d0e21e 1873 STRLEN len;
c2ab57d4
LW
1874 if (getinfo)
1875 {
a0d0e21e
LW
1876 SvPV_force(astr, len);
1877 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
1878 }
1879 else
1880 {
463ee0b2
LW
1881 a = SvPV(astr, len);
1882 if (len != infosize)
cea2e8a9 1883 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
1884 PL_op_desc[optype],
1885 (unsigned long)len,
1886 (long)infosize);
c2ab57d4
LW
1887 }
1888 }
1889 else
1890 {
c030ccd9 1891 IV i = SvIV(astr);
56431972 1892 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 1893 }
748a9306 1894 SETERRNO(0,0);
c2ab57d4
LW
1895 switch (optype)
1896 {
fe14fcc3 1897#ifdef HAS_MSG
79072805 1898 case OP_MSGCTL:
bee1dbe2 1899 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 1900 break;
e5d73d77 1901#endif
fe14fcc3 1902#ifdef HAS_SEM
bd89102f 1903 case OP_SEMCTL: {
39398f3f 1904#ifdef Semctl
bd89102f
AD
1905 union semun unsemds;
1906
e6f0bdd6
GS
1907#ifdef EXTRA_F_IN_SEMUN_BUF
1908 unsemds.buff = (struct semid_ds *)a;
1909#else
bd89102f 1910 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 1911#endif
bd89102f 1912 ret = Semctl(id, n, cmd, unsemds);
39398f3f 1913#else
cea2e8a9 1914 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 1915#endif
bd89102f 1916 }
c2ab57d4 1917 break;
e5d73d77 1918#endif
fe14fcc3 1919#ifdef HAS_SHM
79072805 1920 case OP_SHMCTL:
bee1dbe2 1921 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 1922 break;
e5d73d77 1923#endif
c2ab57d4
LW
1924 }
1925 if (getinfo && ret >= 0) {
79072805
LW
1926 SvCUR_set(astr, infosize);
1927 *SvEND(astr) = '\0';
a0d0e21e 1928 SvSETMAGIC(astr);
c2ab57d4
LW
1929 }
1930 return ret;
1931}
1932
79072805 1933I32
864dbfa3 1934Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 1935{
fe14fcc3 1936#ifdef HAS_MSG
11343788 1937 dTHR;
79072805 1938 SV *mstr;
c2ab57d4 1939 char *mbuf;
79072805 1940 I32 id, msize, flags;
463ee0b2 1941 STRLEN len;
c2ab57d4 1942
463ee0b2 1943 id = SvIVx(*++mark);
79072805 1944 mstr = *++mark;
463ee0b2
LW
1945 flags = SvIVx(*++mark);
1946 mbuf = SvPV(mstr, len);
1947 if ((msize = len - sizeof(long)) < 0)
cea2e8a9 1948 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 1949 SETERRNO(0,0);
bee1dbe2 1950 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 1951#else
cea2e8a9 1952 Perl_croak(aTHX_ "msgsnd not implemented");
e5d73d77 1953#endif
c2ab57d4
LW
1954}
1955
79072805 1956I32
864dbfa3 1957Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 1958{
fe14fcc3 1959#ifdef HAS_MSG
11343788 1960 dTHR;
79072805 1961 SV *mstr;
c2ab57d4
LW
1962 char *mbuf;
1963 long mtype;
79072805 1964 I32 id, msize, flags, ret;
463ee0b2 1965 STRLEN len;
79072805 1966
463ee0b2 1967 id = SvIVx(*++mark);
79072805 1968 mstr = *++mark;
c2e66d9e
GS
1969 /* suppress warning when reading into undef var --jhi */
1970 if (! SvOK(mstr))
1971 sv_setpvn(mstr, "", 0);
463ee0b2
LW
1972 msize = SvIVx(*++mark);
1973 mtype = (long)SvIVx(*++mark);
1974 flags = SvIVx(*++mark);
a0d0e21e
LW
1975 SvPV_force(mstr, len);
1976 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 1977
748a9306 1978 SETERRNO(0,0);
bee1dbe2 1979 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 1980 if (ret >= 0) {
79072805
LW
1981 SvCUR_set(mstr, sizeof(long)+ret);
1982 *SvEND(mstr) = '\0';
41d6edb2
JH
1983#ifndef INCOMPLETE_TAINTS
1984 /* who knows who has been playing with this message? */
1985 SvTAINTED_on(mstr);
1986#endif
c2ab57d4
LW
1987 }
1988 return ret;
e5d73d77 1989#else
cea2e8a9 1990 Perl_croak(aTHX_ "msgrcv not implemented");
e5d73d77 1991#endif
c2ab57d4
LW
1992}
1993
79072805 1994I32
864dbfa3 1995Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 1996{
fe14fcc3 1997#ifdef HAS_SEM
11343788 1998 dTHR;
79072805 1999 SV *opstr;
c2ab57d4 2000 char *opbuf;
463ee0b2
LW
2001 I32 id;
2002 STRLEN opsize;
c2ab57d4 2003
463ee0b2 2004 id = SvIVx(*++mark);
79072805 2005 opstr = *++mark;
463ee0b2 2006 opbuf = SvPV(opstr, opsize);
c2ab57d4
LW
2007 if (opsize < sizeof(struct sembuf)
2008 || (opsize % sizeof(struct sembuf)) != 0) {
748a9306 2009 SETERRNO(EINVAL,LIB$_INVARG);
c2ab57d4
LW
2010 return -1;
2011 }
748a9306 2012 SETERRNO(0,0);
6e21c824 2013 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
e5d73d77 2014#else
cea2e8a9 2015 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2016#endif
c2ab57d4
LW
2017}
2018
79072805 2019I32
864dbfa3 2020Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2021{
fe14fcc3 2022#ifdef HAS_SHM
11343788 2023 dTHR;
79072805 2024 SV *mstr;
c2ab57d4 2025 char *mbuf, *shm;
79072805 2026 I32 id, mpos, msize;
463ee0b2 2027 STRLEN len;
c2ab57d4 2028 struct shmid_ds shmds;
c2ab57d4 2029
463ee0b2 2030 id = SvIVx(*++mark);
79072805 2031 mstr = *++mark;
463ee0b2
LW
2032 mpos = SvIVx(*++mark);
2033 msize = SvIVx(*++mark);
748a9306 2034 SETERRNO(0,0);
c2ab57d4
LW
2035 if (shmctl(id, IPC_STAT, &shmds) == -1)
2036 return -1;
2037 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
748a9306 2038 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2039 return -1;
2040 }
8ac85365 2041 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
2042 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2043 return -1;
79072805 2044 if (optype == OP_SHMREAD) {
9f538c04
GS
2045 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
2046 if (! SvOK(mstr))
2047 sv_setpvn(mstr, "", 0);
a0d0e21e
LW
2048 SvPV_force(mstr, len);
2049 mbuf = SvGROW(mstr, msize+1);
2050
bee1dbe2 2051 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2052 SvCUR_set(mstr, msize);
2053 *SvEND(mstr) = '\0';
a0d0e21e 2054 SvSETMAGIC(mstr);
d929ce6f
JH
2055#ifndef INCOMPLETE_TAINTS
2056 /* who knows who has been playing with this shared memory? */
2057 SvTAINTED_on(mstr);
2058#endif
c2ab57d4
LW
2059 }
2060 else {
79072805 2061 I32 n;
c2ab57d4 2062
a0d0e21e 2063 mbuf = SvPV(mstr, len);
463ee0b2 2064 if ((n = len) > msize)
c2ab57d4 2065 n = msize;
bee1dbe2 2066 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2067 if (n < msize)
bee1dbe2 2068 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2069 }
2070 return shmdt(shm);
e5d73d77 2071#else
cea2e8a9 2072 Perl_croak(aTHX_ "shm I/O not implemented");
e5d73d77 2073#endif
c2ab57d4
LW
2074}
2075
fe14fcc3 2076#endif /* SYSV IPC */
4e35701f 2077