This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Hide the VMS error identifier SS$_NOPRIV, as customary.
[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{
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 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 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 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 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 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);
e934609f
JH
649 /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
650 * socket - this covers PerlIO::scalar - otherwise unless we "know" the
e99cca91
NIS
651 * type probe for socket-ness.
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 */
bd4a5668
NIS
699 if (PerlLIO_dup2(fd, savefd) < 0) {
700 (void)PerlIO_close(fp);
701 goto say_false;
702 }
d082dcd6 703#ifdef VMS
6e60e805 704 if (savefd != PerlIO_fileno(PerlIO_stdin())) {
d0e2cf63
AMS
705 char newname[FILENAME_MAX+1];
706 if (PerlIO_getname(fp, newname)) {
707 if (fd == PerlIO_fileno(PerlIO_stdout()))
0db50132 708 vmssetuserlnm("SYS$OUTPUT", newname);
d0e2cf63 709 if (fd == PerlIO_fileno(PerlIO_stderr()))
0db50132 710 vmssetuserlnm("SYS$ERROR", newname);
d0e2cf63 711 }
d082dcd6
JH
712 }
713#endif
d0e2cf63
AMS
714
715#if !defined(WIN32)
716 /* PL_fdpid isn't used on Windows, so avoid this useless work.
717 * XXX Probably the same for a lot of other places. */
718 {
719 Pid_t pid;
720 SV *sv;
721
d0e2cf63 722 sv = *av_fetch(PL_fdpid,fd,TRUE);
862a34c6 723 SvUPGRADE(sv, SVt_IV);
d0e2cf63 724 pid = SvIVX(sv);
45977657 725 SvIV_set(sv, 0);
d0e2cf63 726 sv = *av_fetch(PL_fdpid,savefd,TRUE);
862a34c6 727 SvUPGRADE(sv, SVt_IV);
45977657 728 SvIV_set(sv, pid);
d0e2cf63
AMS
729 }
730#endif
731
e212fc47
AMS
732 if (was_fdopen) {
733 /* need to close fp without closing underlying fd */
734 int ofd = PerlIO_fileno(fp);
735 int dupfd = PerlLIO_dup(ofd);
03e631df
JH
736#if defined(HAS_FCNTL) && defined(F_SETFD)
737 /* Assume if we have F_SETFD we have F_GETFD */
738 int coe = fcntl(ofd,F_GETFD);
739#endif
e212fc47
AMS
740 PerlIO_close(fp);
741 PerlLIO_dup2(dupfd,ofd);
03e631df
JH
742#if defined(HAS_FCNTL) && defined(F_SETFD)
743 /* The dup trick has lost close-on-exec on ofd */
744 fcntl(ofd,F_SETFD, coe);
745#endif
e212fc47 746 PerlLIO_close(dupfd);
ecdeb87c 747 }
e212fc47
AMS
748 else
749 PerlIO_close(fp);
6e21c824
LW
750 }
751 fp = saveifp;
760ac839 752 PerlIO_clearerr(fp);
e99cca91 753 fd = PerlIO_fileno(fp);
6e21c824 754 }
a0d0e21e 755#if defined(HAS_FCNTL) && defined(F_SETFD)
e99cca91 756 if (fd >= 0) {
4ee39169 757 dSAVE_ERRNO;
a8710ca1 758 fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
4ee39169 759 RESTORE_ERRNO;
a8710ca1 760 }
1462b684 761#endif
8990e307 762 IoIFP(io) = fp;
b931b1d9 763
684bef36 764 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 765 if (writing) {
50952442 766 if (IoTYPE(io) == IoTYPE_SOCKET
e99cca91 767 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
a33cf58c 768 char *s = mode;
3b6c1aba
JH
769 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
770 s++;
a33cf58c 771 *s = 'w';
7c491510 772 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
760ac839 773 PerlIO_close(fp);
4608196e 774 IoIFP(io) = NULL;
6e21c824 775 goto say_false;
fe14fcc3 776 }
1462b684
LW
777 }
778 else
8990e307 779 IoOFP(io) = fp;
bf38876a 780 }
a687059c 781 return TRUE;
6e21c824
LW
782
783say_false:
8990e307
LW
784 IoIFP(io) = saveifp;
785 IoOFP(io) = saveofp;
786 IoTYPE(io) = savetype;
6e21c824 787 return FALSE;
a687059c
LW
788}
789
760ac839 790PerlIO *
5aaab254 791Perl_nextargv(pTHX_ GV *gv)
a687059c 792{
97aff369 793 dVAR;
2d03de9c 794 IO * const io = GvIOp(gv);
fe14fcc3 795
7918f24d
NC
796 PERL_ARGS_ASSERT_NEXTARGV;
797
3280af22 798 if (!PL_argvoutgv)
fafc274c 799 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
18708f5a
GS
800 if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
801 IoFLAGS(io) &= ~IOf_START;
7a1c5554 802 if (PL_inplace) {
294b3b39 803 assert(PL_defoutgv);
29a861e7
NC
804 Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
805 SvREFCNT_inc_simple_NN(PL_defoutgv));
7a1c5554 806 }
18708f5a 807 }
3280af22
NIS
808 if (PL_filemode & (S_ISUID|S_ISGID)) {
809 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
fe14fcc3 810#ifdef HAS_FCHMOD
c797f2d8
DM
811 if (PL_lastfd != -1)
812 (void)fchmod(PL_lastfd,PL_filemode);
fe14fcc3 813#else
b28d0864 814 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
fe14fcc3
LW
815#endif
816 }
c797f2d8 817 PL_lastfd = -1;
3280af22 818 PL_filemode = 0;
5c501b37 819 if (!GvAV(gv))
4608196e 820 return NULL;
b9f2b683 821 while (av_tindex(GvAV(gv)) >= 0) {
85aff577 822 STRLEN oldlen;
1fa0529f 823 SV *const sv = av_shift(GvAV(gv));
8990e307 824 SAVEFREESV(sv);
4bac9ae4 825 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
e203899d 826 sv_setsv(GvSVn(gv),sv);
79072805 827 SvSETMAGIC(GvSV(gv));
3280af22 828 PL_oldname = SvPVx(GvSV(gv), oldlen);
d8015975
NC
829 if (LIKELY(!PL_inplace)) {
830 if (do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)) {
831 return IoIFP(GvIOp(gv));
832 }
833 }
834 else {
835 /* This very long block ends with return IoIFP(GvIOp(gv));
836 Both this block and the block above fall through on open
837 failure to the warning code, and then the while loop above tries
838 the next entry. */
839 if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0)) {
1fa0529f
NC
840#ifndef FLEXFILENAMES
841 int filedev;
842 int fileino;
843#endif
844 Uid_t fileuid;
845 Gid_t filegid;
846
79072805 847 TAINT_PROPER("inplace open");
3280af22 848 if (oldlen == 1 && *PL_oldname == '-') {
fafc274c
NC
849 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
850 SVt_PVIO));
a0d0e21e 851 return IoIFP(GvIOp(gv));
c623bd54 852 }
99b89507 853#ifndef FLEXFILENAMES
b28d0864
NIS
854 filedev = PL_statbuf.st_dev;
855 fileino = PL_statbuf.st_ino;
99b89507 856#endif
3280af22
NIS
857 PL_filemode = PL_statbuf.st_mode;
858 fileuid = PL_statbuf.st_uid;
859 filegid = PL_statbuf.st_gid;
860 if (!S_ISREG(PL_filemode)) {
9b387841
NC
861 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
862 "Can't do inplace edit: %s is not a regular file",
863 PL_oldname );
79072805 864 do_close(gv,FALSE);
c623bd54
LW
865 continue;
866 }
c9930541 867 if (*PL_inplace && strNE(PL_inplace, "*")) {
2d03de9c 868 const char *star = strchr(PL_inplace, '*');
2d259d92 869 if (star) {
2d03de9c 870 const char *begin = PL_inplace;
76f68e9b 871 sv_setpvs(sv, "");
2d259d92
CK
872 do {
873 sv_catpvn(sv, begin, star - begin);
3280af22 874 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK
875 begin = ++star;
876 } while ((star = strchr(begin, '*')));
3d66d7bb
GS
877 if (*begin)
878 sv_catpv(sv,begin);
2d259d92
CK
879 }
880 else {
3280af22 881 sv_catpv(sv,PL_inplace);
2d259d92 882 }
c623bd54 883#ifndef FLEXFILENAMES
95a20fc0 884 if ((PerlLIO_stat(SvPVX_const(sv),&PL_statbuf) >= 0
5f74f29c
JH
885 && PL_statbuf.st_dev == filedev
886 && PL_statbuf.st_ino == fileino)
39e571d4 887#ifdef DJGPP
5f74f29c 888 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
39e571d4 889#endif
f248d071
GS
890 )
891 {
9b387841
NC
892 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
893 "Can't do inplace edit: %"SVf" would not be unique",
894 SVfARG(sv));
79072805 895 do_close(gv,FALSE);
c623bd54
LW
896 continue;
897 }
898#endif
fe14fcc3 899#ifdef HAS_RENAME
739a0b84 900#if !defined(DOSISH) && !defined(__CYGWIN__)
95a20fc0 901 if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
9b387841
NC
902 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
903 "Can't rename %s to %"SVf": %s, skipping file",
904 PL_oldname, SVfARG(sv), Strerror(errno));
79072805 905 do_close(gv,FALSE);
c623bd54
LW
906 continue;
907 }
a687059c 908#else
79072805 909 do_close(gv,FALSE);
95a20fc0
SP
910 (void)PerlLIO_unlink(SvPVX_const(sv));
911 (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv));
d5eb9a46 912 do_open_raw(gv, SvPVX_const(sv), SvCUR(sv), O_RDONLY, 0);
55497cff 913#endif /* DOSISH */
ff8e2863 914#else
95a20fc0
SP
915 (void)UNLINK(SvPVX_const(sv));
916 if (link(PL_oldname,SvPVX_const(sv)) < 0) {
9b387841
NC
917 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
918 "Can't rename %s to %"SVf": %s, skipping file",
919 PL_oldname, SVfARG(sv), Strerror(errno) );
79072805 920 do_close(gv,FALSE);
c623bd54
LW
921 continue;
922 }
b28d0864 923 (void)UNLINK(PL_oldname);
a687059c
LW
924#endif
925 }
926 else {
c030f24b 927#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 928# ifndef VMS /* Don't delete; use automatic file versioning */
3280af22 929 if (UNLINK(PL_oldname) < 0) {
9b387841
NC
930 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
931 "Can't remove %s: %s, skipping file",
932 PL_oldname, Strerror(errno) );
79072805 933 do_close(gv,FALSE);
fe14fcc3
LW
934 continue;
935 }
edc7bc49 936# endif
ff8e2863 937#else
cea2e8a9 938 Perl_croak(aTHX_ "Can't do inplace edit without backup");
ff8e2863 939#endif
a687059c
LW
940 }
941
30fc4309 942 sv_setpvn(sv,PL_oldname,oldlen);
748a9306 943 SETERRNO(0,0); /* in case sprintf set errno */
d5eb9a46
NC
944 if (!Perl_do_open_raw(aTHX_ PL_argvoutgv, SvPVX_const(sv),
945 SvCUR(sv),
4119ab01 946#ifdef VMS
d5eb9a46 947 O_WRONLY|O_CREAT|O_TRUNC, 0
4119ab01 948#else
d5eb9a46 949 O_WRONLY|O_CREAT|OPEN_EXCL, 0600
4119ab01 950#endif
d5eb9a46 951 )) {
9b387841
NC
952 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
953 PL_oldname, Strerror(errno) );
79072805 954 do_close(gv,FALSE);
fe14fcc3
LW
955 continue;
956 }
3280af22
NIS
957 setdefout(PL_argvoutgv);
958 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
959 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
fe14fcc3 960#ifdef HAS_FCHMOD
3280af22 961 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 962#else
b28d0864 963 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
a687059c 964#endif
3280af22 965 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
04783dc7 966 int rc = 0;
fe14fcc3 967#ifdef HAS_FCHOWN
04783dc7 968 rc = fchown(PL_lastfd,fileuid,filegid);
a687059c 969#else
fe14fcc3 970#ifdef HAS_CHOWN
04783dc7 971 rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
a687059c 972#endif
b1248f16 973#endif
04783dc7
DM
974 /* XXX silently ignore failures */
975 PERL_UNUSED_VAR(rc);
fe14fcc3 976 }
d8015975 977 return IoIFP(GvIOp(gv));
a687059c 978 }
d8015975
NC
979 } /* successful do_open_raw(), PL_inplace non-NULL */
980
981 if (ckWARN_d(WARN_INPLACE)) {
982 const int eno = errno;
983 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
984 && !S_ISREG(PL_statbuf.st_mode)) {
985 Perl_warner(aTHX_ packWARN(WARN_INPLACE),
986 "Can't do inplace edit: %s is not a regular file",
987 PL_oldname);
988 }
989 else {
990 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
991 PL_oldname, Strerror(eno));
992 }
4d61ec05 993 }
a687059c 994 }
18708f5a
GS
995 if (io && (IoFLAGS(io) & IOf_ARGV))
996 IoFLAGS(io) |= IOf_START;
3280af22
NIS
997 if (PL_inplace) {
998 (void)do_close(PL_argvoutgv,FALSE);
7a1c5554
GS
999 if (io && (IoFLAGS(io) & IOf_ARGV)
1000 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
1001 {
159b6efe 1002 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
18708f5a 1003 setdefout(oldout);
8e217d4a 1004 SvREFCNT_dec_NN(oldout);
4608196e 1005 return NULL;
18708f5a 1006 }
fafc274c 1007 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
a687059c 1008 }
4608196e 1009 return NULL;
a687059c
LW
1010}
1011
517844ec 1012/* explicit renamed to avoid C++ conflict -- kja */
a687059c 1013bool
864dbfa3 1014Perl_do_close(pTHX_ GV *gv, bool not_implicit)
a687059c 1015{
97aff369 1016 dVAR;
1193dd27
IZ
1017 bool retval;
1018 IO *io;
a687059c 1019
79072805 1020 if (!gv)
3280af22 1021 gv = PL_argvgv;
6e592b3a 1022 if (!gv || !isGV_with_GP(gv)) {
1d2dff63 1023 if (not_implicit)
93189314 1024 SETERRNO(EBADF,SS_IVCHAN);
c2ab57d4 1025 return FALSE;
99b89507 1026 }
79072805
LW
1027 io = GvIO(gv);
1028 if (!io) { /* never opened */
1d2dff63 1029 if (not_implicit) {
51087808 1030 report_evil_fh(gv);
93189314 1031 SETERRNO(EBADF,SS_IVCHAN);
1d2dff63 1032 }
a687059c
LW
1033 return FALSE;
1034 }
f2b5be74 1035 retval = io_close(io, not_implicit);
517844ec 1036 if (not_implicit) {
1193dd27
IZ
1037 IoLINES(io) = 0;
1038 IoPAGE(io) = 0;
1039 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1040 }
50952442 1041 IoTYPE(io) = IoTYPE_CLOSED;
1193dd27
IZ
1042 return retval;
1043}
1044
1045bool
f2b5be74 1046Perl_io_close(pTHX_ IO *io, bool not_implicit)
1193dd27 1047{
97aff369 1048 dVAR;
1193dd27 1049 bool retval = FALSE;
1193dd27 1050
7918f24d
NC
1051 PERL_ARGS_ASSERT_IO_CLOSE;
1052
8990e307 1053 if (IoIFP(io)) {
50952442 1054 if (IoTYPE(io) == IoTYPE_PIPE) {
4373e329 1055 const int status = PerlProc_pclose(IoIFP(io));
f2b5be74 1056 if (not_implicit) {
37038d91 1057 STATUS_NATIVE_CHILD_SET(status);
e5218da5 1058 retval = (STATUS_UNIX == 0);
f2b5be74
GS
1059 }
1060 else {
1061 retval = (status != -1);
1062 }
a687059c 1063 }
50952442 1064 else if (IoTYPE(io) == IoTYPE_STD)
a687059c
LW
1065 retval = TRUE;
1066 else {
8990e307 1067 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
0bcc34c2 1068 const bool prev_err = PerlIO_error(IoOFP(io));
e199e3be 1069 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
760ac839 1070 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4 1071 }
e199e3be 1072 else {
0bcc34c2 1073 const bool prev_err = PerlIO_error(IoIFP(io));
e199e3be
RGS
1074 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1075 }
a687059c 1076 }
4608196e 1077 IoOFP(io) = IoIFP(io) = NULL;
79072805 1078 }
f2b5be74 1079 else if (not_implicit) {
93189314 1080 SETERRNO(EBADF,SS_IVCHAN);
20408e3c 1081 }
1193dd27 1082
a687059c
LW
1083 return retval;
1084}
1085
1086bool
864dbfa3 1087Perl_do_eof(pTHX_ GV *gv)
a687059c 1088{
97aff369 1089 dVAR;
eb578fdb 1090 IO * const io = GvIO(gv);
a687059c 1091
7918f24d
NC
1092 PERL_ARGS_ASSERT_DO_EOF;
1093
79072805 1094 if (!io)
a687059c 1095 return TRUE;
7716c5c5 1096 else if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1097 report_wrongway_fh(gv, '>');
a687059c 1098
8990e307 1099 while (IoIFP(io)) {
760ac839 1100 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
a20bf0c3 1101 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
760ac839
LW
1102 return FALSE; /* this is the most usual case */
1103 }
a687059c 1104
79852593
NC
1105 {
1106 /* getc and ungetc can stomp on errno */
4ee39169 1107 dSAVE_ERRNO;
79852593
NC
1108 const int ch = PerlIO_getc(IoIFP(io));
1109 if (ch != EOF) {
1110 (void)PerlIO_ungetc(IoIFP(io),ch);
4ee39169 1111 RESTORE_ERRNO;
79852593
NC
1112 return FALSE;
1113 }
4ee39169 1114 RESTORE_ERRNO;
a687059c 1115 }
fab3f3a7 1116
760ac839 1117 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
a20bf0c3
JH
1118 if (PerlIO_get_cnt(IoIFP(io)) < -1)
1119 PerlIO_set_cnt(IoIFP(io),-1);
760ac839 1120 }
533c011a 1121 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
ed2c6b9b 1122 if (gv != PL_argvgv || !nextargv(gv)) /* get another fp handy */
a687059c
LW
1123 return TRUE;
1124 }
1125 else
1126 return TRUE; /* normal fp, definitely end of file */
1127 }
1128 return TRUE;
1129}
1130
5ff3f7a4 1131Off_t
864dbfa3 1132Perl_do_tell(pTHX_ GV *gv)
a687059c 1133{
97aff369 1134 dVAR;
9c9f25b8 1135 IO *const io = GvIO(gv);
eb578fdb 1136 PerlIO *fp;
a687059c 1137
7918f24d
NC
1138 PERL_ARGS_ASSERT_DO_TELL;
1139
9c9f25b8 1140 if (io && (fp = IoIFP(io))) {
8903cb82 1141 return PerlIO_tell(fp);
96e4d5b1 1142 }
51087808 1143 report_evil_fh(gv);
93189314 1144 SETERRNO(EBADF,RMS_IFI);
5ff3f7a4 1145 return (Off_t)-1;
a687059c
LW
1146}
1147
1148bool
864dbfa3 1149Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 1150{
97aff369 1151 dVAR;
9c9f25b8 1152 IO *const io = GvIO(gv);
eb578fdb 1153 PerlIO *fp;
a687059c 1154
9c9f25b8 1155 if (io && (fp = IoIFP(io))) {
8903cb82 1156 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 1157 }
51087808 1158 report_evil_fh(gv);
93189314 1159 SETERRNO(EBADF,RMS_IFI);
a687059c
LW
1160 return FALSE;
1161}
1162
97cc44eb 1163Off_t
864dbfa3 1164Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82 1165{
97aff369 1166 dVAR;
9c9f25b8 1167 IO *const io = GvIO(gv);
eb578fdb 1168 PerlIO *fp;
8903cb82 1169
7918f24d
NC
1170 PERL_ARGS_ASSERT_DO_SYSSEEK;
1171
9c9f25b8 1172 if (io && (fp = IoIFP(io)))
3028581b 1173 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
51087808 1174 report_evil_fh(gv);
93189314 1175 SETERRNO(EBADF,RMS_IFI);
d9b3e12d 1176 return (Off_t)-1;
8903cb82 1177}
1178
6ff81951 1179int
a79b25b7 1180Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
16fe6d59
GS
1181{
1182 int mode = O_BINARY;
a79b25b7 1183 if (s) {
16fe6d59
GS
1184 while (*s) {
1185 if (*s == ':') {
1186 switch (s[1]) {
1187 case 'r':
e963d6d2 1188 if (s[2] == 'a' && s[3] == 'w'
16fe6d59
GS
1189 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1190 {
1191 mode = O_BINARY;
1192 s += 4;
1193 len -= 4;
1194 break;
1195 }
1196 /* FALL THROUGH */
1197 case 'c':
e963d6d2 1198 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
16fe6d59
GS
1199 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1200 {
1201 mode = O_TEXT;
1202 s += 5;
1203 len -= 5;
1204 break;
1205 }
1206 /* FALL THROUGH */
1207 default:
1208 goto fail_discipline;
1209 }
1210 }
1211 else if (isSPACE(*s)) {
1212 ++s;
1213 --len;
1214 }
1215 else {
4373e329 1216 const char *end;
16fe6d59
GS
1217fail_discipline:
1218 end = strchr(s+1, ':');
1219 if (!end)
1220 end = s+len;
60382766 1221#ifndef PERLIO_LAYERS
363c40c4 1222 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
60382766 1223#else
18a33fb5 1224 len -= end-s;
60382766
NIS
1225 s = end;
1226#endif
16fe6d59
GS
1227 }
1228 }
1229 }
1230 return mode;
1231}
1232
58e24eff 1233#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
27da23d5
JH
1234I32
1235my_chsize(int fd, Off_t length)
6eb13c3b 1236{
58e24eff
SH
1237#ifdef F_FREESP
1238 /* code courtesy of William Kucharski */
1239#define HAS_CHSIZE
1240
c623ac67 1241 Stat_t filebuf;
6eb13c3b 1242
3028581b 1243 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
1244 return -1;
1245
1246 if (filebuf.st_size < length) {
1247
1248 /* extend file length */
1249
3028581b 1250 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
1251 return -1;
1252
1253 /* write a "0" byte */
1254
3028581b 1255 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
1256 return -1;
1257 }
1258 else {
1259 /* truncate length */
35da51f7 1260 struct flock fl;
6eb13c3b
LW
1261 fl.l_whence = 0;
1262 fl.l_len = 0;
1263 fl.l_start = length;
a0d0e21e 1264 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
1265
1266 /*
a0d0e21e 1267 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
1268 * fcntl(2), which truncates the file so that it ends at the
1269 * position indicated by fl.l_start.
1270 *
1271 * Will minor miracles never cease?
1272 */
1273
a0d0e21e 1274 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
1275 return -1;
1276
1277 }
6eb13c3b 1278 return 0;
58e24eff 1279#else
27da23d5 1280 Perl_croak_nocontext("truncate not implemented");
a0d0e21e 1281#endif /* F_FREESP */
27da23d5 1282 return -1;
58e24eff
SH
1283}
1284#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
ff8e2863 1285
a687059c 1286bool
5aaab254 1287Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
a687059c 1288{
97aff369 1289 dVAR;
7918f24d
NC
1290
1291 PERL_ARGS_ASSERT_DO_PRINT;
1292
79072805
LW
1293 /* assuming fp is checked earlier */
1294 if (!sv)
1295 return TRUE;
e9950d3b
NC
1296 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
1297 assert(!SvGMAGICAL(sv));
1298 if (SvIsUV(sv))
1299 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
1300 else
1301 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
1302 return !PerlIO_error(fp);
1303 }
1304 else {
1305 STRLEN len;
676f44e7 1306 /* Do this first to trigger any overloading. */
e9950d3b
NC
1307 const char *tmps = SvPV_const(sv, len);
1308 U8 *tmpbuf = NULL;
1309 bool happy = TRUE;
1310
d791f93f
KW
1311 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
1312 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
676f44e7
NC
1313 /* We don't modify the original scalar. */
1314 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
1315 tmps = (char *) tmpbuf;
1316 }
a099aed4 1317 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
0876b9a0
KW
1318 (void) check_utf8_print((const U8*) tmps, len);
1319 }
d791f93f
KW
1320 } /* else stream isn't utf8 */
1321 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
1322 convert to bytes */
676f44e7
NC
1323 STRLEN tmplen = len;
1324 bool utf8 = TRUE;
35da51f7 1325 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
676f44e7 1326 if (!utf8) {
d791f93f
KW
1327
1328 /* Here, succeeded in downgrading from utf8. Set up to below
1329 * output the converted value */
676f44e7
NC
1330 tmpbuf = result;
1331 tmps = (char *) tmpbuf;
1332 len = tmplen;
1333 }
d791f93f
KW
1334 else { /* Non-utf8 output stream, but string only representable in
1335 utf8 */
676f44e7 1336 assert((char *)result == tmps);
9b387841 1337 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
21630838
FC
1338 "Wide character in %s",
1339 PL_op ? OP_DESC(PL_op) : "print"
1340 );
0876b9a0
KW
1341 /* Could also check that isn't one of the things to avoid
1342 * in utf8 by using check_utf8_print(), but not doing so,
1343 * since the stream isn't a UTF8 stream */
ae798467
NIS
1344 }
1345 }
e9950d3b
NC
1346 /* To detect whether the process is about to overstep its
1347 * filesize limit we would need getrlimit(). We could then
1348 * also transparently raise the limit with setrlimit() --
1349 * but only until the system hard limit/the filesystem limit,
1350 * at which we would get EPERM. Note that when using buffered
1351 * io the write failure can be delayed until the flush/close. --jhi */
1352 if (len && (PerlIO_write(fp,tmps,len) == 0))
1353 happy = FALSE;
1354 Safefree(tmpbuf);
1355 return happy ? !PerlIO_error(fp) : FALSE;
ff8e2863 1356 }
a687059c
LW
1357}
1358
79072805 1359I32
0d7d409d 1360Perl_my_stat_flags(pTHX_ const U32 flags)
a687059c 1361{
97aff369 1362 dVAR;
39644a26 1363 dSP;
79072805 1364 IO *io;
2dd78f96 1365 GV* gv;
79072805 1366
533c011a 1367 if (PL_op->op_flags & OPf_REF) {
2dd78f96 1368 gv = cGVOP_gv;
748a9306 1369 do_fstat:
5228a96c
SP
1370 if (gv == PL_defgv)
1371 return PL_laststatval;
2dd78f96 1372 io = GvIO(gv);
ad02613c 1373 do_fstat_have_io:
5228a96c 1374 PL_laststype = OP_STAT;
bd5f6c01 1375 PL_statgv = gv ? gv : (GV *)io;
76f68e9b 1376 sv_setpvs(PL_statname, "");
5228a96c
SP
1377 if(io) {
1378 if (IoIFP(io)) {
1379 return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
1380 } else if (IoDIRP(io)) {
3497a01f 1381 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
5228a96c 1382 }
5228a96c 1383 }
3888144c
FC
1384 PL_laststatval = -1;
1385 report_evil_fh(gv);
1386 return -1;
a687059c 1387 }
d2c4d2d1 1388 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
8db8f6b6
FC
1389 == OPpFT_STACKED)
1390 return PL_laststatval;
d2c4d2d1
FC
1391 else {
1392 SV* const sv = TOPs;
4373e329 1393 const char *s;
4ecd490c 1394 STRLEN len;
094a3eec 1395 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
748a9306
LW
1396 goto do_fstat;
1397 }
ad02613c 1398 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 1399 io = MUTABLE_IO(SvRV(sv));
7f39519f 1400 gv = NULL;
ad02613c
SP
1401 goto do_fstat_have_io;
1402 }
748a9306 1403
0d7d409d 1404 s = SvPV_flags_const(sv, len, flags);
a0714e2c 1405 PL_statgv = NULL;
4ecd490c 1406 sv_setpvn(PL_statname, s, len);
95a20fc0 1407 s = SvPVX_const(PL_statname); /* s now NUL-terminated */
3280af22
NIS
1408 PL_laststype = OP_STAT;
1409 PL_laststatval = PerlLIO_stat(s, &PL_statcache);
7cb3f959 1410 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
5d37acd6 1411 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 1412 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
5d37acd6
DM
1413 GCC_DIAG_RESTORE;
1414 }
3280af22 1415 return PL_laststatval;
a687059c
LW
1416 }
1417}
1418
fbb0b3b3 1419
79072805 1420I32
0d7d409d 1421Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 1422{
97aff369 1423 dVAR;
a1894d81 1424 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 1425 dSP;
b16276bb 1426 const char *file;
cd22fad3 1427 SV* const sv = TOPs;
5840701a 1428 bool isio = FALSE;
533c011a 1429 if (PL_op->op_flags & OPf_REF) {
638eceb6 1430 if (cGVOP_gv == PL_defgv) {
3280af22 1431 if (PL_laststype != OP_LSTAT)
0157ef98 1432 Perl_croak(aTHX_ "%s", no_prev_lstat);
3280af22 1433 return PL_laststatval;
fe14fcc3 1434 }
31b139ba 1435 PL_laststatval = -1;
5d3e98de 1436 if (ckWARN(WARN_IO)) {
5840701a 1437 /* diag_listed_as: Use of -l on filehandle%s */
d0c0e7dd
FC
1438 Perl_warner(aTHX_ packWARN(WARN_IO),
1439 "Use of -l on filehandle %"HEKf,
1440 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 1441 }
31b139ba 1442 return -1;
fe14fcc3 1443 }
8db8f6b6
FC
1444 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1445 == OPpFT_STACKED) {
1f26655e 1446 if (PL_laststype != OP_LSTAT)
0157ef98 1447 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 1448 return PL_laststatval;
cd22fad3 1449 }
c623bd54 1450
3280af22 1451 PL_laststype = OP_LSTAT;
a0714e2c 1452 PL_statgv = NULL;
5840701a
FC
1453 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
1454 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
1455 )
1456 || isGV_with_GP(sv)
1457 )
1458 && ckWARN(WARN_IO)) {
1459 if (isio)
1460 /* diag_listed_as: Use of -l on filehandle%s */
1461 Perl_warner(aTHX_ packWARN(WARN_IO),
1462 "Use of -l on filehandle");
1463 else
1464 /* diag_listed_as: Use of -l on filehandle%s */
1465 Perl_warner(aTHX_ packWARN(WARN_IO),
1466 "Use of -l on filehandle %"HEKf,
1467 GvENAME_HEK((const GV *)
1468 (SvROK(sv) ? SvRV(sv) : sv)));
cd22fad3
RS
1469 }
1470 file = SvPV_flags_const_nolen(sv, flags);
b16276bb
VP
1471 sv_setpv(PL_statname,file);
1472 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
7cb3f959 1473 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
5d37acd6
DM
1474 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
1475 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
1476 GCC_DIAG_RESTORE;
1477 }
3280af22 1478 return PL_laststatval;
c623bd54
LW
1479}
1480
a0f2c8ec
JD
1481static void
1482S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
1483{
1484 const int e = errno;
7918f24d 1485 PERL_ARGS_ASSERT_EXEC_FAILED;
a0f2c8ec
JD
1486 if (ckWARN(WARN_EXEC))
1487 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1488 cmd, Strerror(e));
1489 if (do_report) {
04783dc7
DM
1490 int rc = PerlLIO_write(fd, (void*)&e, sizeof(int));
1491 /* silently ignore failures */
1492 PERL_UNUSED_VAR(rc);
a0f2c8ec
JD
1493 PerlLIO_close(fd);
1494 }
1495}
1496
d5a9bfb0 1497bool
5aaab254 1498Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2aa1486d 1499 int fd, int do_report)
d5a9bfb0 1500{
27da23d5 1501 dVAR;
7918f24d 1502 PERL_ARGS_ASSERT_DO_AEXEC5;
e37778c2 1503#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
cd39f2b6
JH
1504 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1505#else
79072805 1506 if (sp > mark) {
360ea906 1507 const char **a;
6136c704 1508 const char *tmps = NULL;
360ea906 1509 Newx(PL_Argv, sp - mark + 1, const char*);
c3c5fad7 1510 a = PL_Argv;
890ce7af 1511
79072805
LW
1512 while (++mark <= sp) {
1513 if (*mark)
360ea906 1514 *a++ = SvPV_nolen_const(*mark);
a687059c
LW
1515 else
1516 *a++ = "";
1517 }
6136c704 1518 *a = NULL;
91b2752f 1519 if (really)
e62f0680 1520 tmps = SvPV_nolen_const(really);
91b2752f
RG
1521 if ((!really && *PL_Argv[0] != '/') ||
1522 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 1523 TAINT_ENV(); /* testing IFS here is overkill, probably */
b35112e7 1524 PERL_FPU_PRE_EXEC
91b2752f 1525 if (really && *tmps)
b4748376 1526 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
a687059c 1527 else
b4748376 1528 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1529 PERL_FPU_POST_EXEC
a0f2c8ec 1530 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
a687059c 1531 }
bee1dbe2 1532 do_execfree();
cd39f2b6 1533#endif
a687059c
LW
1534 return FALSE;
1535}
1536
fe14fcc3 1537void
864dbfa3 1538Perl_do_execfree(pTHX)
ff8e2863 1539{
97aff369 1540 dVAR;
43c5f42d 1541 Safefree(PL_Argv);
4608196e 1542 PL_Argv = NULL;
43c5f42d 1543 Safefree(PL_Cmd);
bd61b366 1544 PL_Cmd = NULL;
ff8e2863
LW
1545}
1546
9555a685 1547#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8
IZ
1548
1549bool
2fbb330f 1550Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 1551{
27da23d5 1552 dVAR;
eb578fdb
KW
1553 const char **a;
1554 char *s;
15db3ae2 1555 char *buf;
2fbb330f 1556 char *cmd;
2fbb330f 1557 /* Make a copy so we can change it */
6fca0082 1558 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC
1559
1560 PERL_ARGS_ASSERT_DO_EXEC3;
1561
15db3ae2
DM
1562 Newx(buf, cmdlen, char);
1563 cmd = buf;
cfff9797 1564 memcpy(cmd, incmd, cmdlen);
a687059c 1565
748a9306
LW
1566 while (*cmd && isSPACE(*cmd))
1567 cmd++;
1568
a687059c
LW
1569 /* save an extra exec if possible */
1570
bf38876a 1571#ifdef CSH
d05c1ba0 1572 {
0c19750d 1573 char flags[PERL_FLAGS_MAX];
d05c1ba0
JH
1574 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
1575 strnEQ(cmd+PL_cshlen," -c",3)) {
28f0d0ec 1576 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
d05c1ba0
JH
1577 s = cmd+PL_cshlen+3;
1578 if (*s == 'f') {
1579 s++;
28f0d0ec 1580 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
d05c1ba0
JH
1581 }
1582 if (*s == ' ')
1583 s++;
1584 if (*s++ == '\'') {
0bcc34c2 1585 char * const ncmd = s;
d05c1ba0
JH
1586
1587 while (*s)
1588 s++;
1589 if (s[-1] == '\n')
1590 *--s = '\0';
1591 if (s[-1] == '\'') {
1592 *--s = '\0';
b35112e7 1593 PERL_FPU_PRE_EXEC
7c0dd7ca 1594 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
b35112e7 1595 PERL_FPU_POST_EXEC
d05c1ba0 1596 *s = '\'';
a0f2c8ec 1597 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
15db3ae2 1598 Safefree(buf);
d05c1ba0
JH
1599 return FALSE;
1600 }
1601 }
a687059c
LW
1602 }
1603 }
bf38876a 1604#endif /* CSH */
a687059c
LW
1605
1606 /* see if there are shell metacharacters in it */
1607
748a9306
LW
1608 if (*cmd == '.' && isSPACE(cmd[1]))
1609 goto doshell;
1610
1611 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1612 goto doshell;
1613
294b3b39 1614 s = cmd;
0eb30aeb 1615 while (isWORDCHAR(*s))
294b3b39 1616 s++; /* catch VAR=val gizmo */
63f2c1e1
LW
1617 if (*s == '=')
1618 goto doshell;
748a9306 1619
a687059c 1620 for (s = cmd; *s; s++) {
d05c1ba0
JH
1621 if (*s != ' ' && !isALPHA(*s) &&
1622 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1623 if (*s == '\n' && !s[1]) {
1624 *s = '\0';
1625 break;
1626 }
603a98b0
IZ
1627 /* handle the 2>&1 construct at the end */
1628 if (*s == '>' && s[1] == '&' && s[2] == '1'
1629 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1630 && (!s[3] || isSPACE(s[3])))
1631 {
6867be6d 1632 const char *t = s + 3;
603a98b0
IZ
1633
1634 while (*t && isSPACE(*t))
1635 ++t;
943bbd07 1636 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
603a98b0
IZ
1637 s[-2] = '\0';
1638 break;
1639 }
1640 }
a687059c 1641 doshell:
b35112e7 1642 PERL_FPU_PRE_EXEC
7c0dd7ca 1643 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
b35112e7 1644 PERL_FPU_POST_EXEC
a0f2c8ec 1645 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
15db3ae2 1646 Safefree(buf);
a687059c
LW
1647 return FALSE;
1648 }
1649 }
748a9306 1650
360ea906 1651 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*);
3280af22
NIS
1652 PL_Cmd = savepvn(cmd, s-cmd);
1653 a = PL_Argv;
1654 for (s = PL_Cmd; *s;) {
294b3b39
AL
1655 while (isSPACE(*s))
1656 s++;
a687059c
LW
1657 if (*s)
1658 *(a++) = s;
294b3b39
AL
1659 while (*s && !isSPACE(*s))
1660 s++;
a687059c
LW
1661 if (*s)
1662 *s++ = '\0';
1663 }
6136c704 1664 *a = NULL;
3280af22 1665 if (PL_Argv[0]) {
b35112e7 1666 PERL_FPU_PRE_EXEC
360ea906 1667 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1668 PERL_FPU_POST_EXEC
b1248f16 1669 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1670 do_execfree();
a687059c 1671 goto doshell;
b1248f16 1672 }
a0f2c8ec 1673 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
a687059c 1674 }
ff8e2863 1675 do_execfree();
15db3ae2 1676 Safefree(buf);
a687059c
LW
1677 return FALSE;
1678}
1679
6890e559 1680#endif /* OS2 || WIN32 */
760ac839 1681
25bbd826
CB
1682#ifdef VMS
1683#include <starlet.h> /* for sys$delprc */
1684#endif
1685
79072805 1686I32
5aaab254 1687Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
a687059c 1688{
97aff369 1689 dVAR;
eb578fdb
KW
1690 I32 val;
1691 I32 tot = 0;
4634a855 1692 const char *const what = PL_op_name[type];
5c144d81 1693 const char *s;
84c7b88c 1694 STRLEN len;
890ce7af 1695 SV ** const oldmark = mark;
885b4b39 1696 bool killgp = FALSE;
a687059c 1697
7918f24d
NC
1698 PERL_ARGS_ASSERT_APPLY;
1699
9a9b5ec9
DM
1700 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
1701
1444765e
NC
1702 /* Doing this ahead of the switch statement preserves the old behaviour,
1703 where attempting to use kill as a taint test test would fail on
1704 platforms where kill was not defined. */
1705#ifndef HAS_KILL
1706 if (type == OP_KILL)
4634a855 1707 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1708#endif
1709#ifndef HAS_CHOWN
1710 if (type == OP_CHOWN)
4634a855 1711 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1712#endif
1713
1714
20408e3c 1715#define APPLY_TAINT_PROPER() \
3280af22 1716 STMT_START { \
284167a5 1717 if (TAINT_get) { TAINT_PROPER(what); } \
873ef191 1718 } STMT_END
20408e3c
GS
1719
1720 /* This is a first heuristic; it doesn't catch tainting magic. */
284167a5 1721 if (TAINTING_get) {
463ee0b2 1722 while (++mark <= sp) {
bbce6d69 1723 if (SvTAINTED(*mark)) {
1724 TAINT;
1725 break;
1726 }
463ee0b2
LW
1727 }
1728 mark = oldmark;
1729 }
a687059c 1730 switch (type) {
79072805 1731 case OP_CHMOD:
20408e3c 1732 APPLY_TAINT_PROPER();
79072805 1733 if (++mark <= sp) {
4ea561bc 1734 val = SvIV(*mark);
20408e3c
GS
1735 APPLY_TAINT_PROPER();
1736 tot = sp - mark;
79072805 1737 while (++mark <= sp) {
c4aca7d0 1738 GV* gv;
2ea1cce7 1739 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1740 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1741#ifdef HAS_FCHMOD
1742 APPLY_TAINT_PROPER();
1743 if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
1744 tot--;
1745#else
b9c6780e 1746 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0
GA
1747#endif
1748 }
1749 else {
1750 tot--;
1751 }
1752 }
c4aca7d0 1753 else {
41188aa0 1754 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 1755 APPLY_TAINT_PROPER();
41188aa0 1756 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC
1757 PerlLIO_chmod(name, val)) {
1758 tot--;
1759 }
c4aca7d0 1760 }
a687059c
LW
1761 }
1762 }
1763 break;
fe14fcc3 1764#ifdef HAS_CHOWN
79072805 1765 case OP_CHOWN:
20408e3c 1766 APPLY_TAINT_PROPER();
79072805 1767 if (sp - mark > 2) {
eb578fdb 1768 I32 val2;
463ee0b2
LW
1769 val = SvIVx(*++mark);
1770 val2 = SvIVx(*++mark);
20408e3c 1771 APPLY_TAINT_PROPER();
a0d0e21e 1772 tot = sp - mark;
79072805 1773 while (++mark <= sp) {
c4aca7d0 1774 GV* gv;
2ea1cce7 1775 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1776 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1777#ifdef HAS_FCHOWN
1778 APPLY_TAINT_PROPER();
1779 if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
1780 tot--;
1781#else
b9c6780e 1782 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0
GA
1783#endif
1784 }
1785 else {
1786 tot--;
1787 }
1788 }
c4aca7d0 1789 else {
41188aa0 1790 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 1791 APPLY_TAINT_PROPER();
41188aa0 1792 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 1793 PerlLIO_chown(name, val, val2)) {
c4aca7d0 1794 tot--;
c8028aa6 1795 }
c4aca7d0 1796 }
a687059c
LW
1797 }
1798 }
1799 break;
b1248f16 1800#endif
a1d180c4 1801/*
dd64f1c3
AD
1802XXX Should we make lchown() directly available from perl?
1803For now, we'll let Configure test for HAS_LCHOWN, but do
1804nothing in the core.
1805 --AD 5/1998
1806*/
fe14fcc3 1807#ifdef HAS_KILL
79072805 1808 case OP_KILL:
20408e3c 1809 APPLY_TAINT_PROPER();
55497cff 1810 if (mark == sp)
1811 break;
84c7b88c 1812 s = SvPVx_const(*++mark, len);
c2fd40cb
DM
1813 if (*s == '-' && isALPHA(s[1]))
1814 {
1815 s++;
1816 len--;
885b4b39 1817 killgp = TRUE;
c2fd40cb 1818 }
e02bfb16 1819 if (isALPHA(*s)) {
84c7b88c 1820 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
79072805 1821 s += 3;
84c7b88c
BF
1822 len -= 3;
1823 }
1824 if ((val = whichsig_pvn(s, len)) < 0)
1825 Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
79072805
LW
1826 }
1827 else
c2fd40cb 1828 {
4ea561bc 1829 val = SvIV(*mark);
c2fd40cb
DM
1830 if (val < 0)
1831 {
885b4b39 1832 killgp = TRUE;
c2fd40cb
DM
1833 val = -val;
1834 }
1835 }
20408e3c
GS
1836 APPLY_TAINT_PROPER();
1837 tot = sp - mark;
3595fcef 1838#ifdef VMS
1839 /* kill() doesn't do process groups (job trees?) under VMS */
3595fcef 1840 if (val == SIGKILL) {
3595fcef 1841 /* Use native sys$delprc() to insure that target process is
1842 * deleted; supervisor-mode images don't pay attention to
1843 * CRTL's emulation of Unix-style signals and kill()
1844 */
1845 while (++mark <= sp) {
5f521955 1846 I32 proc;
eb578fdb 1847 unsigned long int __vmssts;
8af710eb 1848 SvGETMAGIC(*mark);
e2c0f81f
DG
1849 if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
1850 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
8af710eb 1851 proc = SvIV_nomg(*mark);
20408e3c 1852 APPLY_TAINT_PROPER();
3595fcef 1853 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1854 tot--;
1855 switch (__vmssts) {
1856 case SS$_NONEXPR:
1857 case SS$_NOSUCHNODE:
1858 SETERRNO(ESRCH,__vmssts);
1859 break;
1860 case SS$_NOPRIV:
1861 SETERRNO(EPERM,__vmssts);
1862 break;
1863 default:
1864 SETERRNO(EVMSERR,__vmssts);
1865 }
1866 }
1867 }
8165faea 1868 PERL_ASYNC_CHECK();
3595fcef 1869 break;
1870 }
1871#endif
c2fd40cb 1872 while (++mark <= sp) {
60082291 1873 Pid_t proc;
c2fd40cb 1874 SvGETMAGIC(*mark);
60082291 1875 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
c2fd40cb
DM
1876 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
1877 proc = SvIV_nomg(*mark);
c2fd40cb 1878 APPLY_TAINT_PROPER();
111f73b5
DM
1879#ifdef HAS_KILLPG
1880 /* use killpg in preference, as the killpg() wrapper for Win32
1881 * understands process groups, but the kill() wrapper doesn't */
1882 if (killgp ? PerlProc_killpg(proc, val)
1883 : PerlProc_kill(proc, val))
1884#else
1885 if (PerlProc_kill(killgp ? -proc: proc, val))
1886#endif
c2fd40cb 1887 tot--;
a687059c 1888 }
8165faea 1889 PERL_ASYNC_CHECK();
a687059c 1890 break;
b1248f16 1891#endif
79072805 1892 case OP_UNLINK:
20408e3c 1893 APPLY_TAINT_PROPER();
79072805
LW
1894 tot = sp - mark;
1895 while (++mark <= sp) {
41188aa0 1896 s = SvPV_const(*mark, len);
20408e3c 1897 APPLY_TAINT_PROPER();
41188aa0 1898 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC
1899 tot--;
1900 }
f0d85c30 1901 else if (PL_unsafe) {
b8ffc8df 1902 if (UNLINK(s))
a687059c
LW
1903 tot--;
1904 }
1905 else { /* don't let root wipe out directories without -U */
1dcae8b8 1906 if (PerlLIO_lstat(s,&PL_statbuf) < 0)
a687059c 1907 tot--;
1dcae8b8
EZ
1908 else if (S_ISDIR(PL_statbuf.st_mode)) {
1909 tot--;
cd52bc19 1910 SETERRNO(EISDIR, SS_NOPRIV);
1dcae8b8 1911 }
a687059c 1912 else {
b8ffc8df 1913 if (UNLINK(s))
a687059c
LW
1914 tot--;
1915 }
1916 }
1917 }
1918 break;
e96b369d 1919#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 1920 case OP_UTIME:
20408e3c 1921 APPLY_TAINT_PROPER();
79072805 1922 if (sp - mark > 2) {
e96b369d
GA
1923#if defined(HAS_FUTIMES)
1924 struct timeval utbuf[2];
1925 void *utbufp = utbuf;
1926#elif defined(I_UTIME) || defined(VMS)
663a0e37 1927 struct utimbuf utbuf;
07409e01 1928 struct utimbuf *utbufp = &utbuf;
663a0e37 1929#else
a687059c 1930 struct {
dd2821f6
GS
1931 Time_t actime;
1932 Time_t modtime;
a687059c 1933 } utbuf;
07409e01 1934 void *utbufp = &utbuf;
663a0e37 1935#endif
a687059c 1936
0bcc34c2
AL
1937 SV* const accessed = *++mark;
1938 SV* const modified = *++mark;
c6f7b413 1939
6ec06612
SB
1940 /* Be like C, and if both times are undefined, let the C
1941 * library figure out what to do. This usually means
1942 * "current time". */
c6f7b413
RS
1943
1944 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB
1945 utbufp = NULL;
1946 else {
1947 Zero(&utbuf, sizeof utbuf, char);
e96b369d 1948#ifdef HAS_FUTIMES
4ea561bc 1949 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 1950 utbuf[0].tv_usec = 0;
4ea561bc 1951 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA
1952 utbuf[1].tv_usec = 0;
1953#elif defined(BIG_TIME)
4ea561bc
NC
1954 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
1955 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 1956#else
4ea561bc
NC
1957 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
1958 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 1959#endif
6ec06612 1960 }
4373e329 1961 APPLY_TAINT_PROPER();
79072805
LW
1962 tot = sp - mark;
1963 while (++mark <= sp) {
e96b369d 1964 GV* gv;
64617da9 1965 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA
1966 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1967#ifdef HAS_FUTIMES
1968 APPLY_TAINT_PROPER();
8b7231d9
SP
1969 if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
1970 (struct timeval *) utbufp))
e96b369d
GA
1971 tot--;
1972#else
1973 Perl_die(aTHX_ PL_no_func, "futimes");
1974#endif
1975 }
1976 else {
1977 tot--;
1978 }
1979 }
e96b369d 1980 else {
41188aa0 1981 const char * const name = SvPV_nomg_const(*mark, len);
e96b369d 1982 APPLY_TAINT_PROPER();
41188aa0 1983 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC
1984 tot--;
1985 }
1986 else
e96b369d 1987#ifdef HAS_FUTIMES
8b7231d9 1988 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA
1989#else
1990 if (PerlLIO_utime(name, utbufp))
1991#endif
1992 tot--;
1993 }
1994
a687059c 1995 }
a687059c
LW
1996 }
1997 else
79072805 1998 tot = 0;
a687059c 1999 break;
a0d0e21e 2000#endif
a687059c
LW
2001 }
2002 return tot;
20408e3c 2003
20408e3c 2004#undef APPLY_TAINT_PROPER
a687059c
LW
2005}
2006
2007/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 2008#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 2009bool
5aaab254 2010Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC
2011/* effective is a flag, true for EUID, or for checking if the effective gid
2012 * is in the list of groups returned from getgroups().
2013 */
a687059c 2014{
97aff369 2015 dVAR;
7918f24d
NC
2016
2017 PERL_ARGS_ASSERT_CANDO;
2018
bee1dbe2 2019#ifdef DOSISH
fe14fcc3
LW
2020 /* [Comments and code from Len Reed]
2021 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
2022 * to write-protected files. The execute permission bit is set
486ec47a 2023 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW
2024 * .exe files
2025 * .com files
2026 * .bat files
2027 * directories
2028 * All files and directories are readable.
2029 * Directories and special files, e.g. "CON", cannot be
2030 * write-protected.
2031 * [Comment by Tom Dinger -- a directory can have the write-protect
2032 * bit set in the file system, but DOS permits changes to
2033 * the directory anyway. In addition, all bets are off
2034 * here for networked software, such as Novell and
2035 * Sun's PC-NFS.]
2036 */
2037
bee1dbe2
LW
2038 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
2039 * too so it will actually look into the files for magic numbers
2040 */
7f4774ae 2041 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 2042
55497cff 2043#else /* ! DOSISH */
b595cd4b
RU
2044# ifdef __CYGWIN__
2045 if (ingroup(544,effective)) { /* member of Administrators */
2046# else
985213f2 2047 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 2048# endif
7f4774ae 2049 if (mode == S_IXUSR) {
c623bd54 2050 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
2051 return TRUE;
2052 }
2053 else
2054 return TRUE; /* root reads and writes anything */
2055 return FALSE;
2056 }
985213f2 2057 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 2058 if (statbufp->st_mode & mode)
a687059c
LW
2059 return TRUE; /* ok as "user" */
2060 }
d8eceb89 2061 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 2062 if (statbufp->st_mode & mode >> 3)
a687059c
LW
2063 return TRUE; /* ok as "group" */
2064 }
7f4774ae 2065 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
2066 return TRUE; /* ok as "other" */
2067 return FALSE;
55497cff 2068#endif /* ! DOSISH */
a687059c 2069}
a0d0e21e 2070#endif /* ! VMS */
a687059c 2071
1f676739 2072static bool
0da8eb3a 2073S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 2074{
97aff369 2075 dVAR;
985213f2 2076 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 2077 return TRUE;
fe14fcc3 2078#ifdef HAS_GETGROUPS
a687059c 2079 {
331b57bc 2080 Groups_t *gary = NULL;
79072805 2081 I32 anum;
331b57bc 2082 bool rc = FALSE;
a687059c 2083
331b57bc
SP
2084 anum = getgroups(0, gary);
2085 Newx(gary, anum, Groups_t);
2086 anum = getgroups(anum, gary);
a687059c 2087 while (--anum >= 0)
331b57bc
SP
2088 if (gary[anum] == testgid) {
2089 rc = TRUE;
2090 break;
2091 }
2092
2093 Safefree(gary);
2094 return rc;
a687059c 2095 }
c685562b 2096#else
a687059c 2097 return FALSE;
cd39f2b6 2098#endif
a687059c 2099}
c2ab57d4 2100
fe14fcc3 2101#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2102
79072805 2103I32
864dbfa3 2104Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2105{
97aff369 2106 dVAR;
0bcc34c2 2107 const key_t key = (key_t)SvNVx(*++mark);
c3312966 2108 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 2109 const I32 flags = SvIVx(*++mark);
294a48e9 2110
7918f24d 2111 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 2112 PERL_UNUSED_ARG(sp);
c2ab57d4 2113
748a9306 2114 SETERRNO(0,0);
c2ab57d4
LW
2115 switch (optype)
2116 {
fe14fcc3 2117#ifdef HAS_MSG
79072805 2118 case OP_MSGGET:
c2ab57d4 2119 return msgget(key, flags);
e5d73d77 2120#endif
fe14fcc3 2121#ifdef HAS_SEM
79072805 2122 case OP_SEMGET:
c3312966 2123 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2124#endif
fe14fcc3 2125#ifdef HAS_SHM
79072805 2126 case OP_SHMGET:
c3312966 2127 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 2128#endif
fe14fcc3 2129#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2130 default:
fe13d51d 2131 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2132 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2133#endif
c2ab57d4
LW
2134 }
2135 return -1; /* should never happen */
2136}
2137
79072805 2138I32
864dbfa3 2139Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2140{
97aff369 2141 dVAR;
c2ab57d4 2142 char *a;
a0d0e21e 2143 I32 ret = -1;
6867be6d 2144 const I32 id = SvIVx(*++mark);
95b63a38 2145#ifdef Semctl
6867be6d 2146 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2147#endif
6867be6d 2148 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL
2149 SV * const astr = *++mark;
2150 STRLEN infosize = 0;
2151 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2152
7918f24d 2153 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2154 PERL_UNUSED_ARG(sp);
c2ab57d4
LW
2155
2156 switch (optype)
2157 {
fe14fcc3 2158#ifdef HAS_MSG
79072805 2159 case OP_MSGCTL:
c2ab57d4
LW
2160 if (cmd == IPC_STAT || cmd == IPC_SET)
2161 infosize = sizeof(struct msqid_ds);
2162 break;
e5d73d77 2163#endif
fe14fcc3 2164#ifdef HAS_SHM
79072805 2165 case OP_SHMCTL:
c2ab57d4
LW
2166 if (cmd == IPC_STAT || cmd == IPC_SET)
2167 infosize = sizeof(struct shmid_ds);
2168 break;
e5d73d77 2169#endif
fe14fcc3 2170#ifdef HAS_SEM
79072805 2171 case OP_SEMCTL:
39398f3f 2172#ifdef Semctl
c2ab57d4
LW
2173 if (cmd == IPC_STAT || cmd == IPC_SET)
2174 infosize = sizeof(struct semid_ds);
2175 else if (cmd == GETALL || cmd == SETALL)
2176 {
8e591e46 2177 struct semid_ds semds;
bd89102f 2178 union semun semun;
e6f0bdd6
GS
2179#ifdef EXTRA_F_IN_SEMUN_BUF
2180 semun.buff = &semds;
2181#else
84902520 2182 semun.buf = &semds;
e6f0bdd6 2183#endif
c2ab57d4 2184 getinfo = (cmd == GETALL);
9b89d93d
GB
2185 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2186 return -1;
6e21c824
LW
2187 infosize = semds.sem_nsems * sizeof(short);
2188 /* "short" is technically wrong but much more portable
2189 than guessing about u_?short(_t)? */
c2ab57d4 2190 }
39398f3f 2191#else
fe13d51d 2192 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2193 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2194#endif
c2ab57d4 2195 break;
e5d73d77 2196#endif
fe14fcc3 2197#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2198 default:
fe13d51d 2199 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2200 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2201#endif
c2ab57d4
LW
2202 }
2203
2204 if (infosize)
2205 {
2206 if (getinfo)
2207 {
93524f2b 2208 SvPV_force_nolen(astr);
a0d0e21e 2209 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
2210 }
2211 else
2212 {
93524f2b 2213 STRLEN len;
463ee0b2
LW
2214 a = SvPV(astr, len);
2215 if (len != infosize)
cea2e8a9 2216 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
2217 PL_op_desc[optype],
2218 (unsigned long)len,
2219 (long)infosize);
c2ab57d4
LW
2220 }
2221 }
2222 else
2223 {
0bcc34c2 2224 const IV i = SvIV(astr);
56431972 2225 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 2226 }
748a9306 2227 SETERRNO(0,0);
c2ab57d4
LW
2228 switch (optype)
2229 {
fe14fcc3 2230#ifdef HAS_MSG
79072805 2231 case OP_MSGCTL:
bee1dbe2 2232 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 2233 break;
e5d73d77 2234#endif
fe14fcc3 2235#ifdef HAS_SEM
bd89102f 2236 case OP_SEMCTL: {
39398f3f 2237#ifdef Semctl
bd89102f
AD
2238 union semun unsemds;
2239
64d76282
BC
2240 if(cmd == SETVAL) {
2241 unsemds.val = PTR2nat(a);
2242 }
2243 else {
e6f0bdd6 2244#ifdef EXTRA_F_IN_SEMUN_BUF
64d76282 2245 unsemds.buff = (struct semid_ds *)a;
e6f0bdd6 2246#else
64d76282 2247 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 2248#endif
64d76282 2249 }
bd89102f 2250 ret = Semctl(id, n, cmd, unsemds);
39398f3f 2251#else
fe13d51d 2252 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2253 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2254#endif
bd89102f 2255 }
c2ab57d4 2256 break;
e5d73d77 2257#endif
fe14fcc3 2258#ifdef HAS_SHM
79072805 2259 case OP_SHMCTL:
bee1dbe2 2260 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 2261 break;
e5d73d77 2262#endif
c2ab57d4
LW
2263 }
2264 if (getinfo && ret >= 0) {
79072805
LW
2265 SvCUR_set(astr, infosize);
2266 *SvEND(astr) = '\0';
a0d0e21e 2267 SvSETMAGIC(astr);
c2ab57d4
LW
2268 }
2269 return ret;
2270}
2271
79072805 2272I32
864dbfa3 2273Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 2274{
97aff369 2275 dVAR;
fe14fcc3 2276#ifdef HAS_MSG
463ee0b2 2277 STRLEN len;
6867be6d 2278 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2279 SV * const mstr = *++mark;
2280 const I32 flags = SvIVx(*++mark);
2281 const char * const mbuf = SvPV_const(mstr, len);
2282 const I32 msize = len - sizeof(long);
2283
7918f24d 2284 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 2285 PERL_UNUSED_ARG(sp);
c2ab57d4 2286
0bcc34c2 2287 if (msize < 0)
cea2e8a9 2288 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 2289 SETERRNO(0,0);
bee1dbe2 2290 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 2291#else
2d51fa4d
RGS
2292 PERL_UNUSED_ARG(sp);
2293 PERL_UNUSED_ARG(mark);
fe13d51d 2294 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2295 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 2296 return -1;
e5d73d77 2297#endif
c2ab57d4
LW
2298}
2299
79072805 2300I32
864dbfa3 2301Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 2302{
fe14fcc3 2303#ifdef HAS_MSG
97aff369 2304 dVAR;
c2ab57d4
LW
2305 char *mbuf;
2306 long mtype;
6867be6d 2307 I32 msize, flags, ret;
6867be6d 2308 const I32 id = SvIVx(*++mark);
0bcc34c2 2309 SV * const mstr = *++mark;
7918f24d
NC
2310
2311 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 2312 PERL_UNUSED_ARG(sp);
79072805 2313
c2e66d9e
GS
2314 /* suppress warning when reading into undef var --jhi */
2315 if (! SvOK(mstr))
76f68e9b 2316 sv_setpvs(mstr, "");
463ee0b2
LW
2317 msize = SvIVx(*++mark);
2318 mtype = (long)SvIVx(*++mark);
2319 flags = SvIVx(*++mark);
93524f2b 2320 SvPV_force_nolen(mstr);
a0d0e21e 2321 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2322
748a9306 2323 SETERRNO(0,0);
bee1dbe2 2324 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 2325 if (ret >= 0) {
79072805
LW
2326 SvCUR_set(mstr, sizeof(long)+ret);
2327 *SvEND(mstr) = '\0';
41d6edb2
JH
2328 /* who knows who has been playing with this message? */
2329 SvTAINTED_on(mstr);
c2ab57d4
LW
2330 }
2331 return ret;
e5d73d77 2332#else
2d51fa4d
RGS
2333 PERL_UNUSED_ARG(sp);
2334 PERL_UNUSED_ARG(mark);
fe13d51d 2335 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2336 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 2337 return -1;
e5d73d77 2338#endif
c2ab57d4
LW
2339}
2340
79072805 2341I32
864dbfa3 2342Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2343{
fe14fcc3 2344#ifdef HAS_SEM
97aff369 2345 dVAR;
463ee0b2 2346 STRLEN opsize;
6867be6d 2347 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2348 SV * const opstr = *++mark;
2349 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC
2350
2351 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 2352 PERL_UNUSED_ARG(sp);
c2ab57d4 2353
248ff010
NC
2354 if (opsize < 3 * SHORTSIZE
2355 || (opsize % (3 * SHORTSIZE))) {
93189314 2356 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW
2357 return -1;
2358 }
748a9306 2359 SETERRNO(0,0);
248ff010
NC
2360 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2361 {
6867be6d 2362 const int nsops = opsize / (3 * sizeof (short));
248ff010 2363 int i = nsops;
0bcc34c2 2364 short * const ops = (short *) opbuf;
248ff010
NC
2365 short *o = ops;
2366 struct sembuf *temps, *t;
2367 I32 result;
2368
a02a5408 2369 Newx (temps, nsops, struct sembuf);
248ff010
NC
2370 t = temps;
2371 while (i--) {
2372 t->sem_num = *o++;
2373 t->sem_op = *o++;
2374 t->sem_flg = *o++;
2375 t++;
2376 }
2377 result = semop(id, temps, nsops);
248ff010
NC
2378 Safefree(temps);
2379 return result;
2380 }
e5d73d77 2381#else
fe13d51d 2382 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2383 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2384#endif
c2ab57d4
LW
2385}
2386
79072805 2387I32
864dbfa3 2388Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2389{
fe14fcc3 2390#ifdef HAS_SHM
97aff369 2391 dVAR;
4373e329 2392 char *shm;
c2ab57d4 2393 struct shmid_ds shmds;
6867be6d 2394 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2395 SV * const mstr = *++mark;
2396 const I32 mpos = SvIVx(*++mark);
2397 const I32 msize = SvIVx(*++mark);
7918f24d
NC
2398
2399 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 2400 PERL_UNUSED_ARG(sp);
c2ab57d4 2401
748a9306 2402 SETERRNO(0,0);
c2ab57d4
LW
2403 if (shmctl(id, IPC_STAT, &shmds) == -1)
2404 return -1;
7f39519f
NC
2405 if (mpos < 0 || msize < 0
2406 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 2407 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2408 return -1;
2409 }
d4c19fe8 2410 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
2411 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2412 return -1;
79072805 2413 if (optype == OP_SHMREAD) {
c8ae91a8 2414 char *mbuf;
9f538c04 2415 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS
2416 SvGETMAGIC(mstr);
2417 SvUPGRADE(mstr, SVt_PV);
9f538c04 2418 if (! SvOK(mstr))
76f68e9b 2419 sv_setpvs(mstr, "");
af8ff727 2420 SvPOK_only(mstr);
bb7a0f54 2421 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 2422
bee1dbe2 2423 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2424 SvCUR_set(mstr, msize);
2425 *SvEND(mstr) = '\0';
a0d0e21e 2426 SvSETMAGIC(mstr);
d929ce6f
JH
2427 /* who knows who has been playing with this shared memory? */
2428 SvTAINTED_on(mstr);
c2ab57d4
LW
2429 }
2430 else {
93524f2b 2431 STRLEN len;
c2ab57d4 2432
93524f2b 2433 const char *mbuf = SvPV_const(mstr, len);
027aa12d 2434 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 2435 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2436 if (n < msize)
bee1dbe2 2437 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2438 }
2439 return shmdt(shm);
e5d73d77 2440#else
fe13d51d 2441 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2442 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 2443 return -1;
e5d73d77 2444#endif
c2ab57d4
LW
2445}
2446
fe14fcc3 2447#endif /* SYSV IPC */
4e35701f 2448
0d44d22b 2449/*
ccfc67b7
JH
2450=head1 IO Functions
2451
0d44d22b
NC
2452=for apidoc start_glob
2453
2454Function called by C<do_readline> to spawn a glob (or do the glob inside
154e47c8 2455perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
210b36aa 2456this glob starter is only used by miniperl during the build process.
0d44d22b 2457Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
fab3f3a7 2458
0d44d22b
NC
2459=cut
2460*/
2461
2462PerlIO *
2463Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2464{
27da23d5 2465 dVAR;
561b68a9 2466 SV * const tmpcmd = newSV(0);
0d44d22b 2467 PerlIO *fp;
41188aa0
TC
2468 STRLEN len;
2469 const char *s = SvPV(tmpglob, len);
7918f24d
NC
2470
2471 PERL_ARGS_ASSERT_START_GLOB;
2472
41188aa0 2473 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC
2474 return NULL;
2475
0d44d22b
NC
2476 ENTER;
2477 SAVEFREESV(tmpcmd);
2478#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2479 /* since spawning off a process is a real performance hit */
dca5a913
JM
2480
2481PerlIO *
2482Perl_vms_start_glob
2483 (pTHX_ SV *tmpglob,
2484 IO *io);
2485
49a7a762 2486 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 2487
0d44d22b 2488#else /* !VMS */
0d44d22b
NC
2489#ifdef DOSISH
2490#ifdef OS2
2491 sv_setpv(tmpcmd, "for a in ");
2492 sv_catsv(tmpcmd, tmpglob);
2493 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2494#else
2495#ifdef DJGPP
2496 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2497 sv_catsv(tmpcmd, tmpglob);
2498#else
2499 sv_setpv(tmpcmd, "perlglob ");
2500 sv_catsv(tmpcmd, tmpglob);
2501 sv_catpv(tmpcmd, " |");
2502#endif /* !DJGPP */
2503#endif /* !OS2 */
2504#else /* !DOSISH */
2505#if defined(CSH)
2506 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2507 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2508 sv_catsv(tmpcmd, tmpglob);
2509 sv_catpv(tmpcmd, "' 2>/dev/null |");
2510#else
2511 sv_setpv(tmpcmd, "echo ");
2512 sv_catsv(tmpcmd, tmpglob);
0d44d22b 2513 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
0d44d22b
NC
2514#endif /* !CSH */
2515#endif /* !DOSISH */
93b2dae1
FC
2516 {
2517 GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
2518 SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
25018358 2519 SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
93b2dae1 2520 if (home && *home) SvGETMAGIC(*home);
25018358 2521 if (path && *path) SvGETMAGIC(*path);
93b2dae1
FC
2522 save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
2523 if (home && *home) SvSETMAGIC(*home);
25018358 2524 if (path && *path) SvSETMAGIC(*path);
93b2dae1 2525 }
d5eb9a46
NC
2526 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
2527 NULL, NULL, 0);
0d44d22b
NC
2528 fp = IoIFP(io);
2529#endif /* !VMS */
2530 LEAVE;
de7dabb6
TC
2531
2532 if (!fp && ckWARN(WARN_GLOB)) {
2533 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
2534 Strerror(errno));
2535 }
2536
0d44d22b
NC
2537 return fp;
2538}
66610fdd
RGS
2539
2540/*
2541 * Local variables:
2542 * c-indentation-style: bsd
2543 * c-basic-offset: 4
14d04a33 2544 * indent-tabs-mode: nil
66610fdd
RGS
2545 * End:
2546 *
14d04a33 2547 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2548 */