This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Note that the all the fd flags are saved/restored.
[perl5.git] / doio.c
CommitLineData
a0d0e21e 1/* doio.c
a687059c 2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a687059c 5 *
6e21c824
LW
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
a687059c 8 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
12 * Far below them they saw the white waters pour into a foaming bowl, and
13 * then swirl darkly about a deep oval basin in the rocks, until they found
14 * their way out again through a narrow gate, and flowed away, fuming and
15 * chattering, into calmer and more level reaches.
16 *
17 * [p.684 of _The Lord of the Rings_, IV/vi: "The Forbidden Pool"]
a687059c
LW
18 */
19
166f8a29
DM
20/* This file contains functions that do the actual I/O on behalf of ops.
21 * For example, pp_print() calls the do_print() function in this file for
22 * each argument needing printing.
23 */
24
a687059c 25#include "EXTERN.h"
864dbfa3 26#define PERL_IN_DOIO_C
a687059c
LW
27#include "perl.h"
28
fe14fcc3 29#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
aec308ec 30#ifndef HAS_SEM
c2ab57d4 31#include <sys/ipc.h>
aec308ec 32#endif
fe14fcc3 33#ifdef HAS_MSG
c2ab57d4 34#include <sys/msg.h>
e5d73d77 35#endif
fe14fcc3 36#ifdef HAS_SHM
c2ab57d4 37#include <sys/shm.h>
a0d0e21e 38# ifndef HAS_SHMAT_PROTOTYPE
20ce7b12 39 extern Shmat_t shmat (int, char *, int);
a0d0e21e 40# endif
c2ab57d4 41#endif
e5d73d77 42#endif
c2ab57d4 43
663a0e37 44#ifdef I_UTIME
3730b96e 45# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1
PP
46# include <sys/utime.h>
47# else
48# include <utime.h>
49# endif
663a0e37 50#endif
85aff577 51
85aff577
CS
52#ifdef O_EXCL
53# define OPEN_EXCL O_EXCL
54#else
55# define OPEN_EXCL 0
56#endif
a687059c 57
0c19750d
SP
58#define PERL_MODE_MAX 8
59#define PERL_FLAGS_MAX 10
60
76121258 61#include <signal.h>
76121258 62
a2b41d5c
NC
63static IO *
64S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp,
65 int *savefd, char *savetype)
a567e93b 66{
eb578fdb 67 IO * const io = GvIOn(gv);
a687059c 68
a2b41d5c
NC
69 PERL_ARGS_ASSERT_OPENN_SETUP;
70
71 *saveifp = NULL;
72 *saveofp = NULL;
73 *savefd = -1;
74 *savetype = IoTYPE_CLOSED;
7918f24d 75
b931b1d9 76 Zero(mode,sizeof(mode),char);
3280af22 77 PL_forkprocess = 1; /* assume true if no fork */
c07a80fd 78
b931b1d9 79 /* If currently open - close before we re-open */
a0d0e21e 80 if (IoIFP(io)) {
ee518936
NIS
81 if (IoTYPE(io) == IoTYPE_STD) {
82 /* This is a clone of one of STD* handles */
ee518936 83 }
26297fe9
NC
84 else {
85 const int old_fd = PerlIO_fileno(IoIFP(io));
86
87 if (old_fd >= 0 && old_fd <= PL_maxsysfd) {
88 /* This is one of the original STD* handles */
a2b41d5c
NC
89 *saveifp = IoIFP(io);
90 *saveofp = IoOFP(io);
91 *savetype = IoTYPE(io);
92 *savefd = old_fd;
26297fe9
NC
93 }
94 else {
95 int result;
96
97 if (IoTYPE(io) == IoTYPE_PIPE)
98 result = PerlProc_pclose(IoIFP(io));
99 else if (IoIFP(io) != IoOFP(io)) {
100 if (IoOFP(io)) {
101 result = PerlIO_close(IoOFP(io));
102 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
103 }
104 else
105 result = PerlIO_close(IoIFP(io));
106 }
107 else
108 result = PerlIO_close(IoIFP(io));
109
110 if (result == EOF && old_fd > PL_maxsysfd) {
111 /* Why is this not Perl_warn*() call ? */
112 PerlIO_printf(Perl_error_log,
113 "Warning: unable to close filehandle %"HEKf" properly.\n",
114 HEKfARG(GvENAME_HEK(gv))
115 );
116 }
117 }
118 }
4608196e 119 IoOFP(io) = IoIFP(io) = NULL;
a687059c 120 }
a2b41d5c
NC
121 return io;
122}
123
124bool
125Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
126 int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
127 I32 num_svs)
128{
4b451737
NC
129 PERL_ARGS_ASSERT_DO_OPENN;
130
131 if (as_raw) {
132 /* sysopen style args, i.e. integer mode and permissions */
133
134 if (num_svs != 0) {
135 Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld",
136 (long) num_svs);
137 }
138 return do_open_raw(gv, oname, len, rawmode, rawperm);
139 }
140 return do_open6(gv, oname, len, supplied_fp, svp, num_svs);
141}
142
143bool
144Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len,
145 int rawmode, int rawperm)
146{
a2b41d5c
NC
147 PerlIO *saveifp;
148 PerlIO *saveofp;
149 int savefd;
150 char savetype;
151 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */
152 IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype);
153 int writing = 0;
154 PerlIO *fp;
a2b41d5c 155
4b451737 156 PERL_ARGS_ASSERT_DO_OPEN_RAW;
c07a80fd 157
4b451737
NC
158 /* For ease of blame back to 5.000, keep the existing indenting. */
159 {
b931b1d9 160 /* sysopen style args, i.e. integer mode and permissions */
ee518936 161 STRLEN ix = 0;
e1ec3a88 162 const int appendtrunc =
3dccc55c 163 0
d1da7611 164#ifdef O_APPEND /* Not fully portable. */
3dccc55c 165 |O_APPEND
d1da7611
JH
166#endif
167#ifdef O_TRUNC /* Not fully portable. */
3dccc55c 168 |O_TRUNC
d1da7611 169#endif
3dccc55c 170 ;
6867be6d 171 const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc;
3dccc55c 172 int ismodifying;
9229bf8d 173 SV *namesv;
3dccc55c 174
3dccc55c
JH
175 /* It's not always
176
177 O_RDONLY 0
178 O_WRONLY 1
179 O_RDWR 2
180
181 It might be (in OS/390 and Mac OS Classic it is)
182
183 O_WRONLY 1
184 O_RDONLY 2
185 O_RDWR 3
186
187 This means that simple & with O_RDWR would look
188 like O_RDONLY is present. Therefore we have to
189 be more careful.
190 */
191 if ((ismodifying = (rawmode & modifyingmode))) {
192 if ((ismodifying & O_WRONLY) == O_WRONLY ||
193 (ismodifying & O_RDWR) == O_RDWR ||
194 (ismodifying & (O_CREAT|appendtrunc)))
195 TAINT_PROPER("sysopen");
196 }
3b6c1aba 197 mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */
b931b1d9 198
09458382 199#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
b94c04ac 200 rawmode |= O_LARGEFILE; /* Transparently largefiley. */
5ff3f7a4
GS
201#endif
202
06c7082d 203 IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
ee518936 204
59cd0e26 205 namesv = newSVpvn_flags(oname, len, SVs_TEMP);
4b451737 206 fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv);
a687059c 207 }
4b451737
NC
208 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
209 savetype, writing, 0, NULL);
210}
211
212bool
213Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len,
214 PerlIO *supplied_fp, SV **svp, U32 num_svs)
215{
4b451737
NC
216 PerlIO *saveifp;
217 PerlIO *saveofp;
218 int savefd;
219 char savetype;
220 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */
221 IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype);
222 int writing = 0;
223 PerlIO *fp;
224 bool was_fdopen = FALSE;
225 char *type = NULL;
226
227 PERL_ARGS_ASSERT_DO_OPEN6;
228
229 /* For ease of blame back to 5.000, keep the existing indenting. */
230 {
b931b1d9 231 /* Regular (non-sys) open */
2fbb330f 232 char *name;
faecd977 233 STRLEN olen = len;
b931b1d9
NIS
234 char *tend;
235 int dodup = 0;
c564b489
NC
236 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
237
238 /* Collect default raw/crlf info from the op */
239 if (PL_op && PL_op->op_type == OP_OPEN) {
240 /* set up IO layers */
241 const U8 flags = PL_op->op_private;
242 in_raw = (flags & OPpOPEN_IN_RAW);
243 in_crlf = (flags & OPpOPEN_IN_CRLF);
244 out_raw = (flags & OPpOPEN_OUT_RAW);
245 out_crlf = (flags & OPpOPEN_OUT_CRLF);
246 }
c07a80fd 247
2fbb330f 248 type = savepvn(oname, len);
b931b1d9 249 tend = type+len;
faecd977 250 SAVEFREEPV(type);
eb649f83
AMS
251
252 /* Lose leading and trailing white space */
294b3b39
AL
253 while (isSPACE(*type))
254 type++;
eb649f83
AMS
255 while (tend > type && isSPACE(tend[-1]))
256 *--tend = '\0';
257
6170680b 258 if (num_svs) {
41188aa0
TC
259 const char *p;
260 STRLEN nlen = 0;
c2be40b1 261 /* New style explicit name, type is just mode and layer info */
9a869a14 262#ifdef USE_STDIO
2fbb330f 263 if (SvROK(*svp) && !strchr(oname,'&')) {
9a869a14
RGS
264 if (ckWARN(WARN_IO))
265 Perl_warner(aTHX_ packWARN(WARN_IO),
266 "Can't open a reference");
93189314 267 SETERRNO(EINVAL, LIB_INVARG);
a6fc70e5 268 fp = NULL;
9a869a14
RGS
269 goto say_false;
270 }
271#endif /* USE_STDIO */
41188aa0
TC
272 p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL;
273
a6fc70e5
NC
274 if (p && !IS_SAFE_PATHNAME(p, nlen, "open")) {
275 fp = NULL;
c8028aa6 276 goto say_false;
a6fc70e5 277 }
c8028aa6 278
41188aa0
TC
279 name = p ? savepvn(p, nlen) : savepvs("");
280
faecd977 281 SAVEFREEPV(name);
6170680b 282 }
faecd977 283 else {
faecd977 284 name = type;
b931b1d9 285 len = tend-type;
faecd977 286 }
6170680b 287 IoTYPE(io) = *type;
516a5887 288 if ((*type == IoTYPE_RDWR) && /* scary */
01a8ea99 289 (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) &&
516a5887 290 ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) {
c2be40b1 291 TAINT_PROPER("open");
6170680b 292 mode[1] = *type++;
c07a80fd 293 writing = 1;
a687059c 294 }
c07a80fd 295
9f37169a 296 if (*type == IoTYPE_PIPE) {
b931b1d9
NIS
297 if (num_svs) {
298 if (type[1] != IoTYPE_STD) {
c2be40b1 299 unknown_open_mode:
b931b1d9
NIS
300 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
301 }
302 type++;
6170680b 303 }
294b3b39
AL
304 do {
305 type++;
306 } while (isSPACE(*type));
faecd977 307 if (!num_svs) {
6170680b 308 name = type;
b931b1d9 309 len = tend-type;
faecd977 310 }
4a7d1889
NIS
311 if (*name == '\0') {
312 /* command is missing 19990114 */
06eaf0bc 313 if (ckWARN(WARN_PIPE))
9014280d 314 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
06eaf0bc 315 errno = EPIPE;
a6fc70e5 316 fp = NULL;
06eaf0bc
GS
317 goto say_false;
318 }
f27977c3 319 if (!(*name == '-' && name[1] == '\0') || num_svs)
c07a80fd
PP
320 TAINT_ENV();
321 TAINT_PROPER("piped open");
b931b1d9 322 if (!num_svs && name[len-1] == '|') {
faecd977 323 name[--len] = '\0' ;
599cee73 324 if (ckWARN(WARN_PIPE))
9014280d 325 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe");
7b8d334a 326 }
a1d180c4 327 mode[0] = 'w';
c07a80fd 328 writing = 1;
0c19750d 329 if (out_raw)
5686ee58 330 mode[1] = 'b';
0c19750d 331 else if (out_crlf)
5686ee58 332 mode[1] = 't';
4a7d1889
NIS
333 if (num_svs > 1) {
334 fp = PerlProc_popen_list(mode, num_svs, svp);
335 }
336 else {
337 fp = PerlProc_popen(name,mode);
338 }
1771866f
NIS
339 if (num_svs) {
340 if (*type) {
341 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
a6fc70e5 342 fp = NULL;
1771866f
NIS
343 goto say_false;
344 }
345 }
346 }
c2be40b1 347 } /* IoTYPE_PIPE */
9f37169a 348 else if (*type == IoTYPE_WRONLY) {
c07a80fd 349 TAINT_PROPER("open");
6170680b 350 type++;
9f37169a
JH
351 if (*type == IoTYPE_WRONLY) {
352 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
50952442 353 mode[0] = IoTYPE(io) = IoTYPE_APPEND;
6170680b 354 type++;
a0d0e21e 355 }
ee518936 356 else {
c07a80fd 357 mode[0] = 'w';
ee518936 358 }
c07a80fd
PP
359 writing = 1;
360
0c19750d 361 if (out_raw)
5686ee58 362 mode[1] = 'b';
0c19750d 363 else if (out_crlf)
5686ee58 364 mode[1] = 't';
6170680b 365 if (*type == '&') {
c07a80fd 366 duplicity:
ecdeb87c 367 dodup = PERLIO_DUP_FD;
e620cd72
NIS
368 type++;
369 if (*type == '=') {
c07a80fd 370 dodup = 0;
e620cd72 371 type++;
4a7d1889 372 }
ee518936 373 if (!num_svs && !*type && supplied_fp) {
4a7d1889 374 /* "<+&" etc. is used by typemaps */
c07a80fd 375 fp = supplied_fp;
ee518936 376 }
a0d0e21e 377 else {
35da51f7 378 PerlIO *that_fp = NULL;
b4464d55 379 int wanted_fd;
22ff3130 380 UV uv;
e620cd72 381 if (num_svs > 1) {
fe13d51d 382 /* diag_listed_as: More than one argument to '%s' open */
e620cd72
NIS
383 Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
384 }
294b3b39
AL
385 while (isSPACE(*type))
386 type++;
f90b7232
FC
387 if (num_svs && (
388 SvIOK(*svp)
389 || (SvPOKp(*svp) && looks_like_number(*svp))
390 )) {
b4464d55 391 wanted_fd = SvUV(*svp);
24a7a40d 392 num_svs = 0;
ee518936 393 }
22ff3130
HS
394 else if (isDIGIT(*type)
395 && grok_atoUV(type, &uv, NULL)
396 && uv <= INT_MAX
397 ) {
398 wanted_fd = (int)uv;
e620cd72 399 }
c07a80fd 400 else {
e1ec3a88 401 const IO* thatio;
e620cd72
NIS
402 if (num_svs) {
403 thatio = sv_2io(*svp);
404 }
405 else {
35da51f7 406 GV * const thatgv = gv_fetchpvn_flags(type, tend - type,
90e5519e 407 0, SVt_PVIO);
e620cd72
NIS
408 thatio = GvIO(thatgv);
409 }
c07a80fd 410 if (!thatio) {
6e21c824 411#ifdef EINVAL
93189314 412 SETERRNO(EINVAL,SS_IVCHAN);
6e21c824 413#endif
a6fc70e5 414 fp = NULL;
c07a80fd
PP
415 goto say_false;
416 }
f4e789af 417 if ((that_fp = IoIFP(thatio))) {
7211d486
JH
418 /* Flush stdio buffer before dup. --mjd
419 * Unfortunately SEEK_CURing 0 seems to
420 * be optimized away on most platforms;
421 * only Solaris and Linux seem to flush
422 * on that. --jhi */
7211d486
JH
423 /* On the other hand, do all platforms
424 * take gracefully to flushing a read-only
425 * filehandle? Perhaps we should do
426 * fsetpos(src)+fgetpos(dst)? --nik */
ecdeb87c 427 PerlIO_flush(that_fp);
b4464d55 428 wanted_fd = PerlIO_fileno(that_fp);
0759c907
JH
429 /* When dup()ing STDIN, STDOUT or STDERR
430 * explicitly set appropriate access mode */
f4e789af
NC
431 if (that_fp == PerlIO_stdout()
432 || that_fp == PerlIO_stderr())
0759c907 433 IoTYPE(io) = IoTYPE_WRONLY;
f4e789af 434 else if (that_fp == PerlIO_stdin())
0759c907
JH
435 IoTYPE(io) = IoTYPE_RDONLY;
436 /* When dup()ing a socket, say result is
437 * one as well */
438 else if (IoTYPE(thatio) == IoTYPE_SOCKET)
50952442 439 IoTYPE(io) = IoTYPE_SOCKET;
c07a80fd 440 }
0c9375a5
TC
441 else {
442 SETERRNO(EBADF, RMS_IFI);
443 fp = NULL;
444 goto say_false;
445 }
a0d0e21e 446 }
ee518936 447 if (!num_svs)
bd61b366 448 type = NULL;
ecdeb87c
NIS
449 if (that_fp) {
450 fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
451 }
452 else {
c07a80fd 453 if (dodup)
b4464d55 454 wanted_fd = PerlLIO_dup(wanted_fd);
ecdeb87c
NIS
455 else
456 was_fdopen = TRUE;
b4464d55
NC
457 if (!(fp = PerlIO_openn(aTHX_ type,mode,wanted_fd,0,0,NULL,num_svs,svp))) {
458 if (dodup && wanted_fd >= 0)
459 PerlLIO_close(wanted_fd);
ecdeb87c 460 }
faecd977 461 }
c07a80fd 462 }
ee518936 463 } /* & */
c07a80fd 464 else {
294b3b39
AL
465 while (isSPACE(*type))
466 type++;
b931b1d9 467 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
b931b1d9 468 type++;
760ac839 469 fp = PerlIO_stdout();
50952442 470 IoTYPE(io) = IoTYPE_STD;
7cf31beb 471 if (num_svs > 1) {
fe13d51d 472 /* diag_listed_as: More than one argument to '%s' open */
7cf31beb
NIS
473 Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
474 }
c07a80fd
PP
475 }
476 else {
9229bf8d
NC
477 if (num_svs) {
478 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
479 }
480 else {
481 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
bd61b366 482 type = NULL;
9229bf8d 483 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
ee518936 484 }
c07a80fd 485 }
ee518936 486 } /* !& */
7e72d509
JH
487 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
488 goto unknown_open_mode;
c2be40b1 489 } /* IoTYPE_WRONLY */
9f37169a 490 else if (*type == IoTYPE_RDONLY) {
294b3b39
AL
491 do {
492 type++;
493 } while (isSPACE(*type));
bf38876a 494 mode[0] = 'r';
0c19750d 495 if (in_raw)
5686ee58 496 mode[1] = 'b';
0c19750d 497 else if (in_crlf)
5686ee58 498 mode[1] = 't';
6170680b 499 if (*type == '&') {
bf38876a 500 goto duplicity;
6170680b 501 }
b931b1d9 502 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
b931b1d9 503 type++;
760ac839 504 fp = PerlIO_stdin();
50952442 505 IoTYPE(io) = IoTYPE_STD;
7cf31beb 506 if (num_svs > 1) {
fe13d51d 507 /* diag_listed_as: More than one argument to '%s' open */
7cf31beb
NIS
508 Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
509 }
a687059c 510 }
ee518936 511 else {
9229bf8d
NC
512 if (num_svs) {
513 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
514 }
515 else {
516 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
bd61b366 517 type = NULL;
9229bf8d 518 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
ee518936 519 }
ee518936 520 }
7e72d509
JH
521 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
522 goto unknown_open_mode;
c2be40b1
JH
523 } /* IoTYPE_RDONLY */
524 else if ((num_svs && /* '-|...' or '...|' */
525 type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
b931b1d9 526 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
6170680b 527 if (num_svs) {
b931b1d9 528 type += 2; /* skip over '-|' */
6170680b
IZ
529 }
530 else {
b931b1d9
NIS
531 *--tend = '\0';
532 while (tend > type && isSPACE(tend[-1]))
533 *--tend = '\0';
a6e20a40
AL
534 for (; isSPACE(*type); type++)
535 ;
6170680b 536 name = type;
b931b1d9 537 len = tend-type;
6170680b 538 }
4a7d1889
NIS
539 if (*name == '\0') {
540 /* command is missing 19990114 */
06eaf0bc 541 if (ckWARN(WARN_PIPE))
9014280d 542 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
06eaf0bc 543 errno = EPIPE;
a6fc70e5 544 fp = NULL;
06eaf0bc
GS
545 goto say_false;
546 }
770526c1 547 if (!(*name == '-' && name[1] == '\0') || num_svs)
79072805
LW
548 TAINT_ENV();
549 TAINT_PROPER("piped open");
a1d180c4 550 mode[0] = 'r';
0c19750d 551
0c19750d 552 if (in_raw)
5686ee58 553 mode[1] = 'b';
0c19750d 554 else if (in_crlf)
5686ee58 555 mode[1] = 't';
0c19750d 556
4a7d1889
NIS
557 if (num_svs > 1) {
558 fp = PerlProc_popen_list(mode,num_svs,svp);
559 }
e620cd72 560 else {
4a7d1889
NIS
561 fp = PerlProc_popen(name,mode);
562 }
50952442 563 IoTYPE(io) = IoTYPE_PIPE;
1771866f 564 if (num_svs) {
294b3b39
AL
565 while (isSPACE(*type))
566 type++;
1771866f
NIS
567 if (*type) {
568 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
a6fc70e5 569 fp = NULL;
1771866f
NIS
570 goto say_false;
571 }
572 }
573 }
a687059c 574 }
c2be40b1 575 else { /* layer(Args) */
6170680b 576 if (num_svs)
c2be40b1 577 goto unknown_open_mode;
6170680b 578 name = type;
50952442 579 IoTYPE(io) = IoTYPE_RDONLY;
a6e20a40
AL
580 for (; isSPACE(*name); name++)
581 ;
88b61e10 582 mode[0] = 'r';
0c19750d 583
0c19750d 584 if (in_raw)
5686ee58 585 mode[1] = 'b';
0c19750d 586 else if (in_crlf)
5686ee58 587 mode[1] = 't';
0c19750d 588
770526c1 589 if (*name == '-' && name[1] == '\0') {
760ac839 590 fp = PerlIO_stdin();
50952442 591 IoTYPE(io) = IoTYPE_STD;
a687059c 592 }
16fe6d59 593 else {
9229bf8d
NC
594 if (num_svs) {
595 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
596 }
597 else {
598 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
bd61b366 599 type = NULL;
9229bf8d 600 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
ee518936 601 }
16fe6d59 602 }
a687059c
LW
603 }
604 }
a6fc70e5
NC
605
606 say_false:
607 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
608 savetype, writing, was_fdopen, type);
609}
610
611/* Yes, this is ugly, but it's private, and I don't see a cleaner way to
612 simplify the two-headed public interface of do_openn. */
613static bool
614S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
615 PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype,
616 int writing, bool was_fdopen, const char *type)
617{
618 int fd;
619
620 PERL_ARGS_ASSERT_OPENN_CLEANUP;
621
bee1dbe2 622 if (!fp) {
ce44635a 623 if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE)
7cb3f959 624 && should_warn_nl(oname)
ce44635a 625
041457d9 626 )
5d37acd6
DM
627 {
628 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 629 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
5d37acd6
DM
630 GCC_DIAG_RESTORE;
631 }
6e21c824 632 goto say_false;
bee1dbe2 633 }
a00b5bd3
NIS
634
635 if (ckWARN(WARN_IO)) {
636 if ((IoTYPE(io) == IoTYPE_RDONLY) &&
637 (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
9014280d 638 Perl_warner(aTHX_ packWARN(WARN_IO),
d0c0e7dd
FC
639 "Filehandle STD%s reopened as %"HEKf
640 " only for input",
97828cef 641 ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
d0c0e7dd 642 HEKfARG(GvENAME_HEK(gv)));
a00b5bd3 643 }
ee518936 644 else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
9014280d 645 Perl_warner(aTHX_ packWARN(WARN_IO),
d0c0e7dd
FC
646 "Filehandle STDIN reopened as %"HEKf" only for output",
647 HEKfARG(GvENAME_HEK(gv))
648 );
a00b5bd3
NIS
649 }
650 }
651
e99cca91 652 fd = PerlIO_fileno(fp);
375ed12a
JH
653 /* Do NOT do: "if (fd < 0) goto say_false;" here. If there is no
654 * fd assume it isn't a socket - this covers PerlIO::scalar -
655 * otherwise unless we "know" the type probe for socket-ness.
e99cca91
NIS
656 */
657 if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
658 if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
659 /* If PerlIO claims to have fd we had better be able to fstat() it. */
660 (void) PerlIO_close(fp);
6e21c824 661 goto say_false;
a687059c 662 }
7114a2d2 663#ifndef PERL_MICRO
3280af22 664 if (S_ISSOCK(PL_statbuf.st_mode))
50952442 665 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
99b89507
LW
666#ifdef HAS_SOCKET
667 else if (
3280af22 668 !(PL_statbuf.st_mode & S_IFMT)
0759c907
JH
669 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */
670 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */
671 ) { /* on OS's that return 0 on fstat()ed pipe */
e99cca91
NIS
672 char tmpbuf[256];
673 Sock_size_t buflen = sizeof tmpbuf;
674 if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
675 || errno != ENOTSOCK)
676 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
677 /* but some return 0 for streams too, sigh */
99b89507 678 }
e99cca91 679#endif /* HAS_SOCKET */
7114a2d2 680#endif /* !PERL_MICRO */
a687059c 681 }
e99cca91
NIS
682
683 /* Eeek - FIXME !!!
684 * If this is a standard handle we discard all the layer stuff
685 * and just dup the fd into whatever was on the handle before !
686 */
687
6e21c824 688 if (saveifp) { /* must use old fp? */
f5b9d040 689 /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
24c23ab4 690 then dup the new fileno down
f5b9d040 691 */
6e21c824 692 if (saveofp) {
f5b9d040 693 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
6e21c824 694 if (saveofp != saveifp) { /* was a socket? */
760ac839 695 PerlIO_close(saveofp);
6e21c824
LW
696 }
697 }
6e60e805 698 if (savefd != fd) {
e934609f 699 /* Still a small can-of-worms here if (say) PerlIO::scalar
ecdeb87c
NIS
700 is assigned to (say) STDOUT - for now let dup2() fail
701 and provide the error
702 */
375ed12a
JH
703 if (fd < 0) {
704 SETERRNO(EBADF,RMS_IFI);
705 goto say_false;
706 } else if (PerlLIO_dup2(fd, savefd) < 0) {
bd4a5668
NIS
707 (void)PerlIO_close(fp);
708 goto say_false;
709 }
d082dcd6 710#ifdef VMS
6e60e805 711 if (savefd != PerlIO_fileno(PerlIO_stdin())) {
d0e2cf63
AMS
712 char newname[FILENAME_MAX+1];
713 if (PerlIO_getname(fp, newname)) {
714 if (fd == PerlIO_fileno(PerlIO_stdout()))
0db50132 715 vmssetuserlnm("SYS$OUTPUT", newname);
d0e2cf63 716 if (fd == PerlIO_fileno(PerlIO_stderr()))
0db50132 717 vmssetuserlnm("SYS$ERROR", newname);
d0e2cf63 718 }
d082dcd6
JH
719 }
720#endif
d0e2cf63
AMS
721
722#if !defined(WIN32)
723 /* PL_fdpid isn't used on Windows, so avoid this useless work.
724 * XXX Probably the same for a lot of other places. */
725 {
726 Pid_t pid;
727 SV *sv;
728
d0e2cf63 729 sv = *av_fetch(PL_fdpid,fd,TRUE);
862a34c6 730 SvUPGRADE(sv, SVt_IV);
d0e2cf63 731 pid = SvIVX(sv);
45977657 732 SvIV_set(sv, 0);
d0e2cf63 733 sv = *av_fetch(PL_fdpid,savefd,TRUE);
862a34c6 734 SvUPGRADE(sv, SVt_IV);
45977657 735 SvIV_set(sv, pid);
d0e2cf63
AMS
736 }
737#endif
738
e212fc47
AMS
739 if (was_fdopen) {
740 /* need to close fp without closing underlying fd */
741 int ofd = PerlIO_fileno(fp);
375ed12a 742 int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
03e631df 743#if defined(HAS_FCNTL) && defined(F_SETFD)
5798d631
JH
744 /* Assume if we have F_SETFD we have F_GETFD. */
745 /* Get a copy of all the fd flags. */
746 int fd_flags = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
747 if (fd_flags < 0) {
375ed12a
JH
748 if (dupfd >= 0)
749 PerlLIO_close(dupfd);
750 goto say_false;
751 }
03e631df 752#endif
375ed12a
JH
753 if (ofd < 0 || dupfd < 0) {
754 if (dupfd >= 0)
755 PerlLIO_close(dupfd);
756 goto say_false;
757 }
e212fc47 758 PerlIO_close(fp);
375ed12a 759 PerlLIO_dup2(dupfd, ofd);
03e631df 760#if defined(HAS_FCNTL) && defined(F_SETFD)
5798d631
JH
761 /* The dup trick has lost close-on-exec on ofd,
762 * and possibly any other flags, so restore them. */
763 fcntl(ofd,F_SETFD, fd_flags);
03e631df 764#endif
e212fc47 765 PerlLIO_close(dupfd);
ecdeb87c 766 }
e212fc47
AMS
767 else
768 PerlIO_close(fp);
6e21c824
LW
769 }
770 fp = saveifp;
760ac839 771 PerlIO_clearerr(fp);
e99cca91 772 fd = PerlIO_fileno(fp);
6e21c824 773 }
a0d0e21e 774#if defined(HAS_FCNTL) && defined(F_SETFD)
e99cca91 775 if (fd >= 0) {
375ed12a
JH
776 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) {
777 PerlLIO_close(fd);
778 goto say_false;
779 }
a8710ca1 780 }
1462b684 781#endif
8990e307 782 IoIFP(io) = fp;
b931b1d9 783
684bef36 784 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 785 if (writing) {
50952442 786 if (IoTYPE(io) == IoTYPE_SOCKET
e99cca91 787 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
a33cf58c 788 char *s = mode;
3b6c1aba
JH
789 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
790 s++;
a33cf58c 791 *s = 'w';
7c491510 792 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
760ac839 793 PerlIO_close(fp);
6e21c824 794 goto say_false;
fe14fcc3 795 }
1462b684
LW
796 }
797 else
8990e307 798 IoOFP(io) = fp;
bf38876a 799 }
a687059c 800 return TRUE;
6e21c824 801
7b52d656 802 say_false:
8990e307
LW
803 IoIFP(io) = saveifp;
804 IoOFP(io) = saveofp;
805 IoTYPE(io) = savetype;
6e21c824 806 return FALSE;
a687059c
LW
807}
808
760ac839 809PerlIO *
157fb5a1 810Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
a687059c 811{
2d03de9c 812 IO * const io = GvIOp(gv);
fe14fcc3 813
7918f24d
NC
814 PERL_ARGS_ASSERT_NEXTARGV;
815
3280af22 816 if (!PL_argvoutgv)
fafc274c 817 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
5513c2cf 818 if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
18708f5a 819 IoFLAGS(io) &= ~IOf_START;
7a1c5554 820 if (PL_inplace) {
294b3b39 821 assert(PL_defoutgv);
29a861e7
NC
822 Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
823 SvREFCNT_inc_simple_NN(PL_defoutgv));
7a1c5554 824 }
18708f5a 825 }
3280af22
NIS
826 if (PL_filemode & (S_ISUID|S_ISGID)) {
827 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
fe14fcc3 828#ifdef HAS_FCHMOD
c797f2d8
DM
829 if (PL_lastfd != -1)
830 (void)fchmod(PL_lastfd,PL_filemode);
fe14fcc3 831#else
b28d0864 832 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
fe14fcc3
LW
833#endif
834 }
c797f2d8 835 PL_lastfd = -1;
3280af22 836 PL_filemode = 0;
5c501b37 837 if (!GvAV(gv))
4608196e 838 return NULL;
b9f2b683 839 while (av_tindex(GvAV(gv)) >= 0) {
85aff577 840 STRLEN oldlen;
1fa0529f 841 SV *const sv = av_shift(GvAV(gv));
8990e307 842 SAVEFREESV(sv);
4bac9ae4 843 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
e203899d 844 sv_setsv(GvSVn(gv),sv);
79072805 845 SvSETMAGIC(GvSV(gv));
3280af22 846 PL_oldname = SvPVx(GvSV(gv), oldlen);
d8015975 847 if (LIKELY(!PL_inplace)) {
157fb5a1
RGS
848 if (nomagicopen
849 ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)
850 : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)
851 ) {
d8015975
NC
852 return IoIFP(GvIOp(gv));
853 }
854 }
855 else {
856 /* This very long block ends with return IoIFP(GvIOp(gv));
857 Both this block and the block above fall through on open
858 failure to the warning code, and then the while loop above tries
859 the next entry. */
860 if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0)) {
1fa0529f
NC
861#ifndef FLEXFILENAMES
862 int filedev;
863 int fileino;
864#endif
865 Uid_t fileuid;
866 Gid_t filegid;
867
79072805 868 TAINT_PROPER("inplace open");
3280af22 869 if (oldlen == 1 && *PL_oldname == '-') {
fafc274c
NC
870 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
871 SVt_PVIO));
a0d0e21e 872 return IoIFP(GvIOp(gv));
c623bd54 873 }
99b89507 874#ifndef FLEXFILENAMES
b28d0864
NIS
875 filedev = PL_statbuf.st_dev;
876 fileino = PL_statbuf.st_ino;
99b89507 877#endif
3280af22
NIS
878 PL_filemode = PL_statbuf.st_mode;
879 fileuid = PL_statbuf.st_uid;
880 filegid = PL_statbuf.st_gid;
881 if (!S_ISREG(PL_filemode)) {
9b387841
NC
882 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
883 "Can't do inplace edit: %s is not a regular file",
884 PL_oldname );
79072805 885 do_close(gv,FALSE);
c623bd54
LW
886 continue;
887 }
c9930541 888 if (*PL_inplace && strNE(PL_inplace, "*")) {
2d03de9c 889 const char *star = strchr(PL_inplace, '*');
2d259d92 890 if (star) {
2d03de9c 891 const char *begin = PL_inplace;
76f68e9b 892 sv_setpvs(sv, "");
2d259d92
CK
893 do {
894 sv_catpvn(sv, begin, star - begin);
3280af22 895 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK
896 begin = ++star;
897 } while ((star = strchr(begin, '*')));
3d66d7bb
GS
898 if (*begin)
899 sv_catpv(sv,begin);
2d259d92
CK
900 }
901 else {
3280af22 902 sv_catpv(sv,PL_inplace);
2d259d92 903 }
c623bd54 904#ifndef FLEXFILENAMES
95a20fc0 905 if ((PerlLIO_stat(SvPVX_const(sv),&PL_statbuf) >= 0
5f74f29c
JH
906 && PL_statbuf.st_dev == filedev
907 && PL_statbuf.st_ino == fileino)
39e571d4 908#ifdef DJGPP
5f74f29c 909 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
39e571d4 910#endif
f248d071
GS
911 )
912 {
9b387841
NC
913 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
914 "Can't do inplace edit: %"SVf" would not be unique",
915 SVfARG(sv));
79072805 916 do_close(gv,FALSE);
c623bd54
LW
917 continue;
918 }
919#endif
fe14fcc3 920#ifdef HAS_RENAME
739a0b84 921#if !defined(DOSISH) && !defined(__CYGWIN__)
95a20fc0 922 if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
9b387841
NC
923 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
924 "Can't rename %s to %"SVf": %s, skipping file",
925 PL_oldname, SVfARG(sv), Strerror(errno));
79072805 926 do_close(gv,FALSE);
c623bd54
LW
927 continue;
928 }
a687059c 929#else
79072805 930 do_close(gv,FALSE);
95a20fc0
SP
931 (void)PerlLIO_unlink(SvPVX_const(sv));
932 (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv));
d5eb9a46 933 do_open_raw(gv, SvPVX_const(sv), SvCUR(sv), O_RDONLY, 0);
55497cff 934#endif /* DOSISH */
ff8e2863 935#else
95a20fc0
SP
936 (void)UNLINK(SvPVX_const(sv));
937 if (link(PL_oldname,SvPVX_const(sv)) < 0) {
9b387841
NC
938 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
939 "Can't rename %s to %"SVf": %s, skipping file",
940 PL_oldname, SVfARG(sv), Strerror(errno) );
79072805 941 do_close(gv,FALSE);
c623bd54
LW
942 continue;
943 }
b28d0864 944 (void)UNLINK(PL_oldname);
a687059c
LW
945#endif
946 }
947 else {
c030f24b 948#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 949# ifndef VMS /* Don't delete; use automatic file versioning */
3280af22 950 if (UNLINK(PL_oldname) < 0) {
9b387841
NC
951 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
952 "Can't remove %s: %s, skipping file",
953 PL_oldname, Strerror(errno) );
79072805 954 do_close(gv,FALSE);
fe14fcc3
LW
955 continue;
956 }
edc7bc49 957# endif
ff8e2863 958#else
cea2e8a9 959 Perl_croak(aTHX_ "Can't do inplace edit without backup");
ff8e2863 960#endif
a687059c
LW
961 }
962
30fc4309 963 sv_setpvn(sv,PL_oldname,oldlen);
748a9306 964 SETERRNO(0,0); /* in case sprintf set errno */
d5eb9a46
NC
965 if (!Perl_do_open_raw(aTHX_ PL_argvoutgv, SvPVX_const(sv),
966 SvCUR(sv),
4119ab01 967#ifdef VMS
d5eb9a46 968 O_WRONLY|O_CREAT|O_TRUNC, 0
4119ab01 969#else
d5eb9a46 970 O_WRONLY|O_CREAT|OPEN_EXCL, 0600
4119ab01 971#endif
d5eb9a46 972 )) {
9b387841
NC
973 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
974 PL_oldname, Strerror(errno) );
79072805 975 do_close(gv,FALSE);
fe14fcc3
LW
976 continue;
977 }
3280af22
NIS
978 setdefout(PL_argvoutgv);
979 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
375ed12a
JH
980 if (PL_lastfd >= 0) {
981 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
fe14fcc3 982#ifdef HAS_FCHMOD
375ed12a 983 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 984#else
375ed12a 985 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
a687059c 986#endif
375ed12a 987 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
b469f1e0 988 /* XXX silently ignore failures */
fe14fcc3 989#ifdef HAS_FCHOWN
b469f1e0 990 PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
a687059c 991#else
fe14fcc3 992#ifdef HAS_CHOWN
b469f1e0 993 PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid));
a687059c 994#endif
b1248f16 995#endif
375ed12a 996 }
fe14fcc3 997 }
d8015975 998 return IoIFP(GvIOp(gv));
a687059c 999 }
d8015975
NC
1000 } /* successful do_open_raw(), PL_inplace non-NULL */
1001
1002 if (ckWARN_d(WARN_INPLACE)) {
1003 const int eno = errno;
1004 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
1005 && !S_ISREG(PL_statbuf.st_mode)) {
1006 Perl_warner(aTHX_ packWARN(WARN_INPLACE),
1007 "Can't do inplace edit: %s is not a regular file",
1008 PL_oldname);
1009 }
1010 else {
1011 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
1012 PL_oldname, Strerror(eno));
1013 }
4d61ec05 1014 }
a687059c 1015 }
18708f5a
GS
1016 if (io && (IoFLAGS(io) & IOf_ARGV))
1017 IoFLAGS(io) |= IOf_START;
3280af22
NIS
1018 if (PL_inplace) {
1019 (void)do_close(PL_argvoutgv,FALSE);
7a1c5554
GS
1020 if (io && (IoFLAGS(io) & IOf_ARGV)
1021 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
1022 {
159b6efe 1023 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
18708f5a 1024 setdefout(oldout);
8e217d4a 1025 SvREFCNT_dec_NN(oldout);
4608196e 1026 return NULL;
18708f5a 1027 }
fafc274c 1028 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
a687059c 1029 }
4608196e 1030 return NULL;
a687059c
LW
1031}
1032
517844ec 1033/* explicit renamed to avoid C++ conflict -- kja */
a687059c 1034bool
864dbfa3 1035Perl_do_close(pTHX_ GV *gv, bool not_implicit)
a687059c 1036{
1193dd27
IZ
1037 bool retval;
1038 IO *io;
a687059c 1039
79072805 1040 if (!gv)
3280af22 1041 gv = PL_argvgv;
6e592b3a 1042 if (!gv || !isGV_with_GP(gv)) {
1d2dff63 1043 if (not_implicit)
93189314 1044 SETERRNO(EBADF,SS_IVCHAN);
c2ab57d4 1045 return FALSE;
99b89507 1046 }
79072805
LW
1047 io = GvIO(gv);
1048 if (!io) { /* never opened */
1d2dff63 1049 if (not_implicit) {
51087808 1050 report_evil_fh(gv);
93189314 1051 SETERRNO(EBADF,SS_IVCHAN);
1d2dff63 1052 }
a687059c
LW
1053 return FALSE;
1054 }
96d7c888 1055 retval = io_close(io, NULL, not_implicit, FALSE);
517844ec 1056 if (not_implicit) {
1193dd27
IZ
1057 IoLINES(io) = 0;
1058 IoPAGE(io) = 0;
1059 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1060 }
50952442 1061 IoTYPE(io) = IoTYPE_CLOSED;
1193dd27
IZ
1062 return retval;
1063}
1064
1065bool
96d7c888 1066Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
1193dd27
IZ
1067{
1068 bool retval = FALSE;
1193dd27 1069
7918f24d
NC
1070 PERL_ARGS_ASSERT_IO_CLOSE;
1071
8990e307 1072 if (IoIFP(io)) {
50952442 1073 if (IoTYPE(io) == IoTYPE_PIPE) {
4373e329 1074 const int status = PerlProc_pclose(IoIFP(io));
f2b5be74 1075 if (not_implicit) {
37038d91 1076 STATUS_NATIVE_CHILD_SET(status);
e5218da5 1077 retval = (STATUS_UNIX == 0);
f2b5be74
GS
1078 }
1079 else {
1080 retval = (status != -1);
1081 }
a687059c 1082 }
50952442 1083 else if (IoTYPE(io) == IoTYPE_STD)
a687059c
LW
1084 retval = TRUE;
1085 else {
8990e307 1086 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
0bcc34c2 1087 const bool prev_err = PerlIO_error(IoOFP(io));
f4725fad
FC
1088#ifdef USE_PERLIO
1089 if (prev_err)
1090 PerlIO_restore_errno(IoOFP(io));
1091#endif
e199e3be 1092 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
760ac839 1093 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4 1094 }
e199e3be 1095 else {
0bcc34c2 1096 const bool prev_err = PerlIO_error(IoIFP(io));
f4725fad
FC
1097#ifdef USE_PERLIO
1098 if (prev_err)
1099 PerlIO_restore_errno(IoIFP(io));
1100#endif
e199e3be
RGS
1101 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1102 }
a687059c 1103 }
4608196e 1104 IoOFP(io) = IoIFP(io) = NULL;
96d7c888
FC
1105
1106 if (warn_on_fail && !retval) {
1107 if (gv)
1108 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1109 "Warning: unable to close filehandle %"
1110 HEKf" properly: %"SVf,
ac892e4a
DM
1111 HEKfARG(GvNAME_HEK(gv)),
1112 SVfARG(get_sv("!",GV_ADD)));
96d7c888
FC
1113 else
1114 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1115 "Warning: unable to close filehandle "
1116 "properly: %"SVf,
ac892e4a 1117 SVfARG(get_sv("!",GV_ADD)));
96d7c888 1118 }
79072805 1119 }
f2b5be74 1120 else if (not_implicit) {
93189314 1121 SETERRNO(EBADF,SS_IVCHAN);
20408e3c 1122 }
1193dd27 1123
a687059c
LW
1124 return retval;
1125}
1126
1127bool
864dbfa3 1128Perl_do_eof(pTHX_ GV *gv)
a687059c 1129{
eb578fdb 1130 IO * const io = GvIO(gv);
a687059c 1131
7918f24d
NC
1132 PERL_ARGS_ASSERT_DO_EOF;
1133
79072805 1134 if (!io)
a687059c 1135 return TRUE;
7716c5c5 1136 else if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1137 report_wrongway_fh(gv, '>');
a687059c 1138
8990e307 1139 while (IoIFP(io)) {
760ac839 1140 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
a20bf0c3 1141 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
760ac839
LW
1142 return FALSE; /* this is the most usual case */
1143 }
a687059c 1144
79852593
NC
1145 {
1146 /* getc and ungetc can stomp on errno */
4ee39169 1147 dSAVE_ERRNO;
79852593
NC
1148 const int ch = PerlIO_getc(IoIFP(io));
1149 if (ch != EOF) {
1150 (void)PerlIO_ungetc(IoIFP(io),ch);
4ee39169 1151 RESTORE_ERRNO;
79852593
NC
1152 return FALSE;
1153 }
4ee39169 1154 RESTORE_ERRNO;
a687059c 1155 }
fab3f3a7 1156
760ac839 1157 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
a20bf0c3
JH
1158 if (PerlIO_get_cnt(IoIFP(io)) < -1)
1159 PerlIO_set_cnt(IoIFP(io),-1);
760ac839 1160 }
533c011a 1161 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
157fb5a1 1162 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */
a687059c
LW
1163 return TRUE;
1164 }
1165 else
1166 return TRUE; /* normal fp, definitely end of file */
1167 }
1168 return TRUE;
1169}
1170
5ff3f7a4 1171Off_t
864dbfa3 1172Perl_do_tell(pTHX_ GV *gv)
a687059c 1173{
9c9f25b8 1174 IO *const io = GvIO(gv);
eb578fdb 1175 PerlIO *fp;
a687059c 1176
7918f24d
NC
1177 PERL_ARGS_ASSERT_DO_TELL;
1178
9c9f25b8 1179 if (io && (fp = IoIFP(io))) {
8903cb82 1180 return PerlIO_tell(fp);
96e4d5b1 1181 }
51087808 1182 report_evil_fh(gv);
93189314 1183 SETERRNO(EBADF,RMS_IFI);
5ff3f7a4 1184 return (Off_t)-1;
a687059c
LW
1185}
1186
1187bool
864dbfa3 1188Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 1189{
9c9f25b8 1190 IO *const io = GvIO(gv);
eb578fdb 1191 PerlIO *fp;
a687059c 1192
9c9f25b8 1193 if (io && (fp = IoIFP(io))) {
8903cb82 1194 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 1195 }
51087808 1196 report_evil_fh(gv);
93189314 1197 SETERRNO(EBADF,RMS_IFI);
a687059c
LW
1198 return FALSE;
1199}
1200
97cc44eb 1201Off_t
864dbfa3 1202Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82 1203{
9c9f25b8 1204 IO *const io = GvIO(gv);
eb578fdb 1205 PerlIO *fp;
8903cb82 1206
7918f24d
NC
1207 PERL_ARGS_ASSERT_DO_SYSSEEK;
1208
375ed12a
JH
1209 if (io && (fp = IoIFP(io))) {
1210 int fd = PerlIO_fileno(fp);
07bd88da
JH
1211 if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
1212 SETERRNO(EINVAL,LIB_INVARG);
1213 return -1;
1214 } else {
375ed12a
JH
1215 return PerlLIO_lseek(fd, pos, whence);
1216 }
1217 }
51087808 1218 report_evil_fh(gv);
93189314 1219 SETERRNO(EBADF,RMS_IFI);
d9b3e12d 1220 return (Off_t)-1;
8903cb82
PP
1221}
1222
6ff81951 1223int
a79b25b7 1224Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
16fe6d59
GS
1225{
1226 int mode = O_BINARY;
81611534 1227 PERL_UNUSED_CONTEXT;
a79b25b7 1228 if (s) {
16fe6d59
GS
1229 while (*s) {
1230 if (*s == ':') {
1231 switch (s[1]) {
1232 case 'r':
e963d6d2 1233 if (s[2] == 'a' && s[3] == 'w'
16fe6d59
GS
1234 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1235 {
1236 mode = O_BINARY;
1237 s += 4;
1238 len -= 4;
1239 break;
1240 }
924ba076 1241 /* FALLTHROUGH */
16fe6d59 1242 case 'c':
e963d6d2 1243 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
16fe6d59
GS
1244 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1245 {
1246 mode = O_TEXT;
1247 s += 5;
1248 len -= 5;
1249 break;
1250 }
924ba076 1251 /* FALLTHROUGH */
16fe6d59
GS
1252 default:
1253 goto fail_discipline;
1254 }
1255 }
1256 else if (isSPACE(*s)) {
1257 ++s;
1258 --len;
1259 }
1260 else {
4373e329 1261 const char *end;
7b52d656 1262 fail_discipline:
16fe6d59
GS
1263 end = strchr(s+1, ':');
1264 if (!end)
1265 end = s+len;
60382766 1266#ifndef PERLIO_LAYERS
363c40c4 1267 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
60382766 1268#else
18a33fb5 1269 len -= end-s;
60382766
NIS
1270 s = end;
1271#endif
16fe6d59
GS
1272 }
1273 }
1274 }
1275 return mode;
1276}
1277
58e24eff 1278#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
27da23d5
JH
1279I32
1280my_chsize(int fd, Off_t length)
6eb13c3b 1281{
58e24eff
SH
1282#ifdef F_FREESP
1283 /* code courtesy of William Kucharski */
1284#define HAS_CHSIZE
1285
c623ac67 1286 Stat_t filebuf;
6eb13c3b 1287
3028581b 1288 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
1289 return -1;
1290
1291 if (filebuf.st_size < length) {
1292
1293 /* extend file length */
1294
3028581b 1295 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
1296 return -1;
1297
1298 /* write a "0" byte */
1299
3028581b 1300 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
1301 return -1;
1302 }
1303 else {
1304 /* truncate length */
35da51f7 1305 struct flock fl;
6eb13c3b
LW
1306 fl.l_whence = 0;
1307 fl.l_len = 0;
1308 fl.l_start = length;
a0d0e21e 1309 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
1310
1311 /*
a0d0e21e 1312 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
1313 * fcntl(2), which truncates the file so that it ends at the
1314 * position indicated by fl.l_start.
1315 *
1316 * Will minor miracles never cease?
1317 */
1318
a0d0e21e 1319 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
1320 return -1;
1321
1322 }
6eb13c3b 1323 return 0;
58e24eff 1324#else
27da23d5 1325 Perl_croak_nocontext("truncate not implemented");
a0d0e21e 1326#endif /* F_FREESP */
27da23d5 1327 return -1;
58e24eff
SH
1328}
1329#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
ff8e2863 1330
a687059c 1331bool
5aaab254 1332Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
a687059c 1333{
7918f24d
NC
1334 PERL_ARGS_ASSERT_DO_PRINT;
1335
79072805
LW
1336 /* assuming fp is checked earlier */
1337 if (!sv)
1338 return TRUE;
e9950d3b
NC
1339 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
1340 assert(!SvGMAGICAL(sv));
1341 if (SvIsUV(sv))
1342 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
1343 else
1344 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
1345 return !PerlIO_error(fp);
1346 }
1347 else {
1348 STRLEN len;
676f44e7 1349 /* Do this first to trigger any overloading. */
e9950d3b
NC
1350 const char *tmps = SvPV_const(sv, len);
1351 U8 *tmpbuf = NULL;
1352 bool happy = TRUE;
1353
d791f93f
KW
1354 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
1355 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
676f44e7
NC
1356 /* We don't modify the original scalar. */
1357 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
1358 tmps = (char *) tmpbuf;
1359 }
a099aed4 1360 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
0876b9a0
KW
1361 (void) check_utf8_print((const U8*) tmps, len);
1362 }
d791f93f
KW
1363 } /* else stream isn't utf8 */
1364 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
1365 convert to bytes */
676f44e7
NC
1366 STRLEN tmplen = len;
1367 bool utf8 = TRUE;
35da51f7 1368 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
676f44e7 1369 if (!utf8) {
d791f93f
KW
1370
1371 /* Here, succeeded in downgrading from utf8. Set up to below
1372 * output the converted value */
676f44e7
NC
1373 tmpbuf = result;
1374 tmps = (char *) tmpbuf;
1375 len = tmplen;
1376 }
d791f93f
KW
1377 else { /* Non-utf8 output stream, but string only representable in
1378 utf8 */
676f44e7 1379 assert((char *)result == tmps);
9b387841 1380 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
21630838
FC
1381 "Wide character in %s",
1382 PL_op ? OP_DESC(PL_op) : "print"
1383 );
0876b9a0
KW
1384 /* Could also check that isn't one of the things to avoid
1385 * in utf8 by using check_utf8_print(), but not doing so,
1386 * since the stream isn't a UTF8 stream */
ae798467
NIS
1387 }
1388 }
e9950d3b
NC
1389 /* To detect whether the process is about to overstep its
1390 * filesize limit we would need getrlimit(). We could then
1391 * also transparently raise the limit with setrlimit() --
1392 * but only until the system hard limit/the filesystem limit,
1393 * at which we would get EPERM. Note that when using buffered
1394 * io the write failure can be delayed until the flush/close. --jhi */
1395 if (len && (PerlIO_write(fp,tmps,len) == 0))
1396 happy = FALSE;
1397 Safefree(tmpbuf);
1398 return happy ? !PerlIO_error(fp) : FALSE;
ff8e2863 1399 }
a687059c
LW
1400}
1401
79072805 1402I32
0d7d409d 1403Perl_my_stat_flags(pTHX_ const U32 flags)
a687059c 1404{
39644a26 1405 dSP;
79072805 1406 IO *io;
2dd78f96 1407 GV* gv;
79072805 1408
533c011a 1409 if (PL_op->op_flags & OPf_REF) {
2dd78f96 1410 gv = cGVOP_gv;
748a9306 1411 do_fstat:
5228a96c
SP
1412 if (gv == PL_defgv)
1413 return PL_laststatval;
2dd78f96 1414 io = GvIO(gv);
ad02613c 1415 do_fstat_have_io:
5228a96c 1416 PL_laststype = OP_STAT;
bd5f6c01 1417 PL_statgv = gv ? gv : (GV *)io;
76f68e9b 1418 sv_setpvs(PL_statname, "");
77616968 1419 if (io) {
5228a96c 1420 if (IoIFP(io)) {
375ed12a 1421 int fd = PerlIO_fileno(IoIFP(io));
77616968
JH
1422 if (fd < 0) {
1423 /* E.g. PerlIO::scalar has no real fd. */
1424 return (PL_laststatval = -1);
1425 } else {
375ed12a
JH
1426 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
1427 }
5228a96c 1428 } else if (IoDIRP(io)) {
3497a01f 1429 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
5228a96c 1430 }
5228a96c 1431 }
3888144c
FC
1432 PL_laststatval = -1;
1433 report_evil_fh(gv);
1434 return -1;
a687059c 1435 }
d2c4d2d1 1436 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
8db8f6b6
FC
1437 == OPpFT_STACKED)
1438 return PL_laststatval;
d2c4d2d1
FC
1439 else {
1440 SV* const sv = TOPs;
4373e329 1441 const char *s;
4ecd490c 1442 STRLEN len;
094a3eec 1443 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
748a9306
LW
1444 goto do_fstat;
1445 }
ad02613c 1446 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 1447 io = MUTABLE_IO(SvRV(sv));
7f39519f 1448 gv = NULL;
ad02613c
SP
1449 goto do_fstat_have_io;
1450 }
748a9306 1451
0d7d409d 1452 s = SvPV_flags_const(sv, len, flags);
a0714e2c 1453 PL_statgv = NULL;
4ecd490c 1454 sv_setpvn(PL_statname, s, len);
95a20fc0 1455 s = SvPVX_const(PL_statname); /* s now NUL-terminated */
3280af22
NIS
1456 PL_laststype = OP_STAT;
1457 PL_laststatval = PerlLIO_stat(s, &PL_statcache);
7cb3f959 1458 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
5d37acd6 1459 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 1460 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
5d37acd6
DM
1461 GCC_DIAG_RESTORE;
1462 }
3280af22 1463 return PL_laststatval;
a687059c
LW
1464 }
1465}
1466
fbb0b3b3 1467
79072805 1468I32
0d7d409d 1469Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 1470{
a1894d81 1471 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 1472 dSP;
b16276bb 1473 const char *file;
cd22fad3 1474 SV* const sv = TOPs;
5840701a 1475 bool isio = FALSE;
533c011a 1476 if (PL_op->op_flags & OPf_REF) {
638eceb6 1477 if (cGVOP_gv == PL_defgv) {
3280af22 1478 if (PL_laststype != OP_LSTAT)
0157ef98 1479 Perl_croak(aTHX_ "%s", no_prev_lstat);
3280af22 1480 return PL_laststatval;
fe14fcc3 1481 }
31b139ba 1482 PL_laststatval = -1;
5d3e98de 1483 if (ckWARN(WARN_IO)) {
5840701a 1484 /* diag_listed_as: Use of -l on filehandle%s */
d0c0e7dd
FC
1485 Perl_warner(aTHX_ packWARN(WARN_IO),
1486 "Use of -l on filehandle %"HEKf,
1487 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 1488 }
31b139ba 1489 return -1;
fe14fcc3 1490 }
8db8f6b6
FC
1491 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1492 == OPpFT_STACKED) {
1f26655e 1493 if (PL_laststype != OP_LSTAT)
0157ef98 1494 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 1495 return PL_laststatval;
cd22fad3 1496 }
c623bd54 1497
3280af22 1498 PL_laststype = OP_LSTAT;
a0714e2c 1499 PL_statgv = NULL;
5840701a
FC
1500 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
1501 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
1502 )
1503 || isGV_with_GP(sv)
1504 )
1505 && ckWARN(WARN_IO)) {
1506 if (isio)
1507 /* diag_listed_as: Use of -l on filehandle%s */
1508 Perl_warner(aTHX_ packWARN(WARN_IO),
1509 "Use of -l on filehandle");
1510 else
1511 /* diag_listed_as: Use of -l on filehandle%s */
1512 Perl_warner(aTHX_ packWARN(WARN_IO),
1513 "Use of -l on filehandle %"HEKf,
10bafe90
BF
1514 HEKfARG(GvENAME_HEK((const GV *)
1515 (SvROK(sv) ? SvRV(sv) : sv))));
cd22fad3
RS
1516 }
1517 file = SvPV_flags_const_nolen(sv, flags);
b16276bb
VP
1518 sv_setpv(PL_statname,file);
1519 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
7cb3f959 1520 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
5d37acd6
DM
1521 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
1522 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
1523 GCC_DIAG_RESTORE;
1524 }
3280af22 1525 return PL_laststatval;
c623bd54
LW
1526}
1527
a0f2c8ec
JD
1528static void
1529S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
1530{
1531 const int e = errno;
7918f24d 1532 PERL_ARGS_ASSERT_EXEC_FAILED;
a0f2c8ec
JD
1533 if (ckWARN(WARN_EXEC))
1534 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1535 cmd, Strerror(e));
1536 if (do_report) {
b469f1e0
JH
1537 /* XXX silently ignore failures */
1538 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
a0f2c8ec
JD
1539 PerlLIO_close(fd);
1540 }
1541}
1542
d5a9bfb0 1543bool
5aaab254 1544Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2aa1486d 1545 int fd, int do_report)
d5a9bfb0 1546{
27da23d5 1547 dVAR;
7918f24d 1548 PERL_ARGS_ASSERT_DO_AEXEC5;
e37778c2 1549#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
cd39f2b6
JH
1550 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1551#else
79072805 1552 if (sp > mark) {
360ea906 1553 const char **a;
6136c704 1554 const char *tmps = NULL;
360ea906 1555 Newx(PL_Argv, sp - mark + 1, const char*);
c3c5fad7 1556 a = PL_Argv;
890ce7af 1557
79072805
LW
1558 while (++mark <= sp) {
1559 if (*mark)
360ea906 1560 *a++ = SvPV_nolen_const(*mark);
a687059c
LW
1561 else
1562 *a++ = "";
1563 }
6136c704 1564 *a = NULL;
91b2752f 1565 if (really)
e62f0680 1566 tmps = SvPV_nolen_const(really);
91b2752f
RG
1567 if ((!really && *PL_Argv[0] != '/') ||
1568 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 1569 TAINT_ENV(); /* testing IFS here is overkill, probably */
b35112e7 1570 PERL_FPU_PRE_EXEC
91b2752f 1571 if (really && *tmps)
b4748376 1572 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
a687059c 1573 else
b4748376 1574 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1575 PERL_FPU_POST_EXEC
a0f2c8ec 1576 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
a687059c 1577 }
bee1dbe2 1578 do_execfree();
cd39f2b6 1579#endif
a687059c
LW
1580 return FALSE;
1581}
1582
fe14fcc3 1583void
864dbfa3 1584Perl_do_execfree(pTHX)
ff8e2863 1585{
43c5f42d 1586 Safefree(PL_Argv);
4608196e 1587 PL_Argv = NULL;
43c5f42d 1588 Safefree(PL_Cmd);
bd61b366 1589 PL_Cmd = NULL;
ff8e2863
LW
1590}
1591
9555a685 1592#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8
IZ
1593
1594bool
2fbb330f 1595Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 1596{
27da23d5 1597 dVAR;
eb578fdb
KW
1598 const char **a;
1599 char *s;
15db3ae2 1600 char *buf;
2fbb330f 1601 char *cmd;
2fbb330f 1602 /* Make a copy so we can change it */
6fca0082 1603 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC
1604
1605 PERL_ARGS_ASSERT_DO_EXEC3;
1606
15db3ae2
DM
1607 Newx(buf, cmdlen, char);
1608 cmd = buf;
cfff9797 1609 memcpy(cmd, incmd, cmdlen);
a687059c 1610
748a9306
LW
1611 while (*cmd && isSPACE(*cmd))
1612 cmd++;
1613
a687059c
LW
1614 /* save an extra exec if possible */
1615
bf38876a 1616#ifdef CSH
d05c1ba0 1617 {
0c19750d 1618 char flags[PERL_FLAGS_MAX];
d05c1ba0
JH
1619 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
1620 strnEQ(cmd+PL_cshlen," -c",3)) {
28f0d0ec 1621 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
d05c1ba0
JH
1622 s = cmd+PL_cshlen+3;
1623 if (*s == 'f') {
1624 s++;
28f0d0ec 1625 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
d05c1ba0
JH
1626 }
1627 if (*s == ' ')
1628 s++;
1629 if (*s++ == '\'') {
0bcc34c2 1630 char * const ncmd = s;
d05c1ba0
JH
1631
1632 while (*s)
1633 s++;
1634 if (s[-1] == '\n')
1635 *--s = '\0';
1636 if (s[-1] == '\'') {
1637 *--s = '\0';
b35112e7 1638 PERL_FPU_PRE_EXEC
7c0dd7ca 1639 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
b35112e7 1640 PERL_FPU_POST_EXEC
d05c1ba0 1641 *s = '\'';
a0f2c8ec 1642 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
15db3ae2 1643 Safefree(buf);
d05c1ba0
JH
1644 return FALSE;
1645 }
1646 }
a687059c
LW
1647 }
1648 }
bf38876a 1649#endif /* CSH */
a687059c
LW
1650
1651 /* see if there are shell metacharacters in it */
1652
748a9306
LW
1653 if (*cmd == '.' && isSPACE(cmd[1]))
1654 goto doshell;
1655
1656 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1657 goto doshell;
1658
294b3b39 1659 s = cmd;
0eb30aeb 1660 while (isWORDCHAR(*s))
294b3b39 1661 s++; /* catch VAR=val gizmo */
63f2c1e1
LW
1662 if (*s == '=')
1663 goto doshell;
748a9306 1664
a687059c 1665 for (s = cmd; *s; s++) {
d05c1ba0
JH
1666 if (*s != ' ' && !isALPHA(*s) &&
1667 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1668 if (*s == '\n' && !s[1]) {
1669 *s = '\0';
1670 break;
1671 }
603a98b0
IZ
1672 /* handle the 2>&1 construct at the end */
1673 if (*s == '>' && s[1] == '&' && s[2] == '1'
1674 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1675 && (!s[3] || isSPACE(s[3])))
1676 {
6867be6d 1677 const char *t = s + 3;
603a98b0
IZ
1678
1679 while (*t && isSPACE(*t))
1680 ++t;
943bbd07 1681 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
603a98b0
IZ
1682 s[-2] = '\0';
1683 break;
1684 }
1685 }
a687059c 1686 doshell:
b35112e7 1687 PERL_FPU_PRE_EXEC
7c0dd7ca 1688 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
b35112e7 1689 PERL_FPU_POST_EXEC
a0f2c8ec 1690 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
15db3ae2 1691 Safefree(buf);
a687059c
LW
1692 return FALSE;
1693 }
1694 }
748a9306 1695
360ea906 1696 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*);
3280af22
NIS
1697 PL_Cmd = savepvn(cmd, s-cmd);
1698 a = PL_Argv;
1699 for (s = PL_Cmd; *s;) {
294b3b39
AL
1700 while (isSPACE(*s))
1701 s++;
a687059c
LW
1702 if (*s)
1703 *(a++) = s;
294b3b39
AL
1704 while (*s && !isSPACE(*s))
1705 s++;
a687059c
LW
1706 if (*s)
1707 *s++ = '\0';
1708 }
6136c704 1709 *a = NULL;
3280af22 1710 if (PL_Argv[0]) {
b35112e7 1711 PERL_FPU_PRE_EXEC
360ea906 1712 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1713 PERL_FPU_POST_EXEC
b1248f16 1714 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1715 do_execfree();
a687059c 1716 goto doshell;
b1248f16 1717 }
a0f2c8ec 1718 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
a687059c 1719 }
ff8e2863 1720 do_execfree();
15db3ae2 1721 Safefree(buf);
a687059c
LW
1722 return FALSE;
1723}
1724
6890e559 1725#endif /* OS2 || WIN32 */
760ac839 1726
25bbd826
CB
1727#ifdef VMS
1728#include <starlet.h> /* for sys$delprc */
1729#endif
1730
79072805 1731I32
5aaab254 1732Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
a687059c 1733{
eb578fdb
KW
1734 I32 val;
1735 I32 tot = 0;
4634a855 1736 const char *const what = PL_op_name[type];
5c144d81 1737 const char *s;
84c7b88c 1738 STRLEN len;
890ce7af 1739 SV ** const oldmark = mark;
885b4b39 1740 bool killgp = FALSE;
a687059c 1741
7918f24d
NC
1742 PERL_ARGS_ASSERT_APPLY;
1743
9a9b5ec9
DM
1744 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
1745
1444765e
NC
1746 /* Doing this ahead of the switch statement preserves the old behaviour,
1747 where attempting to use kill as a taint test test would fail on
1748 platforms where kill was not defined. */
1749#ifndef HAS_KILL
1750 if (type == OP_KILL)
4634a855 1751 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1752#endif
1753#ifndef HAS_CHOWN
1754 if (type == OP_CHOWN)
4634a855 1755 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1756#endif
1757
1758
20408e3c 1759#define APPLY_TAINT_PROPER() \
3280af22 1760 STMT_START { \
284167a5 1761 if (TAINT_get) { TAINT_PROPER(what); } \
873ef191 1762 } STMT_END
20408e3c
GS
1763
1764 /* This is a first heuristic; it doesn't catch tainting magic. */
284167a5 1765 if (TAINTING_get) {
463ee0b2 1766 while (++mark <= sp) {
bbce6d69
PP
1767 if (SvTAINTED(*mark)) {
1768 TAINT;
1769 break;
1770 }
463ee0b2
LW
1771 }
1772 mark = oldmark;
1773 }
a687059c 1774 switch (type) {
79072805 1775 case OP_CHMOD:
20408e3c 1776 APPLY_TAINT_PROPER();
79072805 1777 if (++mark <= sp) {
4ea561bc 1778 val = SvIV(*mark);
20408e3c
GS
1779 APPLY_TAINT_PROPER();
1780 tot = sp - mark;
79072805 1781 while (++mark <= sp) {
c4aca7d0 1782 GV* gv;
2ea1cce7 1783 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1784 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1785#ifdef HAS_FCHMOD
375ed12a 1786 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 1787 APPLY_TAINT_PROPER();
375ed12a
JH
1788 if (fd < 0) {
1789 SETERRNO(EBADF,RMS_IFI);
1790 tot--;
1791 } else if (fchmod(fd, val))
1792 tot--;
c4aca7d0 1793#else
b9c6780e 1794 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0
GA
1795#endif
1796 }
1797 else {
8334cae6 1798 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA
1799 tot--;
1800 }
1801 }
c4aca7d0 1802 else {
41188aa0 1803 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 1804 APPLY_TAINT_PROPER();
41188aa0 1805 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC
1806 PerlLIO_chmod(name, val)) {
1807 tot--;
1808 }
c4aca7d0 1809 }
a687059c
LW
1810 }
1811 }
1812 break;
fe14fcc3 1813#ifdef HAS_CHOWN
79072805 1814 case OP_CHOWN:
20408e3c 1815 APPLY_TAINT_PROPER();
79072805 1816 if (sp - mark > 2) {
eb578fdb 1817 I32 val2;
463ee0b2
LW
1818 val = SvIVx(*++mark);
1819 val2 = SvIVx(*++mark);
20408e3c 1820 APPLY_TAINT_PROPER();
a0d0e21e 1821 tot = sp - mark;
79072805 1822 while (++mark <= sp) {
c4aca7d0 1823 GV* gv;
2ea1cce7 1824 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1825 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1826#ifdef HAS_FCHOWN
375ed12a 1827 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 1828 APPLY_TAINT_PROPER();
375ed12a
JH
1829 if (fd < 0) {
1830 SETERRNO(EBADF,RMS_IFI);
1831 tot--;
1832 } else if (fchown(fd, val, val2))
c4aca7d0
GA
1833 tot--;
1834#else
b9c6780e 1835 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0
GA
1836#endif
1837 }
1838 else {
8334cae6 1839 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA
1840 tot--;
1841 }
1842 }
c4aca7d0 1843 else {
41188aa0 1844 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 1845 APPLY_TAINT_PROPER();
41188aa0 1846 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 1847 PerlLIO_chown(name, val, val2)) {
c4aca7d0 1848 tot--;
c8028aa6 1849 }
c4aca7d0 1850 }
a687059c
LW
1851 }
1852 }
1853 break;
b1248f16 1854#endif
a1d180c4 1855/*
dd64f1c3
AD
1856XXX Should we make lchown() directly available from perl?
1857For now, we'll let Configure test for HAS_LCHOWN, but do
1858nothing in the core.
1859 --AD 5/1998
1860*/
fe14fcc3 1861#ifdef HAS_KILL
79072805 1862 case OP_KILL:
20408e3c 1863 APPLY_TAINT_PROPER();
55497cff
PP
1864 if (mark == sp)
1865 break;
84c7b88c 1866 s = SvPVx_const(*++mark, len);
c2fd40cb
DM
1867 if (*s == '-' && isALPHA(s[1]))
1868 {
1869 s++;
1870 len--;
885b4b39 1871 killgp = TRUE;
c2fd40cb 1872 }
e02bfb16 1873 if (isALPHA(*s)) {
84c7b88c 1874 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
79072805 1875 s += 3;
84c7b88c
BF
1876 len -= 3;
1877 }
1878 if ((val = whichsig_pvn(s, len)) < 0)
1879 Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
79072805
LW
1880 }
1881 else
c2fd40cb 1882 {
4ea561bc 1883 val = SvIV(*mark);
c2fd40cb
DM
1884 if (val < 0)
1885 {
885b4b39 1886 killgp = TRUE;
c2fd40cb
DM
1887 val = -val;
1888 }
1889 }
20408e3c
GS
1890 APPLY_TAINT_PROPER();
1891 tot = sp - mark;
3595fcef
PP
1892#ifdef VMS
1893 /* kill() doesn't do process groups (job trees?) under VMS */
3595fcef 1894 if (val == SIGKILL) {
3595fcef
PP
1895 /* Use native sys$delprc() to insure that target process is
1896 * deleted; supervisor-mode images don't pay attention to
1897 * CRTL's emulation of Unix-style signals and kill()
1898 */
1899 while (++mark <= sp) {
5f521955 1900 I32 proc;
eb578fdb 1901 unsigned long int __vmssts;
8af710eb 1902 SvGETMAGIC(*mark);
e2c0f81f
DG
1903 if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
1904 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
8af710eb 1905 proc = SvIV_nomg(*mark);
20408e3c 1906 APPLY_TAINT_PROPER();
3595fcef
PP
1907 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1908 tot--;
1909 switch (__vmssts) {
1910 case SS$_NONEXPR:
1911 case SS$_NOSUCHNODE:
1912 SETERRNO(ESRCH,__vmssts);
1913 break;
1914 case SS$_NOPRIV:
1915 SETERRNO(EPERM,__vmssts);
1916 break;
1917 default:
1918 SETERRNO(EVMSERR,__vmssts);
1919 }
1920 }
1921 }
8165faea 1922 PERL_ASYNC_CHECK();
3595fcef
PP
1923 break;
1924 }
1925#endif
c2fd40cb 1926 while (++mark <= sp) {
60082291 1927 Pid_t proc;
c2fd40cb 1928 SvGETMAGIC(*mark);
60082291 1929 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
c2fd40cb
DM
1930 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
1931 proc = SvIV_nomg(*mark);
c2fd40cb 1932 APPLY_TAINT_PROPER();
111f73b5
DM
1933#ifdef HAS_KILLPG
1934 /* use killpg in preference, as the killpg() wrapper for Win32
1935 * understands process groups, but the kill() wrapper doesn't */
1936 if (killgp ? PerlProc_killpg(proc, val)
1937 : PerlProc_kill(proc, val))
1938#else
1939 if (PerlProc_kill(killgp ? -proc: proc, val))
1940#endif
c2fd40cb 1941 tot--;
a687059c 1942 }
8165faea 1943 PERL_ASYNC_CHECK();
a687059c 1944 break;
b1248f16 1945#endif
79072805 1946 case OP_UNLINK:
20408e3c 1947 APPLY_TAINT_PROPER();
79072805
LW
1948 tot = sp - mark;
1949 while (++mark <= sp) {
41188aa0 1950 s = SvPV_const(*mark, len);
20408e3c 1951 APPLY_TAINT_PROPER();
41188aa0 1952 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC
1953 tot--;
1954 }
f0d85c30 1955 else if (PL_unsafe) {
b8ffc8df 1956 if (UNLINK(s))
a687059c
LW
1957 tot--;
1958 }
1959 else { /* don't let root wipe out directories without -U */
1dcae8b8 1960 if (PerlLIO_lstat(s,&PL_statbuf) < 0)
a687059c 1961 tot--;
1dcae8b8
EZ
1962 else if (S_ISDIR(PL_statbuf.st_mode)) {
1963 tot--;
cd52bc19 1964 SETERRNO(EISDIR, SS_NOPRIV);
1dcae8b8 1965 }
a687059c 1966 else {
b8ffc8df 1967 if (UNLINK(s))
a687059c
LW
1968 tot--;
1969 }
1970 }
1971 }
1972 break;
e96b369d 1973#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 1974 case OP_UTIME:
20408e3c 1975 APPLY_TAINT_PROPER();
79072805 1976 if (sp - mark > 2) {
e96b369d
GA
1977#if defined(HAS_FUTIMES)
1978 struct timeval utbuf[2];
1979 void *utbufp = utbuf;
1980#elif defined(I_UTIME) || defined(VMS)
663a0e37 1981 struct utimbuf utbuf;
07409e01 1982 struct utimbuf *utbufp = &utbuf;
663a0e37 1983#else
a687059c 1984 struct {
dd2821f6
GS
1985 Time_t actime;
1986 Time_t modtime;
a687059c 1987 } utbuf;
07409e01 1988 void *utbufp = &utbuf;
663a0e37 1989#endif
a687059c 1990
0bcc34c2
AL
1991 SV* const accessed = *++mark;
1992 SV* const modified = *++mark;
c6f7b413 1993
6ec06612
SB
1994 /* Be like C, and if both times are undefined, let the C
1995 * library figure out what to do. This usually means
1996 * "current time". */
c6f7b413
RS
1997
1998 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB
1999 utbufp = NULL;
2000 else {
2001 Zero(&utbuf, sizeof utbuf, char);
e96b369d 2002#ifdef HAS_FUTIMES
4ea561bc 2003 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 2004 utbuf[0].tv_usec = 0;
4ea561bc 2005 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA
2006 utbuf[1].tv_usec = 0;
2007#elif defined(BIG_TIME)
4ea561bc
NC
2008 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
2009 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 2010#else
4ea561bc
NC
2011 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
2012 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 2013#endif
6ec06612 2014 }
4373e329 2015 APPLY_TAINT_PROPER();
79072805
LW
2016 tot = sp - mark;
2017 while (++mark <= sp) {
e96b369d 2018 GV* gv;
64617da9 2019 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA
2020 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2021#ifdef HAS_FUTIMES
375ed12a 2022 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
e96b369d 2023 APPLY_TAINT_PROPER();
375ed12a
JH
2024 if (fd < 0) {
2025 SETERRNO(EBADF,RMS_IFI);
2026 tot--;
2027 } else if (futimes(fd, (struct timeval *) utbufp))
e96b369d
GA
2028 tot--;
2029#else
2030 Perl_die(aTHX_ PL_no_func, "futimes");
2031#endif
2032 }
2033 else {
2034 tot--;
2035 }
2036 }
e96b369d 2037 else {
41188aa0 2038 const char * const name = SvPV_nomg_const(*mark, len);
e96b369d 2039 APPLY_TAINT_PROPER();
41188aa0 2040 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC
2041 tot--;
2042 }
2043 else
e96b369d 2044#ifdef HAS_FUTIMES
8b7231d9 2045 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA
2046#else
2047 if (PerlLIO_utime(name, utbufp))
2048#endif
2049 tot--;
2050 }
2051
a687059c 2052 }
a687059c
LW
2053 }
2054 else
79072805 2055 tot = 0;
a687059c 2056 break;
a0d0e21e 2057#endif
a687059c
LW
2058 }
2059 return tot;
20408e3c 2060
20408e3c 2061#undef APPLY_TAINT_PROPER
a687059c
LW
2062}
2063
2064/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 2065#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 2066bool
5aaab254 2067Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC
2068/* effective is a flag, true for EUID, or for checking if the effective gid
2069 * is in the list of groups returned from getgroups().
2070 */
a687059c 2071{
7918f24d 2072 PERL_ARGS_ASSERT_CANDO;
81611534 2073 PERL_UNUSED_CONTEXT;
7918f24d 2074
bee1dbe2 2075#ifdef DOSISH
fe14fcc3
LW
2076 /* [Comments and code from Len Reed]
2077 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
2078 * to write-protected files. The execute permission bit is set
486ec47a 2079 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW
2080 * .exe files
2081 * .com files
2082 * .bat files
2083 * directories
2084 * All files and directories are readable.
2085 * Directories and special files, e.g. "CON", cannot be
2086 * write-protected.
2087 * [Comment by Tom Dinger -- a directory can have the write-protect
2088 * bit set in the file system, but DOS permits changes to
2089 * the directory anyway. In addition, all bets are off
2090 * here for networked software, such as Novell and
2091 * Sun's PC-NFS.]
2092 */
2093
bee1dbe2
LW
2094 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
2095 * too so it will actually look into the files for magic numbers
2096 */
7f4774ae 2097 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 2098
55497cff 2099#else /* ! DOSISH */
b595cd4b
RU
2100# ifdef __CYGWIN__
2101 if (ingroup(544,effective)) { /* member of Administrators */
2102# else
985213f2 2103 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 2104# endif
7f4774ae 2105 if (mode == S_IXUSR) {
c623bd54 2106 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
2107 return TRUE;
2108 }
2109 else
2110 return TRUE; /* root reads and writes anything */
2111 return FALSE;
2112 }
985213f2 2113 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 2114 if (statbufp->st_mode & mode)
a687059c
LW
2115 return TRUE; /* ok as "user" */
2116 }
d8eceb89 2117 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 2118 if (statbufp->st_mode & mode >> 3)
a687059c
LW
2119 return TRUE; /* ok as "group" */
2120 }
7f4774ae 2121 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
2122 return TRUE; /* ok as "other" */
2123 return FALSE;
55497cff 2124#endif /* ! DOSISH */
a687059c 2125}
a0d0e21e 2126#endif /* ! VMS */
a687059c 2127
1f676739 2128static bool
0da8eb3a 2129S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 2130{
81611534
JH
2131#ifndef PERL_IMPLICIT_SYS
2132 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */
2133 PERL_UNUSED_CONTEXT;
2134#endif
985213f2 2135 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 2136 return TRUE;
fe14fcc3 2137#ifdef HAS_GETGROUPS
a687059c 2138 {
331b57bc 2139 Groups_t *gary = NULL;
79072805 2140 I32 anum;
331b57bc 2141 bool rc = FALSE;
a687059c 2142
331b57bc 2143 anum = getgroups(0, gary);
375ed12a
JH
2144 if (anum > 0) {
2145 Newx(gary, anum, Groups_t);
2146 anum = getgroups(anum, gary);
2147 while (--anum >= 0)
2148 if (gary[anum] == testgid) {
2149 rc = TRUE;
2150 break;
2151 }
331b57bc 2152
375ed12a
JH
2153 Safefree(gary);
2154 }
331b57bc 2155 return rc;
a687059c 2156 }
c685562b 2157#else
a687059c 2158 return FALSE;
cd39f2b6 2159#endif
a687059c 2160}
c2ab57d4 2161
fe14fcc3 2162#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2163
79072805 2164I32
864dbfa3 2165Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2166{
0bcc34c2 2167 const key_t key = (key_t)SvNVx(*++mark);
c3312966 2168 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 2169 const I32 flags = SvIVx(*++mark);
294a48e9 2170
7918f24d 2171 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 2172 PERL_UNUSED_ARG(sp);
c2ab57d4 2173
748a9306 2174 SETERRNO(0,0);
c2ab57d4
LW
2175 switch (optype)
2176 {
fe14fcc3 2177#ifdef HAS_MSG
79072805 2178 case OP_MSGGET:
c2ab57d4 2179 return msgget(key, flags);
e5d73d77 2180#endif
fe14fcc3 2181#ifdef HAS_SEM
79072805 2182 case OP_SEMGET:
c3312966 2183 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2184#endif
fe14fcc3 2185#ifdef HAS_SHM
79072805 2186 case OP_SHMGET:
c3312966 2187 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 2188#endif
fe14fcc3 2189#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2190 default:
fe13d51d 2191 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2192 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2193#endif
c2ab57d4
LW
2194 }
2195 return -1; /* should never happen */
2196}
2197
79072805 2198I32
864dbfa3 2199Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2200{
c2ab57d4 2201 char *a;
a0d0e21e 2202 I32 ret = -1;
6867be6d 2203 const I32 id = SvIVx(*++mark);
95b63a38 2204#ifdef Semctl
6867be6d 2205 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2206#endif
6867be6d 2207 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL
2208 SV * const astr = *++mark;
2209 STRLEN infosize = 0;
2210 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2211
7918f24d 2212 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2213 PERL_UNUSED_ARG(sp);
c2ab57d4
LW
2214
2215 switch (optype)
2216 {
fe14fcc3 2217#ifdef HAS_MSG
79072805 2218 case OP_MSGCTL:
c2ab57d4
LW
2219 if (cmd == IPC_STAT || cmd == IPC_SET)
2220 infosize = sizeof(struct msqid_ds);
2221 break;
e5d73d77 2222#endif
fe14fcc3 2223#ifdef HAS_SHM
79072805 2224 case OP_SHMCTL:
c2ab57d4
LW
2225 if (cmd == IPC_STAT || cmd == IPC_SET)
2226 infosize = sizeof(struct shmid_ds);
2227 break;
e5d73d77 2228#endif
fe14fcc3 2229#ifdef HAS_SEM
79072805 2230 case OP_SEMCTL:
39398f3f 2231#ifdef Semctl
c2ab57d4
LW
2232 if (cmd == IPC_STAT || cmd == IPC_SET)
2233 infosize = sizeof(struct semid_ds);
2234 else if (cmd == GETALL || cmd == SETALL)
2235 {
8e591e46 2236 struct semid_ds semds;
bd89102f 2237 union semun semun;
e6f0bdd6
GS
2238#ifdef EXTRA_F_IN_SEMUN_BUF
2239 semun.buff = &semds;
2240#else
84902520 2241 semun.buf = &semds;
e6f0bdd6 2242#endif
c2ab57d4 2243 getinfo = (cmd == GETALL);
9b89d93d
GB
2244 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2245 return -1;
6e21c824
LW
2246 infosize = semds.sem_nsems * sizeof(short);
2247 /* "short" is technically wrong but much more portable
2248 than guessing about u_?short(_t)? */
c2ab57d4 2249 }
39398f3f 2250#else
fe13d51d 2251 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2252 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2253#endif
c2ab57d4 2254 break;
e5d73d77 2255#endif
fe14fcc3 2256#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2257 default:
fe13d51d 2258 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2259 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2260#endif
c2ab57d4
LW
2261 }
2262
2263 if (infosize)
2264 {
2265 if (getinfo)
2266 {
93524f2b 2267 SvPV_force_nolen(astr);
a0d0e21e 2268 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
2269 }
2270 else
2271 {
93524f2b 2272 STRLEN len;
463ee0b2
LW
2273 a = SvPV(astr, len);
2274 if (len != infosize)
cea2e8a9 2275 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
2276 PL_op_desc[optype],
2277 (unsigned long)len,
2278 (long)infosize);
c2ab57d4
LW
2279 }
2280 }
2281 else
2282 {
0bcc34c2 2283 const IV i = SvIV(astr);
56431972 2284 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 2285 }
748a9306 2286 SETERRNO(0,0);
c2ab57d4
LW
2287 switch (optype)
2288 {
fe14fcc3 2289#ifdef HAS_MSG
79072805 2290 case OP_MSGCTL:
bee1dbe2 2291 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 2292 break;
e5d73d77 2293#endif
fe14fcc3 2294#ifdef HAS_SEM
bd89102f 2295 case OP_SEMCTL: {
39398f3f 2296#ifdef Semctl
bd89102f
AD
2297 union semun unsemds;
2298
64d76282
BC
2299 if(cmd == SETVAL) {
2300 unsemds.val = PTR2nat(a);
2301 }
2302 else {
e6f0bdd6 2303#ifdef EXTRA_F_IN_SEMUN_BUF
64d76282 2304 unsemds.buff = (struct semid_ds *)a;
e6f0bdd6 2305#else
64d76282 2306 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 2307#endif
64d76282 2308 }
bd89102f 2309 ret = Semctl(id, n, cmd, unsemds);
39398f3f 2310#else
fe13d51d 2311 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2312 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2313#endif
bd89102f 2314 }
c2ab57d4 2315 break;
e5d73d77 2316#endif
fe14fcc3 2317#ifdef HAS_SHM
79072805 2318 case OP_SHMCTL:
bee1dbe2 2319 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 2320 break;
e5d73d77 2321#endif
c2ab57d4
LW
2322 }
2323 if (getinfo && ret >= 0) {
79072805
LW
2324 SvCUR_set(astr, infosize);
2325 *SvEND(astr) = '\0';
a0d0e21e 2326 SvSETMAGIC(astr);
c2ab57d4
LW
2327 }
2328 return ret;
2329}
2330
79072805 2331I32
864dbfa3 2332Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 2333{
fe14fcc3 2334#ifdef HAS_MSG
463ee0b2 2335 STRLEN len;
6867be6d 2336 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2337 SV * const mstr = *++mark;
2338 const I32 flags = SvIVx(*++mark);
2339 const char * const mbuf = SvPV_const(mstr, len);
2340 const I32 msize = len - sizeof(long);
2341
7918f24d 2342 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 2343 PERL_UNUSED_ARG(sp);
c2ab57d4 2344
0bcc34c2 2345 if (msize < 0)
cea2e8a9 2346 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 2347 SETERRNO(0,0);
681fb693
JH
2348 if (id >= 0 && flags >= 0) {
2349 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
2350 } else {
2351 SETERRNO(EINVAL,LIB_INVARG);
2352 return -1;
2353 }
e5d73d77 2354#else
2d51fa4d
RGS
2355 PERL_UNUSED_ARG(sp);
2356 PERL_UNUSED_ARG(mark);
fe13d51d 2357 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2358 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 2359 return -1;
e5d73d77 2360#endif
c2ab57d4
LW
2361}
2362
79072805 2363I32
864dbfa3 2364Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 2365{
fe14fcc3 2366#ifdef HAS_MSG
c2ab57d4
LW
2367 char *mbuf;
2368 long mtype;
6867be6d 2369 I32 msize, flags, ret;
6867be6d 2370 const I32 id = SvIVx(*++mark);
0bcc34c2 2371 SV * const mstr = *++mark;
7918f24d
NC
2372
2373 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 2374 PERL_UNUSED_ARG(sp);
79072805 2375
c2e66d9e
GS
2376 /* suppress warning when reading into undef var --jhi */
2377 if (! SvOK(mstr))
76f68e9b 2378 sv_setpvs(mstr, "");
463ee0b2
LW
2379 msize = SvIVx(*++mark);
2380 mtype = (long)SvIVx(*++mark);
2381 flags = SvIVx(*++mark);
93524f2b 2382 SvPV_force_nolen(mstr);
a0d0e21e 2383 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2384
748a9306 2385 SETERRNO(0,0);
d2607e1e
JH
2386 if (id >= 0 && msize >= 0 && flags >= 0) {
2387 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
2388 } else {
2389 SETERRNO(EINVAL,LIB_INVARG);
2390 ret = -1;
2391 }
c2ab57d4 2392 if (ret >= 0) {
79072805
LW
2393 SvCUR_set(mstr, sizeof(long)+ret);
2394 *SvEND(mstr) = '\0';
41d6edb2
JH
2395 /* who knows who has been playing with this message? */
2396 SvTAINTED_on(mstr);
c2ab57d4
LW
2397 }
2398 return ret;
e5d73d77 2399#else
2d51fa4d
RGS
2400 PERL_UNUSED_ARG(sp);
2401 PERL_UNUSED_ARG(mark);
fe13d51d 2402 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2403 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 2404 return -1;
e5d73d77 2405#endif
c2ab57d4
LW
2406}
2407
79072805 2408I32
864dbfa3 2409Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2410{
fe14fcc3 2411#ifdef HAS_SEM
463ee0b2 2412 STRLEN opsize;
6867be6d 2413 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2414 SV * const opstr = *++mark;
2415 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC
2416
2417 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 2418 PERL_UNUSED_ARG(sp);
c2ab57d4 2419
248ff010
NC
2420 if (opsize < 3 * SHORTSIZE
2421 || (opsize % (3 * SHORTSIZE))) {
93189314 2422 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW
2423 return -1;
2424 }
748a9306 2425 SETERRNO(0,0);
248ff010
NC
2426 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2427 {
6867be6d 2428 const int nsops = opsize / (3 * sizeof (short));
248ff010 2429 int i = nsops;
0bcc34c2 2430 short * const ops = (short *) opbuf;
248ff010
NC
2431 short *o = ops;
2432 struct sembuf *temps, *t;
2433 I32 result;
2434
a02a5408 2435 Newx (temps, nsops, struct sembuf);
248ff010
NC
2436 t = temps;
2437 while (i--) {
2438 t->sem_num = *o++;
2439 t->sem_op = *o++;
2440 t->sem_flg = *o++;
2441 t++;
2442 }
2443 result = semop(id, temps, nsops);
248ff010
NC
2444 Safefree(temps);
2445 return result;
2446 }
e5d73d77 2447#else
fe13d51d 2448 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2449 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2450#endif
c2ab57d4
LW
2451}
2452
79072805 2453I32
864dbfa3 2454Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2455{
fe14fcc3 2456#ifdef HAS_SHM
4373e329 2457 char *shm;
c2ab57d4 2458 struct shmid_ds shmds;
6867be6d 2459 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2460 SV * const mstr = *++mark;
2461 const I32 mpos = SvIVx(*++mark);
2462 const I32 msize = SvIVx(*++mark);
7918f24d
NC
2463
2464 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 2465 PERL_UNUSED_ARG(sp);
c2ab57d4 2466
748a9306 2467 SETERRNO(0,0);
c2ab57d4
LW
2468 if (shmctl(id, IPC_STAT, &shmds) == -1)
2469 return -1;
7f39519f
NC
2470 if (mpos < 0 || msize < 0
2471 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 2472 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2473 return -1;
2474 }
568fc267
JH
2475 if (id >= 0) {
2476 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
2477 } else {
2478 SETERRNO(EINVAL,LIB_INVARG);
2479 return -1;
2480 }
c2ab57d4
LW
2481 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2482 return -1;
79072805 2483 if (optype == OP_SHMREAD) {
c8ae91a8 2484 char *mbuf;
9f538c04 2485 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS
2486 SvGETMAGIC(mstr);
2487 SvUPGRADE(mstr, SVt_PV);
9f538c04 2488 if (! SvOK(mstr))
76f68e9b 2489 sv_setpvs(mstr, "");
af8ff727 2490 SvPOK_only(mstr);
bb7a0f54 2491 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 2492
bee1dbe2 2493 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2494 SvCUR_set(mstr, msize);
2495 *SvEND(mstr) = '\0';
a0d0e21e 2496 SvSETMAGIC(mstr);
d929ce6f
JH
2497 /* who knows who has been playing with this shared memory? */
2498 SvTAINTED_on(mstr);
c2ab57d4
LW
2499 }
2500 else {
93524f2b 2501 STRLEN len;
c2ab57d4 2502
93524f2b 2503 const char *mbuf = SvPV_const(mstr, len);
027aa12d 2504 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 2505 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2506 if (n < msize)
bee1dbe2 2507 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2508 }
2509 return shmdt(shm);
e5d73d77 2510#else
fe13d51d 2511 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2512 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 2513 return -1;
e5d73d77 2514#endif
c2ab57d4
LW
2515}
2516
fe14fcc3 2517#endif /* SYSV IPC */
4e35701f 2518
0d44d22b 2519/*
ccfc67b7
JH
2520=head1 IO Functions
2521
0d44d22b
NC
2522=for apidoc start_glob
2523
2524Function called by C<do_readline> to spawn a glob (or do the glob inside
154e47c8 2525perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
210b36aa 2526this glob starter is only used by miniperl during the build process.
75af9d73 2527Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
fab3f3a7 2528
0d44d22b
NC
2529=cut
2530*/
2531
2532PerlIO *
2533Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2534{
561b68a9 2535 SV * const tmpcmd = newSV(0);
0d44d22b 2536 PerlIO *fp;
41188aa0
TC
2537 STRLEN len;
2538 const char *s = SvPV(tmpglob, len);
7918f24d
NC
2539
2540 PERL_ARGS_ASSERT_START_GLOB;
2541
41188aa0 2542 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC
2543 return NULL;
2544
0d44d22b
NC
2545 ENTER;
2546 SAVEFREESV(tmpcmd);
2547#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2548 /* since spawning off a process is a real performance hit */
dca5a913
JM
2549
2550PerlIO *
2551Perl_vms_start_glob
2552 (pTHX_ SV *tmpglob,
2553 IO *io);
2554
49a7a762 2555 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 2556
0d44d22b 2557#else /* !VMS */
0d44d22b
NC
2558#ifdef DOSISH
2559#ifdef OS2
2560 sv_setpv(tmpcmd, "for a in ");
2561 sv_catsv(tmpcmd, tmpglob);
2562 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2563#else
2564#ifdef DJGPP
2565 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2566 sv_catsv(tmpcmd, tmpglob);
2567#else
2568 sv_setpv(tmpcmd, "perlglob ");
2569 sv_catsv(tmpcmd, tmpglob);
2570 sv_catpv(tmpcmd, " |");
2571#endif /* !DJGPP */
2572#endif /* !OS2 */
2573#else /* !DOSISH */
2574#if defined(CSH)
2575 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2576 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2577 sv_catsv(tmpcmd, tmpglob);
2578 sv_catpv(tmpcmd, "' 2>/dev/null |");
2579#else
2580 sv_setpv(tmpcmd, "echo ");
2581 sv_catsv(tmpcmd, tmpglob);
0d44d22b 2582 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
0d44d22b
NC
2583#endif /* !CSH */
2584#endif /* !DOSISH */
93b2dae1
FC
2585 {
2586 GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
2587 SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
25018358 2588 SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
93b2dae1 2589 if (home && *home) SvGETMAGIC(*home);
25018358 2590 if (path && *path) SvGETMAGIC(*path);
93b2dae1
FC
2591 save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
2592 if (home && *home) SvSETMAGIC(*home);
25018358 2593 if (path && *path) SvSETMAGIC(*path);
93b2dae1 2594 }
d5eb9a46
NC
2595 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
2596 NULL, NULL, 0);
0d44d22b
NC
2597 fp = IoIFP(io);
2598#endif /* !VMS */
2599 LEAVE;
de7dabb6
TC
2600
2601 if (!fp && ckWARN(WARN_GLOB)) {
2602 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
2603 Strerror(errno));
2604 }
2605
0d44d22b
NC
2606 return fp;
2607}
66610fdd
RGS
2608
2609/*
14d04a33 2610 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2611 */