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