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
.gitignore: git should also ignore *.bak files
[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:
5228a96c
SP		 1782 if (gv == PL_defgv)
1783 return PL_laststatval;
2dd78f96 1784 io = GvIO(gv);
ad02613c 1785 do_fstat_have_io:
5228a96c 1786 PL_laststype = OP_STAT;
bd5f6c01 1787 PL_statgv = gv ? gv : (GV *)io;
8062ff11 1788 SvPVCLEAR(PL_statname);
77616968 1789 if (io) {
5228a96c 1790 if (IoIFP(io)) {
375ed12a 1791 int fd = PerlIO_fileno(IoIFP(io));
77616968
JH		 1792 if (fd < 0) {
1793 /* E.g. PerlIO::scalar has no real fd. */
1794 return (PL_laststatval = -1);
1795 } else {
375ed12a
JH		 1796 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
1797 }
5228a96c 1798 } else if (IoDIRP(io)) {
3497a01f 1799 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
5228a96c 1800 }
5228a96c 1801 }
3888144c
FC		 1802 PL_laststatval = -1;
1803 report_evil_fh(gv);
1804 return -1;
a687059c 1805 }
d2c4d2d1 1806 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
8db8f6b6
FC		 1807 == OPpFT_STACKED)
1808 return PL_laststatval;
d2c4d2d1
FC		 1809 else {
1810 SV* const sv = TOPs;
a155eb05 1811 const char *s, *d;
4ecd490c 1812 STRLEN len;
094a3eec 1813 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
748a9306
LW		 1814 goto do_fstat;
1815 }
ad02613c 1816 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 1817 io = MUTABLE_IO(SvRV(sv));
7f39519f 1818 gv = NULL;
ad02613c
SP		 1819 goto do_fstat_have_io;
1820 }
748a9306 1821
0d7d409d 1822 s = SvPV_flags_const(sv, len, flags);
a0714e2c 1823 PL_statgv = NULL;
4ecd490c 1824 sv_setpvn(PL_statname, s, len);
a155eb05 1825 d = SvPVX_const(PL_statname); /* s now NUL-terminated */
3280af22 1826 PL_laststype = OP_STAT;
a155eb05
TC		 1827 if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
1828 PL_laststatval = -1;
1829 }
1830 else {
1831 PL_laststatval = PerlLIO_stat(d, &PL_statcache);
1832 }
7cb3f959 1833 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
5d37acd6 1834 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 1835 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
5d37acd6
DM		 1836 GCC_DIAG_RESTORE;
1837 }
3280af22 1838 return PL_laststatval;
a687059c
LW		 1839 }
1840}
1841
fbb0b3b3 1842
79072805 1843I32
0d7d409d 1844Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 1845{
a1894d81 1846 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 1847 dSP;
b16276bb 1848 const char *file;
a155eb05 1849 STRLEN len;
cd22fad3 1850 SV* const sv = TOPs;
5840701a 1851 bool isio = FALSE;
533c011a 1852 if (PL_op->op_flags & OPf_REF) {
638eceb6 1853 if (cGVOP_gv == PL_defgv) {
3280af22 1854 if (PL_laststype != OP_LSTAT)
0157ef98 1855 Perl_croak(aTHX_ "%s", no_prev_lstat);
3280af22 1856 return PL_laststatval;
fe14fcc3 1857 }
31b139ba 1858 PL_laststatval = -1;
5d3e98de 1859 if (ckWARN(WARN_IO)) {
5840701a 1860 /* diag_listed_as: Use of -l on filehandle%s */
d0c0e7dd 1861 Perl_warner(aTHX_ packWARN(WARN_IO),
147e3846 1862 "Use of -l on filehandle %" HEKf,
d0c0e7dd 1863 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 1864 }
31b139ba 1865 return -1;
fe14fcc3 1866 }
8db8f6b6
FC		 1867 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1868 == OPpFT_STACKED) {
1f26655e 1869 if (PL_laststype != OP_LSTAT)
0157ef98 1870 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 1871 return PL_laststatval;
cd22fad3 1872 }
c623bd54 1873
3280af22 1874 PL_laststype = OP_LSTAT;
a0714e2c 1875 PL_statgv = NULL;
5840701a
FC		 1876 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
1877 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
1878 )
1879 || isGV_with_GP(sv)
1880 )
1881 && ckWARN(WARN_IO)) {
1882 if (isio)
1883 /* diag_listed_as: Use of -l on filehandle%s */
1884 Perl_warner(aTHX_ packWARN(WARN_IO),
1885 "Use of -l on filehandle");
1886 else
1887 /* diag_listed_as: Use of -l on filehandle%s */
1888 Perl_warner(aTHX_ packWARN(WARN_IO),
147e3846 1889 "Use of -l on filehandle %" HEKf,
10bafe90
BF		 1890 HEKfARG(GvENAME_HEK((const GV *)
1891 (SvROK(sv) ? SvRV(sv) : sv))));
cd22fad3 1892 }
a155eb05 1893 file = SvPV_flags_const(sv, len, flags);
b16276bb 1894 sv_setpv(PL_statname,file);
a155eb05
TC		 1895 if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
1896 PL_laststatval = -1;
1897 }
1898 else {
1899 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
1900 }
7cb3f959 1901 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
5d37acd6
DM		 1902 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
1903 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
1904 GCC_DIAG_RESTORE;
1905 }
3280af22 1906 return PL_laststatval;
c623bd54
LW		 1907}
1908
a0f2c8ec
JD		 1909static void
1910S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
1911{
1912 const int e = errno;
7918f24d 1913 PERL_ARGS_ASSERT_EXEC_FAILED;
738ab09f
AB		 1914
1915 if (ckWARN(WARN_EXEC))
1916 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1917 cmd, Strerror(e));
a0f2c8ec 1918 if (do_report) {
b469f1e0
JH		 1919 /* XXX silently ignore failures */
1920 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
a0f2c8ec
JD		 1921 PerlLIO_close(fd);
1922 }
1923}
1924
738ab09f 1925bool
5aaab254 1926Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2aa1486d 1927 int fd, int do_report)
d5a9bfb0 1928{
27da23d5 1929 dVAR;
7918f24d 1930 PERL_ARGS_ASSERT_DO_AEXEC5;
e37778c2 1931#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
cd39f2b6
JH		 1932 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1933#else
2fcab330
DIM		 1934 assert(sp >= mark);
1935 {
360ea906 1936 const char **a;
6136c704 1937 const char *tmps = NULL;
360ea906 1938 Newx(PL_Argv, sp - mark + 1, const char*);
c3c5fad7 1939 a = PL_Argv;
890ce7af 1940
79072805
LW		 1941 while (++mark <= sp) {
1942 if (*mark)
360ea906 1943 *a++ = SvPV_nolen_const(*mark);
a687059c
LW		 1944 else
1945 *a++ = "";
1946 }
6136c704 1947 *a = NULL;
91b2752f 1948 if (really)
e62f0680 1949 tmps = SvPV_nolen_const(really);
2fcab330 1950 if ((!really && PL_Argv[0] && *PL_Argv[0] != '/') ||
91b2752f 1951 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 1952 TAINT_ENV(); /* testing IFS here is overkill, probably */
b35112e7 1953 PERL_FPU_PRE_EXEC
839a9f02 1954 if (really && *tmps) {
738ab09f 1955 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
2fcab330 1956 } else if (PL_Argv[0]) {
738ab09f 1957 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
2fcab330
DIM		 1958 } else {
1959 SETERRNO(ENOENT,RMS_FNF);
1960 }
b35112e7 1961 PERL_FPU_POST_EXEC
2fcab330 1962 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0] ? PL_Argv[0] : ""), fd, do_report);
a687059c 1963 }
bee1dbe2 1964 do_execfree();
cd39f2b6 1965#endif
738ab09f 1966 return FALSE;
a687059c
LW		 1967}
1968
fe14fcc3 1969void
864dbfa3 1970Perl_do_execfree(pTHX)
ff8e2863 1971{
43c5f42d 1972 Safefree(PL_Argv);
4608196e 1973 PL_Argv = NULL;
43c5f42d 1974 Safefree(PL_Cmd);
bd61b366 1975 PL_Cmd = NULL;
ff8e2863
LW		 1976}
1977
9555a685 1978#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8 1979
738ab09f 1980bool
2fbb330f 1981Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 1982{
27da23d5 1983 dVAR;
eb578fdb
KW		 1984 const char **a;
1985 char *s;
15db3ae2 1986 char *buf;
2fbb330f 1987 char *cmd;
2fbb330f 1988 /* Make a copy so we can change it */
6fca0082 1989 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC		 1990
1991 PERL_ARGS_ASSERT_DO_EXEC3;
1992
15db3ae2
DM		 1993 Newx(buf, cmdlen, char);
1994 cmd = buf;
cfff9797 1995 memcpy(cmd, incmd, cmdlen);
a687059c 1996
748a9306
LW		 1997 while (*cmd && isSPACE(*cmd))
1998 cmd++;
1999
a687059c
LW		 2000 /* save an extra exec if possible */
2001
bf38876a 2002#ifdef CSH
d05c1ba0 2003 {
0c19750d 2004 char flags[PERL_FLAGS_MAX];
d05c1ba0 2005 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
c8b388b0 2006 strBEGINs(cmd+PL_cshlen," -c")) {
28f0d0ec 2007 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
d05c1ba0
JH		 2008 s = cmd+PL_cshlen+3;
2009 if (*s == 'f') {
2010 s++;
28f0d0ec 2011 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
d05c1ba0
JH		 2012 }
2013 if (*s == ' ')
2014 s++;
2015 if (*s++ == '\'') {
0bcc34c2 2016 char * const ncmd = s;
d05c1ba0
JH		 2017
2018 while (*s)
2019 s++;
2020 if (s[-1] == '\n')
2021 *--s = '\0';
2022 if (s[-1] == '\'') {
2023 *--s = '\0';
b35112e7 2024 PERL_FPU_PRE_EXEC
738ab09f 2025 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
b35112e7 2026 PERL_FPU_POST_EXEC
d05c1ba0 2027 *s = '\'';
a0f2c8ec 2028 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
15db3ae2 2029 Safefree(buf);
738ab09f 2030 return FALSE;
d05c1ba0
JH		 2031 }
2032 }
a687059c
LW		 2033 }
2034 }
bf38876a 2035#endif /* CSH */
a687059c
LW		 2036
2037 /* see if there are shell metacharacters in it */
2038
748a9306
LW		 2039 if (*cmd == '.' && isSPACE(cmd[1]))
2040 goto doshell;
2041
c8b388b0 2042 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
748a9306
LW		 2043 goto doshell;
2044
294b3b39 2045 s = cmd;
0eb30aeb 2046 while (isWORDCHAR(*s))
294b3b39 2047 s++; /* catch VAR=val gizmo */
63f2c1e1
LW		 2048 if (*s == '=')
2049 goto doshell;
748a9306 2050
a687059c 2051 for (s = cmd; *s; s++) {
d05c1ba0
JH		 2052 if (*s != ' ' && !isALPHA(*s) &&
2053 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW		 2054 if (*s == '\n' && !s[1]) {
2055 *s = '\0';
2056 break;
2057 }
603a98b0
IZ		 2058 /* handle the 2>&1 construct at the end */
2059 if (*s == '>' && s[1] == '&' && s[2] == '1'
2060 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
2061 && (!s[3] || isSPACE(s[3])))
2062 {
6867be6d 2063 const char *t = s + 3;
603a98b0
IZ		 2064
2065 while (*t && isSPACE(*t))
2066 ++t;
943bbd07 2067 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
603a98b0
IZ		 2068 s[-2] = '\0';
2069 break;
2070 }
2071 }
a687059c 2072 doshell:
b35112e7 2073 PERL_FPU_PRE_EXEC
738ab09f 2074 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
b35112e7 2075 PERL_FPU_POST_EXEC
a0f2c8ec 2076 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
15db3ae2 2077 Safefree(buf);
738ab09f 2078 return FALSE;
a687059c
LW		 2079 }
2080 }
748a9306 2081
360ea906 2082 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*);
3280af22
NIS		 2083 PL_Cmd = savepvn(cmd, s-cmd);
2084 a = PL_Argv;
2085 for (s = PL_Cmd; *s;) {
294b3b39
AL		 2086 while (isSPACE(*s))
2087 s++;
a687059c
LW		 2088 if (*s)
2089 *(a++) = s;
294b3b39
AL		 2090 while (*s && !isSPACE(*s))
2091 s++;
a687059c
LW		 2092 if (*s)
2093 *s++ = '\0';
2094 }
6136c704 2095 *a = NULL;
3280af22 2096 if (PL_Argv[0]) {
b35112e7 2097 PERL_FPU_PRE_EXEC
738ab09f 2098 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 2099 PERL_FPU_POST_EXEC
b1248f16 2100 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 2101 do_execfree();
a687059c 2102 goto doshell;
b1248f16 2103 }
a0f2c8ec 2104 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
a687059c 2105 }
ff8e2863 2106 do_execfree();
15db3ae2 2107 Safefree(buf);
738ab09f 2108 return FALSE;
a687059c
LW		 2109}
2110
6890e559 2111#endif /* OS2 || WIN32 */
760ac839 2112
79072805 2113I32
5aaab254 2114Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
a687059c 2115{
eb578fdb
KW		 2116 I32 val;
2117 I32 tot = 0;
4634a855 2118 const char *const what = PL_op_name[type];
5c144d81 2119 const char *s;
84c7b88c 2120 STRLEN len;
890ce7af 2121 SV ** const oldmark = mark;
885b4b39 2122 bool killgp = FALSE;
a687059c 2123
7918f24d
NC		 2124 PERL_ARGS_ASSERT_APPLY;
2125
9a9b5ec9
DM		 2126 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
2127
1444765e
NC		 2128 /* Doing this ahead of the switch statement preserves the old behaviour,
2129 where attempting to use kill as a taint test test would fail on
2130 platforms where kill was not defined. */
2131#ifndef HAS_KILL
2132 if (type == OP_KILL)
4634a855 2133 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2134#endif
2135#ifndef HAS_CHOWN
2136 if (type == OP_CHOWN)
4634a855 2137 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2138#endif
2139
2140
20408e3c 2141#define APPLY_TAINT_PROPER() \
3280af22 2142 STMT_START { \
284167a5 2143 if (TAINT_get) { TAINT_PROPER(what); } \
873ef191 2144 } STMT_END
20408e3c
GS		 2145
2146 /* This is a first heuristic; it doesn't catch tainting magic. */
284167a5 2147 if (TAINTING_get) {
463ee0b2 2148 while (++mark <= sp) {
bbce6d69 2149 if (SvTAINTED(*mark)) {
2150 TAINT;
2151 break;
2152 }
463ee0b2
LW		 2153 }
2154 mark = oldmark;
2155 }
a687059c 2156 switch (type) {
79072805 2157 case OP_CHMOD:
20408e3c 2158 APPLY_TAINT_PROPER();
79072805 2159 if (++mark <= sp) {
4ea561bc 2160 val = SvIV(*mark);
20408e3c
GS		 2161 APPLY_TAINT_PROPER();
2162 tot = sp - mark;
79072805 2163 while (++mark <= sp) {
c4aca7d0 2164 GV* gv;
2ea1cce7 2165 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA		 2166 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2167#ifdef HAS_FCHMOD
375ed12a 2168 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 2169 APPLY_TAINT_PROPER();
375ed12a
JH		 2170 if (fd < 0) {
2171 SETERRNO(EBADF,RMS_IFI);
2172 tot--;
2173 } else if (fchmod(fd, val))
2174 tot--;
c4aca7d0 2175#else
b9c6780e 2176 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0
GA		 2177#endif
2178 }
2179 else {
8334cae6 2180 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 2181 tot--;
2182 }
2183 }
c4aca7d0 2184 else {
41188aa0 2185 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 2186 APPLY_TAINT_PROPER();
41188aa0 2187 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC		 2188 PerlLIO_chmod(name, val)) {
2189 tot--;
2190 }
c4aca7d0 2191 }
a687059c
LW		 2192 }
2193 }
2194 break;
fe14fcc3 2195#ifdef HAS_CHOWN
79072805 2196 case OP_CHOWN:
20408e3c 2197 APPLY_TAINT_PROPER();
79072805 2198 if (sp - mark > 2) {
eb578fdb 2199 I32 val2;
463ee0b2
LW		 2200 val = SvIVx(*++mark);
2201 val2 = SvIVx(*++mark);
20408e3c 2202 APPLY_TAINT_PROPER();
a0d0e21e 2203 tot = sp - mark;
79072805 2204 while (++mark <= sp) {
c4aca7d0 2205 GV* gv;
2ea1cce7 2206 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA		 2207 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2208#ifdef HAS_FCHOWN
375ed12a 2209 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 2210 APPLY_TAINT_PROPER();
375ed12a 2211 if (fd < 0) {
dd1dbff0 2212 SETERRNO(EBADF,RMS_IFI);
f95ba548 2213 tot--;
375ed12a 2214 } else if (fchown(fd, val, val2))
c4aca7d0
GA		 2215 tot--;
2216#else
b9c6780e 2217 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0
GA		 2218#endif
2219 }
2220 else {
8334cae6 2221 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 2222 tot--;
2223 }
2224 }
c4aca7d0 2225 else {
41188aa0 2226 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 2227 APPLY_TAINT_PROPER();
41188aa0 2228 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 2229 PerlLIO_chown(name, val, val2)) {
c4aca7d0 2230 tot--;
c8028aa6 2231 }
c4aca7d0 2232 }
a687059c
LW		 2233 }
2234 }
2235 break;
b1248f16 2236#endif
a1d180c4 2237/*
dd64f1c3
AD		 2238XXX Should we make lchown() directly available from perl?
2239For now, we'll let Configure test for HAS_LCHOWN, but do
2240nothing in the core.
2241 --AD 5/1998
2242*/
fe14fcc3 2243#ifdef HAS_KILL
79072805 2244 case OP_KILL:
20408e3c 2245 APPLY_TAINT_PROPER();
55497cff 2246 if (mark == sp)
2247 break;
84c7b88c 2248 s = SvPVx_const(*++mark, len);
c2fd40cb
DM		 2249 if (*s == '-' && isALPHA(s[1]))
2250 {
2251 s++;
2252 len--;
885b4b39 2253 killgp = TRUE;
c2fd40cb 2254 }
e02bfb16 2255 if (isALPHA(*s)) {
84c7b88c 2256 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
79072805 2257 s += 3;
84c7b88c
BF		 2258 len -= 3;
2259 }
2260 if ((val = whichsig_pvn(s, len)) < 0)
147e3846
KW		 2261 Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"",
2262 SVfARG(*mark));
79072805
LW		 2263 }
2264 else
c2fd40cb 2265 {
4ea561bc 2266 val = SvIV(*mark);
c2fd40cb
DM		 2267 if (val < 0)
2268 {
885b4b39 2269 killgp = TRUE;
c2fd40cb
DM		 2270 val = -val;
2271 }
2272 }
20408e3c
GS		 2273 APPLY_TAINT_PROPER();
2274 tot = sp - mark;
fbcd93f0 2275
c2fd40cb 2276 while (++mark <= sp) {
60082291 2277 Pid_t proc;
c2fd40cb 2278 SvGETMAGIC(*mark);
60082291 2279 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
c2fd40cb
DM		 2280 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
2281 proc = SvIV_nomg(*mark);
c2fd40cb 2282 APPLY_TAINT_PROPER();
111f73b5
DM		 2283#ifdef HAS_KILLPG
2284 /* use killpg in preference, as the killpg() wrapper for Win32
2285 * understands process groups, but the kill() wrapper doesn't */
2286 if (killgp ? PerlProc_killpg(proc, val)
2287 : PerlProc_kill(proc, val))
2288#else
2289 if (PerlProc_kill(killgp ? -proc: proc, val))
2290#endif
c2fd40cb 2291 tot--;
a687059c 2292 }
8165faea 2293 PERL_ASYNC_CHECK();
a687059c 2294 break;
b1248f16 2295#endif
79072805 2296 case OP_UNLINK:
20408e3c 2297 APPLY_TAINT_PROPER();
79072805
LW		 2298 tot = sp - mark;
2299 while (++mark <= sp) {
41188aa0 2300 s = SvPV_const(*mark, len);
20408e3c 2301 APPLY_TAINT_PROPER();
41188aa0 2302 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC		 2303 tot--;
2304 }
f0d85c30 2305 else if (PL_unsafe) {
b8ffc8df 2306 if (UNLINK(s))
5cdd1fc2 2307 {
a687059c 2308 tot--;
5cdd1fc2
AB		 2309 }
2310#if defined(__amigaos4__) && defined(NEWLIB)
2311 else
2312 {
2313 /* Under AmigaOS4 unlink only 'fails' if the
2314 * filename is invalid. It may not remove the file
2315 * if it's locked, so check if it's still around. */
2316 if ((access(s,F_OK) != -1))
2317 {
2318 tot--;
2319 }
2320 }
2321#endif
a687059c
LW		 2322 }
2323 else { /* don't let root wipe out directories without -U */
45a23732
DD		 2324 Stat_t statbuf;
2325 if (PerlLIO_lstat(s, &statbuf) < 0)
1dcae8b8 2326 tot--;
45a23732 2327 else if (S_ISDIR(statbuf.st_mode)) {
cd52bc19 2328 SETERRNO(EISDIR, SS_NOPRIV);
45a23732 2329 tot--;
1dcae8b8 2330 }
a687059c 2331 else {
b8ffc8df 2332 if (UNLINK(s))
5cdd1fc2
AB		 2333 {
2334 tot--;
2335 }
2336#if defined(__amigaos4__) && defined(NEWLIB)
2337 else
2338 {
2339 /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */
2340 /* It may not remove the file if it's Locked, so check if it's still */
2341 /* arround */
2342 if((access(s,F_OK) != -1))
2343 {
2344 tot--;
2345 }
2346 }
2347#endif
a687059c
LW		 2348 }
2349 }
2350 }
2351 break;
e96b369d 2352#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 2353 case OP_UTIME:
20408e3c 2354 APPLY_TAINT_PROPER();
79072805 2355 if (sp - mark > 2) {
e96b369d
GA		 2356#if defined(HAS_FUTIMES)
2357 struct timeval utbuf[2];
2358 void *utbufp = utbuf;
2359#elif defined(I_UTIME) || defined(VMS)
663a0e37 2360 struct utimbuf utbuf;
07409e01 2361 struct utimbuf *utbufp = &utbuf;
663a0e37 2362#else
a687059c 2363 struct {
dd2821f6
GS		 2364 Time_t actime;
2365 Time_t modtime;
a687059c 2366 } utbuf;
07409e01 2367 void *utbufp = &utbuf;
663a0e37 2368#endif
a687059c 2369
0bcc34c2
AL		 2370 SV* const accessed = *++mark;
2371 SV* const modified = *++mark;
c6f7b413 2372
6ec06612
SB		 2373 /* Be like C, and if both times are undefined, let the C
2374 * library figure out what to do. This usually means
2375 * "current time". */
c6f7b413
RS		 2376
2377 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB		 2378 utbufp = NULL;
2379 else {
2380 Zero(&utbuf, sizeof utbuf, char);
e96b369d 2381#ifdef HAS_FUTIMES
4ea561bc 2382 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 2383 utbuf[0].tv_usec = 0;
4ea561bc 2384 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA		 2385 utbuf[1].tv_usec = 0;
2386#elif defined(BIG_TIME)
4ea561bc
NC		 2387 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
2388 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 2389#else
4ea561bc
NC		 2390 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
2391 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 2392#endif
6ec06612 2393 }
4373e329 2394 APPLY_TAINT_PROPER();
79072805
LW		 2395 tot = sp - mark;
2396 while (++mark <= sp) {
e96b369d 2397 GV* gv;
64617da9 2398 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA		 2399 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2400#ifdef HAS_FUTIMES
375ed12a 2401 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
e96b369d 2402 APPLY_TAINT_PROPER();
375ed12a
JH		 2403 if (fd < 0) {
2404 SETERRNO(EBADF,RMS_IFI);
2405 tot--;
2406 } else if (futimes(fd, (struct timeval *) utbufp))
e96b369d
GA		 2407 tot--;
2408#else
2409 Perl_die(aTHX_ PL_no_func, "futimes");
2410#endif
2411 }
2412 else {
2413 tot--;
2414 }
2415 }
e96b369d 2416 else {
41188aa0 2417 const char * const name = SvPV_nomg_const(*mark, len);
e96b369d 2418 APPLY_TAINT_PROPER();
41188aa0 2419 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC		 2420 tot--;
2421 }
2422 else
e96b369d 2423#ifdef HAS_FUTIMES
8b7231d9 2424 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA		 2425#else
2426 if (PerlLIO_utime(name, utbufp))
2427#endif
2428 tot--;
2429 }
2430
a687059c 2431 }
a687059c
LW		 2432 }
2433 else
79072805 2434 tot = 0;
a687059c 2435 break;
a0d0e21e 2436#endif
a687059c
LW		 2437 }
2438 return tot;
20408e3c 2439
20408e3c 2440#undef APPLY_TAINT_PROPER
a687059c
LW		 2441}
2442
bd93adf5 2443/* Do the permissions in *statbufp allow some operation? */
a0d0e21e 2444#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 2445bool
5aaab254 2446Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC		 2447/* effective is a flag, true for EUID, or for checking if the effective gid
2448 * is in the list of groups returned from getgroups().
2449 */
a687059c 2450{
7918f24d 2451 PERL_ARGS_ASSERT_CANDO;
81611534 2452 PERL_UNUSED_CONTEXT;
7918f24d 2453
bee1dbe2 2454#ifdef DOSISH
fe14fcc3
LW		 2455 /* [Comments and code from Len Reed]
2456 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
2457 * to write-protected files. The execute permission bit is set
486ec47a 2458 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW		 2459 * .exe files
2460 * .com files
2461 * .bat files
2462 * directories
2463 * All files and directories are readable.
2464 * Directories and special files, e.g. "CON", cannot be
2465 * write-protected.
2466 * [Comment by Tom Dinger -- a directory can have the write-protect
2467 * bit set in the file system, but DOS permits changes to
2468 * the directory anyway. In addition, all bets are off
2469 * here for networked software, such as Novell and
2470 * Sun's PC-NFS.]
2471 */
2472
bee1dbe2
LW		 2473 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
2474 * too so it will actually look into the files for magic numbers
2475 */
8298454c 2476 return cBOOL(mode & statbufp->st_mode);
fe14fcc3 2477
55497cff 2478#else /* ! DOSISH */
b595cd4b
RU		 2479# ifdef __CYGWIN__
2480 if (ingroup(544,effective)) { /* member of Administrators */
2481# else
985213f2 2482 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 2483# endif
7f4774ae 2484 if (mode == S_IXUSR) {
c623bd54 2485 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW		 2486 return TRUE;
2487 }
2488 else
2489 return TRUE; /* root reads and writes anything */
2490 return FALSE;
2491 }
985213f2 2492 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 2493 if (statbufp->st_mode & mode)
a687059c
LW		 2494 return TRUE; /* ok as "user" */
2495 }
d8eceb89 2496 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 2497 if (statbufp->st_mode & mode >> 3)
a687059c
LW		 2498 return TRUE; /* ok as "group" */
2499 }
7f4774ae 2500 else if (statbufp->st_mode & mode >> 6)
a687059c
LW		 2501 return TRUE; /* ok as "other" */
2502 return FALSE;
55497cff 2503#endif /* ! DOSISH */
a687059c 2504}
a0d0e21e 2505#endif /* ! VMS */
a687059c 2506
1f676739 2507static bool
0da8eb3a 2508S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 2509{
81611534
JH		 2510#ifndef PERL_IMPLICIT_SYS
2511 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */
2512 PERL_UNUSED_CONTEXT;
2513#endif
985213f2 2514 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 2515 return TRUE;
fe14fcc3 2516#ifdef HAS_GETGROUPS
a687059c 2517 {
331b57bc 2518 Groups_t *gary = NULL;
79072805 2519 I32 anum;
331b57bc 2520 bool rc = FALSE;
a687059c 2521
331b57bc 2522 anum = getgroups(0, gary);
375ed12a
JH		 2523 if (anum > 0) {
2524 Newx(gary, anum, Groups_t);
2525 anum = getgroups(anum, gary);
2526 while (--anum >= 0)
2527 if (gary[anum] == testgid) {
2528 rc = TRUE;
2529 break;
2530 }
331b57bc 2531
375ed12a
JH		 2532 Safefree(gary);
2533 }
331b57bc 2534 return rc;
a687059c 2535 }
c685562b 2536#else
a687059c 2537 return FALSE;
cd39f2b6 2538#endif
a687059c 2539}
c2ab57d4 2540
fe14fcc3 2541#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2542
79072805 2543I32
864dbfa3 2544Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2545{
0bcc34c2 2546 const key_t key = (key_t)SvNVx(*++mark);
c3312966 2547 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 2548 const I32 flags = SvIVx(*++mark);
294a48e9 2549
7918f24d 2550 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 2551 PERL_UNUSED_ARG(sp);
c2ab57d4 2552
748a9306 2553 SETERRNO(0,0);
c2ab57d4
LW		 2554 switch (optype)
2555 {
fe14fcc3 2556#ifdef HAS_MSG
79072805 2557 case OP_MSGGET:
c2ab57d4 2558 return msgget(key, flags);
e5d73d77 2559#endif
fe14fcc3 2560#ifdef HAS_SEM
79072805 2561 case OP_SEMGET:
c3312966 2562 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2563#endif
fe14fcc3 2564#ifdef HAS_SHM
79072805 2565 case OP_SHMGET:
c3312966 2566 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 2567#endif
fe14fcc3 2568#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2569 default:
fe13d51d 2570 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2571 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2572#endif
c2ab57d4
LW		 2573 }
2574 return -1; /* should never happen */
2575}
2576
79072805 2577I32
864dbfa3 2578Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2579{
c2ab57d4 2580 char *a;
a0d0e21e 2581 I32 ret = -1;
6867be6d 2582 const I32 id = SvIVx(*++mark);
95b63a38 2583#ifdef Semctl
6867be6d 2584 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2585#endif
6867be6d 2586 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL		 2587 SV * const astr = *++mark;
2588 STRLEN infosize = 0;
2589 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2590
7918f24d 2591 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2592 PERL_UNUSED_ARG(sp);
c2ab57d4
LW		 2593
2594 switch (optype)
2595 {
fe14fcc3 2596#ifdef HAS_MSG
79072805 2597 case OP_MSGCTL:
c2ab57d4
LW		 2598 if (cmd == IPC_STAT || cmd == IPC_SET)
2599 infosize = sizeof(struct msqid_ds);
2600 break;
e5d73d77 2601#endif
fe14fcc3 2602#ifdef HAS_SHM
79072805 2603 case OP_SHMCTL:
c2ab57d4
LW		 2604 if (cmd == IPC_STAT || cmd == IPC_SET)
2605 infosize = sizeof(struct shmid_ds);
2606 break;
e5d73d77 2607#endif
fe14fcc3 2608#ifdef HAS_SEM
79072805 2609 case OP_SEMCTL:
39398f3f 2610#ifdef Semctl
c2ab57d4
LW		 2611 if (cmd == IPC_STAT || cmd == IPC_SET)
2612 infosize = sizeof(struct semid_ds);
2613 else if (cmd == GETALL || cmd == SETALL)
2614 {
8e591e46 2615 struct semid_ds semds;
bd89102f 2616 union semun semun;
e6f0bdd6
GS		 2617#ifdef EXTRA_F_IN_SEMUN_BUF
2618 semun.buff = &semds;
2619#else
84902520 2620 semun.buf = &semds;
e6f0bdd6 2621#endif
c2ab57d4 2622 getinfo = (cmd == GETALL);
9b89d93d
GB		 2623 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2624 return -1;
6e21c824
LW		 2625 infosize = semds.sem_nsems * sizeof(short);
2626 /* "short" is technically wrong but much more portable
2627 than guessing about u_?short(_t)? */
c2ab57d4 2628 }
39398f3f 2629#else
fe13d51d 2630 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2631 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2632#endif
c2ab57d4 2633 break;
e5d73d77 2634#endif
fe14fcc3 2635#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2636 default:
fe13d51d 2637 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2638 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2639#endif
c2ab57d4
LW		 2640 }
2641
2642 if (infosize)
2643 {
2644 if (getinfo)
2645 {
93524f2b 2646 SvPV_force_nolen(astr);
a0d0e21e 2647 a = SvGROW(astr, infosize+1);
c2ab57d4
LW		 2648 }
2649 else
2650 {
93524f2b 2651 STRLEN len;
463ee0b2
LW		 2652 a = SvPV(astr, len);
2653 if (len != infosize)
cea2e8a9 2654 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH		 2655 PL_op_desc[optype],
2656 (unsigned long)len,
2657 (long)infosize);
c2ab57d4
LW		 2658 }
2659 }
2660 else
2661 {
0bcc34c2 2662 const IV i = SvIV(astr);
56431972 2663 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 2664 }
748a9306 2665 SETERRNO(0,0);
c2ab57d4
LW		 2666 switch (optype)
2667 {
fe14fcc3 2668#ifdef HAS_MSG
79072805 2669 case OP_MSGCTL:
bee1dbe2 2670 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 2671 break;
e5d73d77 2672#endif
fe14fcc3 2673#ifdef HAS_SEM
bd89102f 2674 case OP_SEMCTL: {
39398f3f 2675#ifdef Semctl
bd89102f
AD		 2676 union semun unsemds;
2677
64d76282
BC		 2678 if(cmd == SETVAL) {
2679 unsemds.val = PTR2nat(a);
2680 }
2681 else {
e6f0bdd6 2682#ifdef EXTRA_F_IN_SEMUN_BUF
64d76282 2683 unsemds.buff = (struct semid_ds *)a;
e6f0bdd6 2684#else
64d76282 2685 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 2686#endif
64d76282 2687 }
bd89102f 2688 ret = Semctl(id, n, cmd, unsemds);
39398f3f 2689#else
fe13d51d 2690 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2691 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2692#endif
bd89102f 2693 }
c2ab57d4 2694 break;
e5d73d77 2695#endif
fe14fcc3 2696#ifdef HAS_SHM
79072805 2697 case OP_SHMCTL:
bee1dbe2 2698 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 2699 break;
e5d73d77 2700#endif
c2ab57d4
LW		 2701 }
2702 if (getinfo && ret >= 0) {
79072805
LW		 2703 SvCUR_set(astr, infosize);
2704 *SvEND(astr) = '\0';
a0d0e21e 2705 SvSETMAGIC(astr);
c2ab57d4
LW		 2706 }
2707 return ret;
2708}
2709
79072805 2710I32
864dbfa3 2711Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 2712{
fe14fcc3 2713#ifdef HAS_MSG
463ee0b2 2714 STRLEN len;
6867be6d 2715 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 2716 SV * const mstr = *++mark;
2717 const I32 flags = SvIVx(*++mark);
2718 const char * const mbuf = SvPV_const(mstr, len);
2719 const I32 msize = len - sizeof(long);
2720
7918f24d 2721 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 2722 PERL_UNUSED_ARG(sp);
c2ab57d4 2723
0bcc34c2 2724 if (msize < 0)
cea2e8a9 2725 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 2726 SETERRNO(0,0);
681fb693
JH		 2727 if (id >= 0 && flags >= 0) {
2728 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
2729 } else {
2730 SETERRNO(EINVAL,LIB_INVARG);
2731 return -1;
2732 }
e5d73d77 2733#else
2d51fa4d
RGS		 2734 PERL_UNUSED_ARG(sp);
2735 PERL_UNUSED_ARG(mark);
fe13d51d 2736 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2737 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 2738 return -1;
e5d73d77 2739#endif
c2ab57d4
LW		 2740}
2741
79072805 2742I32
864dbfa3 2743Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 2744{
fe14fcc3 2745#ifdef HAS_MSG
c2ab57d4
LW		 2746 char *mbuf;
2747 long mtype;
6867be6d 2748 I32 msize, flags, ret;
6867be6d 2749 const I32 id = SvIVx(*++mark);
0bcc34c2 2750 SV * const mstr = *++mark;
7918f24d
NC		 2751
2752 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 2753 PERL_UNUSED_ARG(sp);
79072805 2754
c2e66d9e
GS		 2755 /* suppress warning when reading into undef var --jhi */
2756 if (! SvOK(mstr))
8062ff11 2757 SvPVCLEAR(mstr);
463ee0b2
LW		 2758 msize = SvIVx(*++mark);
2759 mtype = (long)SvIVx(*++mark);
2760 flags = SvIVx(*++mark);
93524f2b 2761 SvPV_force_nolen(mstr);
a0d0e21e 2762 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2763
748a9306 2764 SETERRNO(0,0);
d2607e1e
JH		 2765 if (id >= 0 && msize >= 0 && flags >= 0) {
2766 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
2767 } else {
2768 SETERRNO(EINVAL,LIB_INVARG);
2769 ret = -1;
2770 }
c2ab57d4 2771 if (ret >= 0) {
79072805
LW		 2772 SvCUR_set(mstr, sizeof(long)+ret);
2773 *SvEND(mstr) = '\0';
41d6edb2
JH		 2774 /* who knows who has been playing with this message? */
2775 SvTAINTED_on(mstr);
c2ab57d4
LW		 2776 }
2777 return ret;
e5d73d77 2778#else
2d51fa4d
RGS		 2779 PERL_UNUSED_ARG(sp);
2780 PERL_UNUSED_ARG(mark);
fe13d51d 2781 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2782 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 2783 return -1;
e5d73d77 2784#endif
c2ab57d4
LW		 2785}
2786
79072805 2787I32
864dbfa3 2788Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2789{
fe14fcc3 2790#ifdef HAS_SEM
463ee0b2 2791 STRLEN opsize;
6867be6d 2792 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 2793 SV * const opstr = *++mark;
2794 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC		 2795
2796 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 2797 PERL_UNUSED_ARG(sp);
c2ab57d4 2798
248ff010
NC		 2799 if (opsize < 3 * SHORTSIZE
2800 || (opsize % (3 * SHORTSIZE))) {
93189314 2801 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW		 2802 return -1;
2803 }
748a9306 2804 SETERRNO(0,0);
248ff010
NC		 2805 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2806 {
6867be6d 2807 const int nsops = opsize / (3 * sizeof (short));
248ff010 2808 int i = nsops;
0bcc34c2 2809 short * const ops = (short *) opbuf;
248ff010
NC		 2810 short *o = ops;
2811 struct sembuf *temps, *t;
2812 I32 result;
2813
a02a5408 2814 Newx (temps, nsops, struct sembuf);
248ff010
NC		 2815 t = temps;
2816 while (i--) {
2817 t->sem_num = *o++;
2818 t->sem_op = *o++;
2819 t->sem_flg = *o++;
2820 t++;
2821 }
2822 result = semop(id, temps, nsops);
248ff010
NC		 2823 Safefree(temps);
2824 return result;
2825 }
e5d73d77 2826#else
fe13d51d 2827 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2828 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2829#endif
c2ab57d4
LW		 2830}
2831
79072805 2832I32
864dbfa3 2833Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2834{
fe14fcc3 2835#ifdef HAS_SHM
4373e329 2836 char *shm;
c2ab57d4 2837 struct shmid_ds shmds;
6867be6d 2838 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 2839 SV * const mstr = *++mark;
2840 const I32 mpos = SvIVx(*++mark);
2841 const I32 msize = SvIVx(*++mark);
7918f24d
NC		 2842
2843 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 2844 PERL_UNUSED_ARG(sp);
c2ab57d4 2845
748a9306 2846 SETERRNO(0,0);
c2ab57d4
LW		 2847 if (shmctl(id, IPC_STAT, &shmds) == -1)
2848 return -1;
7f39519f
NC		 2849 if (mpos < 0 || msize < 0
2850 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 2851 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW		 2852 return -1;
2853 }
568fc267
JH		 2854 if (id >= 0) {
2855 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
2856 } else {
2857 SETERRNO(EINVAL,LIB_INVARG);
2858 return -1;
2859 }
c2ab57d4
LW		 2860 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2861 return -1;
79072805 2862 if (optype == OP_SHMREAD) {
c8ae91a8 2863 char *mbuf;
9f538c04 2864 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS		 2865 SvGETMAGIC(mstr);
2866 SvUPGRADE(mstr, SVt_PV);
9f538c04 2867 if (! SvOK(mstr))
8062ff11 2868 SvPVCLEAR(mstr);
af8ff727 2869 SvPOK_only(mstr);
bb7a0f54 2870 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 2871
bee1dbe2 2872 Copy(shm + mpos, mbuf, msize, char);
79072805
LW		 2873 SvCUR_set(mstr, msize);
2874 *SvEND(mstr) = '\0';
a0d0e21e 2875 SvSETMAGIC(mstr);
d929ce6f
JH		 2876 /* who knows who has been playing with this shared memory? */
2877 SvTAINTED_on(mstr);
c2ab57d4
LW		 2878 }
2879 else {
93524f2b 2880 STRLEN len;
c2ab57d4 2881
93524f2b 2882 const char *mbuf = SvPV_const(mstr, len);
027aa12d 2883 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 2884 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2885 if (n < msize)
bee1dbe2 2886 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW		 2887 }
2888 return shmdt(shm);
e5d73d77 2889#else
fe13d51d 2890 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2891 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 2892 return -1;
e5d73d77 2893#endif
c2ab57d4
LW		 2894}
2895
fe14fcc3 2896#endif /* SYSV IPC */
4e35701f 2897
0d44d22b 2898/*
ccfc67b7
JH		 2899=head1 IO Functions
2900
0d44d22b
NC		 2901=for apidoc start_glob
2902
2903Function called by C<do_readline> to spawn a glob (or do the glob inside
154e47c8 2904perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
25047fde
KW		 2905this glob starter is only used by miniperl during the build process,
2906or when PERL_EXTERNAL_GLOB is defined.
75af9d73 2907Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
fab3f3a7 2908
0d44d22b
NC		 2909=cut
2910*/
2911
2912PerlIO *
2913Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2914{
561b68a9 2915 SV * const tmpcmd = newSV(0);
0d44d22b 2916 PerlIO *fp;
41188aa0
TC		 2917 STRLEN len;
2918 const char *s = SvPV(tmpglob, len);
7918f24d
NC		 2919
2920 PERL_ARGS_ASSERT_START_GLOB;
2921
41188aa0 2922 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC		 2923 return NULL;
2924
0d44d22b
NC		 2925 ENTER;
2926 SAVEFREESV(tmpcmd);
2927#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2928 /* since spawning off a process is a real performance hit */
dca5a913 2929
1cc9774b
CB		 2930PerlIO *
2931Perl_vms_start_glob
2932 (pTHX_ SV *tmpglob,
2933 IO *io);
2934
49a7a762 2935 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 2936
0d44d22b 2937#else /* !VMS */
4009c3ff
AC		 2938# ifdef DOSISH
2939# if defined(OS2)
0d44d22b
NC		 2940 sv_setpv(tmpcmd, "for a in ");
2941 sv_catsv(tmpcmd, tmpglob);
2942 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
4009c3ff 2943# elif defined(DJGPP)
0d44d22b
NC		 2944 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2945 sv_catsv(tmpcmd, tmpglob);
4009c3ff 2946# else
0d44d22b
NC		 2947 sv_setpv(tmpcmd, "perlglob ");
2948 sv_catsv(tmpcmd, tmpglob);
2949 sv_catpv(tmpcmd, " |");
4009c3ff
AC		 2950# endif
2951# elif defined(CSH)
0d44d22b
NC		 2952 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2953 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2954 sv_catsv(tmpcmd, tmpglob);
2955 sv_catpv(tmpcmd, "' 2>/dev/null |");
4009c3ff 2956# else
0d44d22b
NC		 2957 sv_setpv(tmpcmd, "echo ");
2958 sv_catsv(tmpcmd, tmpglob);
0d44d22b 2959 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
4009c3ff 2960# endif /* !DOSISH && !CSH */
93b2dae1 2961 {
acffc8af
FC		 2962 SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
2963 if (svp && *svp)
2964 save_helem_flags(GvHV(PL_envgv),
2965 newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
2966 SAVEf_SETMAGIC);
93b2dae1 2967 }
d5eb9a46
NC		 2968 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
2969 NULL, NULL, 0);
0d44d22b
NC		 2970 fp = IoIFP(io);
2971#endif /* !VMS */
2972 LEAVE;
de7dabb6
TC		 2973
2974 if (!fp && ckWARN(WARN_GLOB)) {
2975 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
2976 Strerror(errno));
2977 }
2978
0d44d22b
NC		 2979 return fp;
2980}
66610fdd
RGS		 2981
2982/*
14d04a33 2983 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2984 */
Unnamed repository; edit this file 'description' to name the repository.