This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
expand code comment in perly.y
[perl5.git] / doio.c
CommitLineData
a0d0e21e 1/* doio.c
a687059c 2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a687059c 5 *
6e21c824
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
a687059c 8 *
a0d0e21e
LW		 9 */
10
11/*
4ac71550
TC		 12 * Far below them they saw the white waters pour into a foaming bowl, and
13 * then swirl darkly about a deep oval basin in the rocks, until they found
14 * their way out again through a narrow gate, and flowed away, fuming and
15 * chattering, into calmer and more level reaches.
16 *
17 * [p.684 of _The Lord of the Rings_, IV/vi: "The Forbidden Pool"]
a687059c
LW		 18 */
19
166f8a29
DM		 20/* This file contains functions that do the actual I/O on behalf of ops.
21 * For example, pp_print() calls the do_print() function in this file for
22 * each argument needing printing.
23 */
24
a687059c 25#include "EXTERN.h"
864dbfa3 26#define PERL_IN_DOIO_C
a687059c
LW		 27#include "perl.h"
28
fe14fcc3 29#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
aec308ec 30#ifndef HAS_SEM
c2ab57d4 31#include <sys/ipc.h>
aec308ec 32#endif
fe14fcc3 33#ifdef HAS_MSG
c2ab57d4 34#include <sys/msg.h>
e5d73d77 35#endif
fe14fcc3 36#ifdef HAS_SHM
c2ab57d4 37#include <sys/shm.h>
a0d0e21e 38# ifndef HAS_SHMAT_PROTOTYPE
20ce7b12 39 extern Shmat_t shmat (int, char *, int);
a0d0e21e 40# endif
c2ab57d4 41#endif
e5d73d77 42#endif
c2ab57d4 43
663a0e37 44#ifdef I_UTIME
3730b96e 45# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 46# include <sys/utime.h>
47# else
48# include <utime.h>
49# endif
663a0e37 50#endif
85aff577 51
85aff577
CS		 52#ifdef O_EXCL
53# define OPEN_EXCL O_EXCL
54#else
55# define OPEN_EXCL 0
56#endif
a687059c 57
0c19750d
SP		 58#define PERL_MODE_MAX 8
59#define PERL_FLAGS_MAX 10
60
76121258 61#include <signal.h>
76121258 62
a2b41d5c
NC		 63static IO *
64S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp,
65 int *savefd, char *savetype)
a567e93b 66{
eb578fdb 67 IO * const io = GvIOn(gv);
a687059c 68
a2b41d5c
NC		 69 PERL_ARGS_ASSERT_OPENN_SETUP;
70
71 *saveifp = NULL;
72 *saveofp = NULL;
73 *savefd = -1;
74 *savetype = IoTYPE_CLOSED;
7918f24d 75
b931b1d9 76 Zero(mode,sizeof(mode),char);
3280af22 77 PL_forkprocess = 1; /* assume true if no fork */
c07a80fd 78
b931b1d9 79 /* If currently open - close before we re-open */
a0d0e21e 80 if (IoIFP(io)) {
ee518936
NIS		 81 if (IoTYPE(io) == IoTYPE_STD) {
82 /* This is a clone of one of STD* handles */
ee518936 83 }
26297fe9
NC		 84 else {
85 const int old_fd = PerlIO_fileno(IoIFP(io));
86
87 if (old_fd >= 0 && old_fd <= PL_maxsysfd) {
88 /* This is one of the original STD* handles */
a2b41d5c
NC		 89 *saveifp = IoIFP(io);
90 *saveofp = IoOFP(io);
91 *savetype = IoTYPE(io);
92 *savefd = old_fd;
26297fe9
NC		 93 }
94 else {
95 int result;
96
97 if (IoTYPE(io) == IoTYPE_PIPE)
98 result = PerlProc_pclose(IoIFP(io));
99 else if (IoIFP(io) != IoOFP(io)) {
100 if (IoOFP(io)) {
101 result = PerlIO_close(IoOFP(io));
102 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
103 }
104 else
105 result = PerlIO_close(IoIFP(io));
106 }
107 else
108 result = PerlIO_close(IoIFP(io));
109
110 if (result == EOF && old_fd > PL_maxsysfd) {
111 /* Why is this not Perl_warn*() call ? */
112 PerlIO_printf(Perl_error_log,
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
9a73c0b8 264 if (SvROK(*svp) && !memchr(oname, '&', len)) {
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 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 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 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 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
e0d4aead
TC		 816/* Open a temp file in the same directory as an original name.
817*/
818
819static bool
820S_openindirtemp(pTHX_ GV *gv, SV *orig_name, SV *temp_out_name) {
821 int fd;
822 PerlIO *fp;
823 const char *p = SvPV_nolen(orig_name);
824 const char *sep;
825
826 /* look for the last directory separator */
827 sep = strrchr(p, '/');
828
829#ifdef DOSISH
830 {
831 const char *sep2;
832 if ((sep2 = strrchr(sep ? sep : p, '\\')))
833 sep = sep2;
834 }
835#endif
836#ifdef VMS
837 if (!sep) {
838 const char *openp = strchr(p, '[');
839 if (openp)
840 sep = strchr(openp, ']');
841 else {
842 sep = strchr(p, ':');
843 }
844 }
845#endif
846 if (sep) {
847 sv_setpvn(temp_out_name, p, sep - p + 1);
848 sv_catpvs(temp_out_name, "XXXXXXXX");
849 }
850 else
851 sv_setpvs(temp_out_name, "XXXXXXXX");
852
853 fd = Perl_my_mkstemp(SvPVX(temp_out_name));
854
855 if (fd < 0)
856 return FALSE;
857
858 fp = PerlIO_fdopen(fd, "w+");
859 if (!fp)
860 return FALSE;
861
862 return do_openn(gv, "+>&", 3, 0, 0, 0, fp, NULL, 0);
863}
864
733612e0 865#if defined(HAS_UNLINKAT) && defined(HAS_RENAMEAT) && defined(HAS_FCHMODAT) && \
c3fcee07
JK		 866 (defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)) && !defined(NO_USE_ATFUNCTIONS) && \
867 defined(HAS_LINKAT)
733612e0
TC		 868# define ARGV_USE_ATFUNCTIONS
869#endif
870
1b4d0d79
TC		 871/* Win32 doesn't necessarily return useful information
872 * in st_dev, st_ino.
873 */
874#ifndef ARGV_USE_ATFUNCTIONS
875# ifndef DOSISH
876# define ARGV_USE_STAT_INO
877# endif
878#endif
879
e0d4aead
TC		 880#define ARGVMG_BACKUP_NAME 0
881#define ARGVMG_TEMP_NAME 1
882#define ARGVMG_ORIG_NAME 2
883#define ARGVMG_ORIG_MODE 3
05df5c88 884#define ARGVMG_ORIG_PID 4
bb082417 885
1b4d0d79 886#if defined(ARGV_USE_ATFUNCTIONS)
05df5c88 887#define ARGVMG_ORIG_DIRP 5
1b4d0d79 888#elif defined(ARGV_USE_STAT_INO)
bb082417
TC		 889/* we store the entire stat_t since the ino_t and dev_t values might
890 not fit in an IV. I could have created a new structure and
891 transferred them across, but this seemed too much effort for very
892 little win.
893 */
894#define ARGVMG_ORIG_CWD_STAT 5
895#endif
e0d4aead
TC		 896
897static int
d0405818 898S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
e0d4aead
TC		 899 SV **temp_psv;
900
d0405818 901 PERL_UNUSED_ARG(io);
e0d4aead
TC		 902
903 /* note this can be entered once the file has been
904 successfully deleted too */
d0405818
TC		 905 assert(IoTYPE(io) != IoTYPE_PIPE);
906
8ab93df0
TC		 907 /* mg_obj can be NULL if a thread is created with the handle open, in which
908 case we leave any clean up to the parent thread */
909 if (mg->mg_obj && IoIFP(io)) {
910 SV **pid_psv;
733612e0
TC		 911#ifdef ARGV_USE_ATFUNCTIONS
912 SV **dir_psv;
913 DIR *dir;
914#endif
d0405818 915 PerlIO *iop = IoIFP(io);
05df5c88
TC		 916
917 assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
918
919 pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
920
921 assert(pid_psv && *pid_psv);
922
923 if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
924 /* if we get here the file hasn't been closed explicitly by the
925 user and hadn't been closed implicitly by nextargv(), so
926 abandon the edit */
927 (void)PerlIO_close(iop);
928 IoIFP(io) = IoOFP(io) = NULL;
929 temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
930 assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
733612e0 931#ifdef ARGV_USE_ATFUNCTIONS
05df5c88
TC		 932 dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
933 assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
934 dir = INT2PTR(DIR *, SvIV(*dir_psv));
935 if (dir) {
936 (void)unlinkat(my_dirfd(dir), SvPVX(*temp_psv), 0);
937 closedir(dir);
938 }
733612e0 939#else
05df5c88 940 (void)UNLINK(SvPVX(*temp_psv));
733612e0 941#endif
05df5c88 942 }
e0d4aead
TC		 943 }
944
945 return 0;
946}
947
8ab93df0
TC		 948static int
949S_argvout_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
950 PERL_UNUSED_ARG(param);
951
952 /* ideally we could just remove the magic from the SV but we don't get the SV here */
953 SvREFCNT_dec(mg->mg_obj);
954 mg->mg_obj = NULL;
955
956 return 0;
957}
958
e0d4aead
TC		 959/* Magic of this type has an AV containing the following:
960 0: name of the backup file (if any)
961 1: name of the temp output file
962 2: name of the original file
963 3: file mode of the original file
05df5c88
TC		 964 4: pid of the process we opened at, to prevent doing the renaming
965 etc in both the child and the parent after a fork
733612e0
TC		 966
967If we have unlinkat(), renameat(), fchmodat(), dirfd() we also keep:
05df5c88 968 5: the DIR * for the current directory when we open the file, stored as an IV
e0d4aead
TC		 969 */
970
971static const MGVTBL argvout_vtbl =
972 {
973 NULL, /* svt_get */
974 NULL, /* svt_set */
975 NULL, /* svt_len */
976 NULL, /* svt_clear */
977 S_argvout_free, /* svt_free */
978 NULL, /* svt_copy */
8ab93df0
TC		 979 S_argvout_dup, /* svt_dup */
980 NULL /* svt_local */
e0d4aead
TC		 981 };
982
760ac839 983PerlIO *
157fb5a1 984Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
a687059c 985{
2d03de9c 986 IO * const io = GvIOp(gv);
502aca56 987 SV *const old_out_name = PL_inplace ? newSVsv(GvSV(gv)) : NULL;
fe14fcc3 988
7918f24d
NC		 989 PERL_ARGS_ASSERT_NEXTARGV;
990
502aca56
TC		 991 if (old_out_name)
992 SAVEFREESV(old_out_name);
993
3280af22 994 if (!PL_argvoutgv)
fafc274c 995 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
5513c2cf 996 if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
18708f5a 997 IoFLAGS(io) &= ~IOf_START;
7a1c5554 998 if (PL_inplace) {
294b3b39 999 assert(PL_defoutgv);
29a861e7
NC		 1000 Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
1001 SvREFCNT_inc_simple_NN(PL_defoutgv));
7a1c5554 1002 }
18708f5a 1003 }
e0d4aead
TC		 1004
1005 {
1006 IO * const io = GvIOp(PL_argvoutgv);
1007 if (io && IoIFP(io) && old_out_name) {
1008 do_close(PL_argvoutgv, FALSE);
1009 }
fe14fcc3 1010 }
e0d4aead 1011
c797f2d8 1012 PL_lastfd = -1;
3280af22 1013 PL_filemode = 0;
5c501b37 1014 if (!GvAV(gv))
4608196e 1015 return NULL;
b9f2b683 1016 while (av_tindex(GvAV(gv)) >= 0) {
85aff577 1017 STRLEN oldlen;
1fa0529f 1018 SV *const sv = av_shift(GvAV(gv));
8990e307 1019 SAVEFREESV(sv);
4bac9ae4 1020 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
e203899d 1021 sv_setsv(GvSVn(gv),sv);
79072805 1022 SvSETMAGIC(GvSV(gv));
3280af22 1023 PL_oldname = SvPVx(GvSV(gv), oldlen);
d8015975 1024 if (LIKELY(!PL_inplace)) {
157fb5a1
RGS		 1025 if (nomagicopen
1026 ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)
1027 : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)
1028 ) {
d8015975
NC		 1029 return IoIFP(GvIOp(gv));
1030 }
1031 }
1032 else {
7e30e49f 1033 Stat_t statbuf;
d8015975
NC		 1034 /* This very long block ends with return IoIFP(GvIOp(gv));
1035 Both this block and the block above fall through on open
1036 failure to the warning code, and then the while loop above tries
1037 the next entry. */
7e30e49f 1038 if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0, &statbuf)) {
1fa0529f
NC		 1039#ifndef FLEXFILENAMES
1040 int filedev;
1041 int fileino;
1042#endif
733612e0
TC		 1043#ifdef ARGV_USE_ATFUNCTIONS
1044 DIR *curdir;
1045#endif
1fa0529f
NC		 1046 Uid_t fileuid;
1047 Gid_t filegid;
e0d4aead
TC		 1048 AV *magic_av = NULL;
1049 SV *temp_name_sv = NULL;
8ab93df0 1050 MAGIC *mg;
1fa0529f 1051
79072805 1052 TAINT_PROPER("inplace open");
3280af22 1053 if (oldlen == 1 && *PL_oldname == '-') {
fafc274c
NC		 1054 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
1055 SVt_PVIO));
a0d0e21e 1056 return IoIFP(GvIOp(gv));
c623bd54 1057 }
99b89507 1058#ifndef FLEXFILENAMES
7e30e49f
DIM		 1059 filedev = statbuf.st_dev;
1060 fileino = statbuf.st_ino;
99b89507 1061#endif
7e30e49f
DIM		 1062 PL_filemode = statbuf.st_mode;
1063 fileuid = statbuf.st_uid;
1064 filegid = statbuf.st_gid;
3280af22 1065 if (!S_ISREG(PL_filemode)) {
9b387841
NC		 1066 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1067 "Can't do inplace edit: %s is not a regular file",
1068 PL_oldname );
79072805 1069 do_close(gv,FALSE);
c623bd54
LW		 1070 continue;
1071 }
e0d4aead 1072 magic_av = newAV();
c9930541 1073 if (*PL_inplace && strNE(PL_inplace, "*")) {
2d03de9c 1074 const char *star = strchr(PL_inplace, '*');
2d259d92 1075 if (star) {
2d03de9c 1076 const char *begin = PL_inplace;
8062ff11 1077 SvPVCLEAR(sv);
2d259d92
CK		 1078 do {
1079 sv_catpvn(sv, begin, star - begin);
3280af22 1080 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK		 1081 begin = ++star;
1082 } while ((star = strchr(begin, '*')));
3d66d7bb
GS		 1083 if (*begin)
1084 sv_catpv(sv,begin);
2d259d92
CK		 1085 }
1086 else {
3280af22 1087 sv_catpv(sv,PL_inplace);
2d259d92 1088 }
c623bd54 1089#ifndef FLEXFILENAMES
7e30e49f
DIM		 1090 if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0
1091 && statbuf.st_dev == filedev
1092 && statbuf.st_ino == fileino)
39e571d4 1093#ifdef DJGPP
5f74f29c 1094 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
39e571d4 1095#endif
f248d071
GS		 1096 )
1097 {
9b387841 1098 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
147e3846
KW		 1099 "Can't do inplace edit: %"
1100 SVf " would not be unique",
9b387841 1101 SVfARG(sv));
e0d4aead 1102 goto cleanup_argv;
c623bd54 1103 }
ff8e2863 1104#endif
e0d4aead 1105 av_store(magic_av, ARGVMG_BACKUP_NAME, newSVsv(sv));
a687059c
LW		 1106 }
1107
30fc4309 1108 sv_setpvn(sv,PL_oldname,oldlen);
748a9306 1109 SETERRNO(0,0); /* in case sprintf set errno */
e0d4aead
TC		 1110 temp_name_sv = newSV(0);
1111 if (!S_openindirtemp(aTHX_ PL_argvoutgv, GvSV(gv), temp_name_sv)) {
1112 SvREFCNT_dec(temp_name_sv);
1113 /* diag_listed_as: Can't do inplace edit on %s: %s */
1114 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: Cannot make temp name: %s",
9b387841 1115 PL_oldname, Strerror(errno) );
e0d4aead
TC		 1116#ifndef FLEXFILENAMES
1117 cleanup_argv:
1118#endif
1119 do_close(gv,FALSE);
1120 SvREFCNT_dec(magic_av);
1121 continue;
fe14fcc3 1122 }
e0d4aead
TC		 1123 av_store(magic_av, ARGVMG_TEMP_NAME, temp_name_sv);
1124 av_store(magic_av, ARGVMG_ORIG_NAME, newSVsv(sv));
1125 av_store(magic_av, ARGVMG_ORIG_MODE, newSVuv(PL_filemode));
05df5c88 1126 av_store(magic_av, ARGVMG_ORIG_PID, newSViv((IV)PerlProc_getpid()));
1b4d0d79 1127#if defined(ARGV_USE_ATFUNCTIONS)
733612e0
TC		 1128 curdir = opendir(".");
1129 av_store(magic_av, ARGVMG_ORIG_DIRP, newSViv(PTR2IV(curdir)));
1b4d0d79 1130#elif defined(ARGV_USE_STAT_INO)
bb082417
TC		 1131 if (PerlLIO_stat(".", &statbuf) >= 0) {
1132 av_store(magic_av, ARGVMG_ORIG_CWD_STAT,
1133 newSVpvn((char *)&statbuf, sizeof(statbuf)));
1134 }
733612e0 1135#endif
3280af22 1136 setdefout(PL_argvoutgv);
dddabd86 1137 sv_setsv(GvSVn(PL_argvoutgv), temp_name_sv);
8ab93df0
TC		 1138 mg = sv_magicext((SV*)GvIOp(PL_argvoutgv), (SV*)magic_av, PERL_MAGIC_uvar, &argvout_vtbl, NULL, 0);
1139 mg->mg_flags |= MGf_DUP;
e0d4aead 1140 SvREFCNT_dec(magic_av);
3280af22 1141 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
375ed12a 1142 if (PL_lastfd >= 0) {
45a23732 1143 (void)PerlLIO_fstat(PL_lastfd,&statbuf);
fe14fcc3 1144#ifdef HAS_FCHMOD
375ed12a 1145 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 1146#else
375ed12a 1147 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
a687059c 1148#endif
45a23732 1149 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
b469f1e0 1150 /* XXX silently ignore failures */
fe14fcc3 1151#ifdef HAS_FCHOWN
b469f1e0 1152 PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
4009c3ff 1153#elif defined(HAS_CHOWN)
b469f1e0 1154 PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid));
a687059c 1155#endif
375ed12a 1156 }
fe14fcc3 1157 }
d8015975 1158 return IoIFP(GvIOp(gv));
a687059c 1159 }
d8015975
NC		 1160 } /* successful do_open_raw(), PL_inplace non-NULL */
1161
1162 if (ckWARN_d(WARN_INPLACE)) {
1163 const int eno = errno;
7e30e49f 1164 Stat_t statbuf;
45a23732
DD		 1165 if (PerlLIO_stat(PL_oldname, &statbuf) >= 0
1166 && !S_ISREG(statbuf.st_mode)) {
d8015975
NC		 1167 Perl_warner(aTHX_ packWARN(WARN_INPLACE),
1168 "Can't do inplace edit: %s is not a regular file",
1169 PL_oldname);
1170 }
1171 else {
1172 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
1173 PL_oldname, Strerror(eno));
1174 }
4d61ec05 1175 }
a687059c 1176 }
18708f5a
GS		 1177 if (io && (IoFLAGS(io) & IOf_ARGV))
1178 IoFLAGS(io) |= IOf_START;
3280af22 1179 if (PL_inplace) {
7a1c5554
GS		 1180 if (io && (IoFLAGS(io) & IOf_ARGV)
1181 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
1182 {
159b6efe 1183 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
18708f5a 1184 setdefout(oldout);
8e217d4a 1185 SvREFCNT_dec_NN(oldout);
4608196e 1186 return NULL;
18708f5a 1187 }
fafc274c 1188 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
a687059c 1189 }
4608196e 1190 return NULL;
a687059c
LW		 1191}
1192
84dbe61c
TC		 1193#ifdef ARGV_USE_ATFUNCTIONS
1194# if defined(__FreeBSD__)
1195
1196/* FreeBSD 11 renameat() mis-behaves strangely with absolute paths in cases where the
1197 * equivalent rename() succeeds
1198 */
1199static int
1200S_my_renameat(int olddfd, const char *oldpath, int newdfd, const char *newpath) {
1201 /* this is intended only for use in Perl_do_close() */
1202 assert(olddfd == newdfd);
1203 assert(PERL_FILE_IS_ABSOLUTE(oldpath) == PERL_FILE_IS_ABSOLUTE(newpath));
1204 if (PERL_FILE_IS_ABSOLUTE(oldpath)) {
1205 return PerlLIO_rename(oldpath, newpath);
1206 }
1207 else {
1208 return renameat(olddfd, oldpath, newdfd, newpath);
1209 }
1210}
1211
1212# else
1213# define S_my_renameat(dh1, pv1, dh2, pv2) renameat((dh1), (pv1), (dh2), (pv2))
1214# endif /* if defined(__FreeBSD__) */
1215#endif
1216
517844ec 1217/* explicit renamed to avoid C++ conflict -- kja */
a687059c 1218bool
864dbfa3 1219Perl_do_close(pTHX_ GV *gv, bool not_implicit)
a687059c 1220{
1193dd27
IZ		 1221 bool retval;
1222 IO *io;
e0d4aead 1223 MAGIC *mg;
a687059c 1224
79072805 1225 if (!gv)
3280af22 1226 gv = PL_argvgv;
6e592b3a 1227 if (!gv || !isGV_with_GP(gv)) {
1d2dff63 1228 if (not_implicit)
93189314 1229 SETERRNO(EBADF,SS_IVCHAN);
c2ab57d4 1230 return FALSE;
99b89507 1231 }
79072805
LW		 1232 io = GvIO(gv);
1233 if (!io) { /* never opened */
1d2dff63 1234 if (not_implicit) {
51087808 1235 report_evil_fh(gv);
93189314 1236 SETERRNO(EBADF,SS_IVCHAN);
1d2dff63 1237 }
a687059c
LW		 1238 return FALSE;
1239 }
e0d4aead
TC		 1240 if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl))
1241 && mg->mg_obj) {
1242 /* handle to an in-place edit work file */
1243 SV **back_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_BACKUP_NAME, FALSE);
1244 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1245 /* PL_oldname may have been modified by a nested ARGV use at this point */
1246 SV **orig_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_NAME, FALSE);
1247 SV **mode_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_MODE, FALSE);
05df5c88 1248 SV **pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
1b4d0d79 1249#if defined(ARGV_USE_ATFUNCTIONS)
05df5c88 1250 SV **dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
733612e0
TC		 1251 DIR *dir;
1252 int dfd;
1b4d0d79 1253#elif defined(ARGV_USE_STAT_INO)
bb082417
TC		 1254 SV **stat_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_CWD_STAT, FALSE);
1255 Stat_t *orig_cwd_stat = stat_psv && *stat_psv ? (Stat_t *)SvPVX(*stat_psv) : NULL;
733612e0 1256#endif
1b4d0d79
TC		 1257#ifndef ARGV_USE_ATFUNCTIONS
1258 Stat_t statbuf;
1259#endif
e0d4aead
TC		 1260 UV mode;
1261 int fd;
1262
1263 const char *orig_pv;
1264
1265 assert(temp_psv && *temp_psv);
1266 assert(orig_psv && *orig_psv);
1267 assert(mode_psv && *mode_psv);
05df5c88 1268 assert(pid_psv && *pid_psv);
733612e0
TC		 1269#ifdef ARGV_USE_ATFUNCTIONS
1270 assert(dir_psv && *dir_psv);
1271 dir = INT2PTR(DIR *, SvIVX(*dir_psv));
1272 dfd = my_dirfd(dir);
1273#endif
e0d4aead
TC		 1274
1275 orig_pv = SvPVX(*orig_psv);
e0d4aead
TC		 1276 mode = SvUV(*mode_psv);
1277
1278 if ((mode & (S_ISUID|S_ISGID)) != 0
1279 && (fd = PerlIO_fileno(IoIFP(io))) >= 0) {
1280 (void)PerlIO_flush(IoIFP(io));
1281#ifdef HAS_FCHMOD
1282 (void)fchmod(fd, mode);
1283#else
1284 (void)PerlLIO_chmod(orig_pv, mode);
1285#endif
1286 }
1287
1288 retval = io_close(io, NULL, not_implicit, FALSE);
1289
05df5c88
TC		 1290 if (SvIV(*pid_psv) != (IV)PerlProc_getpid()) {
1291 /* this is a child process, don't duplicate our rename() etc
1292 processing below */
1293 goto freext;
1294 }
1295
e0d4aead 1296 if (retval) {
1b4d0d79 1297#ifdef ARGV_USE_STAT_INO
bb082417
TC		 1298 /* if the path is absolute the possible moving of cwd (which the file
1299 might be in) isn't our problem.
1300 This code tries to be reasonably balanced about detecting a changed
1301 CWD, if we have the information needed to check that curdir has changed, we
1302 check it
1303 */
1304 if (!PERL_FILE_IS_ABSOLUTE(SvPVX(*orig_psv))
1305 && orig_cwd_stat
1306 && PerlLIO_stat(".", &statbuf) >= 0
1307 && ( statbuf.st_dev != orig_cwd_stat->st_dev
1308 || statbuf.st_ino != orig_cwd_stat->st_ino)) {
1b4d0d79
TC		 1309 Perl_croak(aTHX_ "Cannot complete in-place edit of %" SVf ": %s",
1310 *orig_psv, "Current directory has changed");
1311 }
1312#endif
1313#if !defined(ARGV_USE_ATFUNCTIONS) && !defined(ARGV_USE_STAT_INO)
1314 /* Some platforms don't have useful st_ino etc, so just
1315 check we can see the work file.
1316 */
1317 if (!PERL_FILE_IS_ABSOLUTE(SvPVX(*orig_psv))
1318 && PerlLIO_stat(SvPVX(*temp_psv), &statbuf) < 0) {
1319 Perl_croak(aTHX_ "Cannot complete in-place edit of %" SVf ": %s",
1320 *orig_psv,
1321 "Work file is missing - did you change directory?");
bb082417
TC		 1322 }
1323#endif
1324
e0d4aead
TC		 1325#if defined(DOSISH) || defined(__CYGWIN__)
1326 if (PL_argvgv && GvIOp(PL_argvgv)
1327 && IoIFP(GvIOp(PL_argvgv))
1328 && (IoFLAGS(GvIOp(PL_argvgv)) & (IOf_ARGV|IOf_START)) == IOf_ARGV) {
1329 do_close(PL_argvgv, FALSE);
1330 }
1331#endif
1332 if (back_psv && *back_psv) {
1333#if defined(HAS_LINK) && !defined(DOSISH) && !defined(__CYGWIN__) && defined(HAS_RENAME)
733612e0
TC		 1334 if (
1335# ifdef ARGV_USE_ATFUNCTIONS
1336 linkat(dfd, orig_pv, dfd, SvPVX(*back_psv), 0) < 0
1337# else
1338 link(orig_pv, SvPVX(*back_psv)) < 0
1339# endif
1340 )
e0d4aead
TC		 1341#endif
1342 {
1343#ifdef HAS_RENAME
733612e0
TC		 1344 if (
1345# ifdef ARGV_USE_ATFUNCTIONS
84dbe61c 1346 S_my_renameat(dfd, orig_pv, dfd, SvPVX(*back_psv)) < 0
733612e0
TC		 1347# else
1348 PerlLIO_rename(orig_pv, SvPVX(*back_psv)) < 0
1349# endif
1350 ) {
e0d4aead 1351 if (!not_implicit) {
83419aa9
TC		 1352# ifdef ARGV_USE_ATFUNCTIONS
1353 (void)unlinkat(dfd, SvPVX_const(*temp_psv), 0);
1354# else
1355 UNLINK(SvPVX(*temp_psv));
1356# endif
e0d4aead
TC		 1357 Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file",
1358 SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno));
1359 }
1360 /* should we warn here? */
1361 goto abort_inplace;
1362 }
1363#else
1364 (void)UNLINK(SvPVX(*back_psv));
1365 if (link(orig_pv, SvPVX(*back_psv))) {
1366 if (!not_implicit) {
1367 Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file",
1368 SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno));
1369 }
1370 goto abort_inplace;
1371 }
1372 /* we need to use link() to get the temp into place too, and linK()
1373 fails if the new link name exists */
1374 (void)UNLINK(orig_pv);
1375#endif
1376 }
1377 }
1378#if defined(DOSISH) || defined(__CYGWIN__) || !defined(HAS_RENAME)
1379 else {
1380 UNLINK(orig_pv);
1381 }
1382#endif
1383 if (
4009c3ff
AC		 1384#if !defined(HAS_RENAME)
1385 link(SvPVX(*temp_psv), orig_pv) < 0
1386#elif defined(ARGV_USE_ATFUNCTIONS)
84dbe61c 1387 S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0
e0d4aead 1388#else
4009c3ff 1389 PerlLIO_rename(SvPVX(*temp_psv), orig_pv) < 0
e0d4aead
TC		 1390#endif
1391 ) {
1392 if (!not_implicit) {
dddabd86
TC		 1393#ifdef ARGV_USE_ATFUNCTIONS
1394 (void)unlinkat(dfd, SvPVX_const(*temp_psv), 0);
1395#else
1396 UNLINK(SvPVX(*temp_psv));
1397#endif
e0d4aead
TC		 1398 Perl_croak(aTHX_ "Can't rename in-place work file '%s' to '%s': %s\n",
1399 SvPVX(*temp_psv), SvPVX(*orig_psv), Strerror(errno));
1400 }
1401 abort_inplace:
1402 UNLINK(SvPVX_const(*temp_psv));
1403 retval = FALSE;
1404 }
1405#ifndef HAS_RENAME
1406 UNLINK(SvPVX(*temp_psv));
1407#endif
1408 }
1409 else {
733612e0
TC		 1410#ifdef ARGV_USE_ATFUNCTIONS
1411 unlinkat(dfd, SvPVX_const(*temp_psv), 0);
1412#else
e0d4aead 1413 UNLINK(SvPVX_const(*temp_psv));
733612e0 1414#endif
e0d4aead
TC		 1415 if (!not_implicit) {
1416 Perl_croak(aTHX_ "Failed to close in-place work file %s: %s",
1417 SvPVX(*temp_psv), Strerror(errno));
1418 }
1419 }
05df5c88 1420 freext:
e0d4aead
TC		 1421 mg_freeext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl);
1422 }
1423 else {
1424 retval = io_close(io, NULL, not_implicit, FALSE);
1425 }
517844ec 1426 if (not_implicit) {
1193dd27
IZ		 1427 IoLINES(io) = 0;
1428 IoPAGE(io) = 0;
1429 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1430 }
50952442 1431 IoTYPE(io) = IoTYPE_CLOSED;
1193dd27
IZ		 1432 return retval;
1433}
1434
1435bool
96d7c888 1436Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
1193dd27
IZ		 1437{
1438 bool retval = FALSE;
1193dd27 1439
7918f24d
NC		 1440 PERL_ARGS_ASSERT_IO_CLOSE;
1441
8990e307 1442 if (IoIFP(io)) {
50952442 1443 if (IoTYPE(io) == IoTYPE_PIPE) {
4373e329 1444 const int status = PerlProc_pclose(IoIFP(io));
f2b5be74 1445 if (not_implicit) {
37038d91 1446 STATUS_NATIVE_CHILD_SET(status);
e5218da5 1447 retval = (STATUS_UNIX == 0);
f2b5be74
GS		 1448 }
1449 else {
1450 retval = (status != -1);
1451 }
a687059c 1452 }
50952442 1453 else if (IoTYPE(io) == IoTYPE_STD)
a687059c
LW		 1454 retval = TRUE;
1455 else {
8990e307 1456 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
0bcc34c2 1457 const bool prev_err = PerlIO_error(IoOFP(io));
f4725fad
FC		 1458#ifdef USE_PERLIO
1459 if (prev_err)
1460 PerlIO_restore_errno(IoOFP(io));
1461#endif
e199e3be 1462 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
760ac839 1463 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4 1464 }
e199e3be 1465 else {
0bcc34c2 1466 const bool prev_err = PerlIO_error(IoIFP(io));
f4725fad
FC		 1467#ifdef USE_PERLIO
1468 if (prev_err)
1469 PerlIO_restore_errno(IoIFP(io));
1470#endif
e199e3be
RGS		 1471 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1472 }
a687059c 1473 }
4608196e 1474 IoOFP(io) = IoIFP(io) = NULL;
96d7c888
FC		 1475
1476 if (warn_on_fail && !retval) {
1477 if (gv)
1478 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1479 "Warning: unable to close filehandle %"
147e3846 1480 HEKf " properly: %" SVf,
ac892e4a
DM		 1481 HEKfARG(GvNAME_HEK(gv)),
1482 SVfARG(get_sv("!",GV_ADD)));
96d7c888
FC		 1483 else
1484 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1485 "Warning: unable to close filehandle "
147e3846 1486 "properly: %" SVf,
ac892e4a 1487 SVfARG(get_sv("!",GV_ADD)));
96d7c888 1488 }
79072805 1489 }
f2b5be74 1490 else if (not_implicit) {
93189314 1491 SETERRNO(EBADF,SS_IVCHAN);
20408e3c 1492 }
1193dd27 1493
a687059c
LW		 1494 return retval;
1495}
1496
1497bool
864dbfa3 1498Perl_do_eof(pTHX_ GV *gv)
a687059c 1499{
eb578fdb 1500 IO * const io = GvIO(gv);
a687059c 1501
7918f24d
NC		 1502 PERL_ARGS_ASSERT_DO_EOF;
1503
79072805 1504 if (!io)
a687059c 1505 return TRUE;
7716c5c5 1506 else if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1507 report_wrongway_fh(gv, '>');
a687059c 1508
8990e307 1509 while (IoIFP(io)) {
760ac839 1510 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
a20bf0c3 1511 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
760ac839
LW		 1512 return FALSE; /* this is the most usual case */
1513 }
a687059c 1514
79852593
NC		 1515 {
1516 /* getc and ungetc can stomp on errno */
4ee39169 1517 dSAVE_ERRNO;
79852593
NC		 1518 const int ch = PerlIO_getc(IoIFP(io));
1519 if (ch != EOF) {
1520 (void)PerlIO_ungetc(IoIFP(io),ch);
4ee39169 1521 RESTORE_ERRNO;
79852593
NC		 1522 return FALSE;
1523 }
4ee39169 1524 RESTORE_ERRNO;
a687059c 1525 }
fab3f3a7 1526
760ac839 1527 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
a20bf0c3
JH		 1528 if (PerlIO_get_cnt(IoIFP(io)) < -1)
1529 PerlIO_set_cnt(IoIFP(io),-1);
760ac839 1530 }
533c011a 1531 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
157fb5a1 1532 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */
a687059c
LW		 1533 return TRUE;
1534 }
1535 else
1536 return TRUE; /* normal fp, definitely end of file */
1537 }
1538 return TRUE;
1539}
1540
5ff3f7a4 1541Off_t
864dbfa3 1542Perl_do_tell(pTHX_ GV *gv)
a687059c 1543{
9c9f25b8 1544 IO *const io = GvIO(gv);
eb578fdb 1545 PerlIO *fp;
a687059c 1546
7918f24d
NC		 1547 PERL_ARGS_ASSERT_DO_TELL;
1548
9c9f25b8 1549 if (io && (fp = IoIFP(io))) {
8903cb82 1550 return PerlIO_tell(fp);
96e4d5b1 1551 }
51087808 1552 report_evil_fh(gv);
93189314 1553 SETERRNO(EBADF,RMS_IFI);
5ff3f7a4 1554 return (Off_t)-1;
a687059c
LW		 1555}
1556
1557bool
864dbfa3 1558Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 1559{
9c9f25b8 1560 IO *const io = GvIO(gv);
eb578fdb 1561 PerlIO *fp;
a687059c 1562
9c9f25b8 1563 if (io && (fp = IoIFP(io))) {
8903cb82 1564 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 1565 }
51087808 1566 report_evil_fh(gv);
93189314 1567 SETERRNO(EBADF,RMS_IFI);
a687059c
LW		 1568 return FALSE;
1569}
1570
97cc44eb 1571Off_t
864dbfa3 1572Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82 1573{
9c9f25b8 1574 IO *const io = GvIO(gv);
eb578fdb 1575 PerlIO *fp;
8903cb82 1576
7918f24d
NC		 1577 PERL_ARGS_ASSERT_DO_SYSSEEK;
1578
375ed12a
JH		 1579 if (io && (fp = IoIFP(io))) {
1580 int fd = PerlIO_fileno(fp);
07bd88da
JH		 1581 if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
1582 SETERRNO(EINVAL,LIB_INVARG);
1583 return -1;
1584 } else {
375ed12a
JH		 1585 return PerlLIO_lseek(fd, pos, whence);
1586 }
1587 }
51087808 1588 report_evil_fh(gv);
93189314 1589 SETERRNO(EBADF,RMS_IFI);
d9b3e12d 1590 return (Off_t)-1;
8903cb82 1591}
1592
6ff81951 1593int
a79b25b7 1594Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
16fe6d59
GS		 1595{
1596 int mode = O_BINARY;
81611534 1597 PERL_UNUSED_CONTEXT;
a79b25b7 1598 if (s) {
16fe6d59
GS		 1599 while (*s) {
1600 if (*s == ':') {
1601 switch (s[1]) {
1602 case 'r':
e963d6d2 1603 if (s[2] == 'a' && s[3] == 'w'
16fe6d59
GS		 1604 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1605 {
1606 mode = O_BINARY;
1607 s += 4;
1608 len -= 4;
1609 break;
1610 }
924ba076 1611 /* FALLTHROUGH */
16fe6d59 1612 case 'c':
e963d6d2 1613 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
16fe6d59
GS		 1614 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1615 {
1616 mode = O_TEXT;
1617 s += 5;
1618 len -= 5;
1619 break;
1620 }
924ba076 1621 /* FALLTHROUGH */
16fe6d59
GS		 1622 default:
1623 goto fail_discipline;
1624 }
1625 }
1626 else if (isSPACE(*s)) {
1627 ++s;
1628 --len;
1629 }
1630 else {
4373e329 1631 const char *end;
7b52d656 1632 fail_discipline:
9a73c0b8 1633 end = (char *) memchr(s+1, ':', len);
16fe6d59
GS		 1634 if (!end)
1635 end = s+len;
60382766 1636#ifndef PERLIO_LAYERS
363c40c4 1637 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
60382766 1638#else
18a33fb5 1639 len -= end-s;
60382766
NIS		 1640 s = end;
1641#endif
16fe6d59
GS		 1642 }
1643 }
1644 }
1645 return mode;
1646}
1647
58e24eff 1648#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
27da23d5
JH		 1649I32
1650my_chsize(int fd, Off_t length)
6eb13c3b 1651{
58e24eff
SH		 1652#ifdef F_FREESP
1653 /* code courtesy of William Kucharski */
1654#define HAS_CHSIZE
1655
c623ac67 1656 Stat_t filebuf;
6eb13c3b 1657
3028581b 1658 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW		 1659 return -1;
1660
1661 if (filebuf.st_size < length) {
1662
1663 /* extend file length */
1664
3028581b 1665 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW		 1666 return -1;
1667
1668 /* write a "0" byte */
1669
3028581b 1670 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW		 1671 return -1;
1672 }
1673 else {
1674 /* truncate length */
35da51f7 1675 struct flock fl;
6eb13c3b
LW		 1676 fl.l_whence = 0;
1677 fl.l_len = 0;
1678 fl.l_start = length;
a0d0e21e 1679 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW		 1680
1681 /*
a0d0e21e 1682 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW		 1683 * fcntl(2), which truncates the file so that it ends at the
1684 * position indicated by fl.l_start.
1685 *
1686 * Will minor miracles never cease?
1687 */
1688
a0d0e21e 1689 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW		 1690 return -1;
1691
1692 }
6eb13c3b 1693 return 0;
58e24eff 1694#else
27da23d5 1695 Perl_croak_nocontext("truncate not implemented");
a0d0e21e 1696#endif /* F_FREESP */
27da23d5 1697 return -1;
58e24eff
SH		 1698}
1699#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
ff8e2863 1700
a687059c 1701bool
5aaab254 1702Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
a687059c 1703{
7918f24d
NC		 1704 PERL_ARGS_ASSERT_DO_PRINT;
1705
79072805
LW		 1706 /* assuming fp is checked earlier */
1707 if (!sv)
1708 return TRUE;
e9950d3b
NC		 1709 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
1710 assert(!SvGMAGICAL(sv));
1711 if (SvIsUV(sv))
147e3846 1712 PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv));
e9950d3b 1713 else
147e3846 1714 PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv));
e9950d3b
NC		 1715 return !PerlIO_error(fp);
1716 }
1717 else {
1718 STRLEN len;
676f44e7 1719 /* Do this first to trigger any overloading. */
e9950d3b
NC		 1720 const char *tmps = SvPV_const(sv, len);
1721 U8 *tmpbuf = NULL;
1722 bool happy = TRUE;
1723
d791f93f
KW		 1724 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
1725 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
676f44e7
NC		 1726 /* We don't modify the original scalar. */
1727 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
1728 tmps = (char *) tmpbuf;
1729 }
a099aed4 1730 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
0876b9a0
KW		 1731 (void) check_utf8_print((const U8*) tmps, len);
1732 }
d791f93f
KW		 1733 } /* else stream isn't utf8 */
1734 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
1735 convert to bytes */
676f44e7
NC		 1736 STRLEN tmplen = len;
1737 bool utf8 = TRUE;
35da51f7 1738 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
676f44e7 1739 if (!utf8) {
d791f93f
KW		 1740
1741 /* Here, succeeded in downgrading from utf8. Set up to below
1742 * output the converted value */
676f44e7
NC		 1743 tmpbuf = result;
1744 tmps = (char *) tmpbuf;
1745 len = tmplen;
1746 }
d791f93f
KW		 1747 else { /* Non-utf8 output stream, but string only representable in
1748 utf8 */
676f44e7 1749 assert((char *)result == tmps);
9b387841 1750 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
21630838
FC		 1751 "Wide character in %s",
1752 PL_op ? OP_DESC(PL_op) : "print"
1753 );
0876b9a0
KW		 1754 /* Could also check that isn't one of the things to avoid
1755 * in utf8 by using check_utf8_print(), but not doing so,
1756 * since the stream isn't a UTF8 stream */
ae798467
NIS		 1757 }
1758 }
e9950d3b
NC		 1759 /* To detect whether the process is about to overstep its
1760 * filesize limit we would need getrlimit(). We could then
1761 * also transparently raise the limit with setrlimit() --
1762 * but only until the system hard limit/the filesystem limit,
1763 * at which we would get EPERM. Note that when using buffered
1764 * io the write failure can be delayed until the flush/close. --jhi */
1765 if (len && (PerlIO_write(fp,tmps,len) == 0))
1766 happy = FALSE;
1767 Safefree(tmpbuf);
1768 return happy ? !PerlIO_error(fp) : FALSE;
ff8e2863 1769 }
a687059c
LW		 1770}
1771
79072805 1772I32
0d7d409d 1773Perl_my_stat_flags(pTHX_ const U32 flags)
a687059c 1774{
39644a26 1775 dSP;
79072805 1776 IO *io;
2dd78f96 1777 GV* gv;
79072805 1778
533c011a 1779 if (PL_op->op_flags & OPf_REF) {
2dd78f96 1780 gv = cGVOP_gv;
748a9306 1781 do_fstat:
97c8f3e6
Z		 1782 if (gv == PL_defgv) {
1783 if (PL_laststatval < 0)
1784 SETERRNO(EBADF,RMS_IFI);
5228a96c 1785 return PL_laststatval;
97c8f3e6 1786 }
2dd78f96 1787 io = GvIO(gv);
ad02613c 1788 do_fstat_have_io:
5228a96c 1789 PL_laststype = OP_STAT;
bd5f6c01 1790 PL_statgv = gv ? gv : (GV *)io;
8062ff11 1791 SvPVCLEAR(PL_statname);
77616968 1792 if (io) {
5228a96c 1793 if (IoIFP(io)) {
375ed12a 1794 int fd = PerlIO_fileno(IoIFP(io));
77616968
JH		 1795 if (fd < 0) {
1796 /* E.g. PerlIO::scalar has no real fd. */
97c8f3e6 1797 SETERRNO(EBADF,RMS_IFI);
77616968
JH		 1798 return (PL_laststatval = -1);
1799 } else {
375ed12a
JH		 1800 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
1801 }
5228a96c 1802 } else if (IoDIRP(io)) {
3497a01f 1803 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
5228a96c 1804 }
5228a96c 1805 }
3888144c
FC		 1806 PL_laststatval = -1;
1807 report_evil_fh(gv);
97c8f3e6 1808 SETERRNO(EBADF,RMS_IFI);
3888144c 1809 return -1;
a687059c 1810 }
d2c4d2d1 1811 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
8db8f6b6
FC		 1812 == OPpFT_STACKED)
1813 return PL_laststatval;
d2c4d2d1
FC		 1814 else {
1815 SV* const sv = TOPs;
a155eb05 1816 const char *s, *d;
4ecd490c 1817 STRLEN len;
094a3eec 1818 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
748a9306
LW		 1819 goto do_fstat;
1820 }
ad02613c 1821 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 1822 io = MUTABLE_IO(SvRV(sv));
7f39519f 1823 gv = NULL;
ad02613c
SP		 1824 goto do_fstat_have_io;
1825 }
748a9306 1826
0d7d409d 1827 s = SvPV_flags_const(sv, len, flags);
a0714e2c 1828 PL_statgv = NULL;
4ecd490c 1829 sv_setpvn(PL_statname, s, len);
a155eb05 1830 d = SvPVX_const(PL_statname); /* s now NUL-terminated */
3280af22 1831 PL_laststype = OP_STAT;
a155eb05
TC		 1832 if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
1833 PL_laststatval = -1;
1834 }
1835 else {
1836 PL_laststatval = PerlLIO_stat(d, &PL_statcache);
1837 }
7cb3f959 1838 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
5d37acd6 1839 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 1840 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
5d37acd6
DM		 1841 GCC_DIAG_RESTORE;
1842 }
3280af22 1843 return PL_laststatval;
a687059c
LW		 1844 }
1845}
1846
fbb0b3b3 1847
79072805 1848I32
0d7d409d 1849Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 1850{
a1894d81 1851 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 1852 dSP;
b16276bb 1853 const char *file;
a155eb05 1854 STRLEN len;
cd22fad3 1855 SV* const sv = TOPs;
5840701a 1856 bool isio = FALSE;
533c011a 1857 if (PL_op->op_flags & OPf_REF) {
638eceb6 1858 if (cGVOP_gv == PL_defgv) {
3280af22 1859 if (PL_laststype != OP_LSTAT)
0157ef98 1860 Perl_croak(aTHX_ "%s", no_prev_lstat);
97c8f3e6
Z		 1861 if (PL_laststatval < 0)
1862 SETERRNO(EBADF,RMS_IFI);
3280af22 1863 return PL_laststatval;
fe14fcc3 1864 }
31b139ba 1865 PL_laststatval = -1;
5d3e98de 1866 if (ckWARN(WARN_IO)) {
5840701a 1867 /* diag_listed_as: Use of -l on filehandle%s */
d0c0e7dd 1868 Perl_warner(aTHX_ packWARN(WARN_IO),
147e3846 1869 "Use of -l on filehandle %" HEKf,
d0c0e7dd 1870 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 1871 }
97c8f3e6 1872 SETERRNO(EBADF,RMS_IFI);
31b139ba 1873 return -1;
fe14fcc3 1874 }
8db8f6b6
FC		 1875 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1876 == OPpFT_STACKED) {
1f26655e 1877 if (PL_laststype != OP_LSTAT)
0157ef98 1878 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 1879 return PL_laststatval;
cd22fad3 1880 }
c623bd54 1881
3280af22 1882 PL_laststype = OP_LSTAT;
a0714e2c 1883 PL_statgv = NULL;
5840701a
FC		 1884 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
1885 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
1886 )
1887 || isGV_with_GP(sv)
1888 )
1889 && ckWARN(WARN_IO)) {
1890 if (isio)
1891 /* diag_listed_as: Use of -l on filehandle%s */
1892 Perl_warner(aTHX_ packWARN(WARN_IO),
1893 "Use of -l on filehandle");
1894 else
1895 /* diag_listed_as: Use of -l on filehandle%s */
1896 Perl_warner(aTHX_ packWARN(WARN_IO),
147e3846 1897 "Use of -l on filehandle %" HEKf,
10bafe90
BF		 1898 HEKfARG(GvENAME_HEK((const GV *)
1899 (SvROK(sv) ? SvRV(sv) : sv))));
cd22fad3 1900 }
a155eb05 1901 file = SvPV_flags_const(sv, len, flags);
b16276bb 1902 sv_setpv(PL_statname,file);
a155eb05
TC		 1903 if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
1904 PL_laststatval = -1;
1905 }
1906 else {
1907 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
1908 }
7cb3f959 1909 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
5d37acd6
DM		 1910 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
1911 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
1912 GCC_DIAG_RESTORE;
1913 }
3280af22 1914 return PL_laststatval;
c623bd54
LW		 1915}
1916
a0f2c8ec
JD		 1917static void
1918S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
1919{
1920 const int e = errno;
7918f24d 1921 PERL_ARGS_ASSERT_EXEC_FAILED;
738ab09f
AB		 1922
1923 if (ckWARN(WARN_EXEC))
1924 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1925 cmd, Strerror(e));
a0f2c8ec 1926 if (do_report) {
b469f1e0
JH		 1927 /* XXX silently ignore failures */
1928 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
a0f2c8ec
JD		 1929 PerlLIO_close(fd);
1930 }
1931}
1932
738ab09f 1933bool
5aaab254 1934Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2aa1486d 1935 int fd, int do_report)
d5a9bfb0 1936{
27da23d5 1937 dVAR;
7918f24d 1938 PERL_ARGS_ASSERT_DO_AEXEC5;
e37778c2 1939#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
cd39f2b6
JH		 1940 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1941#else
2fcab330
DIM		 1942 assert(sp >= mark);
1943 {
360ea906 1944 const char **a;
6136c704 1945 const char *tmps = NULL;
360ea906 1946 Newx(PL_Argv, sp - mark + 1, const char*);
c3c5fad7 1947 a = PL_Argv;
890ce7af 1948
79072805
LW		 1949 while (++mark <= sp) {
1950 if (*mark)
360ea906 1951 *a++ = SvPV_nolen_const(*mark);
a687059c
LW		 1952 else
1953 *a++ = "";
1954 }
6136c704 1955 *a = NULL;
91b2752f 1956 if (really)
e62f0680 1957 tmps = SvPV_nolen_const(really);
2fcab330 1958 if ((!really && PL_Argv[0] && *PL_Argv[0] != '/') ||
91b2752f 1959 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 1960 TAINT_ENV(); /* testing IFS here is overkill, probably */
b35112e7 1961 PERL_FPU_PRE_EXEC
839a9f02 1962 if (really && *tmps) {
738ab09f 1963 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
2fcab330 1964 } else if (PL_Argv[0]) {
738ab09f 1965 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
2fcab330
DIM		 1966 } else {
1967 SETERRNO(ENOENT,RMS_FNF);
1968 }
b35112e7 1969 PERL_FPU_POST_EXEC
2fcab330 1970 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0] ? PL_Argv[0] : ""), fd, do_report);
a687059c 1971 }
bee1dbe2 1972 do_execfree();
cd39f2b6 1973#endif
738ab09f 1974 return FALSE;
a687059c
LW		 1975}
1976
fe14fcc3 1977void
864dbfa3 1978Perl_do_execfree(pTHX)
ff8e2863 1979{
43c5f42d 1980 Safefree(PL_Argv);
4608196e 1981 PL_Argv = NULL;
43c5f42d 1982 Safefree(PL_Cmd);
bd61b366 1983 PL_Cmd = NULL;
ff8e2863
LW		 1984}
1985
9555a685 1986#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8 1987
738ab09f 1988bool
2fbb330f 1989Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 1990{
27da23d5 1991 dVAR;
eb578fdb
KW		 1992 const char **a;
1993 char *s;
15db3ae2 1994 char *buf;
2fbb330f 1995 char *cmd;
2fbb330f 1996 /* Make a copy so we can change it */
6fca0082 1997 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC		 1998
1999 PERL_ARGS_ASSERT_DO_EXEC3;
2000
15db3ae2
DM		 2001 Newx(buf, cmdlen, char);
2002 cmd = buf;
cfff9797 2003 memcpy(cmd, incmd, cmdlen);
a687059c 2004
748a9306
LW		 2005 while (*cmd && isSPACE(*cmd))
2006 cmd++;
2007
a687059c
LW		 2008 /* save an extra exec if possible */
2009
bf38876a 2010#ifdef CSH
d05c1ba0 2011 {
0c19750d 2012 char flags[PERL_FLAGS_MAX];
d05c1ba0 2013 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
c8b388b0 2014 strBEGINs(cmd+PL_cshlen," -c")) {
28f0d0ec 2015 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
d05c1ba0
JH		 2016 s = cmd+PL_cshlen+3;
2017 if (*s == 'f') {
2018 s++;
28f0d0ec 2019 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
d05c1ba0
JH		 2020 }
2021 if (*s == ' ')
2022 s++;
2023 if (*s++ == '\'') {
0bcc34c2 2024 char * const ncmd = s;
d05c1ba0
JH		 2025
2026 while (*s)
2027 s++;
2028 if (s[-1] == '\n')
2029 *--s = '\0';
2030 if (s[-1] == '\'') {
2031 *--s = '\0';
b35112e7 2032 PERL_FPU_PRE_EXEC
738ab09f 2033 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
b35112e7 2034 PERL_FPU_POST_EXEC
d05c1ba0 2035 *s = '\'';
a0f2c8ec 2036 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
15db3ae2 2037 Safefree(buf);
738ab09f 2038 return FALSE;
d05c1ba0
JH		 2039 }
2040 }
a687059c
LW		 2041 }
2042 }
bf38876a 2043#endif /* CSH */
a687059c
LW		 2044
2045 /* see if there are shell metacharacters in it */
2046
748a9306
LW		 2047 if (*cmd == '.' && isSPACE(cmd[1]))
2048 goto doshell;
2049
c8b388b0 2050 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
748a9306
LW		 2051 goto doshell;
2052
294b3b39 2053 s = cmd;
0eb30aeb 2054 while (isWORDCHAR(*s))
294b3b39 2055 s++; /* catch VAR=val gizmo */
63f2c1e1
LW		 2056 if (*s == '=')
2057 goto doshell;
748a9306 2058
a687059c 2059 for (s = cmd; *s; s++) {
d05c1ba0
JH		 2060 if (*s != ' ' && !isALPHA(*s) &&
2061 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW		 2062 if (*s == '\n' && !s[1]) {
2063 *s = '\0';
2064 break;
2065 }
603a98b0
IZ		 2066 /* handle the 2>&1 construct at the end */
2067 if (*s == '>' && s[1] == '&' && s[2] == '1'
2068 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
2069 && (!s[3] || isSPACE(s[3])))
2070 {
6867be6d 2071 const char *t = s + 3;
603a98b0
IZ		 2072
2073 while (*t && isSPACE(*t))
2074 ++t;
943bbd07 2075 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
603a98b0
IZ		 2076 s[-2] = '\0';
2077 break;
2078 }
2079 }
a687059c 2080 doshell:
b35112e7 2081 PERL_FPU_PRE_EXEC
738ab09f 2082 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
b35112e7 2083 PERL_FPU_POST_EXEC
a0f2c8ec 2084 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
15db3ae2 2085 Safefree(buf);
738ab09f 2086 return FALSE;
a687059c
LW		 2087 }
2088 }
748a9306 2089
360ea906 2090 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*);
3280af22
NIS		 2091 PL_Cmd = savepvn(cmd, s-cmd);
2092 a = PL_Argv;
2093 for (s = PL_Cmd; *s;) {
294b3b39
AL		 2094 while (isSPACE(*s))
2095 s++;
a687059c
LW		 2096 if (*s)
2097 *(a++) = s;
294b3b39
AL		 2098 while (*s && !isSPACE(*s))
2099 s++;
a687059c
LW		 2100 if (*s)
2101 *s++ = '\0';
2102 }
6136c704 2103 *a = NULL;
3280af22 2104 if (PL_Argv[0]) {
b35112e7 2105 PERL_FPU_PRE_EXEC
738ab09f 2106 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 2107 PERL_FPU_POST_EXEC
b1248f16 2108 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 2109 do_execfree();
a687059c 2110 goto doshell;
b1248f16 2111 }
a0f2c8ec 2112 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
a687059c 2113 }
ff8e2863 2114 do_execfree();
15db3ae2 2115 Safefree(buf);
738ab09f 2116 return FALSE;
a687059c
LW		 2117}
2118
6890e559 2119#endif /* OS2 || WIN32 */
760ac839 2120
79072805 2121I32
5aaab254 2122Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
a687059c 2123{
eb578fdb
KW		 2124 I32 val;
2125 I32 tot = 0;
4634a855 2126 const char *const what = PL_op_name[type];
5c144d81 2127 const char *s;
84c7b88c 2128 STRLEN len;
890ce7af 2129 SV ** const oldmark = mark;
885b4b39 2130 bool killgp = FALSE;
a687059c 2131
7918f24d
NC		 2132 PERL_ARGS_ASSERT_APPLY;
2133
9a9b5ec9
DM		 2134 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
2135
1444765e
NC		 2136 /* Doing this ahead of the switch statement preserves the old behaviour,
2137 where attempting to use kill as a taint test test would fail on
2138 platforms where kill was not defined. */
2139#ifndef HAS_KILL
2140 if (type == OP_KILL)
4634a855 2141 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2142#endif
2143#ifndef HAS_CHOWN
2144 if (type == OP_CHOWN)
4634a855 2145 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2146#endif
2147
2148
20408e3c 2149#define APPLY_TAINT_PROPER() \
3280af22 2150 STMT_START { \
284167a5 2151 if (TAINT_get) { TAINT_PROPER(what); } \
873ef191 2152 } STMT_END
20408e3c
GS		 2153
2154 /* This is a first heuristic; it doesn't catch tainting magic. */
284167a5 2155 if (TAINTING_get) {
463ee0b2 2156 while (++mark <= sp) {
bbce6d69 2157 if (SvTAINTED(*mark)) {
2158 TAINT;
2159 break;
2160 }
463ee0b2
LW		 2161 }
2162 mark = oldmark;
2163 }
a687059c 2164 switch (type) {
79072805 2165 case OP_CHMOD:
20408e3c 2166 APPLY_TAINT_PROPER();
79072805 2167 if (++mark <= sp) {
4ea561bc 2168 val = SvIV(*mark);
20408e3c
GS		 2169 APPLY_TAINT_PROPER();
2170 tot = sp - mark;
79072805 2171 while (++mark <= sp) {
c4aca7d0 2172 GV* gv;
2ea1cce7 2173 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA		 2174 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2175#ifdef HAS_FCHMOD
375ed12a 2176 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 2177 APPLY_TAINT_PROPER();
375ed12a
JH		 2178 if (fd < 0) {
2179 SETERRNO(EBADF,RMS_IFI);
2180 tot--;
2181 } else if (fchmod(fd, val))
2182 tot--;
c4aca7d0 2183#else
b9c6780e 2184 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0
GA		 2185#endif
2186 }
2187 else {
8334cae6 2188 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 2189 tot--;
2190 }
2191 }
c4aca7d0 2192 else {
41188aa0 2193 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 2194 APPLY_TAINT_PROPER();
41188aa0 2195 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC		 2196 PerlLIO_chmod(name, val)) {
2197 tot--;
2198 }
c4aca7d0 2199 }
a687059c
LW		 2200 }
2201 }
2202 break;
fe14fcc3 2203#ifdef HAS_CHOWN
79072805 2204 case OP_CHOWN:
20408e3c 2205 APPLY_TAINT_PROPER();
79072805 2206 if (sp - mark > 2) {
eb578fdb 2207 I32 val2;
463ee0b2
LW		 2208 val = SvIVx(*++mark);
2209 val2 = SvIVx(*++mark);
20408e3c 2210 APPLY_TAINT_PROPER();
a0d0e21e 2211 tot = sp - mark;
79072805 2212 while (++mark <= sp) {
c4aca7d0 2213 GV* gv;
2ea1cce7 2214 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA		 2215 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2216#ifdef HAS_FCHOWN
375ed12a 2217 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 2218 APPLY_TAINT_PROPER();
375ed12a 2219 if (fd < 0) {
dd1dbff0 2220 SETERRNO(EBADF,RMS_IFI);
f95ba548 2221 tot--;
375ed12a 2222 } else if (fchown(fd, val, val2))
c4aca7d0
GA		 2223 tot--;
2224#else
b9c6780e 2225 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0
GA		 2226#endif
2227 }
2228 else {
8334cae6 2229 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 2230 tot--;
2231 }
2232 }
c4aca7d0 2233 else {
41188aa0 2234 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 2235 APPLY_TAINT_PROPER();
41188aa0 2236 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 2237 PerlLIO_chown(name, val, val2)) {
c4aca7d0 2238 tot--;
c8028aa6 2239 }
c4aca7d0 2240 }
a687059c
LW		 2241 }
2242 }
2243 break;
b1248f16 2244#endif
a1d180c4 2245/*
dd64f1c3
AD		 2246XXX Should we make lchown() directly available from perl?
2247For now, we'll let Configure test for HAS_LCHOWN, but do
2248nothing in the core.
2249 --AD 5/1998
2250*/
fe14fcc3 2251#ifdef HAS_KILL
79072805 2252 case OP_KILL:
20408e3c 2253 APPLY_TAINT_PROPER();
55497cff 2254 if (mark == sp)
2255 break;
84c7b88c 2256 s = SvPVx_const(*++mark, len);
c2fd40cb
DM		 2257 if (*s == '-' && isALPHA(s[1]))
2258 {
2259 s++;
2260 len--;
885b4b39 2261 killgp = TRUE;
c2fd40cb 2262 }
e02bfb16 2263 if (isALPHA(*s)) {
84c7b88c 2264 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
79072805 2265 s += 3;
84c7b88c
BF		 2266 len -= 3;
2267 }
2268 if ((val = whichsig_pvn(s, len)) < 0)
147e3846
KW		 2269 Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"",
2270 SVfARG(*mark));
79072805
LW		 2271 }
2272 else
c2fd40cb 2273 {
4ea561bc 2274 val = SvIV(*mark);
c2fd40cb
DM		 2275 if (val < 0)
2276 {
885b4b39 2277 killgp = TRUE;
c2fd40cb
DM		 2278 val = -val;
2279 }
2280 }
20408e3c
GS		 2281 APPLY_TAINT_PROPER();
2282 tot = sp - mark;
fbcd93f0 2283
c2fd40cb 2284 while (++mark <= sp) {
60082291 2285 Pid_t proc;
c2fd40cb 2286 SvGETMAGIC(*mark);
60082291 2287 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
c2fd40cb
DM		 2288 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
2289 proc = SvIV_nomg(*mark);
c2fd40cb 2290 APPLY_TAINT_PROPER();
111f73b5
DM		 2291#ifdef HAS_KILLPG
2292 /* use killpg in preference, as the killpg() wrapper for Win32
2293 * understands process groups, but the kill() wrapper doesn't */
2294 if (killgp ? PerlProc_killpg(proc, val)
2295 : PerlProc_kill(proc, val))
2296#else
2297 if (PerlProc_kill(killgp ? -proc: proc, val))
2298#endif
c2fd40cb 2299 tot--;
a687059c 2300 }
8165faea 2301 PERL_ASYNC_CHECK();
a687059c 2302 break;
b1248f16 2303#endif
79072805 2304 case OP_UNLINK:
20408e3c 2305 APPLY_TAINT_PROPER();
79072805
LW		 2306 tot = sp - mark;
2307 while (++mark <= sp) {
41188aa0 2308 s = SvPV_const(*mark, len);
20408e3c 2309 APPLY_TAINT_PROPER();
41188aa0 2310 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC		 2311 tot--;
2312 }
f0d85c30 2313 else if (PL_unsafe) {
b8ffc8df 2314 if (UNLINK(s))
5cdd1fc2 2315 {
a687059c 2316 tot--;
5cdd1fc2
AB		 2317 }
2318#if defined(__amigaos4__) && defined(NEWLIB)
2319 else
2320 {
2321 /* Under AmigaOS4 unlink only 'fails' if the
2322 * filename is invalid. It may not remove the file
2323 * if it's locked, so check if it's still around. */
2324 if ((access(s,F_OK) != -1))
2325 {
2326 tot--;
2327 }
2328 }
2329#endif
a687059c
LW		 2330 }
2331 else { /* don't let root wipe out directories without -U */
45a23732
DD		 2332 Stat_t statbuf;
2333 if (PerlLIO_lstat(s, &statbuf) < 0)
1dcae8b8 2334 tot--;
45a23732 2335 else if (S_ISDIR(statbuf.st_mode)) {
cd52bc19 2336 SETERRNO(EISDIR, SS_NOPRIV);
45a23732 2337 tot--;
1dcae8b8 2338 }
a687059c 2339 else {
b8ffc8df 2340 if (UNLINK(s))
5cdd1fc2
AB		 2341 {
2342 tot--;
2343 }
2344#if defined(__amigaos4__) && defined(NEWLIB)
2345 else
2346 {
2347 /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */
2348 /* It may not remove the file if it's Locked, so check if it's still */
2349 /* arround */
2350 if((access(s,F_OK) != -1))
2351 {
2352 tot--;
2353 }
2354 }
2355#endif
a687059c
LW		 2356 }
2357 }
2358 }
2359 break;
e96b369d 2360#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 2361 case OP_UTIME:
20408e3c 2362 APPLY_TAINT_PROPER();
79072805 2363 if (sp - mark > 2) {
e96b369d
GA		 2364#if defined(HAS_FUTIMES)
2365 struct timeval utbuf[2];
2366 void *utbufp = utbuf;
2367#elif defined(I_UTIME) || defined(VMS)
663a0e37 2368 struct utimbuf utbuf;
07409e01 2369 struct utimbuf *utbufp = &utbuf;
663a0e37 2370#else
a687059c 2371 struct {
dd2821f6
GS		 2372 Time_t actime;
2373 Time_t modtime;
a687059c 2374 } utbuf;
07409e01 2375 void *utbufp = &utbuf;
663a0e37 2376#endif
a687059c 2377
0bcc34c2
AL		 2378 SV* const accessed = *++mark;
2379 SV* const modified = *++mark;
c6f7b413 2380
6ec06612
SB		 2381 /* Be like C, and if both times are undefined, let the C
2382 * library figure out what to do. This usually means
2383 * "current time". */
c6f7b413
RS		 2384
2385 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB		 2386 utbufp = NULL;
2387 else {
2388 Zero(&utbuf, sizeof utbuf, char);
e96b369d 2389#ifdef HAS_FUTIMES
4ea561bc 2390 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 2391 utbuf[0].tv_usec = 0;
4ea561bc 2392 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA		 2393 utbuf[1].tv_usec = 0;
2394#elif defined(BIG_TIME)
4ea561bc
NC		 2395 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
2396 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 2397#else
4ea561bc
NC		 2398 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
2399 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 2400#endif
6ec06612 2401 }
4373e329 2402 APPLY_TAINT_PROPER();
79072805
LW		 2403 tot = sp - mark;
2404 while (++mark <= sp) {
e96b369d 2405 GV* gv;
64617da9 2406 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA		 2407 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2408#ifdef HAS_FUTIMES
375ed12a 2409 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
e96b369d 2410 APPLY_TAINT_PROPER();
375ed12a
JH		 2411 if (fd < 0) {
2412 SETERRNO(EBADF,RMS_IFI);
2413 tot--;
2414 } else if (futimes(fd, (struct timeval *) utbufp))
e96b369d
GA		 2415 tot--;
2416#else
2417 Perl_die(aTHX_ PL_no_func, "futimes");
2418#endif
2419 }
2420 else {
2421 tot--;
2422 }
2423 }
e96b369d 2424 else {
41188aa0 2425 const char * const name = SvPV_nomg_const(*mark, len);
e96b369d 2426 APPLY_TAINT_PROPER();
41188aa0 2427 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC		 2428 tot--;
2429 }
2430 else
e96b369d 2431#ifdef HAS_FUTIMES
8b7231d9 2432 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA		 2433#else
2434 if (PerlLIO_utime(name, utbufp))
2435#endif
2436 tot--;
2437 }
2438
a687059c 2439 }
a687059c
LW		 2440 }
2441 else
79072805 2442 tot = 0;
a687059c 2443 break;
a0d0e21e 2444#endif
a687059c
LW		 2445 }
2446 return tot;
20408e3c 2447
20408e3c 2448#undef APPLY_TAINT_PROPER
a687059c
LW		 2449}
2450
bd93adf5 2451/* Do the permissions in *statbufp allow some operation? */
a0d0e21e 2452#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 2453bool
5aaab254 2454Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC		 2455/* effective is a flag, true for EUID, or for checking if the effective gid
2456 * is in the list of groups returned from getgroups().
2457 */
a687059c 2458{
7918f24d 2459 PERL_ARGS_ASSERT_CANDO;
81611534 2460 PERL_UNUSED_CONTEXT;
7918f24d 2461
bee1dbe2 2462#ifdef DOSISH
fe14fcc3
LW		 2463 /* [Comments and code from Len Reed]
2464 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
2465 * to write-protected files. The execute permission bit is set
486ec47a 2466 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW		 2467 * .exe files
2468 * .com files
2469 * .bat files
2470 * directories
2471 * All files and directories are readable.
2472 * Directories and special files, e.g. "CON", cannot be
2473 * write-protected.
2474 * [Comment by Tom Dinger -- a directory can have the write-protect
2475 * bit set in the file system, but DOS permits changes to
2476 * the directory anyway. In addition, all bets are off
2477 * here for networked software, such as Novell and
2478 * Sun's PC-NFS.]
2479 */
2480
bee1dbe2
LW		 2481 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
2482 * too so it will actually look into the files for magic numbers
2483 */
8298454c 2484 return cBOOL(mode & statbufp->st_mode);
fe14fcc3 2485
55497cff 2486#else /* ! DOSISH */
b595cd4b
RU		 2487# ifdef __CYGWIN__
2488 if (ingroup(544,effective)) { /* member of Administrators */
2489# else
985213f2 2490 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 2491# endif
7f4774ae 2492 if (mode == S_IXUSR) {
c623bd54 2493 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW		 2494 return TRUE;
2495 }
2496 else
2497 return TRUE; /* root reads and writes anything */
2498 return FALSE;
2499 }
985213f2 2500 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 2501 if (statbufp->st_mode & mode)
a687059c
LW		 2502 return TRUE; /* ok as "user" */
2503 }
d8eceb89 2504 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 2505 if (statbufp->st_mode & mode >> 3)
a687059c
LW		 2506 return TRUE; /* ok as "group" */
2507 }
7f4774ae 2508 else if (statbufp->st_mode & mode >> 6)
a687059c
LW		 2509 return TRUE; /* ok as "other" */
2510 return FALSE;
55497cff 2511#endif /* ! DOSISH */
a687059c 2512}
a0d0e21e 2513#endif /* ! VMS */
a687059c 2514
1f676739 2515static bool
0da8eb3a 2516S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 2517{
81611534
JH		 2518#ifndef PERL_IMPLICIT_SYS
2519 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */
2520 PERL_UNUSED_CONTEXT;
2521#endif
985213f2 2522 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 2523 return TRUE;
fe14fcc3 2524#ifdef HAS_GETGROUPS
a687059c 2525 {
331b57bc 2526 Groups_t *gary = NULL;
79072805 2527 I32 anum;
331b57bc 2528 bool rc = FALSE;
a687059c 2529
331b57bc 2530 anum = getgroups(0, gary);
375ed12a
JH		 2531 if (anum > 0) {
2532 Newx(gary, anum, Groups_t);
2533 anum = getgroups(anum, gary);
2534 while (--anum >= 0)
2535 if (gary[anum] == testgid) {
2536 rc = TRUE;
2537 break;
2538 }
331b57bc 2539
375ed12a
JH		 2540 Safefree(gary);
2541 }
331b57bc 2542 return rc;
a687059c 2543 }
c685562b 2544#else
a687059c 2545 return FALSE;
cd39f2b6 2546#endif
a687059c 2547}
c2ab57d4 2548
fe14fcc3 2549#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2550
79072805 2551I32
864dbfa3 2552Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2553{
0bcc34c2 2554 const key_t key = (key_t)SvNVx(*++mark);
c3312966 2555 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 2556 const I32 flags = SvIVx(*++mark);
294a48e9 2557
7918f24d 2558 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 2559 PERL_UNUSED_ARG(sp);
c2ab57d4 2560
748a9306 2561 SETERRNO(0,0);
c2ab57d4
LW		 2562 switch (optype)
2563 {
fe14fcc3 2564#ifdef HAS_MSG
79072805 2565 case OP_MSGGET:
c2ab57d4 2566 return msgget(key, flags);
e5d73d77 2567#endif
fe14fcc3 2568#ifdef HAS_SEM
79072805 2569 case OP_SEMGET:
c3312966 2570 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2571#endif
fe14fcc3 2572#ifdef HAS_SHM
79072805 2573 case OP_SHMGET:
c3312966 2574 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 2575#endif
fe14fcc3 2576#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2577 default:
fe13d51d 2578 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2579 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2580#endif
c2ab57d4
LW		 2581 }
2582 return -1; /* should never happen */
2583}
2584
79072805 2585I32
864dbfa3 2586Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2587{
c2ab57d4 2588 char *a;
a0d0e21e 2589 I32 ret = -1;
6867be6d 2590 const I32 id = SvIVx(*++mark);
95b63a38 2591#ifdef Semctl
6867be6d 2592 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2593#endif
6867be6d 2594 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL		 2595 SV * const astr = *++mark;
2596 STRLEN infosize = 0;
2597 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2598
7918f24d 2599 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2600 PERL_UNUSED_ARG(sp);
c2ab57d4
LW		 2601
2602 switch (optype)
2603 {
fe14fcc3 2604#ifdef HAS_MSG
79072805 2605 case OP_MSGCTL:
c2ab57d4
LW		 2606 if (cmd == IPC_STAT || cmd == IPC_SET)
2607 infosize = sizeof(struct msqid_ds);
2608 break;
e5d73d77 2609#endif
fe14fcc3 2610#ifdef HAS_SHM
79072805 2611 case OP_SHMCTL:
c2ab57d4
LW		 2612 if (cmd == IPC_STAT || cmd == IPC_SET)
2613 infosize = sizeof(struct shmid_ds);
2614 break;
e5d73d77 2615#endif
fe14fcc3 2616#ifdef HAS_SEM
79072805 2617 case OP_SEMCTL:
39398f3f 2618#ifdef Semctl
c2ab57d4
LW		 2619 if (cmd == IPC_STAT || cmd == IPC_SET)
2620 infosize = sizeof(struct semid_ds);
2621 else if (cmd == GETALL || cmd == SETALL)
2622 {
8e591e46 2623 struct semid_ds semds;
bd89102f 2624 union semun semun;
e6f0bdd6
GS		 2625#ifdef EXTRA_F_IN_SEMUN_BUF
2626 semun.buff = &semds;
2627#else
84902520 2628 semun.buf = &semds;
e6f0bdd6 2629#endif
c2ab57d4 2630 getinfo = (cmd == GETALL);
9b89d93d
GB		 2631 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2632 return -1;
6e21c824
LW		 2633 infosize = semds.sem_nsems * sizeof(short);
2634 /* "short" is technically wrong but much more portable
2635 than guessing about u_?short(_t)? */
c2ab57d4 2636 }
39398f3f 2637#else
fe13d51d 2638 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2639 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2640#endif
c2ab57d4 2641 break;
e5d73d77 2642#endif
fe14fcc3 2643#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2644 default:
fe13d51d 2645 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2646 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2647#endif
c2ab57d4
LW		 2648 }
2649
2650 if (infosize)
2651 {
2652 if (getinfo)
2653 {
93524f2b 2654 SvPV_force_nolen(astr);
a0d0e21e 2655 a = SvGROW(astr, infosize+1);
c2ab57d4
LW		 2656 }
2657 else
2658 {
93524f2b 2659 STRLEN len;
463ee0b2
LW		 2660 a = SvPV(astr, len);
2661 if (len != infosize)
cea2e8a9 2662 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH		 2663 PL_op_desc[optype],
2664 (unsigned long)len,
2665 (long)infosize);
c2ab57d4
LW		 2666 }
2667 }
2668 else
2669 {
0bcc34c2 2670 const IV i = SvIV(astr);
56431972 2671 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 2672 }
748a9306 2673 SETERRNO(0,0);
c2ab57d4
LW		 2674 switch (optype)
2675 {
fe14fcc3 2676#ifdef HAS_MSG
79072805 2677 case OP_MSGCTL:
bee1dbe2 2678 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 2679 break;
e5d73d77 2680#endif
fe14fcc3 2681#ifdef HAS_SEM
bd89102f 2682 case OP_SEMCTL: {
39398f3f 2683#ifdef Semctl
bd89102f
AD		 2684 union semun unsemds;
2685
64d76282
BC		 2686 if(cmd == SETVAL) {
2687 unsemds.val = PTR2nat(a);
2688 }
2689 else {
e6f0bdd6 2690#ifdef EXTRA_F_IN_SEMUN_BUF
64d76282 2691 unsemds.buff = (struct semid_ds *)a;
e6f0bdd6 2692#else
64d76282 2693 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 2694#endif
64d76282 2695 }
bd89102f 2696 ret = Semctl(id, n, cmd, unsemds);
39398f3f 2697#else
fe13d51d 2698 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2699 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2700#endif
bd89102f 2701 }
c2ab57d4 2702 break;
e5d73d77 2703#endif
fe14fcc3 2704#ifdef HAS_SHM
79072805 2705 case OP_SHMCTL:
bee1dbe2 2706 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 2707 break;
e5d73d77 2708#endif
c2ab57d4
LW		 2709 }
2710 if (getinfo && ret >= 0) {
79072805
LW		 2711 SvCUR_set(astr, infosize);
2712 *SvEND(astr) = '\0';
a0d0e21e 2713 SvSETMAGIC(astr);
c2ab57d4
LW		 2714 }
2715 return ret;
2716}
2717
79072805 2718I32
864dbfa3 2719Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 2720{
fe14fcc3 2721#ifdef HAS_MSG
463ee0b2 2722 STRLEN len;
6867be6d 2723 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 2724 SV * const mstr = *++mark;
2725 const I32 flags = SvIVx(*++mark);
2726 const char * const mbuf = SvPV_const(mstr, len);
2727 const I32 msize = len - sizeof(long);
2728
7918f24d 2729 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 2730 PERL_UNUSED_ARG(sp);
c2ab57d4 2731
0bcc34c2 2732 if (msize < 0)
cea2e8a9 2733 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 2734 SETERRNO(0,0);
681fb693
JH		 2735 if (id >= 0 && flags >= 0) {
2736 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
2737 } else {
2738 SETERRNO(EINVAL,LIB_INVARG);
2739 return -1;
2740 }
e5d73d77 2741#else
2d51fa4d
RGS		 2742 PERL_UNUSED_ARG(sp);
2743 PERL_UNUSED_ARG(mark);
fe13d51d 2744 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2745 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 2746 return -1;
e5d73d77 2747#endif
c2ab57d4
LW		 2748}
2749
79072805 2750I32
864dbfa3 2751Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 2752{
fe14fcc3 2753#ifdef HAS_MSG
c2ab57d4
LW		 2754 char *mbuf;
2755 long mtype;
6867be6d 2756 I32 msize, flags, ret;
6867be6d 2757 const I32 id = SvIVx(*++mark);
0bcc34c2 2758 SV * const mstr = *++mark;
7918f24d
NC		 2759
2760 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 2761 PERL_UNUSED_ARG(sp);
79072805 2762
c2e66d9e
GS		 2763 /* suppress warning when reading into undef var --jhi */
2764 if (! SvOK(mstr))
8062ff11 2765 SvPVCLEAR(mstr);
463ee0b2
LW		 2766 msize = SvIVx(*++mark);
2767 mtype = (long)SvIVx(*++mark);
2768 flags = SvIVx(*++mark);
93524f2b 2769 SvPV_force_nolen(mstr);
a0d0e21e 2770 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2771
748a9306 2772 SETERRNO(0,0);
d2607e1e
JH		 2773 if (id >= 0 && msize >= 0 && flags >= 0) {
2774 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
2775 } else {
2776 SETERRNO(EINVAL,LIB_INVARG);
2777 ret = -1;
2778 }
c2ab57d4 2779 if (ret >= 0) {
79072805
LW		 2780 SvCUR_set(mstr, sizeof(long)+ret);
2781 *SvEND(mstr) = '\0';
41d6edb2
JH		 2782 /* who knows who has been playing with this message? */
2783 SvTAINTED_on(mstr);
c2ab57d4
LW		 2784 }
2785 return ret;
e5d73d77 2786#else
2d51fa4d
RGS		 2787 PERL_UNUSED_ARG(sp);
2788 PERL_UNUSED_ARG(mark);
fe13d51d 2789 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2790 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 2791 return -1;
e5d73d77 2792#endif
c2ab57d4
LW		 2793}
2794
79072805 2795I32
864dbfa3 2796Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2797{
fe14fcc3 2798#ifdef HAS_SEM
463ee0b2 2799 STRLEN opsize;
6867be6d 2800 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 2801 SV * const opstr = *++mark;
2802 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC		 2803
2804 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 2805 PERL_UNUSED_ARG(sp);
c2ab57d4 2806
248ff010
NC		 2807 if (opsize < 3 * SHORTSIZE
2808 || (opsize % (3 * SHORTSIZE))) {
93189314 2809 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW		 2810 return -1;
2811 }
748a9306 2812 SETERRNO(0,0);
248ff010
NC		 2813 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2814 {
6867be6d 2815 const int nsops = opsize / (3 * sizeof (short));
248ff010 2816 int i = nsops;
0bcc34c2 2817 short * const ops = (short *) opbuf;
248ff010
NC		 2818 short *o = ops;
2819 struct sembuf *temps, *t;
2820 I32 result;
2821
a02a5408 2822 Newx (temps, nsops, struct sembuf);
248ff010
NC		 2823 t = temps;
2824 while (i--) {
2825 t->sem_num = *o++;
2826 t->sem_op = *o++;
2827 t->sem_flg = *o++;
2828 t++;
2829 }
2830 result = semop(id, temps, nsops);
248ff010
NC		 2831 Safefree(temps);
2832 return result;
2833 }
e5d73d77 2834#else
fe13d51d 2835 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2836 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2837#endif
c2ab57d4
LW		 2838}
2839
79072805 2840I32
864dbfa3 2841Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2842{
fe14fcc3 2843#ifdef HAS_SHM
4373e329 2844 char *shm;
c2ab57d4 2845 struct shmid_ds shmds;
6867be6d 2846 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 2847 SV * const mstr = *++mark;
2848 const I32 mpos = SvIVx(*++mark);
2849 const I32 msize = SvIVx(*++mark);
7918f24d
NC		 2850
2851 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 2852 PERL_UNUSED_ARG(sp);
c2ab57d4 2853
748a9306 2854 SETERRNO(0,0);
c2ab57d4
LW		 2855 if (shmctl(id, IPC_STAT, &shmds) == -1)
2856 return -1;
7f39519f
NC		 2857 if (mpos < 0 || msize < 0
2858 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 2859 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW		 2860 return -1;
2861 }
568fc267
JH		 2862 if (id >= 0) {
2863 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
2864 } else {
2865 SETERRNO(EINVAL,LIB_INVARG);
2866 return -1;
2867 }
c2ab57d4
LW		 2868 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2869 return -1;
79072805 2870 if (optype == OP_SHMREAD) {
c8ae91a8 2871 char *mbuf;
9f538c04 2872 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS		 2873 SvGETMAGIC(mstr);
2874 SvUPGRADE(mstr, SVt_PV);
9f538c04 2875 if (! SvOK(mstr))
8062ff11 2876 SvPVCLEAR(mstr);
af8ff727 2877 SvPOK_only(mstr);
bb7a0f54 2878 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 2879
bee1dbe2 2880 Copy(shm + mpos, mbuf, msize, char);
79072805
LW		 2881 SvCUR_set(mstr, msize);
2882 *SvEND(mstr) = '\0';
a0d0e21e 2883 SvSETMAGIC(mstr);
d929ce6f
JH		 2884 /* who knows who has been playing with this shared memory? */
2885 SvTAINTED_on(mstr);
c2ab57d4
LW		 2886 }
2887 else {
93524f2b 2888 STRLEN len;
c2ab57d4 2889
93524f2b 2890 const char *mbuf = SvPV_const(mstr, len);
027aa12d 2891 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 2892 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2893 if (n < msize)
bee1dbe2 2894 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW		 2895 }
2896 return shmdt(shm);
e5d73d77 2897#else
fe13d51d 2898 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2899 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 2900 return -1;
e5d73d77 2901#endif
c2ab57d4
LW		 2902}
2903
fe14fcc3 2904#endif /* SYSV IPC */
4e35701f 2905
0d44d22b 2906/*
ccfc67b7
JH		 2907=head1 IO Functions
2908
0d44d22b
NC		 2909=for apidoc start_glob
2910
2911Function called by C<do_readline> to spawn a glob (or do the glob inside
154e47c8 2912perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
25047fde
KW		 2913this glob starter is only used by miniperl during the build process,
2914or when PERL_EXTERNAL_GLOB is defined.
75af9d73 2915Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
fab3f3a7 2916
0d44d22b
NC		 2917=cut
2918*/
2919
2920PerlIO *
2921Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2922{
561b68a9 2923 SV * const tmpcmd = newSV(0);
0d44d22b 2924 PerlIO *fp;
41188aa0
TC		 2925 STRLEN len;
2926 const char *s = SvPV(tmpglob, len);
7918f24d
NC		 2927
2928 PERL_ARGS_ASSERT_START_GLOB;
2929
41188aa0 2930 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC		 2931 return NULL;
2932
0d44d22b
NC		 2933 ENTER;
2934 SAVEFREESV(tmpcmd);
2935#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2936 /* since spawning off a process is a real performance hit */
dca5a913 2937
1cc9774b
CB		 2938PerlIO *
2939Perl_vms_start_glob
2940 (pTHX_ SV *tmpglob,
2941 IO *io);
2942
49a7a762 2943 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 2944
0d44d22b 2945#else /* !VMS */
4009c3ff
AC		 2946# ifdef DOSISH
2947# if defined(OS2)
0d44d22b
NC		 2948 sv_setpv(tmpcmd, "for a in ");
2949 sv_catsv(tmpcmd, tmpglob);
2950 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
4009c3ff 2951# elif defined(DJGPP)
0d44d22b
NC		 2952 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2953 sv_catsv(tmpcmd, tmpglob);
4009c3ff 2954# else
0d44d22b
NC		 2955 sv_setpv(tmpcmd, "perlglob ");
2956 sv_catsv(tmpcmd, tmpglob);
2957 sv_catpv(tmpcmd, " |");
4009c3ff
AC		 2958# endif
2959# elif defined(CSH)
0d44d22b
NC		 2960 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2961 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2962 sv_catsv(tmpcmd, tmpglob);
2963 sv_catpv(tmpcmd, "' 2>/dev/null |");
4009c3ff 2964# else
0d44d22b
NC		 2965 sv_setpv(tmpcmd, "echo ");
2966 sv_catsv(tmpcmd, tmpglob);
0d44d22b 2967 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
4009c3ff 2968# endif /* !DOSISH && !CSH */
93b2dae1 2969 {
acffc8af
FC		 2970 SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
2971 if (svp && *svp)
2972 save_helem_flags(GvHV(PL_envgv),
2973 newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
2974 SAVEf_SETMAGIC);
93b2dae1 2975 }
d5eb9a46
NC		 2976 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
2977 NULL, NULL, 0);
0d44d22b
NC		 2978 fp = IoIFP(io);
2979#endif /* !VMS */
2980 LEAVE;
de7dabb6
TC		 2981
2982 if (!fp && ckWARN(WARN_GLOB)) {
2983 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
2984 Strerror(errno));
2985 }
2986
0d44d22b
NC		 2987 return fp;
2988}
66610fdd
RGS		 2989
2990/*
14d04a33 2991 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2992 */
Unnamed repository; edit this file 'description' to name the repository.