This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
AUTHORS for 8c1ed856
[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 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 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 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 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 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 }
194e5090
JH
774#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
775 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
776 PerlLIO_close(fd);
777 goto say_false;
a8710ca1 778 }
1462b684 779#endif
8990e307 780 IoIFP(io) = fp;
b931b1d9 781
684bef36 782 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 783 if (writing) {
50952442 784 if (IoTYPE(io) == IoTYPE_SOCKET
e99cca91 785 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
a33cf58c 786 char *s = mode;
3b6c1aba
JH
787 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
788 s++;
a33cf58c 789 *s = 'w';
7c491510 790 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
760ac839 791 PerlIO_close(fp);
6e21c824 792 goto say_false;
fe14fcc3 793 }
1462b684
LW
794 }
795 else
8990e307 796 IoOFP(io) = fp;
bf38876a 797 }
a687059c 798 return TRUE;
6e21c824 799
7b52d656 800 say_false:
8990e307
LW
801 IoIFP(io) = saveifp;
802 IoOFP(io) = saveofp;
803 IoTYPE(io) = savetype;
6e21c824 804 return FALSE;
a687059c
LW
805}
806
760ac839 807PerlIO *
157fb5a1 808Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
a687059c 809{
2d03de9c 810 IO * const io = GvIOp(gv);
fe14fcc3 811
7918f24d
NC
812 PERL_ARGS_ASSERT_NEXTARGV;
813
3280af22 814 if (!PL_argvoutgv)
fafc274c 815 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
5513c2cf 816 if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
18708f5a 817 IoFLAGS(io) &= ~IOf_START;
7a1c5554 818 if (PL_inplace) {
294b3b39 819 assert(PL_defoutgv);
29a861e7
NC
820 Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
821 SvREFCNT_inc_simple_NN(PL_defoutgv));
7a1c5554 822 }
18708f5a 823 }
3280af22
NIS
824 if (PL_filemode & (S_ISUID|S_ISGID)) {
825 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
fe14fcc3 826#ifdef HAS_FCHMOD
c797f2d8
DM
827 if (PL_lastfd != -1)
828 (void)fchmod(PL_lastfd,PL_filemode);
fe14fcc3 829#else
b28d0864 830 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
fe14fcc3
LW
831#endif
832 }
c797f2d8 833 PL_lastfd = -1;
3280af22 834 PL_filemode = 0;
5c501b37 835 if (!GvAV(gv))
4608196e 836 return NULL;
b9f2b683 837 while (av_tindex(GvAV(gv)) >= 0) {
85aff577 838 STRLEN oldlen;
1fa0529f 839 SV *const sv = av_shift(GvAV(gv));
8990e307 840 SAVEFREESV(sv);
4bac9ae4 841 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
e203899d 842 sv_setsv(GvSVn(gv),sv);
79072805 843 SvSETMAGIC(GvSV(gv));
3280af22 844 PL_oldname = SvPVx(GvSV(gv), oldlen);
d8015975 845 if (LIKELY(!PL_inplace)) {
157fb5a1
RGS
846 if (nomagicopen
847 ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)
848 : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)
849 ) {
d8015975
NC
850 return IoIFP(GvIOp(gv));
851 }
852 }
853 else {
854 /* This very long block ends with return IoIFP(GvIOp(gv));
855 Both this block and the block above fall through on open
856 failure to the warning code, and then the while loop above tries
857 the next entry. */
858 if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0)) {
1fa0529f
NC
859#ifndef FLEXFILENAMES
860 int filedev;
861 int fileino;
862#endif
863 Uid_t fileuid;
864 Gid_t filegid;
865
79072805 866 TAINT_PROPER("inplace open");
3280af22 867 if (oldlen == 1 && *PL_oldname == '-') {
fafc274c
NC
868 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
869 SVt_PVIO));
a0d0e21e 870 return IoIFP(GvIOp(gv));
c623bd54 871 }
99b89507 872#ifndef FLEXFILENAMES
b28d0864
NIS
873 filedev = PL_statbuf.st_dev;
874 fileino = PL_statbuf.st_ino;
99b89507 875#endif
3280af22
NIS
876 PL_filemode = PL_statbuf.st_mode;
877 fileuid = PL_statbuf.st_uid;
878 filegid = PL_statbuf.st_gid;
879 if (!S_ISREG(PL_filemode)) {
9b387841
NC
880 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
881 "Can't do inplace edit: %s is not a regular file",
882 PL_oldname );
79072805 883 do_close(gv,FALSE);
c623bd54
LW
884 continue;
885 }
c9930541 886 if (*PL_inplace && strNE(PL_inplace, "*")) {
2d03de9c 887 const char *star = strchr(PL_inplace, '*');
2d259d92 888 if (star) {
2d03de9c 889 const char *begin = PL_inplace;
76f68e9b 890 sv_setpvs(sv, "");
2d259d92
CK
891 do {
892 sv_catpvn(sv, begin, star - begin);
3280af22 893 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK
894 begin = ++star;
895 } while ((star = strchr(begin, '*')));
3d66d7bb
GS
896 if (*begin)
897 sv_catpv(sv,begin);
2d259d92
CK
898 }
899 else {
3280af22 900 sv_catpv(sv,PL_inplace);
2d259d92 901 }
c623bd54 902#ifndef FLEXFILENAMES
95a20fc0 903 if ((PerlLIO_stat(SvPVX_const(sv),&PL_statbuf) >= 0
5f74f29c
JH
904 && PL_statbuf.st_dev == filedev
905 && PL_statbuf.st_ino == fileino)
39e571d4 906#ifdef DJGPP
5f74f29c 907 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
39e571d4 908#endif
f248d071
GS
909 )
910 {
9b387841
NC
911 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
912 "Can't do inplace edit: %"SVf" would not be unique",
913 SVfARG(sv));
79072805 914 do_close(gv,FALSE);
c623bd54
LW
915 continue;
916 }
917#endif
fe14fcc3 918#ifdef HAS_RENAME
739a0b84 919#if !defined(DOSISH) && !defined(__CYGWIN__)
95a20fc0 920 if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
9b387841
NC
921 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
922 "Can't rename %s to %"SVf": %s, skipping file",
923 PL_oldname, SVfARG(sv), Strerror(errno));
79072805 924 do_close(gv,FALSE);
c623bd54
LW
925 continue;
926 }
a687059c 927#else
79072805 928 do_close(gv,FALSE);
95a20fc0
SP
929 (void)PerlLIO_unlink(SvPVX_const(sv));
930 (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv));
d5eb9a46 931 do_open_raw(gv, SvPVX_const(sv), SvCUR(sv), O_RDONLY, 0);
55497cff 932#endif /* DOSISH */
ff8e2863 933#else
95a20fc0
SP
934 (void)UNLINK(SvPVX_const(sv));
935 if (link(PL_oldname,SvPVX_const(sv)) < 0) {
9b387841
NC
936 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
937 "Can't rename %s to %"SVf": %s, skipping file",
938 PL_oldname, SVfARG(sv), Strerror(errno) );
79072805 939 do_close(gv,FALSE);
c623bd54
LW
940 continue;
941 }
b28d0864 942 (void)UNLINK(PL_oldname);
a687059c
LW
943#endif
944 }
945 else {
c030f24b 946#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 947# ifndef VMS /* Don't delete; use automatic file versioning */
3280af22 948 if (UNLINK(PL_oldname) < 0) {
9b387841
NC
949 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
950 "Can't remove %s: %s, skipping file",
951 PL_oldname, Strerror(errno) );
79072805 952 do_close(gv,FALSE);
fe14fcc3
LW
953 continue;
954 }
edc7bc49 955# endif
ff8e2863 956#else
cea2e8a9 957 Perl_croak(aTHX_ "Can't do inplace edit without backup");
ff8e2863 958#endif
a687059c
LW
959 }
960
30fc4309 961 sv_setpvn(sv,PL_oldname,oldlen);
748a9306 962 SETERRNO(0,0); /* in case sprintf set errno */
d5eb9a46
NC
963 if (!Perl_do_open_raw(aTHX_ PL_argvoutgv, SvPVX_const(sv),
964 SvCUR(sv),
4119ab01 965#ifdef VMS
d5eb9a46 966 O_WRONLY|O_CREAT|O_TRUNC, 0
4119ab01 967#else
d5eb9a46 968 O_WRONLY|O_CREAT|OPEN_EXCL, 0600
4119ab01 969#endif
d5eb9a46 970 )) {
9b387841
NC
971 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
972 PL_oldname, Strerror(errno) );
79072805 973 do_close(gv,FALSE);
fe14fcc3
LW
974 continue;
975 }
3280af22
NIS
976 setdefout(PL_argvoutgv);
977 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
375ed12a
JH
978 if (PL_lastfd >= 0) {
979 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
fe14fcc3 980#ifdef HAS_FCHMOD
375ed12a 981 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 982#else
375ed12a 983 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
a687059c 984#endif
375ed12a 985 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
b469f1e0 986 /* XXX silently ignore failures */
fe14fcc3 987#ifdef HAS_FCHOWN
b469f1e0 988 PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
a687059c 989#else
fe14fcc3 990#ifdef HAS_CHOWN
b469f1e0 991 PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid));
a687059c 992#endif
b1248f16 993#endif
375ed12a 994 }
fe14fcc3 995 }
d8015975 996 return IoIFP(GvIOp(gv));
a687059c 997 }
d8015975
NC
998 } /* successful do_open_raw(), PL_inplace non-NULL */
999
1000 if (ckWARN_d(WARN_INPLACE)) {
1001 const int eno = errno;
1002 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
1003 && !S_ISREG(PL_statbuf.st_mode)) {
1004 Perl_warner(aTHX_ packWARN(WARN_INPLACE),
1005 "Can't do inplace edit: %s is not a regular file",
1006 PL_oldname);
1007 }
1008 else {
1009 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
1010 PL_oldname, Strerror(eno));
1011 }
4d61ec05 1012 }
a687059c 1013 }
18708f5a
GS
1014 if (io && (IoFLAGS(io) & IOf_ARGV))
1015 IoFLAGS(io) |= IOf_START;
3280af22
NIS
1016 if (PL_inplace) {
1017 (void)do_close(PL_argvoutgv,FALSE);
7a1c5554
GS
1018 if (io && (IoFLAGS(io) & IOf_ARGV)
1019 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
1020 {
159b6efe 1021 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
18708f5a 1022 setdefout(oldout);
8e217d4a 1023 SvREFCNT_dec_NN(oldout);
4608196e 1024 return NULL;
18708f5a 1025 }
fafc274c 1026 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
a687059c 1027 }
4608196e 1028 return NULL;
a687059c
LW
1029}
1030
517844ec 1031/* explicit renamed to avoid C++ conflict -- kja */
a687059c 1032bool
864dbfa3 1033Perl_do_close(pTHX_ GV *gv, bool not_implicit)
a687059c 1034{
1193dd27
IZ
1035 bool retval;
1036 IO *io;
a687059c 1037
79072805 1038 if (!gv)
3280af22 1039 gv = PL_argvgv;
6e592b3a 1040 if (!gv || !isGV_with_GP(gv)) {
1d2dff63 1041 if (not_implicit)
93189314 1042 SETERRNO(EBADF,SS_IVCHAN);
c2ab57d4 1043 return FALSE;
99b89507 1044 }
79072805
LW
1045 io = GvIO(gv);
1046 if (!io) { /* never opened */
1d2dff63 1047 if (not_implicit) {
51087808 1048 report_evil_fh(gv);
93189314 1049 SETERRNO(EBADF,SS_IVCHAN);
1d2dff63 1050 }
a687059c
LW
1051 return FALSE;
1052 }
96d7c888 1053 retval = io_close(io, NULL, not_implicit, FALSE);
517844ec 1054 if (not_implicit) {
1193dd27
IZ
1055 IoLINES(io) = 0;
1056 IoPAGE(io) = 0;
1057 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1058 }
50952442 1059 IoTYPE(io) = IoTYPE_CLOSED;
1193dd27
IZ
1060 return retval;
1061}
1062
1063bool
96d7c888 1064Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
1193dd27
IZ
1065{
1066 bool retval = FALSE;
1193dd27 1067
7918f24d
NC
1068 PERL_ARGS_ASSERT_IO_CLOSE;
1069
8990e307 1070 if (IoIFP(io)) {
50952442 1071 if (IoTYPE(io) == IoTYPE_PIPE) {
4373e329 1072 const int status = PerlProc_pclose(IoIFP(io));
f2b5be74 1073 if (not_implicit) {
37038d91 1074 STATUS_NATIVE_CHILD_SET(status);
e5218da5 1075 retval = (STATUS_UNIX == 0);
f2b5be74
GS
1076 }
1077 else {
1078 retval = (status != -1);
1079 }
a687059c 1080 }
50952442 1081 else if (IoTYPE(io) == IoTYPE_STD)
a687059c
LW
1082 retval = TRUE;
1083 else {
8990e307 1084 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
0bcc34c2 1085 const bool prev_err = PerlIO_error(IoOFP(io));
f4725fad
FC
1086#ifdef USE_PERLIO
1087 if (prev_err)
1088 PerlIO_restore_errno(IoOFP(io));
1089#endif
e199e3be 1090 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
760ac839 1091 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4 1092 }
e199e3be 1093 else {
0bcc34c2 1094 const bool prev_err = PerlIO_error(IoIFP(io));
f4725fad
FC
1095#ifdef USE_PERLIO
1096 if (prev_err)
1097 PerlIO_restore_errno(IoIFP(io));
1098#endif
e199e3be
RGS
1099 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1100 }
a687059c 1101 }
4608196e 1102 IoOFP(io) = IoIFP(io) = NULL;
96d7c888
FC
1103
1104 if (warn_on_fail && !retval) {
1105 if (gv)
1106 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1107 "Warning: unable to close filehandle %"
1108 HEKf" properly: %"SVf,
ac892e4a
DM
1109 HEKfARG(GvNAME_HEK(gv)),
1110 SVfARG(get_sv("!",GV_ADD)));
96d7c888
FC
1111 else
1112 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1113 "Warning: unable to close filehandle "
1114 "properly: %"SVf,
ac892e4a 1115 SVfARG(get_sv("!",GV_ADD)));
96d7c888 1116 }
79072805 1117 }
f2b5be74 1118 else if (not_implicit) {
93189314 1119 SETERRNO(EBADF,SS_IVCHAN);
20408e3c 1120 }
1193dd27 1121
a687059c
LW
1122 return retval;
1123}
1124
1125bool
864dbfa3 1126Perl_do_eof(pTHX_ GV *gv)
a687059c 1127{
eb578fdb 1128 IO * const io = GvIO(gv);
a687059c 1129
7918f24d
NC
1130 PERL_ARGS_ASSERT_DO_EOF;
1131
79072805 1132 if (!io)
a687059c 1133 return TRUE;
7716c5c5 1134 else if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1135 report_wrongway_fh(gv, '>');
a687059c 1136
8990e307 1137 while (IoIFP(io)) {
760ac839 1138 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
a20bf0c3 1139 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
760ac839
LW
1140 return FALSE; /* this is the most usual case */
1141 }
a687059c 1142
79852593
NC
1143 {
1144 /* getc and ungetc can stomp on errno */
4ee39169 1145 dSAVE_ERRNO;
79852593
NC
1146 const int ch = PerlIO_getc(IoIFP(io));
1147 if (ch != EOF) {
1148 (void)PerlIO_ungetc(IoIFP(io),ch);
4ee39169 1149 RESTORE_ERRNO;
79852593
NC
1150 return FALSE;
1151 }
4ee39169 1152 RESTORE_ERRNO;
a687059c 1153 }
fab3f3a7 1154
760ac839 1155 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
a20bf0c3
JH
1156 if (PerlIO_get_cnt(IoIFP(io)) < -1)
1157 PerlIO_set_cnt(IoIFP(io),-1);
760ac839 1158 }
533c011a 1159 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
157fb5a1 1160 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */
a687059c
LW
1161 return TRUE;
1162 }
1163 else
1164 return TRUE; /* normal fp, definitely end of file */
1165 }
1166 return TRUE;
1167}
1168
5ff3f7a4 1169Off_t
864dbfa3 1170Perl_do_tell(pTHX_ GV *gv)
a687059c 1171{
9c9f25b8 1172 IO *const io = GvIO(gv);
eb578fdb 1173 PerlIO *fp;
a687059c 1174
7918f24d
NC
1175 PERL_ARGS_ASSERT_DO_TELL;
1176
9c9f25b8 1177 if (io && (fp = IoIFP(io))) {
8903cb82 1178 return PerlIO_tell(fp);
96e4d5b1 1179 }
51087808 1180 report_evil_fh(gv);
93189314 1181 SETERRNO(EBADF,RMS_IFI);
5ff3f7a4 1182 return (Off_t)-1;
a687059c
LW
1183}
1184
1185bool
864dbfa3 1186Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 1187{
9c9f25b8 1188 IO *const io = GvIO(gv);
eb578fdb 1189 PerlIO *fp;
a687059c 1190
9c9f25b8 1191 if (io && (fp = IoIFP(io))) {
8903cb82 1192 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 1193 }
51087808 1194 report_evil_fh(gv);
93189314 1195 SETERRNO(EBADF,RMS_IFI);
a687059c
LW
1196 return FALSE;
1197}
1198
97cc44eb 1199Off_t
864dbfa3 1200Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82 1201{
9c9f25b8 1202 IO *const io = GvIO(gv);
eb578fdb 1203 PerlIO *fp;
8903cb82 1204
7918f24d
NC
1205 PERL_ARGS_ASSERT_DO_SYSSEEK;
1206
375ed12a
JH
1207 if (io && (fp = IoIFP(io))) {
1208 int fd = PerlIO_fileno(fp);
07bd88da
JH
1209 if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
1210 SETERRNO(EINVAL,LIB_INVARG);
1211 return -1;
1212 } else {
375ed12a
JH
1213 return PerlLIO_lseek(fd, pos, whence);
1214 }
1215 }
51087808 1216 report_evil_fh(gv);
93189314 1217 SETERRNO(EBADF,RMS_IFI);
d9b3e12d 1218 return (Off_t)-1;
8903cb82 1219}
1220
6ff81951 1221int
a79b25b7 1222Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
16fe6d59
GS
1223{
1224 int mode = O_BINARY;
81611534 1225 PERL_UNUSED_CONTEXT;
a79b25b7 1226 if (s) {
16fe6d59
GS
1227 while (*s) {
1228 if (*s == ':') {
1229 switch (s[1]) {
1230 case 'r':
e963d6d2 1231 if (s[2] == 'a' && s[3] == 'w'
16fe6d59
GS
1232 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1233 {
1234 mode = O_BINARY;
1235 s += 4;
1236 len -= 4;
1237 break;
1238 }
924ba076 1239 /* FALLTHROUGH */
16fe6d59 1240 case 'c':
e963d6d2 1241 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
16fe6d59
GS
1242 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1243 {
1244 mode = O_TEXT;
1245 s += 5;
1246 len -= 5;
1247 break;
1248 }
924ba076 1249 /* FALLTHROUGH */
16fe6d59
GS
1250 default:
1251 goto fail_discipline;
1252 }
1253 }
1254 else if (isSPACE(*s)) {
1255 ++s;
1256 --len;
1257 }
1258 else {
4373e329 1259 const char *end;
7b52d656 1260 fail_discipline:
16fe6d59
GS
1261 end = strchr(s+1, ':');
1262 if (!end)
1263 end = s+len;
60382766 1264#ifndef PERLIO_LAYERS
363c40c4 1265 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
60382766 1266#else
18a33fb5 1267 len -= end-s;
60382766
NIS
1268 s = end;
1269#endif
16fe6d59
GS
1270 }
1271 }
1272 }
1273 return mode;
1274}
1275
58e24eff 1276#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
27da23d5
JH
1277I32
1278my_chsize(int fd, Off_t length)
6eb13c3b 1279{
58e24eff
SH
1280#ifdef F_FREESP
1281 /* code courtesy of William Kucharski */
1282#define HAS_CHSIZE
1283
c623ac67 1284 Stat_t filebuf;
6eb13c3b 1285
3028581b 1286 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
1287 return -1;
1288
1289 if (filebuf.st_size < length) {
1290
1291 /* extend file length */
1292
3028581b 1293 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
1294 return -1;
1295
1296 /* write a "0" byte */
1297
3028581b 1298 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
1299 return -1;
1300 }
1301 else {
1302 /* truncate length */
35da51f7 1303 struct flock fl;
6eb13c3b
LW
1304 fl.l_whence = 0;
1305 fl.l_len = 0;
1306 fl.l_start = length;
a0d0e21e 1307 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
1308
1309 /*
a0d0e21e 1310 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
1311 * fcntl(2), which truncates the file so that it ends at the
1312 * position indicated by fl.l_start.
1313 *
1314 * Will minor miracles never cease?
1315 */
1316
a0d0e21e 1317 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
1318 return -1;
1319
1320 }
6eb13c3b 1321 return 0;
58e24eff 1322#else
27da23d5 1323 Perl_croak_nocontext("truncate not implemented");
a0d0e21e 1324#endif /* F_FREESP */
27da23d5 1325 return -1;
58e24eff
SH
1326}
1327#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
ff8e2863 1328
a687059c 1329bool
5aaab254 1330Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
a687059c 1331{
7918f24d
NC
1332 PERL_ARGS_ASSERT_DO_PRINT;
1333
79072805
LW
1334 /* assuming fp is checked earlier */
1335 if (!sv)
1336 return TRUE;
e9950d3b
NC
1337 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
1338 assert(!SvGMAGICAL(sv));
1339 if (SvIsUV(sv))
1340 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
1341 else
1342 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
1343 return !PerlIO_error(fp);
1344 }
1345 else {
1346 STRLEN len;
676f44e7 1347 /* Do this first to trigger any overloading. */
e9950d3b
NC
1348 const char *tmps = SvPV_const(sv, len);
1349 U8 *tmpbuf = NULL;
1350 bool happy = TRUE;
1351
d791f93f
KW
1352 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
1353 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
676f44e7
NC
1354 /* We don't modify the original scalar. */
1355 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
1356 tmps = (char *) tmpbuf;
1357 }
a099aed4 1358 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
0876b9a0
KW
1359 (void) check_utf8_print((const U8*) tmps, len);
1360 }
d791f93f
KW
1361 } /* else stream isn't utf8 */
1362 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
1363 convert to bytes */
676f44e7
NC
1364 STRLEN tmplen = len;
1365 bool utf8 = TRUE;
35da51f7 1366 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
676f44e7 1367 if (!utf8) {
d791f93f
KW
1368
1369 /* Here, succeeded in downgrading from utf8. Set up to below
1370 * output the converted value */
676f44e7
NC
1371 tmpbuf = result;
1372 tmps = (char *) tmpbuf;
1373 len = tmplen;
1374 }
d791f93f
KW
1375 else { /* Non-utf8 output stream, but string only representable in
1376 utf8 */
676f44e7 1377 assert((char *)result == tmps);
9b387841 1378 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
21630838
FC
1379 "Wide character in %s",
1380 PL_op ? OP_DESC(PL_op) : "print"
1381 );
0876b9a0
KW
1382 /* Could also check that isn't one of the things to avoid
1383 * in utf8 by using check_utf8_print(), but not doing so,
1384 * since the stream isn't a UTF8 stream */
ae798467
NIS
1385 }
1386 }
e9950d3b
NC
1387 /* To detect whether the process is about to overstep its
1388 * filesize limit we would need getrlimit(). We could then
1389 * also transparently raise the limit with setrlimit() --
1390 * but only until the system hard limit/the filesystem limit,
1391 * at which we would get EPERM. Note that when using buffered
1392 * io the write failure can be delayed until the flush/close. --jhi */
1393 if (len && (PerlIO_write(fp,tmps,len) == 0))
1394 happy = FALSE;
1395 Safefree(tmpbuf);
1396 return happy ? !PerlIO_error(fp) : FALSE;
ff8e2863 1397 }
a687059c
LW
1398}
1399
79072805 1400I32
0d7d409d 1401Perl_my_stat_flags(pTHX_ const U32 flags)
a687059c 1402{
39644a26 1403 dSP;
79072805 1404 IO *io;
2dd78f96 1405 GV* gv;
79072805 1406
533c011a 1407 if (PL_op->op_flags & OPf_REF) {
2dd78f96 1408 gv = cGVOP_gv;
748a9306 1409 do_fstat:
5228a96c
SP
1410 if (gv == PL_defgv)
1411 return PL_laststatval;
2dd78f96 1412 io = GvIO(gv);
ad02613c 1413 do_fstat_have_io:
5228a96c 1414 PL_laststype = OP_STAT;
bd5f6c01 1415 PL_statgv = gv ? gv : (GV *)io;
76f68e9b 1416 sv_setpvs(PL_statname, "");
77616968 1417 if (io) {
5228a96c 1418 if (IoIFP(io)) {
375ed12a 1419 int fd = PerlIO_fileno(IoIFP(io));
77616968
JH
1420 if (fd < 0) {
1421 /* E.g. PerlIO::scalar has no real fd. */
1422 return (PL_laststatval = -1);
1423 } else {
375ed12a
JH
1424 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
1425 }
5228a96c 1426 } else if (IoDIRP(io)) {
3497a01f 1427 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
5228a96c 1428 }
5228a96c 1429 }
3888144c
FC
1430 PL_laststatval = -1;
1431 report_evil_fh(gv);
1432 return -1;
a687059c 1433 }
d2c4d2d1 1434 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
8db8f6b6
FC
1435 == OPpFT_STACKED)
1436 return PL_laststatval;
d2c4d2d1
FC
1437 else {
1438 SV* const sv = TOPs;
4373e329 1439 const char *s;
4ecd490c 1440 STRLEN len;
094a3eec 1441 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
748a9306
LW
1442 goto do_fstat;
1443 }
ad02613c 1444 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 1445 io = MUTABLE_IO(SvRV(sv));
7f39519f 1446 gv = NULL;
ad02613c
SP
1447 goto do_fstat_have_io;
1448 }
748a9306 1449
0d7d409d 1450 s = SvPV_flags_const(sv, len, flags);
a0714e2c 1451 PL_statgv = NULL;
4ecd490c 1452 sv_setpvn(PL_statname, s, len);
95a20fc0 1453 s = SvPVX_const(PL_statname); /* s now NUL-terminated */
3280af22
NIS
1454 PL_laststype = OP_STAT;
1455 PL_laststatval = PerlLIO_stat(s, &PL_statcache);
7cb3f959 1456 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
5d37acd6 1457 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 1458 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
5d37acd6
DM
1459 GCC_DIAG_RESTORE;
1460 }
3280af22 1461 return PL_laststatval;
a687059c
LW
1462 }
1463}
1464
fbb0b3b3 1465
79072805 1466I32
0d7d409d 1467Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 1468{
a1894d81 1469 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 1470 dSP;
b16276bb 1471 const char *file;
cd22fad3 1472 SV* const sv = TOPs;
5840701a 1473 bool isio = FALSE;
533c011a 1474 if (PL_op->op_flags & OPf_REF) {
638eceb6 1475 if (cGVOP_gv == PL_defgv) {
3280af22 1476 if (PL_laststype != OP_LSTAT)
0157ef98 1477 Perl_croak(aTHX_ "%s", no_prev_lstat);
3280af22 1478 return PL_laststatval;
fe14fcc3 1479 }
31b139ba 1480 PL_laststatval = -1;
5d3e98de 1481 if (ckWARN(WARN_IO)) {
5840701a 1482 /* diag_listed_as: Use of -l on filehandle%s */
d0c0e7dd
FC
1483 Perl_warner(aTHX_ packWARN(WARN_IO),
1484 "Use of -l on filehandle %"HEKf,
1485 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 1486 }
31b139ba 1487 return -1;
fe14fcc3 1488 }
8db8f6b6
FC
1489 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1490 == OPpFT_STACKED) {
1f26655e 1491 if (PL_laststype != OP_LSTAT)
0157ef98 1492 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 1493 return PL_laststatval;
cd22fad3 1494 }
c623bd54 1495
3280af22 1496 PL_laststype = OP_LSTAT;
a0714e2c 1497 PL_statgv = NULL;
5840701a
FC
1498 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
1499 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
1500 )
1501 || isGV_with_GP(sv)
1502 )
1503 && ckWARN(WARN_IO)) {
1504 if (isio)
1505 /* diag_listed_as: Use of -l on filehandle%s */
1506 Perl_warner(aTHX_ packWARN(WARN_IO),
1507 "Use of -l on filehandle");
1508 else
1509 /* diag_listed_as: Use of -l on filehandle%s */
1510 Perl_warner(aTHX_ packWARN(WARN_IO),
1511 "Use of -l on filehandle %"HEKf,
10bafe90
BF
1512 HEKfARG(GvENAME_HEK((const GV *)
1513 (SvROK(sv) ? SvRV(sv) : sv))));
cd22fad3
RS
1514 }
1515 file = SvPV_flags_const_nolen(sv, flags);
b16276bb
VP
1516 sv_setpv(PL_statname,file);
1517 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
7cb3f959 1518 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
5d37acd6
DM
1519 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
1520 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
1521 GCC_DIAG_RESTORE;
1522 }
3280af22 1523 return PL_laststatval;
c623bd54
LW
1524}
1525
a0f2c8ec
JD
1526static void
1527S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
1528{
1529 const int e = errno;
7918f24d 1530 PERL_ARGS_ASSERT_EXEC_FAILED;
a0f2c8ec
JD
1531 if (ckWARN(WARN_EXEC))
1532 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1533 cmd, Strerror(e));
1534 if (do_report) {
b469f1e0
JH
1535 /* XXX silently ignore failures */
1536 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
a0f2c8ec
JD
1537 PerlLIO_close(fd);
1538 }
1539}
1540
d5a9bfb0 1541bool
5aaab254 1542Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2aa1486d 1543 int fd, int do_report)
d5a9bfb0 1544{
27da23d5 1545 dVAR;
7918f24d 1546 PERL_ARGS_ASSERT_DO_AEXEC5;
e37778c2 1547#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
cd39f2b6
JH
1548 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1549#else
79072805 1550 if (sp > mark) {
360ea906 1551 const char **a;
6136c704 1552 const char *tmps = NULL;
360ea906 1553 Newx(PL_Argv, sp - mark + 1, const char*);
c3c5fad7 1554 a = PL_Argv;
890ce7af 1555
79072805
LW
1556 while (++mark <= sp) {
1557 if (*mark)
360ea906 1558 *a++ = SvPV_nolen_const(*mark);
a687059c
LW
1559 else
1560 *a++ = "";
1561 }
6136c704 1562 *a = NULL;
91b2752f 1563 if (really)
e62f0680 1564 tmps = SvPV_nolen_const(really);
91b2752f
RG
1565 if ((!really && *PL_Argv[0] != '/') ||
1566 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 1567 TAINT_ENV(); /* testing IFS here is overkill, probably */
b35112e7 1568 PERL_FPU_PRE_EXEC
91b2752f 1569 if (really && *tmps)
b4748376 1570 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
a687059c 1571 else
b4748376 1572 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1573 PERL_FPU_POST_EXEC
a0f2c8ec 1574 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
a687059c 1575 }
bee1dbe2 1576 do_execfree();
cd39f2b6 1577#endif
a687059c
LW
1578 return FALSE;
1579}
1580
fe14fcc3 1581void
864dbfa3 1582Perl_do_execfree(pTHX)
ff8e2863 1583{
43c5f42d 1584 Safefree(PL_Argv);
4608196e 1585 PL_Argv = NULL;
43c5f42d 1586 Safefree(PL_Cmd);
bd61b366 1587 PL_Cmd = NULL;
ff8e2863
LW
1588}
1589
9555a685 1590#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8
IZ
1591
1592bool
2fbb330f 1593Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 1594{
27da23d5 1595 dVAR;
eb578fdb
KW
1596 const char **a;
1597 char *s;
15db3ae2 1598 char *buf;
2fbb330f 1599 char *cmd;
2fbb330f 1600 /* Make a copy so we can change it */
6fca0082 1601 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC
1602
1603 PERL_ARGS_ASSERT_DO_EXEC3;
1604
15db3ae2
DM
1605 Newx(buf, cmdlen, char);
1606 cmd = buf;
cfff9797 1607 memcpy(cmd, incmd, cmdlen);
a687059c 1608
748a9306
LW
1609 while (*cmd && isSPACE(*cmd))
1610 cmd++;
1611
a687059c
LW
1612 /* save an extra exec if possible */
1613
bf38876a 1614#ifdef CSH
d05c1ba0 1615 {
0c19750d 1616 char flags[PERL_FLAGS_MAX];
d05c1ba0
JH
1617 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
1618 strnEQ(cmd+PL_cshlen," -c",3)) {
28f0d0ec 1619 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
d05c1ba0
JH
1620 s = cmd+PL_cshlen+3;
1621 if (*s == 'f') {
1622 s++;
28f0d0ec 1623 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
d05c1ba0
JH
1624 }
1625 if (*s == ' ')
1626 s++;
1627 if (*s++ == '\'') {
0bcc34c2 1628 char * const ncmd = s;
d05c1ba0
JH
1629
1630 while (*s)
1631 s++;
1632 if (s[-1] == '\n')
1633 *--s = '\0';
1634 if (s[-1] == '\'') {
1635 *--s = '\0';
b35112e7 1636 PERL_FPU_PRE_EXEC
7c0dd7ca 1637 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
b35112e7 1638 PERL_FPU_POST_EXEC
d05c1ba0 1639 *s = '\'';
a0f2c8ec 1640 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
15db3ae2 1641 Safefree(buf);
d05c1ba0
JH
1642 return FALSE;
1643 }
1644 }
a687059c
LW
1645 }
1646 }
bf38876a 1647#endif /* CSH */
a687059c
LW
1648
1649 /* see if there are shell metacharacters in it */
1650
748a9306
LW
1651 if (*cmd == '.' && isSPACE(cmd[1]))
1652 goto doshell;
1653
1654 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1655 goto doshell;
1656
294b3b39 1657 s = cmd;
0eb30aeb 1658 while (isWORDCHAR(*s))
294b3b39 1659 s++; /* catch VAR=val gizmo */
63f2c1e1
LW
1660 if (*s == '=')
1661 goto doshell;
748a9306 1662
a687059c 1663 for (s = cmd; *s; s++) {
d05c1ba0
JH
1664 if (*s != ' ' && !isALPHA(*s) &&
1665 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1666 if (*s == '\n' && !s[1]) {
1667 *s = '\0';
1668 break;
1669 }
603a98b0
IZ
1670 /* handle the 2>&1 construct at the end */
1671 if (*s == '>' && s[1] == '&' && s[2] == '1'
1672 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1673 && (!s[3] || isSPACE(s[3])))
1674 {
6867be6d 1675 const char *t = s + 3;
603a98b0
IZ
1676
1677 while (*t && isSPACE(*t))
1678 ++t;
943bbd07 1679 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
603a98b0
IZ
1680 s[-2] = '\0';
1681 break;
1682 }
1683 }
a687059c 1684 doshell:
b35112e7 1685 PERL_FPU_PRE_EXEC
7c0dd7ca 1686 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
b35112e7 1687 PERL_FPU_POST_EXEC
a0f2c8ec 1688 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
15db3ae2 1689 Safefree(buf);
a687059c
LW
1690 return FALSE;
1691 }
1692 }
748a9306 1693
360ea906 1694 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*);
3280af22
NIS
1695 PL_Cmd = savepvn(cmd, s-cmd);
1696 a = PL_Argv;
1697 for (s = PL_Cmd; *s;) {
294b3b39
AL
1698 while (isSPACE(*s))
1699 s++;
a687059c
LW
1700 if (*s)
1701 *(a++) = s;
294b3b39
AL
1702 while (*s && !isSPACE(*s))
1703 s++;
a687059c
LW
1704 if (*s)
1705 *s++ = '\0';
1706 }
6136c704 1707 *a = NULL;
3280af22 1708 if (PL_Argv[0]) {
b35112e7 1709 PERL_FPU_PRE_EXEC
360ea906 1710 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1711 PERL_FPU_POST_EXEC
b1248f16 1712 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1713 do_execfree();
a687059c 1714 goto doshell;
b1248f16 1715 }
a0f2c8ec 1716 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
a687059c 1717 }
ff8e2863 1718 do_execfree();
15db3ae2 1719 Safefree(buf);
a687059c
LW
1720 return FALSE;
1721}
1722
6890e559 1723#endif /* OS2 || WIN32 */
760ac839 1724
25bbd826
CB
1725#ifdef VMS
1726#include <starlet.h> /* for sys$delprc */
1727#endif
1728
79072805 1729I32
5aaab254 1730Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
a687059c 1731{
eb578fdb
KW
1732 I32 val;
1733 I32 tot = 0;
4634a855 1734 const char *const what = PL_op_name[type];
5c144d81 1735 const char *s;
84c7b88c 1736 STRLEN len;
890ce7af 1737 SV ** const oldmark = mark;
885b4b39 1738 bool killgp = FALSE;
a687059c 1739
7918f24d
NC
1740 PERL_ARGS_ASSERT_APPLY;
1741
9a9b5ec9
DM
1742 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
1743
1444765e
NC
1744 /* Doing this ahead of the switch statement preserves the old behaviour,
1745 where attempting to use kill as a taint test test would fail on
1746 platforms where kill was not defined. */
1747#ifndef HAS_KILL
1748 if (type == OP_KILL)
4634a855 1749 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1750#endif
1751#ifndef HAS_CHOWN
1752 if (type == OP_CHOWN)
4634a855 1753 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1754#endif
1755
1756
20408e3c 1757#define APPLY_TAINT_PROPER() \
3280af22 1758 STMT_START { \
284167a5 1759 if (TAINT_get) { TAINT_PROPER(what); } \
873ef191 1760 } STMT_END
20408e3c
GS
1761
1762 /* This is a first heuristic; it doesn't catch tainting magic. */
284167a5 1763 if (TAINTING_get) {
463ee0b2 1764 while (++mark <= sp) {
bbce6d69 1765 if (SvTAINTED(*mark)) {
1766 TAINT;
1767 break;
1768 }
463ee0b2
LW
1769 }
1770 mark = oldmark;
1771 }
a687059c 1772 switch (type) {
79072805 1773 case OP_CHMOD:
20408e3c 1774 APPLY_TAINT_PROPER();
79072805 1775 if (++mark <= sp) {
4ea561bc 1776 val = SvIV(*mark);
20408e3c
GS
1777 APPLY_TAINT_PROPER();
1778 tot = sp - mark;
79072805 1779 while (++mark <= sp) {
c4aca7d0 1780 GV* gv;
2ea1cce7 1781 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1782 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1783#ifdef HAS_FCHMOD
375ed12a 1784 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 1785 APPLY_TAINT_PROPER();
375ed12a
JH
1786 if (fd < 0) {
1787 SETERRNO(EBADF,RMS_IFI);
1788 tot--;
1789 } else if (fchmod(fd, val))
1790 tot--;
c4aca7d0 1791#else
b9c6780e 1792 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0
GA
1793#endif
1794 }
1795 else {
8334cae6 1796 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA
1797 tot--;
1798 }
1799 }
c4aca7d0 1800 else {
41188aa0 1801 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 1802 APPLY_TAINT_PROPER();
41188aa0 1803 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC
1804 PerlLIO_chmod(name, val)) {
1805 tot--;
1806 }
c4aca7d0 1807 }
a687059c
LW
1808 }
1809 }
1810 break;
fe14fcc3 1811#ifdef HAS_CHOWN
79072805 1812 case OP_CHOWN:
20408e3c 1813 APPLY_TAINT_PROPER();
79072805 1814 if (sp - mark > 2) {
eb578fdb 1815 I32 val2;
463ee0b2
LW
1816 val = SvIVx(*++mark);
1817 val2 = SvIVx(*++mark);
20408e3c 1818 APPLY_TAINT_PROPER();
a0d0e21e 1819 tot = sp - mark;
79072805 1820 while (++mark <= sp) {
c4aca7d0 1821 GV* gv;
2ea1cce7 1822 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1823 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1824#ifdef HAS_FCHOWN
375ed12a 1825 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 1826 APPLY_TAINT_PROPER();
375ed12a
JH
1827 if (fd < 0) {
1828 SETERRNO(EBADF,RMS_IFI);
1829 tot--;
1830 } else if (fchown(fd, val, val2))
c4aca7d0
GA
1831 tot--;
1832#else
b9c6780e 1833 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0
GA
1834#endif
1835 }
1836 else {
8334cae6 1837 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA
1838 tot--;
1839 }
1840 }
c4aca7d0 1841 else {
41188aa0 1842 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 1843 APPLY_TAINT_PROPER();
41188aa0 1844 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 1845 PerlLIO_chown(name, val, val2)) {
c4aca7d0 1846 tot--;
c8028aa6 1847 }
c4aca7d0 1848 }
a687059c
LW
1849 }
1850 }
1851 break;
b1248f16 1852#endif
a1d180c4 1853/*
dd64f1c3
AD
1854XXX Should we make lchown() directly available from perl?
1855For now, we'll let Configure test for HAS_LCHOWN, but do
1856nothing in the core.
1857 --AD 5/1998
1858*/
fe14fcc3 1859#ifdef HAS_KILL
79072805 1860 case OP_KILL:
20408e3c 1861 APPLY_TAINT_PROPER();
55497cff 1862 if (mark == sp)
1863 break;
84c7b88c 1864 s = SvPVx_const(*++mark, len);
c2fd40cb
DM
1865 if (*s == '-' && isALPHA(s[1]))
1866 {
1867 s++;
1868 len--;
885b4b39 1869 killgp = TRUE;
c2fd40cb 1870 }
e02bfb16 1871 if (isALPHA(*s)) {
84c7b88c 1872 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
79072805 1873 s += 3;
84c7b88c
BF
1874 len -= 3;
1875 }
1876 if ((val = whichsig_pvn(s, len)) < 0)
1877 Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
79072805
LW
1878 }
1879 else
c2fd40cb 1880 {
4ea561bc 1881 val = SvIV(*mark);
c2fd40cb
DM
1882 if (val < 0)
1883 {
885b4b39 1884 killgp = TRUE;
c2fd40cb
DM
1885 val = -val;
1886 }
1887 }
20408e3c
GS
1888 APPLY_TAINT_PROPER();
1889 tot = sp - mark;
3595fcef 1890#ifdef VMS
1891 /* kill() doesn't do process groups (job trees?) under VMS */
3595fcef 1892 if (val == SIGKILL) {
3595fcef 1893 /* Use native sys$delprc() to insure that target process is
1894 * deleted; supervisor-mode images don't pay attention to
1895 * CRTL's emulation of Unix-style signals and kill()
1896 */
1897 while (++mark <= sp) {
5f521955 1898 I32 proc;
eb578fdb 1899 unsigned long int __vmssts;
8af710eb 1900 SvGETMAGIC(*mark);
e2c0f81f
DG
1901 if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
1902 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
8af710eb 1903 proc = SvIV_nomg(*mark);
20408e3c 1904 APPLY_TAINT_PROPER();
3595fcef 1905 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1906 tot--;
1907 switch (__vmssts) {
1908 case SS$_NONEXPR:
1909 case SS$_NOSUCHNODE:
1910 SETERRNO(ESRCH,__vmssts);
1911 break;
1912 case SS$_NOPRIV:
1913 SETERRNO(EPERM,__vmssts);
1914 break;
1915 default:
1916 SETERRNO(EVMSERR,__vmssts);
1917 }
1918 }
1919 }
8165faea 1920 PERL_ASYNC_CHECK();
3595fcef 1921 break;
1922 }
1923#endif
c2fd40cb 1924 while (++mark <= sp) {
60082291 1925 Pid_t proc;
c2fd40cb 1926 SvGETMAGIC(*mark);
60082291 1927 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
c2fd40cb
DM
1928 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
1929 proc = SvIV_nomg(*mark);
c2fd40cb 1930 APPLY_TAINT_PROPER();
111f73b5
DM
1931#ifdef HAS_KILLPG
1932 /* use killpg in preference, as the killpg() wrapper for Win32
1933 * understands process groups, but the kill() wrapper doesn't */
1934 if (killgp ? PerlProc_killpg(proc, val)
1935 : PerlProc_kill(proc, val))
1936#else
1937 if (PerlProc_kill(killgp ? -proc: proc, val))
1938#endif
c2fd40cb 1939 tot--;
a687059c 1940 }
8165faea 1941 PERL_ASYNC_CHECK();
a687059c 1942 break;
b1248f16 1943#endif
79072805 1944 case OP_UNLINK:
20408e3c 1945 APPLY_TAINT_PROPER();
79072805
LW
1946 tot = sp - mark;
1947 while (++mark <= sp) {
41188aa0 1948 s = SvPV_const(*mark, len);
20408e3c 1949 APPLY_TAINT_PROPER();
41188aa0 1950 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC
1951 tot--;
1952 }
f0d85c30 1953 else if (PL_unsafe) {
b8ffc8df 1954 if (UNLINK(s))
a687059c
LW
1955 tot--;
1956 }
1957 else { /* don't let root wipe out directories without -U */
1dcae8b8 1958 if (PerlLIO_lstat(s,&PL_statbuf) < 0)
a687059c 1959 tot--;
1dcae8b8
EZ
1960 else if (S_ISDIR(PL_statbuf.st_mode)) {
1961 tot--;
cd52bc19 1962 SETERRNO(EISDIR, SS_NOPRIV);
1dcae8b8 1963 }
a687059c 1964 else {
b8ffc8df 1965 if (UNLINK(s))
a687059c
LW
1966 tot--;
1967 }
1968 }
1969 }
1970 break;
e96b369d 1971#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 1972 case OP_UTIME:
20408e3c 1973 APPLY_TAINT_PROPER();
79072805 1974 if (sp - mark > 2) {
e96b369d
GA
1975#if defined(HAS_FUTIMES)
1976 struct timeval utbuf[2];
1977 void *utbufp = utbuf;
1978#elif defined(I_UTIME) || defined(VMS)
663a0e37 1979 struct utimbuf utbuf;
07409e01 1980 struct utimbuf *utbufp = &utbuf;
663a0e37 1981#else
a687059c 1982 struct {
dd2821f6
GS
1983 Time_t actime;
1984 Time_t modtime;
a687059c 1985 } utbuf;
07409e01 1986 void *utbufp = &utbuf;
663a0e37 1987#endif
a687059c 1988
0bcc34c2
AL
1989 SV* const accessed = *++mark;
1990 SV* const modified = *++mark;
c6f7b413 1991
6ec06612
SB
1992 /* Be like C, and if both times are undefined, let the C
1993 * library figure out what to do. This usually means
1994 * "current time". */
c6f7b413
RS
1995
1996 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB
1997 utbufp = NULL;
1998 else {
1999 Zero(&utbuf, sizeof utbuf, char);
e96b369d 2000#ifdef HAS_FUTIMES
4ea561bc 2001 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 2002 utbuf[0].tv_usec = 0;
4ea561bc 2003 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA
2004 utbuf[1].tv_usec = 0;
2005#elif defined(BIG_TIME)
4ea561bc
NC
2006 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
2007 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 2008#else
4ea561bc
NC
2009 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
2010 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 2011#endif
6ec06612 2012 }
4373e329 2013 APPLY_TAINT_PROPER();
79072805
LW
2014 tot = sp - mark;
2015 while (++mark <= sp) {
e96b369d 2016 GV* gv;
64617da9 2017 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA
2018 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2019#ifdef HAS_FUTIMES
375ed12a 2020 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
e96b369d 2021 APPLY_TAINT_PROPER();
375ed12a
JH
2022 if (fd < 0) {
2023 SETERRNO(EBADF,RMS_IFI);
2024 tot--;
2025 } else if (futimes(fd, (struct timeval *) utbufp))
e96b369d
GA
2026 tot--;
2027#else
2028 Perl_die(aTHX_ PL_no_func, "futimes");
2029#endif
2030 }
2031 else {
2032 tot--;
2033 }
2034 }
e96b369d 2035 else {
41188aa0 2036 const char * const name = SvPV_nomg_const(*mark, len);
e96b369d 2037 APPLY_TAINT_PROPER();
41188aa0 2038 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC
2039 tot--;
2040 }
2041 else
e96b369d 2042#ifdef HAS_FUTIMES
8b7231d9 2043 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA
2044#else
2045 if (PerlLIO_utime(name, utbufp))
2046#endif
2047 tot--;
2048 }
2049
a687059c 2050 }
a687059c
LW
2051 }
2052 else
79072805 2053 tot = 0;
a687059c 2054 break;
a0d0e21e 2055#endif
a687059c
LW
2056 }
2057 return tot;
20408e3c 2058
20408e3c 2059#undef APPLY_TAINT_PROPER
a687059c
LW
2060}
2061
2062/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 2063#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 2064bool
5aaab254 2065Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC
2066/* effective is a flag, true for EUID, or for checking if the effective gid
2067 * is in the list of groups returned from getgroups().
2068 */
a687059c 2069{
7918f24d 2070 PERL_ARGS_ASSERT_CANDO;
81611534 2071 PERL_UNUSED_CONTEXT;
7918f24d 2072
bee1dbe2 2073#ifdef DOSISH
fe14fcc3
LW
2074 /* [Comments and code from Len Reed]
2075 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
2076 * to write-protected files. The execute permission bit is set
486ec47a 2077 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW
2078 * .exe files
2079 * .com files
2080 * .bat files
2081 * directories
2082 * All files and directories are readable.
2083 * Directories and special files, e.g. "CON", cannot be
2084 * write-protected.
2085 * [Comment by Tom Dinger -- a directory can have the write-protect
2086 * bit set in the file system, but DOS permits changes to
2087 * the directory anyway. In addition, all bets are off
2088 * here for networked software, such as Novell and
2089 * Sun's PC-NFS.]
2090 */
2091
bee1dbe2
LW
2092 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
2093 * too so it will actually look into the files for magic numbers
2094 */
7f4774ae 2095 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 2096
55497cff 2097#else /* ! DOSISH */
b595cd4b
RU
2098# ifdef __CYGWIN__
2099 if (ingroup(544,effective)) { /* member of Administrators */
2100# else
985213f2 2101 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 2102# endif
7f4774ae 2103 if (mode == S_IXUSR) {
c623bd54 2104 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
2105 return TRUE;
2106 }
2107 else
2108 return TRUE; /* root reads and writes anything */
2109 return FALSE;
2110 }
985213f2 2111 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 2112 if (statbufp->st_mode & mode)
a687059c
LW
2113 return TRUE; /* ok as "user" */
2114 }
d8eceb89 2115 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 2116 if (statbufp->st_mode & mode >> 3)
a687059c
LW
2117 return TRUE; /* ok as "group" */
2118 }
7f4774ae 2119 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
2120 return TRUE; /* ok as "other" */
2121 return FALSE;
55497cff 2122#endif /* ! DOSISH */
a687059c 2123}
a0d0e21e 2124#endif /* ! VMS */
a687059c 2125
1f676739 2126static bool
0da8eb3a 2127S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 2128{
81611534
JH
2129#ifndef PERL_IMPLICIT_SYS
2130 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */
2131 PERL_UNUSED_CONTEXT;
2132#endif
985213f2 2133 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 2134 return TRUE;
fe14fcc3 2135#ifdef HAS_GETGROUPS
a687059c 2136 {
331b57bc 2137 Groups_t *gary = NULL;
79072805 2138 I32 anum;
331b57bc 2139 bool rc = FALSE;
a687059c 2140
331b57bc 2141 anum = getgroups(0, gary);
375ed12a
JH
2142 if (anum > 0) {
2143 Newx(gary, anum, Groups_t);
2144 anum = getgroups(anum, gary);
2145 while (--anum >= 0)
2146 if (gary[anum] == testgid) {
2147 rc = TRUE;
2148 break;
2149 }
331b57bc 2150
375ed12a
JH
2151 Safefree(gary);
2152 }
331b57bc 2153 return rc;
a687059c 2154 }
c685562b 2155#else
a687059c 2156 return FALSE;
cd39f2b6 2157#endif
a687059c 2158}
c2ab57d4 2159
fe14fcc3 2160#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2161
79072805 2162I32
864dbfa3 2163Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2164{
0bcc34c2 2165 const key_t key = (key_t)SvNVx(*++mark);
c3312966 2166 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 2167 const I32 flags = SvIVx(*++mark);
294a48e9 2168
7918f24d 2169 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 2170 PERL_UNUSED_ARG(sp);
c2ab57d4 2171
748a9306 2172 SETERRNO(0,0);
c2ab57d4
LW
2173 switch (optype)
2174 {
fe14fcc3 2175#ifdef HAS_MSG
79072805 2176 case OP_MSGGET:
c2ab57d4 2177 return msgget(key, flags);
e5d73d77 2178#endif
fe14fcc3 2179#ifdef HAS_SEM
79072805 2180 case OP_SEMGET:
c3312966 2181 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2182#endif
fe14fcc3 2183#ifdef HAS_SHM
79072805 2184 case OP_SHMGET:
c3312966 2185 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 2186#endif
fe14fcc3 2187#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2188 default:
fe13d51d 2189 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2190 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2191#endif
c2ab57d4
LW
2192 }
2193 return -1; /* should never happen */
2194}
2195
79072805 2196I32
864dbfa3 2197Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2198{
c2ab57d4 2199 char *a;
a0d0e21e 2200 I32 ret = -1;
6867be6d 2201 const I32 id = SvIVx(*++mark);
95b63a38 2202#ifdef Semctl
6867be6d 2203 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2204#endif
6867be6d 2205 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL
2206 SV * const astr = *++mark;
2207 STRLEN infosize = 0;
2208 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2209
7918f24d 2210 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2211 PERL_UNUSED_ARG(sp);
c2ab57d4
LW
2212
2213 switch (optype)
2214 {
fe14fcc3 2215#ifdef HAS_MSG
79072805 2216 case OP_MSGCTL:
c2ab57d4
LW
2217 if (cmd == IPC_STAT || cmd == IPC_SET)
2218 infosize = sizeof(struct msqid_ds);
2219 break;
e5d73d77 2220#endif
fe14fcc3 2221#ifdef HAS_SHM
79072805 2222 case OP_SHMCTL:
c2ab57d4
LW
2223 if (cmd == IPC_STAT || cmd == IPC_SET)
2224 infosize = sizeof(struct shmid_ds);
2225 break;
e5d73d77 2226#endif
fe14fcc3 2227#ifdef HAS_SEM
79072805 2228 case OP_SEMCTL:
39398f3f 2229#ifdef Semctl
c2ab57d4
LW
2230 if (cmd == IPC_STAT || cmd == IPC_SET)
2231 infosize = sizeof(struct semid_ds);
2232 else if (cmd == GETALL || cmd == SETALL)
2233 {
8e591e46 2234 struct semid_ds semds;
bd89102f 2235 union semun semun;
e6f0bdd6
GS
2236#ifdef EXTRA_F_IN_SEMUN_BUF
2237 semun.buff = &semds;
2238#else
84902520 2239 semun.buf = &semds;
e6f0bdd6 2240#endif
c2ab57d4 2241 getinfo = (cmd == GETALL);
9b89d93d
GB
2242 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2243 return -1;
6e21c824
LW
2244 infosize = semds.sem_nsems * sizeof(short);
2245 /* "short" is technically wrong but much more portable
2246 than guessing about u_?short(_t)? */
c2ab57d4 2247 }
39398f3f 2248#else
fe13d51d 2249 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2250 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2251#endif
c2ab57d4 2252 break;
e5d73d77 2253#endif
fe14fcc3 2254#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2255 default:
fe13d51d 2256 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2257 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2258#endif
c2ab57d4
LW
2259 }
2260
2261 if (infosize)
2262 {
2263 if (getinfo)
2264 {
93524f2b 2265 SvPV_force_nolen(astr);
a0d0e21e 2266 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
2267 }
2268 else
2269 {
93524f2b 2270 STRLEN len;
463ee0b2
LW
2271 a = SvPV(astr, len);
2272 if (len != infosize)
cea2e8a9 2273 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
2274 PL_op_desc[optype],
2275 (unsigned long)len,
2276 (long)infosize);
c2ab57d4
LW
2277 }
2278 }
2279 else
2280 {
0bcc34c2 2281 const IV i = SvIV(astr);
56431972 2282 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 2283 }
748a9306 2284 SETERRNO(0,0);
c2ab57d4
LW
2285 switch (optype)
2286 {
fe14fcc3 2287#ifdef HAS_MSG
79072805 2288 case OP_MSGCTL:
bee1dbe2 2289 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 2290 break;
e5d73d77 2291#endif
fe14fcc3 2292#ifdef HAS_SEM
bd89102f 2293 case OP_SEMCTL: {
39398f3f 2294#ifdef Semctl
bd89102f
AD
2295 union semun unsemds;
2296
64d76282
BC
2297 if(cmd == SETVAL) {
2298 unsemds.val = PTR2nat(a);
2299 }
2300 else {
e6f0bdd6 2301#ifdef EXTRA_F_IN_SEMUN_BUF
64d76282 2302 unsemds.buff = (struct semid_ds *)a;
e6f0bdd6 2303#else
64d76282 2304 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 2305#endif
64d76282 2306 }
bd89102f 2307 ret = Semctl(id, n, cmd, unsemds);
39398f3f 2308#else
fe13d51d 2309 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2310 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2311#endif
bd89102f 2312 }
c2ab57d4 2313 break;
e5d73d77 2314#endif
fe14fcc3 2315#ifdef HAS_SHM
79072805 2316 case OP_SHMCTL:
bee1dbe2 2317 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 2318 break;
e5d73d77 2319#endif
c2ab57d4
LW
2320 }
2321 if (getinfo && ret >= 0) {
79072805
LW
2322 SvCUR_set(astr, infosize);
2323 *SvEND(astr) = '\0';
a0d0e21e 2324 SvSETMAGIC(astr);
c2ab57d4
LW
2325 }
2326 return ret;
2327}
2328
79072805 2329I32
864dbfa3 2330Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 2331{
fe14fcc3 2332#ifdef HAS_MSG
463ee0b2 2333 STRLEN len;
6867be6d 2334 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2335 SV * const mstr = *++mark;
2336 const I32 flags = SvIVx(*++mark);
2337 const char * const mbuf = SvPV_const(mstr, len);
2338 const I32 msize = len - sizeof(long);
2339
7918f24d 2340 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 2341 PERL_UNUSED_ARG(sp);
c2ab57d4 2342
0bcc34c2 2343 if (msize < 0)
cea2e8a9 2344 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 2345 SETERRNO(0,0);
681fb693
JH
2346 if (id >= 0 && flags >= 0) {
2347 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
2348 } else {
2349 SETERRNO(EINVAL,LIB_INVARG);
2350 return -1;
2351 }
e5d73d77 2352#else
2d51fa4d
RGS
2353 PERL_UNUSED_ARG(sp);
2354 PERL_UNUSED_ARG(mark);
fe13d51d 2355 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2356 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 2357 return -1;
e5d73d77 2358#endif
c2ab57d4
LW
2359}
2360
79072805 2361I32
864dbfa3 2362Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 2363{
fe14fcc3 2364#ifdef HAS_MSG
c2ab57d4
LW
2365 char *mbuf;
2366 long mtype;
6867be6d 2367 I32 msize, flags, ret;
6867be6d 2368 const I32 id = SvIVx(*++mark);
0bcc34c2 2369 SV * const mstr = *++mark;
7918f24d
NC
2370
2371 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 2372 PERL_UNUSED_ARG(sp);
79072805 2373
c2e66d9e
GS
2374 /* suppress warning when reading into undef var --jhi */
2375 if (! SvOK(mstr))
76f68e9b 2376 sv_setpvs(mstr, "");
463ee0b2
LW
2377 msize = SvIVx(*++mark);
2378 mtype = (long)SvIVx(*++mark);
2379 flags = SvIVx(*++mark);
93524f2b 2380 SvPV_force_nolen(mstr);
a0d0e21e 2381 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2382
748a9306 2383 SETERRNO(0,0);
d2607e1e
JH
2384 if (id >= 0 && msize >= 0 && flags >= 0) {
2385 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
2386 } else {
2387 SETERRNO(EINVAL,LIB_INVARG);
2388 ret = -1;
2389 }
c2ab57d4 2390 if (ret >= 0) {
79072805
LW
2391 SvCUR_set(mstr, sizeof(long)+ret);
2392 *SvEND(mstr) = '\0';
41d6edb2
JH
2393 /* who knows who has been playing with this message? */
2394 SvTAINTED_on(mstr);
c2ab57d4
LW
2395 }
2396 return ret;
e5d73d77 2397#else
2d51fa4d
RGS
2398 PERL_UNUSED_ARG(sp);
2399 PERL_UNUSED_ARG(mark);
fe13d51d 2400 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2401 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 2402 return -1;
e5d73d77 2403#endif
c2ab57d4
LW
2404}
2405
79072805 2406I32
864dbfa3 2407Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2408{
fe14fcc3 2409#ifdef HAS_SEM
463ee0b2 2410 STRLEN opsize;
6867be6d 2411 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2412 SV * const opstr = *++mark;
2413 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC
2414
2415 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 2416 PERL_UNUSED_ARG(sp);
c2ab57d4 2417
248ff010
NC
2418 if (opsize < 3 * SHORTSIZE
2419 || (opsize % (3 * SHORTSIZE))) {
93189314 2420 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW
2421 return -1;
2422 }
748a9306 2423 SETERRNO(0,0);
248ff010
NC
2424 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2425 {
6867be6d 2426 const int nsops = opsize / (3 * sizeof (short));
248ff010 2427 int i = nsops;
0bcc34c2 2428 short * const ops = (short *) opbuf;
248ff010
NC
2429 short *o = ops;
2430 struct sembuf *temps, *t;
2431 I32 result;
2432
a02a5408 2433 Newx (temps, nsops, struct sembuf);
248ff010
NC
2434 t = temps;
2435 while (i--) {
2436 t->sem_num = *o++;
2437 t->sem_op = *o++;
2438 t->sem_flg = *o++;
2439 t++;
2440 }
2441 result = semop(id, temps, nsops);
248ff010
NC
2442 Safefree(temps);
2443 return result;
2444 }
e5d73d77 2445#else
fe13d51d 2446 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2447 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2448#endif
c2ab57d4
LW
2449}
2450
79072805 2451I32
864dbfa3 2452Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2453{
fe14fcc3 2454#ifdef HAS_SHM
4373e329 2455 char *shm;
c2ab57d4 2456 struct shmid_ds shmds;
6867be6d 2457 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2458 SV * const mstr = *++mark;
2459 const I32 mpos = SvIVx(*++mark);
2460 const I32 msize = SvIVx(*++mark);
7918f24d
NC
2461
2462 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 2463 PERL_UNUSED_ARG(sp);
c2ab57d4 2464
748a9306 2465 SETERRNO(0,0);
c2ab57d4
LW
2466 if (shmctl(id, IPC_STAT, &shmds) == -1)
2467 return -1;
7f39519f
NC
2468 if (mpos < 0 || msize < 0
2469 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 2470 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2471 return -1;
2472 }
568fc267
JH
2473 if (id >= 0) {
2474 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
2475 } else {
2476 SETERRNO(EINVAL,LIB_INVARG);
2477 return -1;
2478 }
c2ab57d4
LW
2479 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2480 return -1;
79072805 2481 if (optype == OP_SHMREAD) {
c8ae91a8 2482 char *mbuf;
9f538c04 2483 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS
2484 SvGETMAGIC(mstr);
2485 SvUPGRADE(mstr, SVt_PV);
9f538c04 2486 if (! SvOK(mstr))
76f68e9b 2487 sv_setpvs(mstr, "");
af8ff727 2488 SvPOK_only(mstr);
bb7a0f54 2489 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 2490
bee1dbe2 2491 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2492 SvCUR_set(mstr, msize);
2493 *SvEND(mstr) = '\0';
a0d0e21e 2494 SvSETMAGIC(mstr);
d929ce6f
JH
2495 /* who knows who has been playing with this shared memory? */
2496 SvTAINTED_on(mstr);
c2ab57d4
LW
2497 }
2498 else {
93524f2b 2499 STRLEN len;
c2ab57d4 2500
93524f2b 2501 const char *mbuf = SvPV_const(mstr, len);
027aa12d 2502 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 2503 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2504 if (n < msize)
bee1dbe2 2505 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2506 }
2507 return shmdt(shm);
e5d73d77 2508#else
fe13d51d 2509 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2510 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 2511 return -1;
e5d73d77 2512#endif
c2ab57d4
LW
2513}
2514
fe14fcc3 2515#endif /* SYSV IPC */
4e35701f 2516
0d44d22b 2517/*
ccfc67b7
JH
2518=head1 IO Functions
2519
0d44d22b
NC
2520=for apidoc start_glob
2521
2522Function called by C<do_readline> to spawn a glob (or do the glob inside
154e47c8 2523perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
210b36aa 2524this glob starter is only used by miniperl during the build process.
75af9d73 2525Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
fab3f3a7 2526
0d44d22b
NC
2527=cut
2528*/
2529
2530PerlIO *
2531Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2532{
561b68a9 2533 SV * const tmpcmd = newSV(0);
0d44d22b 2534 PerlIO *fp;
41188aa0
TC
2535 STRLEN len;
2536 const char *s = SvPV(tmpglob, len);
7918f24d
NC
2537
2538 PERL_ARGS_ASSERT_START_GLOB;
2539
41188aa0 2540 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC
2541 return NULL;
2542
0d44d22b
NC
2543 ENTER;
2544 SAVEFREESV(tmpcmd);
2545#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2546 /* since spawning off a process is a real performance hit */
dca5a913
JM
2547
2548PerlIO *
2549Perl_vms_start_glob
2550 (pTHX_ SV *tmpglob,
2551 IO *io);
2552
49a7a762 2553 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 2554
0d44d22b 2555#else /* !VMS */
0d44d22b
NC
2556#ifdef DOSISH
2557#ifdef OS2
2558 sv_setpv(tmpcmd, "for a in ");
2559 sv_catsv(tmpcmd, tmpglob);
2560 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2561#else
2562#ifdef DJGPP
2563 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2564 sv_catsv(tmpcmd, tmpglob);
2565#else
2566 sv_setpv(tmpcmd, "perlglob ");
2567 sv_catsv(tmpcmd, tmpglob);
2568 sv_catpv(tmpcmd, " |");
2569#endif /* !DJGPP */
2570#endif /* !OS2 */
2571#else /* !DOSISH */
2572#if defined(CSH)
2573 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2574 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2575 sv_catsv(tmpcmd, tmpglob);
2576 sv_catpv(tmpcmd, "' 2>/dev/null |");
2577#else
2578 sv_setpv(tmpcmd, "echo ");
2579 sv_catsv(tmpcmd, tmpglob);
0d44d22b 2580 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
0d44d22b
NC
2581#endif /* !CSH */
2582#endif /* !DOSISH */
93b2dae1
FC
2583 {
2584 GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
2585 SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
25018358 2586 SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
93b2dae1 2587 if (home && *home) SvGETMAGIC(*home);
25018358 2588 if (path && *path) SvGETMAGIC(*path);
93b2dae1
FC
2589 save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
2590 if (home && *home) SvSETMAGIC(*home);
25018358 2591 if (path && *path) SvSETMAGIC(*path);
93b2dae1 2592 }
d5eb9a46
NC
2593 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
2594 NULL, NULL, 0);
0d44d22b
NC
2595 fp = IoIFP(io);
2596#endif /* !VMS */
2597 LEAVE;
de7dabb6
TC
2598
2599 if (!fp && ckWARN(WARN_GLOB)) {
2600 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
2601 Strerror(errno));
2602 }
2603
0d44d22b
NC
2604 return fp;
2605}
66610fdd
RGS
2606
2607/*
14d04a33 2608 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2609 */