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