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