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