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