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
Current ppport.h forcibly overrides older buggy versions of utf8_to_uvchr_buf
[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)
1604cfb0 86 setfd_cloexec(fd);
884fc2d3
Z		 87}
88
89void
74df577f
Z		 90Perl_setfd_inhexec_for_sysfd(pTHX_ int fd)
91{
92 assert(fd >= 0);
93 if(fd <= PL_maxsysfd)
1604cfb0 94 setfd_inhexec(fd);
74df577f 95}
884fc2d3
Z		 96void
97Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd)
98{
99 assert(fd >= 0);
100 if(fd <= PL_maxsysfd)
1604cfb0 101 setfd_inhexec(fd);
884fc2d3 102 else
1604cfb0 103 setfd_cloexec(fd);
884fc2d3
Z		 104}
105
74df577f
Z		 106
107#define DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
1604cfb0
MS		 108 do { \
109 int res = (GENOPEN_NORMAL); \
110 if(LIKELY(res != -1)) GENSETFD_CLOEXEC; \
111 return res; \
112 } while(0)
f9821aff 113#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \
1604cfb0 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, \
1604cfb0
MS		 117 GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
118 do { \
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; \
129 GENSETFD_CLOEXEC; \
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; \
136 GENSETFD_CLOEXEC; \
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: \
147 DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC); \
148 } \
149 } while(0)
f9821aff 150#else
999d65ed 151# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
1604cfb0
MS		 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) \
1604cfb0
MS		 157 do { \
158 int fd; \
159 DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \
160 setfd_cloexec(fd)); \
161 } while(0)
999d65ed
DM		 162#define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \
163 ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \
1604cfb0
MS		 164 do { \
165 int fd; \
166 DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
999d65ed
DM		 167 fd, \
168 fd = (ONEOPEN_CLOEXEC), \
1604cfb0
MS		 169 fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \
170 } while(0)
f9821aff 171
74df577f 172#define DO_PIPESETFD_CLOEXEC(PIPEFD) \
1604cfb0
MS		 173 do { \
174 setfd_cloexec((PIPEFD)[0]); \
175 setfd_cloexec((PIPEFD)[1]); \
176 } while(0)
f9821aff 177#define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \
1604cfb0 178 DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
999d65ed 179#define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \
1604cfb0
MS		 180 PIPEOPEN_NORMAL) \
181 DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
999d65ed 182 (PIPEFD)[0], PIPEOPEN_CLOEXEC, \
1604cfb0 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,
1604cfb0
MS		 196 fcntl(oldfd, F_DUPFD_CLOEXEC, 0),
197 PerlLIO_dup(oldfd));
f9821aff
Z		 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,
1604cfb0
MS		 214 dup3(oldfd, newfd, O_CLOEXEC),
215 PerlLIO_dup2(oldfd, newfd));
f9821aff
Z		 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,
1604cfb0
MS		 228 PerlLIO_open(file, flag | O_CLOEXEC),
229 PerlLIO_open(file, flag));
f9821aff
Z		 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,
1604cfb0
MS		 242 PerlLIO_open3(file, flag | O_CLOEXEC, perm),
243 PerlLIO_open3(file, flag, perm));
f9821aff
Z		 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,
1604cfb0
MS		 256 Perl_my_mkostemp(templte, O_CLOEXEC),
257 Perl_my_mkstemp(templte));
1cdb2692
Z		 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,
1604cfb0
MS		 270 Perl_my_mkostemp(templte, flags | O_CLOEXEC),
271 Perl_my_mkostemp(templte, flags));
ae73d7ec
TC		 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,
1604cfb0
MS		 289 pipe2(pipefd, O_CLOEXEC),
290 PerlProc_pipe(pipefd));
f9821aff
Z		 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,
1604cfb0
MS		 305 PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol),
306 PerlSock_socket(domain, type, protocol));
f9821aff
Z		 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) && \
1604cfb0 317 defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC)
f9821aff
Z		 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,
1604cfb0
MS		 325 accept4(listenfd, addr, addrlen, SOCK_CLOEXEC),
326 PerlSock_accept(listenfd, addr, addrlen));
f9821aff
Z		 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) && \
1604cfb0 336 defined(AF_INET) && defined(PF_INET))
f9821aff
Z		 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,
1604cfb0
MS		 344 PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd),
345 PerlSock_socketpair(domain, type, protocol, pairfd));
f9821aff
Z		 346# else
347 DO_PIPEOPEN_THEN_CLOEXEC(pairfd,
1604cfb0 348 PerlSock_socketpair(domain, type, protocol, pairfd));
f9821aff
Z		 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)) {
1604cfb0
MS		 371 if (IoTYPE(io) == IoTYPE_STD) {
372 /* This is a clone of one of STD* handles */
373 }
374 else {
26297fe9
NC		 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 }
1604cfb0 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,
1604cfb0
MS		 417 int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
418 I32 num_svs)
a2b41d5c 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
1604cfb0
MS		 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 */
1604cfb0
MS		 452 STRLEN ix = 0;
453 const int appendtrunc =
454 0
d1da7611 455#ifdef O_APPEND /* Not fully portable. */
1604cfb0 456 |O_APPEND
d1da7611
JH		 457#endif
458#ifdef O_TRUNC /* Not fully portable. */
1604cfb0 459 |O_TRUNC
d1da7611 460#endif
1604cfb0
MS		 461 ;
462 const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc;
463 int ismodifying;
9229bf8d 464 SV *namesv;
3dccc55c 465
1604cfb0 466 /* It's not always
3dccc55c 467
1604cfb0
MS		 468 O_RDONLY 0
469 O_WRONLY 1
470 O_RDWR 2
3dccc55c 471
1604cfb0 472 It might be (in OS/390 and Mac OS Classic it is)
3dccc55c 473
1604cfb0
MS		 474 O_WRONLY 1
475 O_RDONLY 2
476 O_RDWR 3
3dccc55c 477
1604cfb0
MS		 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 }
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)
1604cfb0 491 rawmode |= O_LARGEFILE; /* Transparently largefiley. */
5ff3f7a4
GS		 492#endif
493
06c7082d 494 IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
ee518936 495
1604cfb0
MS		 496 namesv = newSVpvn_flags(oname, len, SVs_TEMP);
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 {
1604cfb0
MS		 522 /* Regular (non-sys) open */
523 char *name;
524 STRLEN olen = len;
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
1604cfb0
MS		 539 type = savepvn(oname, len);
540 tend = type+len;
541 SAVEFREEPV(type);
eb649f83
AMS		 542
543 /* Lose leading and trailing white space */
1604cfb0
MS		 544 while (isSPACE(*type))
545 type++;
eb649f83 546 while (tend > type && isSPACE(tend[-1]))
1604cfb0 547 *--tend = '\0';
eb649f83 548
1604cfb0 549 if (num_svs) {
41188aa0
TC		 550 const char *p;
551 STRLEN nlen = 0;
1604cfb0 552 /* New style explicit name, type is just mode and layer info */
9a869a14 553#ifdef USE_STDIO
1604cfb0
MS		 554 if (SvROK(*svp) && !memchr(oname, '&', len)) {
555 if (ckWARN(WARN_IO))
556 Perl_warner(aTHX_ packWARN(WARN_IO),
557 "Can't open a reference");
558 SETERRNO(EINVAL, LIB_INVARG);
a6fc70e5 559 fp = NULL;
1604cfb0
MS		 560 goto say_false;
561 }
9a869a14 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
1604cfb0 570 name = p ? savepvn(p, nlen) : savepvs("");
41188aa0 571
1604cfb0
MS		 572 SAVEFREEPV(name);
573 }
574 else {
575 name = type;
576 len = tend-type;
577 }
578 IoTYPE(io) = *type;
579 if ((*type == IoTYPE_RDWR) && /* scary */
01a8ea99 580 (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) &&
1604cfb0
MS		 581 ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) {
582 TAINT_PROPER("open");
583 mode[1] = *type++;
584 writing = 1;
585 }
586
587 if (*type == IoTYPE_PIPE) {
588 if (num_svs) {
589 if (type[1] != IoTYPE_STD) {
590 unknown_open_mode:
591 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
592 }
593 type++;
594 }
595 do {
596 type++;
597 } while (isSPACE(*type));
598 if (!num_svs) {
599 name = type;
600 len = tend-type;
601 }
602 if (*name == '\0') {
603 /* command is missing 19990114 */
604 if (ckWARN(WARN_PIPE))
605 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
606 errno = EPIPE;
a6fc70e5 607 fp = NULL;
1604cfb0
MS		 608 goto say_false;
609 }
610 if (!(*name == '-' && name[1] == '\0') || num_svs)
611 TAINT_ENV();
612 TAINT_PROPER("piped open");
613 if (!num_svs && name[len-1] == '|') {
614 name[--len] = '\0' ;
615 if (ckWARN(WARN_PIPE))
616 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe");
617 }
618 mode[0] = 'w';
619 writing = 1;
0c19750d 620 if (out_raw)
1604cfb0 621 mode[1] = 'b';
0c19750d 622 else if (out_crlf)
1604cfb0
MS		 623 mode[1] = 't';
624 if (num_svs > 1) {
625 fp = PerlProc_popen_list(mode, num_svs, svp);
626 }
627 else {
628 fp = PerlProc_popen(name,mode);
629 }
630 if (num_svs) {
631 if (*type) {
632 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
a6fc70e5 633 fp = NULL;
1604cfb0
MS		 634 goto say_false;
635 }
636 }
637 }
638 } /* IoTYPE_PIPE */
639 else if (*type == IoTYPE_WRONLY) {
640 TAINT_PROPER("open");
641 type++;
642 if (*type == IoTYPE_WRONLY) {
643 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
644 mode[0] = IoTYPE(io) = IoTYPE_APPEND;
645 type++;
646 }
647 else {
648 mode[0] = 'w';
649 }
650 writing = 1;
c07a80fd 651
0c19750d 652 if (out_raw)
1604cfb0 653 mode[1] = 'b';
0c19750d 654 else if (out_crlf)
1604cfb0
MS		 655 mode[1] = 't';
656 if (*type == '&') {
657 duplicity:
658 dodup = PERLIO_DUP_FD;
659 type++;
660 if (*type == '=') {
661 dodup = 0;
662 type++;
663 }
664 if (!num_svs && !*type && supplied_fp) {
665 /* "<+&" etc. is used by typemaps */
666 fp = supplied_fp;
667 }
668 else {
669 PerlIO *that_fp = NULL;
b4464d55 670 int wanted_fd;
22ff3130 671 UV uv;
1604cfb0
MS		 672 if (num_svs > 1) {
673 /* diag_listed_as: More than one argument to '%s' open */
674 Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
675 }
676 while (isSPACE(*type))
677 type++;
678 if (num_svs && (
679 SvIOK(*svp)
680 || (SvPOKp(*svp) && looks_like_number(*svp))
681 )) {
b4464d55 682 wanted_fd = SvUV(*svp);
1604cfb0
MS		 683 num_svs = 0;
684 }
685 else if (isDIGIT(*type)
22ff3130
HS		 686 && grok_atoUV(type, &uv, NULL)
687 && uv <= INT_MAX
688 ) {
689 wanted_fd = (int)uv;
1604cfb0
MS		 690 }
691 else {
692 const IO* thatio;
693 if (num_svs) {
694 thatio = sv_2io(*svp);
695 }
696 else {
697 GV * const thatgv = gv_fetchpvn_flags(type, tend - type,
698 0, SVt_PVIO);
699 thatio = GvIO(thatgv);
700 }
701 if (!thatio) {
6e21c824 702#ifdef EINVAL
1604cfb0 703 SETERRNO(EINVAL,SS_IVCHAN);
6e21c824 704#endif
a6fc70e5 705 fp = NULL;
1604cfb0
MS		 706 goto say_false;
707 }
708 if ((that_fp = IoIFP(thatio))) {
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 */
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 */
718 PerlIO_flush(that_fp);
719 wanted_fd = PerlIO_fileno(that_fp);
720 /* When dup()ing STDIN, STDOUT or STDERR
721 * explicitly set appropriate access mode */
722 if (that_fp == PerlIO_stdout()
723 || that_fp == PerlIO_stderr())
724 IoTYPE(io) = IoTYPE_WRONLY;
725 else if (that_fp == PerlIO_stdin())
0759c907 726 IoTYPE(io) = IoTYPE_RDONLY;
1604cfb0
MS		 727 /* When dup()ing a socket, say result is
728 * one as well */
729 else if (IoTYPE(thatio) == IoTYPE_SOCKET)
730 IoTYPE(io) = IoTYPE_SOCKET;
731 }
0c9375a5
TC		 732 else {
733 SETERRNO(EBADF, RMS_IFI);
734 fp = NULL;
735 goto say_false;
736 }
1604cfb0
MS		 737 }
738 if (!num_svs)
739 type = NULL;
740 if (that_fp) {
741 fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
742 }
743 else {
744 if (dodup)
884fc2d3 745 wanted_fd = PerlLIO_dup_cloexec(wanted_fd);
1604cfb0
MS		 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);
1604cfb0
MS		 751 }
752 }
753 }
754 } /* & */
755 else {
756 while (isSPACE(*type))
757 type++;
758 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
759 type++;
760 fp = PerlIO_stdout();
761 IoTYPE(io) = IoTYPE_STD;
762 if (num_svs > 1) {
763 /* diag_listed_as: More than one argument to '%s' open */
764 Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
765 }
766 }
767 else {
768 if (num_svs) {
9229bf8d
NC		 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);
1604cfb0 773 type = NULL;
9229bf8d 774 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
1604cfb0
MS		 775 }
776 }
777 } /* !& */
778 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
779 goto unknown_open_mode;
780 } /* IoTYPE_WRONLY */
781 else if (*type == IoTYPE_RDONLY) {
782 do {
783 type++;
784 } while (isSPACE(*type));
785 mode[0] = 'r';
0c19750d 786 if (in_raw)
1604cfb0 787 mode[1] = 'b';
0c19750d 788 else if (in_crlf)
1604cfb0
MS		 789 mode[1] = 't';
790 if (*type == '&') {
791 goto duplicity;
792 }
793 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
794 type++;
795 fp = PerlIO_stdin();
796 IoTYPE(io) = IoTYPE_STD;
797 if (num_svs > 1) {
798 /* diag_listed_as: More than one argument to '%s' open */
799 Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
800 }
801 }
802 else {
803 if (num_svs) {
9229bf8d
NC		 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);
1604cfb0 808 type = NULL;
9229bf8d 809 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
1604cfb0
MS		 810 }
811 }
812 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
813 goto unknown_open_mode;
814 } /* IoTYPE_RDONLY */
815 else if ((num_svs && /* '-|...' or '...|' */
816 type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
817 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
818 if (num_svs) {
819 type += 2; /* skip over '-|' */
820 }
821 else {
822 *--tend = '\0';
823 while (tend > type && isSPACE(tend[-1]))
824 *--tend = '\0';
825 for (; isSPACE(*type); type++)
826 ;
827 name = type;
828 len = tend-type;
829 }
830 if (*name == '\0') {
831 /* command is missing 19990114 */
832 if (ckWARN(WARN_PIPE))
833 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
834 errno = EPIPE;
a6fc70e5 835 fp = NULL;
1604cfb0
MS		 836 goto say_false;
837 }
838 if (!(*name == '-' && name[1] == '\0') || num_svs)
839 TAINT_ENV();
840 TAINT_PROPER("piped open");
841 mode[0] = 'r';
0c19750d 842
0c19750d 843 if (in_raw)
1604cfb0 844 mode[1] = 'b';
0c19750d 845 else if (in_crlf)
1604cfb0
MS		 846 mode[1] = 't';
847
848 if (num_svs > 1) {
849 fp = PerlProc_popen_list(mode,num_svs,svp);
850 }
851 else {
852 fp = PerlProc_popen(name,mode);
853 }
854 IoTYPE(io) = IoTYPE_PIPE;
855 if (num_svs) {
856 while (isSPACE(*type))
857 type++;
858 if (*type) {
859 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
a6fc70e5 860 fp = NULL;
1604cfb0
MS		 861 goto say_false;
862 }
863 }
864 }
865 }
866 else { /* layer(Args) */
867 if (num_svs)
868 goto unknown_open_mode;
869 name = type;
870 IoTYPE(io) = IoTYPE_RDONLY;
871 for (; isSPACE(*name); name++)
872 ;
873 mode[0] = 'r';
0c19750d 874
0c19750d 875 if (in_raw)
1604cfb0 876 mode[1] = 'b';
0c19750d 877 else if (in_crlf)
1604cfb0
MS		 878 mode[1] = 't';
879
880 if (*name == '-' && name[1] == '\0') {
881 fp = PerlIO_stdin();
882 IoTYPE(io) = IoTYPE_STD;
883 }
884 else {
885 if (num_svs) {
9229bf8d
NC		 886 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
887 }
888 else {
1604cfb0
MS		 889 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
890 type = NULL;
9229bf8d 891 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
1604cfb0
MS		 892 }
893 }
894 }
a687059c 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) {
1604cfb0
MS		 917 if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE)
918 && should_warn_nl(oname)
919
920 )
5d37acd6 921 {
7347ee54 922 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
1604cfb0 923 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
7347ee54 924 GCC_DIAG_RESTORE_STMT;
5d37acd6 925 }
1604cfb0 926 goto say_false;
bee1dbe2 927 }
a00b5bd3
NIS		 928
929 if (ckWARN(WARN_IO)) {
1604cfb0
MS		 930 if ((IoTYPE(io) == IoTYPE_RDONLY) &&
931 (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
932 Perl_warner(aTHX_ packWARN(WARN_IO),
933 "Filehandle STD%s reopened as %" HEKf
934 " only for input",
935 ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
936 HEKfARG(GvENAME_HEK(gv)));
937 }
938 else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
939 Perl_warner(aTHX_ packWARN(WARN_IO),
940 "Filehandle STDIN reopened as %" HEKf " only for output",
941 HEKfARG(GvENAME_HEK(gv))
942 );
943 }
a00b5bd3
NIS		 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) {
1604cfb0
MS		 952 if (PerlLIO_fstat(fd,&statbuf) < 0) {
953 /* If PerlIO claims to have fd we had better be able to fstat() it. */
954 (void) PerlIO_close(fp);
955 goto say_false;
956 }
7114a2d2 957#ifndef PERL_MICRO
1604cfb0
MS		 958 if (S_ISSOCK(statbuf.st_mode))
959 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
99b89507 960#ifdef HAS_SOCKET
1604cfb0
MS		 961 else if (
962 !(statbuf.st_mode & S_IFMT)
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 */
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 */
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 */
1604cfb0
MS		 986 if (saveofp) {
987 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
988 if (saveofp != saveifp) { /* was a socket? */
989 PerlIO_close(saveofp);
990 }
991 }
992 if (savefd != fd) {
993 /* Still a small can-of-worms here if (say) PerlIO::scalar
994 is assigned to (say) STDOUT - for now let dup2() fail
995 and provide the error
996 */
997 if (fd < 0) {
375ed12a 998 SETERRNO(EBADF,RMS_IFI);
1604cfb0 999 goto say_false;
375ed12a 1000 } else if (PerlLIO_dup2(fd, savefd) < 0) {
1604cfb0
MS		 1001 (void)PerlIO_close(fp);
1002 goto say_false;
1003 }
d082dcd6 1004#ifdef VMS
1604cfb0 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 }
1604cfb0 1013 }
d082dcd6 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
1604cfb0 1033 if (was_fdopen) {
e212fc47
AMS		 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);
1604cfb0 1046 }
e212fc47 1047 else
1604cfb0
MS		 1048 PerlIO_close(fp);
1049 }
1050 fp = saveifp;
1051 PerlIO_clearerr(fp);
1052 fd = PerlIO_fileno(fp);
6e21c824 1053 }
8990e307 1054 IoIFP(io) = fp;
b931b1d9 1055
684bef36 1056 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 1057 if (writing) {
1604cfb0
MS		 1058 if (IoTYPE(io) == IoTYPE_SOCKET
1059 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) {
1060 char *s = mode;
1061 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
1062 s++;
1063 *s = 'w';
1064 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
1065 PerlIO_close(fp);
1066 goto say_false;
1067 }
1068 }
1069 else
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)
1604cfb0 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)) {
1604cfb0
MS		 1296 IoFLAGS(io) &= ~IOf_START;
1297 if (PL_inplace) {
1298 assert(PL_defoutgv);
1299 Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
1300 SvREFCNT_inc_simple_NN(PL_defoutgv));
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))
1604cfb0 1314 return NULL;
698ac381 1315 while (av_count(GvAV(gv)) > 0) {
1604cfb0 1316 STRLEN oldlen;
1fa0529f 1317 SV *const sv = av_shift(GvAV(gv));
1604cfb0
MS		 1318 SAVEFREESV(sv);
1319 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
1320 sv_setsv(GvSVn(gv),sv);
1321 SvSETMAGIC(GvSV(gv));
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
1604cfb0
MS		 1351 TAINT_PROPER("inplace open");
1352 if (oldlen == 1 && *PL_oldname == '-') {
1353 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
1354 SVt_PVIO));
1355 return IoIFP(GvIOp(gv));
1356 }
99b89507 1357#ifndef FLEXFILENAMES
1604cfb0
MS		 1358 filedev = statbuf.st_dev;
1359 fileino = statbuf.st_ino;
1360#endif
1361 PL_filemode = statbuf.st_mode;
1362 fileuid = statbuf.st_uid;
1363 filegid = statbuf.st_gid;
1364 if (!S_ISREG(PL_filemode)) {
1365 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1366 "Can't do inplace edit: %s is not a regular file",
1367 PL_oldname );
1368 do_close(gv,FALSE);
1369 continue;
1370 }
e0d4aead 1371 magic_av = newAV();
1604cfb0
MS		 1372 if (*PL_inplace && strNE(PL_inplace, "*")) {
1373 const char *star = strchr(PL_inplace, '*');
1374 if (star) {
1375 const char *begin = PL_inplace;
8062ff11 1376 SvPVCLEAR(sv);
1604cfb0
MS		 1377 do {
1378 sv_catpvn(sv, begin, star - begin);
1379 sv_catpvn(sv, PL_oldname, oldlen);
1380 begin = ++star;
1381 } while ((star = strchr(begin, '*')));
1382 if (*begin)
1383 sv_catpv(sv,begin);
1384 }
1385 else {
1386 sv_catpv(sv,PL_inplace);
1387 }
c623bd54 1388#ifndef FLEXFILENAMES
1604cfb0
MS		 1389 if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0
1390 && statbuf.st_dev == filedev
1391 && statbuf.st_ino == fileino)
39e571d4 1392#ifdef DJGPP
1604cfb0 1393 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
39e571d4 1394#endif
f248d071 1395 )
1604cfb0
MS		 1396 {
1397 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1398 "Can't do inplace edit: %"
147e3846 1399 SVf " would not be unique",
1604cfb0 1400 SVfARG(sv));
e0d4aead 1401 goto cleanup_argv;
1604cfb0 1402 }
ff8e2863 1403#endif
e0d4aead 1404 av_store(magic_av, ARGVMG_BACKUP_NAME, newSVsv(sv));
1604cfb0 1405 }
a687059c 1406
1604cfb0
MS		 1407 sv_setpvn(sv,PL_oldname,oldlen);
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",
1604cfb0 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;
1604cfb0 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
1604cfb0 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);
1604cfb0 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 }
1604cfb0 1456 }
d8015975 1457 return IoIFP(GvIOp(gv));
1604cfb0
MS		 1458 }
1459 } /* successful do_open_raw(), PL_inplace non-NULL */
d8015975
NC		 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 }
1604cfb0 1474 }
a687059c 1475 }
18708f5a 1476 if (io && (IoFLAGS(io) & IOf_ARGV))
1604cfb0 1477 IoFLAGS(io) |= IOf_START;
3280af22 1478 if (PL_inplace) {
1604cfb0
MS		 1479 if (io && (IoFLAGS(io) & IOf_ARGV)
1480 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
1481 {
1482 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
1483 setdefout(oldout);
1484 SvREFCNT_dec_NN(oldout);
1485 return NULL;
1486 }
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)
1604cfb0 1690 S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 &&
184f90dc 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)
1604cfb0 1747 gv = PL_argvgv;
404395d2 1748 if (!gv || !isGV_with_GP(gv)) {
1604cfb0
MS		 1749 if (not_implicit)
1750 SETERRNO(EBADF,SS_IVCHAN);
1751 return FALSE;
404395d2
TC		 1752 }
1753 io = GvIO(gv);
1754 if (!io) { /* never opened */
1604cfb0
MS		 1755 if (not_implicit) {
1756 report_evil_fh(gv);
1757 SETERRNO(EBADF,SS_IVCHAN);
1758 }
1759 return FALSE;
404395d2
TC		 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) {
1604cfb0
MS		 1770 IoLINES(io) = 0;
1771 IoPAGE(io) = 0;
1772 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1193dd27 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)) {
1604cfb0 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;
1604cfb0
MS		 1797 status = PerlProc_pclose(fh);
1798 if (not_implicit) {
1799 STATUS_NATIVE_CHILD_SET(status);
1800 retval = (STATUS_UNIX == 0);
1801 }
1802 else {
1803 retval = (status != -1);
1804 }
1805 }
1806 else if (IoTYPE(io) == IoTYPE_STD)
1807 retval = TRUE;
1808 else {
1809 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
1810 const bool prev_err = PerlIO_error(IoOFP(io));
f4725fad 1811#ifdef USE_PERLIO
1604cfb0
MS		 1812 if (prev_err)
1813 PerlIO_restore_errno(IoOFP(io));
1814#endif
1815 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
1816 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
1817 }
1818 else {
1819 const bool prev_err = PerlIO_error(IoIFP(io));
f4725fad 1820#ifdef USE_PERLIO
1604cfb0
MS		 1821 if (prev_err)
1822 PerlIO_restore_errno(IoIFP(io));
1823#endif
1824 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1825 }
1826 }
1827 IoOFP(io) = IoIFP(io) = NULL;
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 %"
1833 HEKf " properly: %" SVf,
1834 HEKfARG(GvNAME_HEK(gv)),
ac892e4a 1835 SVfARG(get_sv("!",GV_ADD)));
1604cfb0
MS		 1836 else
1837 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1838 "Warning: unable to close filehandle "
1839 "properly: %" SVf,
1840 SVfARG(get_sv("!",GV_ADD)));
1841 }
79072805 1842 }
f2b5be74 1843 else if (not_implicit) {
1604cfb0 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)
1604cfb0 1858 return TRUE;
7716c5c5 1859 else if (IoTYPE(io) == IoTYPE_WRONLY)
1604cfb0 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) */
1604cfb0
MS		 1864 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
1865 return FALSE; /* this is the most usual case */
1866 }
1867
1868 {
1869 /* getc and ungetc can stomp on errno */
1870 dSAVE_ERRNO;
1871 const int ch = PerlIO_getc(IoIFP(io));
1872 if (ch != EOF) {
1873 (void)PerlIO_ungetc(IoIFP(io),ch);
1874 RESTORE_ERRNO;
1875 return FALSE;
1876 }
1877 RESTORE_ERRNO;
1878 }
fab3f3a7 1879
760ac839 1880 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
1604cfb0
MS		 1881 if (PerlIO_get_cnt(IoIFP(io)) < -1)
1882 PerlIO_set_cnt(IoIFP(io),-1);
1883 }
1884 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
1885 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */
1886 return TRUE;
1887 }
1888 else
1889 return TRUE; /* normal fp, definitely end of file */
a687059c
LW		 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))) {
1604cfb0 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))) {
1604cfb0 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) {
1604cfb0
MS		 1952 while (*s) {
1953 if (*s == ':') {
1954 switch (s[1]) {
1955 case 'r':
1956 if (s[2] == 'a' && s[3] == 'w'
1957 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1958 {
1959 mode = O_BINARY;
1960 s += 4;
1961 len -= 4;
1962 break;
1963 }
1964 /* FALLTHROUGH */
1965 case 'c':
1966 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
1967 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1968 {
1969 mode = O_TEXT;
1970 s += 5;
1971 len -= 5;
1972 break;
1973 }
1974 /* FALLTHROUGH */
1975 default:
1976 goto fail_discipline;
1977 }
1978 }
1979 else if (isSPACE(*s)) {
1980 ++s;
1981 --len;
1982 }
1983 else {
1984 const char *end;
7b52d656 1985 fail_discipline:
1604cfb0
MS		 1986 end = (char *) memchr(s+1, ':', len);
1987 if (!end)
1988 end = s+len;
60382766 1989#ifndef PERLIO_LAYERS
1604cfb0 1990 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
60382766 1991#else
1604cfb0
MS		 1992 len -= end-s;
1993 s = end;
60382766 1994#endif
1604cfb0
MS		 1995 }
1996 }
16fe6d59
GS		 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 2005#ifdef F_FREESP
1604cfb0 2006 /* code courtesy of William Kucharski */
58e24eff
SH		 2007#define HAS_CHSIZE
2008
c623ac67 2009 Stat_t filebuf;
6eb13c3b 2010
3028581b 2011 if (PerlLIO_fstat(fd, &filebuf) < 0)
1604cfb0 2012 return -1;
6eb13c3b
LW		 2013
2014 if (filebuf.st_size < length) {
2015
1604cfb0 2016 /* extend file length */
6eb13c3b 2017
1604cfb0
MS		 2018 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
2019 return -1;
6eb13c3b 2020
1604cfb0 2021 /* write a "0" byte */
6eb13c3b 2022
1604cfb0
MS		 2023 if ((PerlLIO_write(fd, "", 1)) != 1)
2024 return -1;
6eb13c3b
LW		 2025 }
2026 else {
1604cfb0
MS		 2027 /* truncate length */
2028 struct flock fl;
2029 fl.l_whence = 0;
2030 fl.l_len = 0;
2031 fl.l_start = length;
2032 fl.l_type = F_WRLCK; /* write lock on file space */
2033
2034 /*
2035 * This relies on the UNDOCUMENTED F_FREESP argument to
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 */
6eb13c3b 2041
1604cfb0
MS		 2042 if (fcntl(fd, F_FREESP, &fl) < 0)
2043 return -1;
6eb13c3b
LW		 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)
1604cfb0 2061 return TRUE;
e9950d3b 2062 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
1604cfb0
MS		 2063 assert(!SvGMAGICAL(sv));
2064 if (SvIsUV(sv))
2065 PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv));
2066 else
2067 PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv));
2068 return !PerlIO_error(fp);
e9950d3b
NC		 2069 }
2070 else {
1604cfb0
MS		 2071 STRLEN len;
2072 /* Do this first to trigger any overloading. */
2073 const char *tmps = SvPV_const(sv, len);
2074 U8 *tmpbuf = NULL;
2075 bool happy = TRUE;
2076
2077 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
2078 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
2079 /* We don't modify the original scalar. */
2080 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
2081 tmps = (char *) tmpbuf;
2082 }
2083 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
2084 (void) check_utf8_print((const U8*) tmps, len);
2085 }
2086 } /* else stream isn't utf8 */
2087 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
2088 convert to bytes */
2089 STRLEN tmplen = len;
2090 bool utf8 = TRUE;
2091 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
2092 if (!utf8) {
2093
2094 /* Here, succeeded in downgrading from utf8. Set up to below
2095 * output the converted value */
2096 tmpbuf = result;
2097 tmps = (char *) tmpbuf;
2098 len = tmplen;
2099 }
2100 else { /* Non-utf8 output stream, but string only representable in
2101 utf8 */
2102 assert((char *)result == tmps);
2103 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2104 "Wide character in %s",
2105 PL_op ? OP_DESC(PL_op) : "print"
2106 );
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 */
2110 }
2111 }
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) {
1604cfb0 2133 gv = cGVOP_gv;
748a9306 2134 do_fstat:
97c8f3e6 2135 if (gv == PL_defgv) {
1604cfb0
MS		 2136 if (PL_laststatval < 0)
2137 SETERRNO(EBADF,RMS_IFI);
5228a96c 2138 return PL_laststatval;
1604cfb0
MS		 2139 }
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) {
1604cfb0 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. */
1604cfb0 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 }
1604cfb0
MS		 2159 PL_laststatval = -1;
2160 report_evil_fh(gv);
2161 SETERRNO(EBADF,RMS_IFI);
2162 return -1;
a687059c 2163 }
d2c4d2d1 2164 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1604cfb0
MS		 2165 == OPpFT_STACKED)
2166 return PL_laststatval;
d2c4d2d1 2167 else {
1604cfb0
MS		 2168 SV* const sv = TOPs;
2169 const char *s, *d;
2170 STRLEN len;
2171 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
2172 goto do_fstat;
2173 }
ad02613c 2174 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2175 io = MUTABLE_IO(SvRV(sv));
1604cfb0 2176 gv = NULL;
ad02613c
SP		 2177 goto do_fstat_have_io;
2178 }
748a9306 2179
1604cfb0
MS		 2180 s = SvPV_flags_const(sv, len, flags);
2181 PL_statgv = NULL;
2182 sv_setpvn(PL_statname, s, len);
2183 d = SvPVX_const(PL_statname); /* s now NUL-terminated */
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 }
1604cfb0 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 */
1604cfb0 2193 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
7347ee54 2194 GCC_DIAG_RESTORE_STMT;
5d37acd6 2195 }
1604cfb0 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) {
1604cfb0
MS		 2211 if (cGVOP_gv == PL_defgv) {
2212 if (PL_laststype != OP_LSTAT)
2213 Perl_croak(aTHX_ "%s", no_prev_lstat);
2214 if (PL_laststatval < 0)
2215 SETERRNO(EBADF,RMS_IFI);
2216 return PL_laststatval;
2217 }
2218 PL_laststatval = -1;
2219 if (ckWARN(WARN_IO)) {
2220 /* diag_listed_as: Use of -l on filehandle%s */
2221 Perl_warner(aTHX_ packWARN(WARN_IO),
2222 "Use of -l on filehandle %" HEKf,
2223 HEKfARG(GvENAME_HEK(cGVOP_gv)));
2224 }
2225 SETERRNO(EBADF,RMS_IFI);
2226 return -1;
fe14fcc3 2227 }
8db8f6b6 2228 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1604cfb0 2229 == OPpFT_STACKED) {
1f26655e 2230 if (PL_laststype != OP_LSTAT)
1604cfb0 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)
1604cfb0 2244 /* diag_listed_as: Use of -l on filehandle%s */
5840701a
FC		 2245 Perl_warner(aTHX_ packWARN(WARN_IO),
2246 "Use of -l on filehandle");
2247 else
1604cfb0 2248 /* diag_listed_as: Use of -l on filehandle%s */
5840701a 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)));
1604cfb0 2282 PerlLIO_close(fd);
a0f2c8ec
JD		 2283 }
2284}
2285
738ab09f 2286bool
5aaab254 2287Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
1604cfb0 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 {
1604cfb0
MS		 2297 const char **argv, **a;
2298 const char *tmps = NULL;
2299 Newx(argv, sp - mark + 1, const char*);
2300 SAVEFREEPV(argv);
2301 a = argv;
2302
2303 while (++mark <= sp) {
2304 if (*mark) {
2305 char *arg = savepv(SvPV_nolen_const(*mark));
2306 SAVEFREEPV(arg);
2307 *a++ = arg;
2308 } else
2309 *a++ = "";
2310 }
2311 *a = NULL;
2312 if (really) {
2313 tmps = savepv(SvPV_nolen_const(really));
2314 SAVEFREEPV(tmps);
2315 }
282fc0b3 2316 if ((!really && argv[0] && *argv[0] != '/') ||
1604cfb0
MS		 2317 (really && *tmps != '/')) /* will execvp use PATH? */
2318 TAINT_ENV(); /* testing IFS here is overkill, probably */
2319 PERL_FPU_PRE_EXEC
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 }
1604cfb0 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 2355 while (*cmd && isSPACE(*cmd))
1604cfb0 2356 cmd++;
748a9306 2357
a687059c
LW		 2358 /* save an extra exec if possible */
2359
bf38876a 2360#ifdef CSH
d05c1ba0 2361 {
0c19750d 2362 char flags[PERL_FLAGS_MAX];
1604cfb0
MS		 2363 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
2364 strBEGINs(cmd+PL_cshlen," -c")) {
28f0d0ec 2365 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
1604cfb0
MS		 2366 s = cmd+PL_cshlen+3;
2367 if (*s == 'f') {
2368 s++;
28f0d0ec 2369 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
1604cfb0
MS		 2370 }
2371 if (*s == ' ')
2372 s++;
2373 if (*s++ == '\'') {
2374 char * const ncmd = s;
2375
2376 while (*s)
2377 s++;
2378 if (s[-1] == '\n')
2379 *--s = '\0';
2380 if (s[-1] == '\'') {
2381 *--s = '\0';
2382 PERL_FPU_PRE_EXEC
2383 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
2384 PERL_FPU_POST_EXEC
2385 *s = '\'';
2386 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
2387 goto leave;
2388 }
2389 }
2390 }
a687059c 2391 }
bf38876a 2392#endif /* CSH */
a687059c
LW		 2393
2394 /* see if there are shell metacharacters in it */
2395
748a9306 2396 if (*cmd == '.' && isSPACE(cmd[1]))
1604cfb0 2397 goto doshell;
748a9306 2398
c8b388b0 2399 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
1604cfb0 2400 goto doshell;
748a9306 2401
294b3b39 2402 s = cmd;
0eb30aeb 2403 while (isWORDCHAR(*s))
1604cfb0 2404 s++; /* catch VAR=val gizmo */
63f2c1e1 2405 if (*s == '=')
1604cfb0 2406 goto doshell;
748a9306 2407
a687059c 2408 for (s = cmd; *s; s++) {
1604cfb0
MS		 2409 if (*s != ' ' && !isALPHA(*s) &&
2410 memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) {
2411 if (*s == '\n' && !s[1]) {
2412 *s = '\0';
2413 break;
2414 }
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 2421
1604cfb0
MS		 2422 while (*t && isSPACE(*t))
2423 ++t;
2424 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
2425 s[-2] = '\0';
2426 break;
2427 }
2428 }
2429 doshell:
2430 PERL_FPU_PRE_EXEC
738ab09f 2431 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
1604cfb0
MS		 2432 PERL_FPU_POST_EXEC
2433 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
2434 goto leave;
2435 }
a687059c 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;) {
1604cfb0
MS		 2444 while (isSPACE(*s))
2445 s++;
2446 if (*s)
2447 *(a++) = s;
2448 while (*s && !isSPACE(*s))
2449 s++;
2450 if (*s)
2451 *s++ = '\0';
a687059c 2452 }
6136c704 2453 *a = NULL;
282fc0b3 2454 if (argv[0]) {
1604cfb0 2455 PERL_FPU_PRE_EXEC
282fc0b3 2456 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
1604cfb0
MS		 2457 PERL_FPU_POST_EXEC
2458 if (errno == ENOEXEC) /* for system V NIH syndrome */
2459 goto doshell;
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)
1604cfb0 2489 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2490#endif
2491#ifndef HAS_CHOWN
2492 if (type == OP_CHOWN)
1604cfb0 2493 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2494#endif
2495
2496
20408e3c 2497#define APPLY_TAINT_PROPER() \
3280af22 2498 STMT_START { \
1604cfb0 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) {
1604cfb0
MS		 2504 while (++mark <= sp) {
2505 if (SvTAINTED(*mark)) {
2506 TAINT;
2507 break;
2508 }
2509 }
2510 mark = oldmark;
463ee0b2 2511 }
a687059c 2512 switch (type) {
79072805 2513 case OP_CHMOD:
1604cfb0
MS		 2514 APPLY_TAINT_PROPER();
2515 if (++mark <= sp) {
2516 val = SvIV(*mark);
2517 APPLY_TAINT_PROPER();
2518 tot = sp - mark;
2519 while (++mark <= sp) {
c4aca7d0 2520 GV* gv;
2ea1cce7 2521 if ((gv = MAYBE_DEREF_GV(*mark))) {
1604cfb0 2522 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
c4aca7d0 2523#ifdef HAS_FCHMOD
375ed12a 2524 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
1604cfb0 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
1604cfb0 2532 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0 2533#endif
1604cfb0
MS		 2534 }
2535 else {
8334cae6 2536 SETERRNO(EBADF,RMS_IFI);
1604cfb0
MS		 2537 tot--;
2538 }
2539 }
2540 else {
2541 const char *name = SvPV_nomg_const(*mark, len);
2542 APPLY_TAINT_PROPER();
41188aa0 2543 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC		 2544 PerlLIO_chmod(name, val)) {
2545 tot--;
2546 }
1604cfb0
MS		 2547 }
2548 }
2549 }
2550 break;
fe14fcc3 2551#ifdef HAS_CHOWN
79072805 2552 case OP_CHOWN:
1604cfb0
MS		 2553 APPLY_TAINT_PROPER();
2554 if (sp - mark > 2) {
eb578fdb 2555 I32 val2;
1604cfb0
MS		 2556 val = SvIVx(*++mark);
2557 val2 = SvIVx(*++mark);
2558 APPLY_TAINT_PROPER();
2559 tot = sp - mark;
2560 while (++mark <= sp) {
c4aca7d0 2561 GV* gv;
1604cfb0
MS		 2562 if ((gv = MAYBE_DEREF_GV(*mark))) {
2563 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
c4aca7d0 2564#ifdef HAS_FCHOWN
375ed12a 2565 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
1604cfb0 2566 APPLY_TAINT_PROPER();
375ed12a 2567 if (fd < 0) {
dd1dbff0 2568 SETERRNO(EBADF,RMS_IFI);
1604cfb0 2569 tot--;
375ed12a 2570 } else if (fchown(fd, val, val2))
1604cfb0 2571 tot--;
c4aca7d0 2572#else
1604cfb0 2573 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0 2574#endif
1604cfb0
MS		 2575 }
2576 else {
8334cae6 2577 SETERRNO(EBADF,RMS_IFI);
1604cfb0
MS		 2578 tot--;
2579 }
2580 }
2581 else {
2582 const char *name = SvPV_nomg_const(*mark, len);
2583 APPLY_TAINT_PROPER();
41188aa0 2584 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 2585 PerlLIO_chown(name, val, val2)) {
1604cfb0 2586 tot--;
c8028aa6 2587 }
1604cfb0
MS		 2588 }
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:
1604cfb0
MS		 2601 APPLY_TAINT_PROPER();
2602 if (mark == sp)
2603 break;
2604 s = SvPVx_const(*++mark, len);
2605 if (*s == '-' && isALPHA(s[1]))
2606 {
2607 s++;
2608 len--;
885b4b39 2609 killgp = TRUE;
1604cfb0
MS		 2610 }
2611 if (isALPHA(*s)) {
2612 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
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));
1604cfb0
MS		 2619 }
2620 else
2621 {
2622 val = SvIV(*mark);
2623 if (val < 0)
2624 {
2625 killgp = TRUE;
c2fd40cb 2626 val = -val;
1604cfb0
MS		 2627 }
2628 }
2629 APPLY_TAINT_PROPER();
2630 tot = sp - mark;
2631
2632 while (++mark <= sp) {
2633 Pid_t proc;
2634 SvGETMAGIC(*mark);
2635 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
2636 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
2637 proc = SvIV_nomg(*mark);
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
1604cfb0
MS		 2647 tot--;
2648 }
2649 PERL_ASYNC_CHECK();
2650 break;
b1248f16 2651#endif
79072805 2652 case OP_UNLINK:
1604cfb0
MS		 2653 APPLY_TAINT_PROPER();
2654 tot = sp - mark;
2655 while (++mark <= sp) {
2656 s = SvPV_const(*mark, len);
2657 APPLY_TAINT_PROPER();
2658 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC		 2659 tot--;
2660 }
1604cfb0
MS		 2661 else if (PL_unsafe) {
2662 if (UNLINK(s))
2663 {
2664 tot--;
2665 }
5cdd1fc2 2666#if defined(__amigaos4__) && defined(NEWLIB)
1604cfb0
MS		 2667 else
2668 {
5cdd1fc2
AB		 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 }
1604cfb0
MS		 2676 }
2677#endif
2678 }
2679 else { /* don't let root wipe out directories without -U */
2680 Stat_t statbuf;
2681 if (PerlLIO_lstat(s, &statbuf) < 0)
2682 tot--;
2683 else if (S_ISDIR(statbuf.st_mode)) {
2684 SETERRNO(EISDIR, SS_NOPRIV);
2685 tot--;
2686 }
2687 else {
2688 if (UNLINK(s))
2689 {
2690 tot--;
2691 }
5cdd1fc2 2692#if defined(__amigaos4__) && defined(NEWLIB)
1604cfb0
MS		 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
2704 }
2705 }
2706 }
2707 break;
e96b369d 2708#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 2709 case OP_UTIME:
1604cfb0
MS		 2710 APPLY_TAINT_PROPER();
2711 if (sp - mark > 2) {
e96b369d 2712#if defined(HAS_FUTIMES)
1604cfb0
MS		 2713 struct timeval utbuf[2];
2714 void *utbufp = utbuf;
e96b369d 2715#elif defined(I_UTIME) || defined(VMS)
1604cfb0
MS		 2716 struct utimbuf utbuf;
2717 struct utimbuf *utbufp = &utbuf;
663a0e37 2718#else
1604cfb0
MS		 2719 struct {
2720 Time_t actime;
2721 Time_t modtime;
2722 } utbuf;
2723 void *utbufp = &utbuf;
663a0e37 2724#endif
a687059c 2725
1604cfb0
MS		 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
1604cfb0
MS		 2738 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
2739 utbuf[0].tv_usec = 0;
2740 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
2741 utbuf[1].tv_usec = 0;
e96b369d 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 }
1604cfb0
MS		 2750 APPLY_TAINT_PROPER();
2751 tot = sp - mark;
2752 while (++mark <= sp) {
e96b369d 2753 GV* gv;
64617da9 2754 if ((gv = MAYBE_DEREF_GV(*mark))) {
1604cfb0 2755 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
e96b369d 2756#ifdef HAS_FUTIMES
375ed12a 2757 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
1604cfb0 2758 APPLY_TAINT_PROPER();
375ed12a
JH		 2759 if (fd < 0) {
2760 SETERRNO(EBADF,RMS_IFI);
2761 tot--;
1604cfb0
MS		 2762 } else if (futimes(fd, (struct timeval *) utbufp))
2763 tot--;
e96b369d 2764#else
1604cfb0
MS		 2765 Perl_die(aTHX_ PL_no_func, "futimes");
2766#endif
2767 }
2768 else {
2769 tot--;
2770 }
2771 }
2772 else {
2773 const char * const name = SvPV_nomg_const(*mark, len);
2774 APPLY_TAINT_PROPER();
2775 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC		 2776 tot--;
2777 }
2778 else
e96b369d 2779#ifdef HAS_FUTIMES
1604cfb0 2780 if (utimes(name, (struct timeval *)utbufp))
e96b369d 2781#else
1604cfb0 2782 if (PerlLIO_utime(name, utbufp))
e96b369d 2783#endif
1604cfb0
MS		 2784 tot--;
2785 }
e96b369d 2786
1604cfb0
MS		 2787 }
2788 }
2789 else
2790 tot = 0;
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
1604cfb0
MS		 2840 if (mode == S_IXUSR) {
2841 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
2842 return TRUE;
2843 }
2844 else
2845 return TRUE; /* root reads and writes anything */
2846 return FALSE;
a687059c 2847 }
985213f2 2848 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
1604cfb0
MS		 2849 if (statbufp->st_mode & mode)
2850 return TRUE; /* ok as "user" */
a687059c 2851 }
d8eceb89 2852 else if (ingroup(statbufp->st_gid,effective)) {
1604cfb0
MS		 2853 if (statbufp->st_mode & mode >> 3)
2854 return TRUE; /* ok as "group" */
a687059c 2855 }
7f4774ae 2856 else if (statbufp->st_mode & mode >> 6)
1604cfb0 2857 return TRUE; /* ok as "other" */
a687059c 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()))
1604cfb0 2871 return TRUE;
fe14fcc3 2872#ifdef HAS_GETGROUPS
a687059c 2873 {
1604cfb0
MS		 2874 Groups_t *gary = NULL;
2875 I32 anum;
331b57bc 2876 bool rc = FALSE;
a687059c 2877
1604cfb0 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:
1604cfb0 2914 return msgget(key, flags);
e5d73d77 2915#endif
fe14fcc3 2916#ifdef HAS_SEM
79072805 2917 case OP_SEMGET:
1604cfb0 2918 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2919#endif
fe14fcc3 2920#ifdef HAS_SHM
79072805 2921 case OP_SHMGET:
1604cfb0 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 */
1604cfb0 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:
1604cfb0
MS		 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:
1604cfb0
MS		 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
1604cfb0
MS		 2967 if (cmd == IPC_STAT || cmd == IPC_SET)
2968 infosize = sizeof(struct semid_ds);
2969 else if (cmd == GETALL || cmd == SETALL)
2970 {
2971 struct semid_ds semds;
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
1604cfb0
MS		 2978 getinfo = (cmd == GETALL);
2979 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2980 return -1;
2981 infosize = semds.sem_nsems * sizeof(short);
2982 /* "short" is technically wrong but much more portable
2983 than guessing about u_?short(_t)? */
2984 }
39398f3f 2985#else
fe13d51d 2986 /* diag_listed_as: sem%s not implemented */
1604cfb0 2987 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2988#endif
1604cfb0 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 */
1604cfb0 2994 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2995#endif
c2ab57d4
LW		 2996 }
2997
2998 if (infosize)
2999 {
1604cfb0
MS		 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);
1604cfb0
MS		 3007 a = SvGROW(astr, infosize+1);
3008 }
3009 else
3010 {
3011 STRLEN len;
3012 a = SvPVbyte(astr, len);
3013 if (len != infosize)
3014 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
3015 PL_op_desc[optype],
3016 (unsigned long)len,
3017 (long)infosize);
3018 }
c2ab57d4
LW		 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:
1604cfb0
MS		 3040 ret = msgctl(id, cmd, (struct msqid_ds *)a);
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 }
1604cfb0 3058 ret = Semctl(id, n, cmd, unsemds);
39398f3f 3059#else
1604cfb0
MS		 3060 /* diag_listed_as: sem%s not implemented */
3061 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 3062#endif
bd89102f 3063 }
1604cfb0 3064 break;
e5d73d77 3065#endif
fe14fcc3 3066#ifdef HAS_SHM
79072805 3067 case OP_SHMCTL:
1604cfb0
MS		 3068 ret = shmctl(id, cmd, (struct shmid_ds *)a);
3069 break;
e5d73d77 3070#endif
c2ab57d4
LW		 3071 }
3072 if (getinfo && ret >= 0) {
1604cfb0
MS		 3073 SvCUR_set(astr, infosize);
3074 *SvEND(astr) = '\0';
d43c116b 3075 SvPOK_only(astr);
1604cfb0 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)
1604cfb0 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) {
1604cfb0 3143 SvCUR_set(mstr, sizeof(long)+ret);
6987f443 3144 SvPOK_only(mstr);
1604cfb0
MS		 3145 *SvEND(mstr) = '\0';
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 3171 if (opsize < 3 * SHORTSIZE
1604cfb0
MS		 3172 || (opsize % (3 * SHORTSIZE))) {
3173 SETERRNO(EINVAL,LIB_INVARG);
3174 return -1;
c2ab57d4 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 3219 if (shmctl(id, IPC_STAT, &shmds) == -1)
1604cfb0 3220 return -1;
7f39519f 3221 if (mpos < 0 || msize < 0
1604cfb0
MS		 3222 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
3223 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
3224 return -1;
c2ab57d4 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 3232 if (shm == (char *)-1) /* I hate System V IPC, I really do */
1604cfb0 3233 return -1;
79072805 3234 if (optype == OP_SHMREAD) {
1604cfb0
MS		 3235 char *mbuf;
3236 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
3237 SvGETMAGIC(mstr);
3238 SvUPGRADE(mstr, SVt_PV);
3239 if (! SvOK(mstr))
8062ff11 3240 SvPVCLEAR(mstr);
1604cfb0
MS		 3241 SvPOK_only(mstr);
3242 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 3243
1604cfb0
MS		 3244 Copy(shm + mpos, mbuf, msize, char);
3245 SvCUR_set(mstr, msize);
3246 *SvEND(mstr) = '\0';
3247 SvSETMAGIC(mstr);
3248 /* who knows who has been playing with this shared memory? */
3249 SvTAINTED_on(mstr);
c2ab57d4
LW		 3250 }
3251 else {
1604cfb0 3252 STRLEN len;
c2ab57d4 3253
1604cfb0
MS		 3254 const char *mbuf = SvPVbyte(mstr, len);
3255 const I32 n = ((I32)len > msize) ? msize : (I32)len;
3256 Copy(mbuf, shm + mpos, n, char);
3257 if (n < msize)
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.