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