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