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
(perl #133936) ensure TO is honoured for UDP $sock->send()
[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) {
35608a16
TC		 1782 PerlIO *fh = IoIFP(io);
1783 int status;
1784
1785 /* my_pclose() can propagate signals which might bypass any code
1786 after the call here if the signal handler throws an exception.
1787 This would leave the handle in the IO object and try to close it again
1788 when the SV is destroyed on unwind or global destruction.
1789 So NULL it early.
1790 */
1791 IoOFP(io) = IoIFP(io) = NULL;
1792 status = PerlProc_pclose(fh);
f2b5be74 1793 if (not_implicit) {
37038d91 1794 STATUS_NATIVE_CHILD_SET(status);
e5218da5 1795 retval = (STATUS_UNIX == 0);
f2b5be74
GS		 1796 }
1797 else {
1798 retval = (status != -1);
1799 }
a687059c 1800 }
50952442 1801 else if (IoTYPE(io) == IoTYPE_STD)
a687059c
LW		 1802 retval = TRUE;
1803 else {
8990e307 1804 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
0bcc34c2 1805 const bool prev_err = PerlIO_error(IoOFP(io));
f4725fad
FC		 1806#ifdef USE_PERLIO
1807 if (prev_err)
1808 PerlIO_restore_errno(IoOFP(io));
1809#endif
e199e3be 1810 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
760ac839 1811 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4 1812 }
e199e3be 1813 else {
0bcc34c2 1814 const bool prev_err = PerlIO_error(IoIFP(io));
f4725fad
FC		 1815#ifdef USE_PERLIO
1816 if (prev_err)
1817 PerlIO_restore_errno(IoIFP(io));
1818#endif
e199e3be
RGS		 1819 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1820 }
a687059c 1821 }
4608196e 1822 IoOFP(io) = IoIFP(io) = NULL;
96d7c888
FC		 1823
1824 if (warn_on_fail && !retval) {
1825 if (gv)
1826 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1827 "Warning: unable to close filehandle %"
147e3846 1828 HEKf " properly: %" SVf,
ac892e4a
DM		 1829 HEKfARG(GvNAME_HEK(gv)),
1830 SVfARG(get_sv("!",GV_ADD)));
96d7c888
FC		 1831 else
1832 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1833 "Warning: unable to close filehandle "
147e3846 1834 "properly: %" SVf,
ac892e4a 1835 SVfARG(get_sv("!",GV_ADD)));
96d7c888 1836 }
79072805 1837 }
f2b5be74 1838 else if (not_implicit) {
93189314 1839 SETERRNO(EBADF,SS_IVCHAN);
20408e3c 1840 }
1193dd27 1841
a687059c
LW		 1842 return retval;
1843}
1844
1845bool
864dbfa3 1846Perl_do_eof(pTHX_ GV *gv)
a687059c 1847{
eb578fdb 1848 IO * const io = GvIO(gv);
a687059c 1849
7918f24d
NC		 1850 PERL_ARGS_ASSERT_DO_EOF;
1851
79072805 1852 if (!io)
a687059c 1853 return TRUE;
7716c5c5 1854 else if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1855 report_wrongway_fh(gv, '>');
a687059c 1856
8990e307 1857 while (IoIFP(io)) {
760ac839 1858 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
a20bf0c3 1859 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
760ac839
LW		 1860 return FALSE; /* this is the most usual case */
1861 }
a687059c 1862
79852593
NC		 1863 {
1864 /* getc and ungetc can stomp on errno */
4ee39169 1865 dSAVE_ERRNO;
79852593
NC		 1866 const int ch = PerlIO_getc(IoIFP(io));
1867 if (ch != EOF) {
1868 (void)PerlIO_ungetc(IoIFP(io),ch);
4ee39169 1869 RESTORE_ERRNO;
79852593
NC		 1870 return FALSE;
1871 }
4ee39169 1872 RESTORE_ERRNO;
a687059c 1873 }
fab3f3a7 1874
760ac839 1875 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
a20bf0c3
JH		 1876 if (PerlIO_get_cnt(IoIFP(io)) < -1)
1877 PerlIO_set_cnt(IoIFP(io),-1);
760ac839 1878 }
533c011a 1879 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
157fb5a1 1880 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */
a687059c
LW		 1881 return TRUE;
1882 }
1883 else
1884 return TRUE; /* normal fp, definitely end of file */
1885 }
1886 return TRUE;
1887}
1888
5ff3f7a4 1889Off_t
864dbfa3 1890Perl_do_tell(pTHX_ GV *gv)
a687059c 1891{
9c9f25b8 1892 IO *const io = GvIO(gv);
eb578fdb 1893 PerlIO *fp;
a687059c 1894
7918f24d
NC		 1895 PERL_ARGS_ASSERT_DO_TELL;
1896
9c9f25b8 1897 if (io && (fp = IoIFP(io))) {
8903cb82 1898 return PerlIO_tell(fp);
96e4d5b1 1899 }
51087808 1900 report_evil_fh(gv);
93189314 1901 SETERRNO(EBADF,RMS_IFI);
5ff3f7a4 1902 return (Off_t)-1;
a687059c
LW		 1903}
1904
1905bool
864dbfa3 1906Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 1907{
9c9f25b8 1908 IO *const io = GvIO(gv);
eb578fdb 1909 PerlIO *fp;
a687059c 1910
9c9f25b8 1911 if (io && (fp = IoIFP(io))) {
8903cb82 1912 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 1913 }
51087808 1914 report_evil_fh(gv);
93189314 1915 SETERRNO(EBADF,RMS_IFI);
a687059c
LW		 1916 return FALSE;
1917}
1918
97cc44eb 1919Off_t
864dbfa3 1920Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82 1921{
9c9f25b8 1922 IO *const io = GvIO(gv);
eb578fdb 1923 PerlIO *fp;
8903cb82 1924
7918f24d
NC		 1925 PERL_ARGS_ASSERT_DO_SYSSEEK;
1926
375ed12a
JH		 1927 if (io && (fp = IoIFP(io))) {
1928 int fd = PerlIO_fileno(fp);
07bd88da
JH		 1929 if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
1930 SETERRNO(EINVAL,LIB_INVARG);
1931 return -1;
1932 } else {
375ed12a
JH		 1933 return PerlLIO_lseek(fd, pos, whence);
1934 }
1935 }
51087808 1936 report_evil_fh(gv);
93189314 1937 SETERRNO(EBADF,RMS_IFI);
d9b3e12d 1938 return (Off_t)-1;
8903cb82 1939}
1940
6ff81951 1941int
a79b25b7 1942Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
16fe6d59
GS		 1943{
1944 int mode = O_BINARY;
81611534 1945 PERL_UNUSED_CONTEXT;
a79b25b7 1946 if (s) {
16fe6d59
GS		 1947 while (*s) {
1948 if (*s == ':') {
1949 switch (s[1]) {
1950 case 'r':
e963d6d2 1951 if (s[2] == 'a' && s[3] == 'w'
16fe6d59
GS		 1952 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1953 {
1954 mode = O_BINARY;
1955 s += 4;
1956 len -= 4;
1957 break;
1958 }
924ba076 1959 /* FALLTHROUGH */
16fe6d59 1960 case 'c':
e963d6d2 1961 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
16fe6d59
GS		 1962 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1963 {
1964 mode = O_TEXT;
1965 s += 5;
1966 len -= 5;
1967 break;
1968 }
924ba076 1969 /* FALLTHROUGH */
16fe6d59
GS		 1970 default:
1971 goto fail_discipline;
1972 }
1973 }
1974 else if (isSPACE(*s)) {
1975 ++s;
1976 --len;
1977 }
1978 else {
4373e329 1979 const char *end;
7b52d656 1980 fail_discipline:
9a73c0b8 1981 end = (char *) memchr(s+1, ':', len);
16fe6d59
GS		 1982 if (!end)
1983 end = s+len;
60382766 1984#ifndef PERLIO_LAYERS
363c40c4 1985 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
60382766 1986#else
18a33fb5 1987 len -= end-s;
60382766
NIS		 1988 s = end;
1989#endif
16fe6d59
GS		 1990 }
1991 }
1992 }
1993 return mode;
1994}
1995
58e24eff 1996#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
27da23d5
JH		 1997I32
1998my_chsize(int fd, Off_t length)
6eb13c3b 1999{
58e24eff
SH		 2000#ifdef F_FREESP
2001 /* code courtesy of William Kucharski */
2002#define HAS_CHSIZE
2003
c623ac67 2004 Stat_t filebuf;
6eb13c3b 2005
3028581b 2006 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW		 2007 return -1;
2008
2009 if (filebuf.st_size < length) {
2010
2011 /* extend file length */
2012
3028581b 2013 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW		 2014 return -1;
2015
2016 /* write a "0" byte */
2017
3028581b 2018 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW		 2019 return -1;
2020 }
2021 else {
2022 /* truncate length */
35da51f7 2023 struct flock fl;
6eb13c3b
LW		 2024 fl.l_whence = 0;
2025 fl.l_len = 0;
2026 fl.l_start = length;
a0d0e21e 2027 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW		 2028
2029 /*
a0d0e21e 2030 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW		 2031 * fcntl(2), which truncates the file so that it ends at the
2032 * position indicated by fl.l_start.
2033 *
2034 * Will minor miracles never cease?
2035 */
2036
a0d0e21e 2037 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW		 2038 return -1;
2039
2040 }
6eb13c3b 2041 return 0;
58e24eff 2042#else
27da23d5 2043 Perl_croak_nocontext("truncate not implemented");
a0d0e21e 2044#endif /* F_FREESP */
27da23d5 2045 return -1;
58e24eff
SH		 2046}
2047#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
ff8e2863 2048
a687059c 2049bool
5aaab254 2050Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
a687059c 2051{
7918f24d
NC		 2052 PERL_ARGS_ASSERT_DO_PRINT;
2053
79072805
LW		 2054 /* assuming fp is checked earlier */
2055 if (!sv)
2056 return TRUE;
e9950d3b
NC		 2057 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
2058 assert(!SvGMAGICAL(sv));
2059 if (SvIsUV(sv))
147e3846 2060 PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv));
e9950d3b 2061 else
147e3846 2062 PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv));
e9950d3b
NC		 2063 return !PerlIO_error(fp);
2064 }
2065 else {
2066 STRLEN len;
676f44e7 2067 /* Do this first to trigger any overloading. */
e9950d3b
NC		 2068 const char *tmps = SvPV_const(sv, len);
2069 U8 *tmpbuf = NULL;
2070 bool happy = TRUE;
2071
d791f93f
KW		 2072 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
2073 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
676f44e7
NC		 2074 /* We don't modify the original scalar. */
2075 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
2076 tmps = (char *) tmpbuf;
2077 }
a099aed4 2078 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
0876b9a0
KW		 2079 (void) check_utf8_print((const U8*) tmps, len);
2080 }
d791f93f
KW		 2081 } /* else stream isn't utf8 */
2082 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
2083 convert to bytes */
676f44e7
NC		 2084 STRLEN tmplen = len;
2085 bool utf8 = TRUE;
35da51f7 2086 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
676f44e7 2087 if (!utf8) {
d791f93f
KW		 2088
2089 /* Here, succeeded in downgrading from utf8. Set up to below
2090 * output the converted value */
676f44e7
NC		 2091 tmpbuf = result;
2092 tmps = (char *) tmpbuf;
2093 len = tmplen;
2094 }
d791f93f
KW		 2095 else { /* Non-utf8 output stream, but string only representable in
2096 utf8 */
676f44e7 2097 assert((char *)result == tmps);
9b387841 2098 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
21630838
FC		 2099 "Wide character in %s",
2100 PL_op ? OP_DESC(PL_op) : "print"
2101 );
0876b9a0
KW		 2102 /* Could also check that isn't one of the things to avoid
2103 * in utf8 by using check_utf8_print(), but not doing so,
2104 * since the stream isn't a UTF8 stream */
ae798467
NIS		 2105 }
2106 }
e9950d3b
NC		 2107 /* To detect whether the process is about to overstep its
2108 * filesize limit we would need getrlimit(). We could then
2109 * also transparently raise the limit with setrlimit() --
2110 * but only until the system hard limit/the filesystem limit,
2111 * at which we would get EPERM. Note that when using buffered
2112 * io the write failure can be delayed until the flush/close. --jhi */
2113 if (len && (PerlIO_write(fp,tmps,len) == 0))
2114 happy = FALSE;
2115 Safefree(tmpbuf);
2116 return happy ? !PerlIO_error(fp) : FALSE;
ff8e2863 2117 }
a687059c
LW		 2118}
2119
79072805 2120I32
0d7d409d 2121Perl_my_stat_flags(pTHX_ const U32 flags)
a687059c 2122{
39644a26 2123 dSP;
79072805 2124 IO *io;
2dd78f96 2125 GV* gv;
79072805 2126
533c011a 2127 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2128 gv = cGVOP_gv;
748a9306 2129 do_fstat:
97c8f3e6
Z		 2130 if (gv == PL_defgv) {
2131 if (PL_laststatval < 0)
2132 SETERRNO(EBADF,RMS_IFI);
5228a96c 2133 return PL_laststatval;
97c8f3e6 2134 }
2dd78f96 2135 io = GvIO(gv);
ad02613c 2136 do_fstat_have_io:
5228a96c 2137 PL_laststype = OP_STAT;
bd5f6c01 2138 PL_statgv = gv ? gv : (GV *)io;
8062ff11 2139 SvPVCLEAR(PL_statname);
77616968 2140 if (io) {
5228a96c 2141 if (IoIFP(io)) {
375ed12a 2142 int fd = PerlIO_fileno(IoIFP(io));
77616968
JH		 2143 if (fd < 0) {
2144 /* E.g. PerlIO::scalar has no real fd. */
97c8f3e6 2145 SETERRNO(EBADF,RMS_IFI);
77616968
JH		 2146 return (PL_laststatval = -1);
2147 } else {
375ed12a
JH		 2148 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
2149 }
5228a96c 2150 } else if (IoDIRP(io)) {
3497a01f 2151 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
5228a96c 2152 }
5228a96c 2153 }
3888144c
FC		 2154 PL_laststatval = -1;
2155 report_evil_fh(gv);
97c8f3e6 2156 SETERRNO(EBADF,RMS_IFI);
3888144c 2157 return -1;
a687059c 2158 }
d2c4d2d1 2159 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
8db8f6b6
FC		 2160 == OPpFT_STACKED)
2161 return PL_laststatval;
d2c4d2d1
FC		 2162 else {
2163 SV* const sv = TOPs;
a155eb05 2164 const char *s, *d;
4ecd490c 2165 STRLEN len;
094a3eec 2166 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
748a9306
LW		 2167 goto do_fstat;
2168 }
ad02613c 2169 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2170 io = MUTABLE_IO(SvRV(sv));
7f39519f 2171 gv = NULL;
ad02613c
SP		 2172 goto do_fstat_have_io;
2173 }
748a9306 2174
0d7d409d 2175 s = SvPV_flags_const(sv, len, flags);
a0714e2c 2176 PL_statgv = NULL;
4ecd490c 2177 sv_setpvn(PL_statname, s, len);
a155eb05 2178 d = SvPVX_const(PL_statname); /* s now NUL-terminated */
3280af22 2179 PL_laststype = OP_STAT;
a155eb05
TC		 2180 if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
2181 PL_laststatval = -1;
2182 }
2183 else {
2184 PL_laststatval = PerlLIO_stat(d, &PL_statcache);
2185 }
7cb3f959 2186 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
7347ee54 2187 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 2188 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
7347ee54 2189 GCC_DIAG_RESTORE_STMT;
5d37acd6 2190 }
3280af22 2191 return PL_laststatval;
a687059c
LW		 2192 }
2193}
2194
fbb0b3b3 2195
79072805 2196I32
0d7d409d 2197Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 2198{
a1894d81 2199 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 2200 dSP;
b16276bb 2201 const char *file;
a155eb05 2202 STRLEN len;
cd22fad3 2203 SV* const sv = TOPs;
5840701a 2204 bool isio = FALSE;
533c011a 2205 if (PL_op->op_flags & OPf_REF) {
638eceb6 2206 if (cGVOP_gv == PL_defgv) {
3280af22 2207 if (PL_laststype != OP_LSTAT)
0157ef98 2208 Perl_croak(aTHX_ "%s", no_prev_lstat);
97c8f3e6
Z		 2209 if (PL_laststatval < 0)
2210 SETERRNO(EBADF,RMS_IFI);
3280af22 2211 return PL_laststatval;
fe14fcc3 2212 }
31b139ba 2213 PL_laststatval = -1;
5d3e98de 2214 if (ckWARN(WARN_IO)) {
5840701a 2215 /* diag_listed_as: Use of -l on filehandle%s */
d0c0e7dd 2216 Perl_warner(aTHX_ packWARN(WARN_IO),
147e3846 2217 "Use of -l on filehandle %" HEKf,
d0c0e7dd 2218 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 2219 }
97c8f3e6 2220 SETERRNO(EBADF,RMS_IFI);
31b139ba 2221 return -1;
fe14fcc3 2222 }
8db8f6b6
FC		 2223 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
2224 == OPpFT_STACKED) {
1f26655e 2225 if (PL_laststype != OP_LSTAT)
0157ef98 2226 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 2227 return PL_laststatval;
cd22fad3 2228 }
c623bd54 2229
3280af22 2230 PL_laststype = OP_LSTAT;
a0714e2c 2231 PL_statgv = NULL;
5840701a
FC		 2232 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
2233 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
2234 )
2235 || isGV_with_GP(sv)
2236 )
2237 && ckWARN(WARN_IO)) {
2238 if (isio)
2239 /* diag_listed_as: Use of -l on filehandle%s */
2240 Perl_warner(aTHX_ packWARN(WARN_IO),
2241 "Use of -l on filehandle");
2242 else
2243 /* diag_listed_as: Use of -l on filehandle%s */
2244 Perl_warner(aTHX_ packWARN(WARN_IO),
147e3846 2245 "Use of -l on filehandle %" HEKf,
10bafe90
BF		 2246 HEKfARG(GvENAME_HEK((const GV *)
2247 (SvROK(sv) ? SvRV(sv) : sv))));
cd22fad3 2248 }
a155eb05 2249 file = SvPV_flags_const(sv, len, flags);
b16276bb 2250 sv_setpv(PL_statname,file);
a155eb05
TC		 2251 if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
2252 PL_laststatval = -1;
2253 }
2254 else {
2255 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
2256 }
7cb3f959 2257 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
7347ee54 2258 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
5d37acd6 2259 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
7347ee54 2260 GCC_DIAG_RESTORE_STMT;
5d37acd6 2261 }
3280af22 2262 return PL_laststatval;
c623bd54
LW		 2263}
2264
a0f2c8ec
JD		 2265static void
2266S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
2267{
2268 const int e = errno;
7918f24d 2269 PERL_ARGS_ASSERT_EXEC_FAILED;
738ab09f
AB		 2270
2271 if (ckWARN(WARN_EXEC))
2272 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
2273 cmd, Strerror(e));
a0f2c8ec 2274 if (do_report) {
b469f1e0
JH		 2275 /* XXX silently ignore failures */
2276 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
a0f2c8ec
JD		 2277 PerlLIO_close(fd);
2278 }
2279}
2280
738ab09f 2281bool
5aaab254 2282Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2aa1486d 2283 int fd, int do_report)
d5a9bfb0 2284{
27da23d5 2285 dVAR;
7918f24d 2286 PERL_ARGS_ASSERT_DO_AEXEC5;
e37778c2 2287#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
cd39f2b6
JH		 2288 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
2289#else
2fcab330 2290 assert(sp >= mark);
282fc0b3 2291 ENTER;
2fcab330 2292 {
282fc0b3 2293 const char **argv, **a;
6136c704 2294 const char *tmps = NULL;
282fc0b3
Z		 2295 Newx(argv, sp - mark + 1, const char*);
2296 SAVEFREEPV(argv);
2297 a = argv;
890ce7af 2298
79072805 2299 while (++mark <= sp) {
282fc0b3
Z		 2300 if (*mark) {
2301 char *arg = savepv(SvPV_nolen_const(*mark));
2302 SAVEFREEPV(arg);
2303 *a++ = arg;
2304 } else
a687059c
LW		 2305 *a++ = "";
2306 }
6136c704 2307 *a = NULL;
282fc0b3
Z		 2308 if (really) {
2309 tmps = savepv(SvPV_nolen_const(really));
2310 SAVEFREEPV(tmps);
2311 }
2312 if ((!really && argv[0] && *argv[0] != '/') ||
91b2752f 2313 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 2314 TAINT_ENV(); /* testing IFS here is overkill, probably */
b35112e7 2315 PERL_FPU_PRE_EXEC
839a9f02 2316 if (really && *tmps) {
282fc0b3
Z		 2317 PerlProc_execvp(tmps,EXEC_ARGV_CAST(argv));
2318 } else if (argv[0]) {
2319 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
2fcab330
DIM		 2320 } else {
2321 SETERRNO(ENOENT,RMS_FNF);
2322 }
b35112e7 2323 PERL_FPU_POST_EXEC
282fc0b3 2324 S_exec_failed(aTHX_ (really ? tmps : argv[0] ? argv[0] : ""), fd, do_report);
a687059c 2325 }
282fc0b3 2326 LEAVE;
cd39f2b6 2327#endif
738ab09f 2328 return FALSE;
a687059c
LW		 2329}
2330
9555a685 2331#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8 2332
738ab09f 2333bool
2fbb330f 2334Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 2335{
27da23d5 2336 dVAR;
282fc0b3 2337 const char **argv, **a;
eb578fdb 2338 char *s;
15db3ae2 2339 char *buf;
2fbb330f 2340 char *cmd;
2fbb330f 2341 /* Make a copy so we can change it */
6fca0082 2342 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC		 2343
2344 PERL_ARGS_ASSERT_DO_EXEC3;
2345
282fc0b3 2346 ENTER;
15db3ae2 2347 Newx(buf, cmdlen, char);
282fc0b3 2348 SAVEFREEPV(buf);
15db3ae2 2349 cmd = buf;
cfff9797 2350 memcpy(cmd, incmd, cmdlen);
a687059c 2351
748a9306
LW		 2352 while (*cmd && isSPACE(*cmd))
2353 cmd++;
2354
a687059c
LW		 2355 /* save an extra exec if possible */
2356
bf38876a 2357#ifdef CSH
d05c1ba0 2358 {
0c19750d 2359 char flags[PERL_FLAGS_MAX];
d05c1ba0 2360 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
c8b388b0 2361 strBEGINs(cmd+PL_cshlen," -c")) {
28f0d0ec 2362 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
d05c1ba0
JH		 2363 s = cmd+PL_cshlen+3;
2364 if (*s == 'f') {
2365 s++;
28f0d0ec 2366 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
d05c1ba0
JH		 2367 }
2368 if (*s == ' ')
2369 s++;
2370 if (*s++ == '\'') {
0bcc34c2 2371 char * const ncmd = s;
d05c1ba0
JH		 2372
2373 while (*s)
2374 s++;
2375 if (s[-1] == '\n')
2376 *--s = '\0';
2377 if (s[-1] == '\'') {
2378 *--s = '\0';
b35112e7 2379 PERL_FPU_PRE_EXEC
738ab09f 2380 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
b35112e7 2381 PERL_FPU_POST_EXEC
d05c1ba0 2382 *s = '\'';
a0f2c8ec 2383 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
282fc0b3 2384 goto leave;
d05c1ba0
JH		 2385 }
2386 }
a687059c
LW		 2387 }
2388 }
bf38876a 2389#endif /* CSH */
a687059c
LW		 2390
2391 /* see if there are shell metacharacters in it */
2392
748a9306
LW		 2393 if (*cmd == '.' && isSPACE(cmd[1]))
2394 goto doshell;
2395
c8b388b0 2396 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
748a9306
LW		 2397 goto doshell;
2398
294b3b39 2399 s = cmd;
0eb30aeb 2400 while (isWORDCHAR(*s))
294b3b39 2401 s++; /* catch VAR=val gizmo */
63f2c1e1
LW		 2402 if (*s == '=')
2403 goto doshell;
748a9306 2404
a687059c 2405 for (s = cmd; *s; s++) {
d05c1ba0
JH		 2406 if (*s != ' ' && !isALPHA(*s) &&
2407 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW		 2408 if (*s == '\n' && !s[1]) {
2409 *s = '\0';
2410 break;
2411 }
603a98b0
IZ		 2412 /* handle the 2>&1 construct at the end */
2413 if (*s == '>' && s[1] == '&' && s[2] == '1'
2414 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
2415 && (!s[3] || isSPACE(s[3])))
2416 {
6867be6d 2417 const char *t = s + 3;
603a98b0
IZ		 2418
2419 while (*t && isSPACE(*t))
2420 ++t;
943bbd07 2421 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
603a98b0
IZ		 2422 s[-2] = '\0';
2423 break;
2424 }
2425 }
a687059c 2426 doshell:
b35112e7 2427 PERL_FPU_PRE_EXEC
738ab09f 2428 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
b35112e7 2429 PERL_FPU_POST_EXEC
a0f2c8ec 2430 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
282fc0b3 2431 goto leave;
a687059c
LW		 2432 }
2433 }
748a9306 2434
282fc0b3
Z		 2435 Newx(argv, (s - cmd) / 2 + 2, const char*);
2436 SAVEFREEPV(argv);
2437 cmd = savepvn(cmd, s-cmd);
2438 SAVEFREEPV(cmd);
2439 a = argv;
2440 for (s = cmd; *s;) {
294b3b39
AL		 2441 while (isSPACE(*s))
2442 s++;
a687059c
LW		 2443 if (*s)
2444 *(a++) = s;
294b3b39
AL		 2445 while (*s && !isSPACE(*s))
2446 s++;
a687059c
LW		 2447 if (*s)
2448 *s++ = '\0';
2449 }
6136c704 2450 *a = NULL;
282fc0b3 2451 if (argv[0]) {
b35112e7 2452 PERL_FPU_PRE_EXEC
282fc0b3 2453 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
b35112e7 2454 PERL_FPU_POST_EXEC
282fc0b3 2455 if (errno == ENOEXEC) /* for system V NIH syndrome */
a687059c 2456 goto doshell;
282fc0b3 2457 S_exec_failed(aTHX_ argv[0], fd, do_report);
a687059c 2458 }
282fc0b3
Z		 2459leave:
2460 LEAVE;
738ab09f 2461 return FALSE;
a687059c
LW		 2462}
2463
6890e559 2464#endif /* OS2 || WIN32 */
760ac839 2465
79072805 2466I32
5aaab254 2467Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
a687059c 2468{
eb578fdb
KW		 2469 I32 val;
2470 I32 tot = 0;
4634a855 2471 const char *const what = PL_op_name[type];
5c144d81 2472 const char *s;
84c7b88c 2473 STRLEN len;
890ce7af 2474 SV ** const oldmark = mark;
885b4b39 2475 bool killgp = FALSE;
a687059c 2476
7918f24d
NC		 2477 PERL_ARGS_ASSERT_APPLY;
2478
9a9b5ec9
DM		 2479 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
2480
1444765e
NC		 2481 /* Doing this ahead of the switch statement preserves the old behaviour,
2482 where attempting to use kill as a taint test test would fail on
2483 platforms where kill was not defined. */
2484#ifndef HAS_KILL
2485 if (type == OP_KILL)
4634a855 2486 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2487#endif
2488#ifndef HAS_CHOWN
2489 if (type == OP_CHOWN)
4634a855 2490 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2491#endif
2492
2493
20408e3c 2494#define APPLY_TAINT_PROPER() \
3280af22 2495 STMT_START { \
284167a5 2496 if (TAINT_get) { TAINT_PROPER(what); } \
873ef191 2497 } STMT_END
20408e3c
GS		 2498
2499 /* This is a first heuristic; it doesn't catch tainting magic. */
284167a5 2500 if (TAINTING_get) {
463ee0b2 2501 while (++mark <= sp) {
bbce6d69 2502 if (SvTAINTED(*mark)) {
2503 TAINT;
2504 break;
2505 }
463ee0b2
LW		 2506 }
2507 mark = oldmark;
2508 }
a687059c 2509 switch (type) {
79072805 2510 case OP_CHMOD:
20408e3c 2511 APPLY_TAINT_PROPER();
79072805 2512 if (++mark <= sp) {
4ea561bc 2513 val = SvIV(*mark);
20408e3c
GS		 2514 APPLY_TAINT_PROPER();
2515 tot = sp - mark;
79072805 2516 while (++mark <= sp) {
c4aca7d0 2517 GV* gv;
2ea1cce7 2518 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA		 2519 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2520#ifdef HAS_FCHMOD
375ed12a 2521 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 2522 APPLY_TAINT_PROPER();
375ed12a
JH		 2523 if (fd < 0) {
2524 SETERRNO(EBADF,RMS_IFI);
2525 tot--;
2526 } else if (fchmod(fd, val))
2527 tot--;
c4aca7d0 2528#else
b9c6780e 2529 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0
GA		 2530#endif
2531 }
2532 else {
8334cae6 2533 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 2534 tot--;
2535 }
2536 }
c4aca7d0 2537 else {
41188aa0 2538 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 2539 APPLY_TAINT_PROPER();
41188aa0 2540 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC		 2541 PerlLIO_chmod(name, val)) {
2542 tot--;
2543 }
c4aca7d0 2544 }
a687059c
LW		 2545 }
2546 }
2547 break;
fe14fcc3 2548#ifdef HAS_CHOWN
79072805 2549 case OP_CHOWN:
20408e3c 2550 APPLY_TAINT_PROPER();
79072805 2551 if (sp - mark > 2) {
eb578fdb 2552 I32 val2;
463ee0b2
LW		 2553 val = SvIVx(*++mark);
2554 val2 = SvIVx(*++mark);
20408e3c 2555 APPLY_TAINT_PROPER();
a0d0e21e 2556 tot = sp - mark;
79072805 2557 while (++mark <= sp) {
c4aca7d0 2558 GV* gv;
2ea1cce7 2559 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA		 2560 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2561#ifdef HAS_FCHOWN
375ed12a 2562 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
c4aca7d0 2563 APPLY_TAINT_PROPER();
375ed12a 2564 if (fd < 0) {
dd1dbff0 2565 SETERRNO(EBADF,RMS_IFI);
f95ba548 2566 tot--;
375ed12a 2567 } else if (fchown(fd, val, val2))
c4aca7d0
GA		 2568 tot--;
2569#else
b9c6780e 2570 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0
GA		 2571#endif
2572 }
2573 else {
8334cae6 2574 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 2575 tot--;
2576 }
2577 }
c4aca7d0 2578 else {
41188aa0 2579 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 2580 APPLY_TAINT_PROPER();
41188aa0 2581 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 2582 PerlLIO_chown(name, val, val2)) {
c4aca7d0 2583 tot--;
c8028aa6 2584 }
c4aca7d0 2585 }
a687059c
LW		 2586 }
2587 }
2588 break;
b1248f16 2589#endif
a1d180c4 2590/*
dd64f1c3
AD		 2591XXX Should we make lchown() directly available from perl?
2592For now, we'll let Configure test for HAS_LCHOWN, but do
2593nothing in the core.
2594 --AD 5/1998
2595*/
fe14fcc3 2596#ifdef HAS_KILL
79072805 2597 case OP_KILL:
20408e3c 2598 APPLY_TAINT_PROPER();
55497cff 2599 if (mark == sp)
2600 break;
84c7b88c 2601 s = SvPVx_const(*++mark, len);
c2fd40cb
DM		 2602 if (*s == '-' && isALPHA(s[1]))
2603 {
2604 s++;
2605 len--;
885b4b39 2606 killgp = TRUE;
c2fd40cb 2607 }
e02bfb16 2608 if (isALPHA(*s)) {
84c7b88c 2609 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
79072805 2610 s += 3;
84c7b88c
BF		 2611 len -= 3;
2612 }
2613 if ((val = whichsig_pvn(s, len)) < 0)
147e3846
KW		 2614 Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"",
2615 SVfARG(*mark));
79072805
LW		 2616 }
2617 else
c2fd40cb 2618 {
4ea561bc 2619 val = SvIV(*mark);
c2fd40cb
DM		 2620 if (val < 0)
2621 {
885b4b39 2622 killgp = TRUE;
c2fd40cb
DM		 2623 val = -val;
2624 }
2625 }
20408e3c
GS		 2626 APPLY_TAINT_PROPER();
2627 tot = sp - mark;
fbcd93f0 2628
c2fd40cb 2629 while (++mark <= sp) {
60082291 2630 Pid_t proc;
c2fd40cb 2631 SvGETMAGIC(*mark);
60082291 2632 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
c2fd40cb
DM		 2633 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
2634 proc = SvIV_nomg(*mark);
c2fd40cb 2635 APPLY_TAINT_PROPER();
111f73b5
DM		 2636#ifdef HAS_KILLPG
2637 /* use killpg in preference, as the killpg() wrapper for Win32
2638 * understands process groups, but the kill() wrapper doesn't */
2639 if (killgp ? PerlProc_killpg(proc, val)
2640 : PerlProc_kill(proc, val))
2641#else
2642 if (PerlProc_kill(killgp ? -proc: proc, val))
2643#endif
c2fd40cb 2644 tot--;
a687059c 2645 }
8165faea 2646 PERL_ASYNC_CHECK();
a687059c 2647 break;
b1248f16 2648#endif
79072805 2649 case OP_UNLINK:
20408e3c 2650 APPLY_TAINT_PROPER();
79072805
LW		 2651 tot = sp - mark;
2652 while (++mark <= sp) {
41188aa0 2653 s = SvPV_const(*mark, len);
20408e3c 2654 APPLY_TAINT_PROPER();
41188aa0 2655 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC		 2656 tot--;
2657 }
f0d85c30 2658 else if (PL_unsafe) {
b8ffc8df 2659 if (UNLINK(s))
5cdd1fc2 2660 {
a687059c 2661 tot--;
5cdd1fc2
AB		 2662 }
2663#if defined(__amigaos4__) && defined(NEWLIB)
2664 else
2665 {
2666 /* Under AmigaOS4 unlink only 'fails' if the
2667 * filename is invalid. It may not remove the file
2668 * if it's locked, so check if it's still around. */
2669 if ((access(s,F_OK) != -1))
2670 {
2671 tot--;
2672 }
2673 }
2674#endif
a687059c
LW		 2675 }
2676 else { /* don't let root wipe out directories without -U */
45a23732
DD		 2677 Stat_t statbuf;
2678 if (PerlLIO_lstat(s, &statbuf) < 0)
1dcae8b8 2679 tot--;
45a23732 2680 else if (S_ISDIR(statbuf.st_mode)) {
cd52bc19 2681 SETERRNO(EISDIR, SS_NOPRIV);
45a23732 2682 tot--;
1dcae8b8 2683 }
a687059c 2684 else {
b8ffc8df 2685 if (UNLINK(s))
5cdd1fc2
AB		 2686 {
2687 tot--;
2688 }
2689#if defined(__amigaos4__) && defined(NEWLIB)
2690 else
2691 {
2692 /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */
2693 /* It may not remove the file if it's Locked, so check if it's still */
2694 /* arround */
2695 if((access(s,F_OK) != -1))
2696 {
2697 tot--;
2698 }
2699 }
2700#endif
a687059c
LW		 2701 }
2702 }
2703 }
2704 break;
e96b369d 2705#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 2706 case OP_UTIME:
20408e3c 2707 APPLY_TAINT_PROPER();
79072805 2708 if (sp - mark > 2) {
e96b369d
GA		 2709#if defined(HAS_FUTIMES)
2710 struct timeval utbuf[2];
2711 void *utbufp = utbuf;
2712#elif defined(I_UTIME) || defined(VMS)
663a0e37 2713 struct utimbuf utbuf;
07409e01 2714 struct utimbuf *utbufp = &utbuf;
663a0e37 2715#else
a687059c 2716 struct {
dd2821f6
GS		 2717 Time_t actime;
2718 Time_t modtime;
a687059c 2719 } utbuf;
07409e01 2720 void *utbufp = &utbuf;
663a0e37 2721#endif
a687059c 2722
0bcc34c2
AL		 2723 SV* const accessed = *++mark;
2724 SV* const modified = *++mark;
c6f7b413 2725
6ec06612
SB		 2726 /* Be like C, and if both times are undefined, let the C
2727 * library figure out what to do. This usually means
2728 * "current time". */
c6f7b413
RS		 2729
2730 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB		 2731 utbufp = NULL;
2732 else {
2733 Zero(&utbuf, sizeof utbuf, char);
e96b369d 2734#ifdef HAS_FUTIMES
4ea561bc 2735 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 2736 utbuf[0].tv_usec = 0;
4ea561bc 2737 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA		 2738 utbuf[1].tv_usec = 0;
2739#elif defined(BIG_TIME)
4ea561bc
NC		 2740 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
2741 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 2742#else
4ea561bc
NC		 2743 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
2744 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 2745#endif
6ec06612 2746 }
4373e329 2747 APPLY_TAINT_PROPER();
79072805
LW		 2748 tot = sp - mark;
2749 while (++mark <= sp) {
e96b369d 2750 GV* gv;
64617da9 2751 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA		 2752 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2753#ifdef HAS_FUTIMES
375ed12a 2754 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
e96b369d 2755 APPLY_TAINT_PROPER();
375ed12a
JH		 2756 if (fd < 0) {
2757 SETERRNO(EBADF,RMS_IFI);
2758 tot--;
2759 } else if (futimes(fd, (struct timeval *) utbufp))
e96b369d
GA		 2760 tot--;
2761#else
2762 Perl_die(aTHX_ PL_no_func, "futimes");
2763#endif
2764 }
2765 else {
2766 tot--;
2767 }
2768 }
e96b369d 2769 else {
41188aa0 2770 const char * const name = SvPV_nomg_const(*mark, len);
e96b369d 2771 APPLY_TAINT_PROPER();
41188aa0 2772 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC		 2773 tot--;
2774 }
2775 else
e96b369d 2776#ifdef HAS_FUTIMES
8b7231d9 2777 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA		 2778#else
2779 if (PerlLIO_utime(name, utbufp))
2780#endif
2781 tot--;
2782 }
2783
a687059c 2784 }
a687059c
LW		 2785 }
2786 else
79072805 2787 tot = 0;
a687059c 2788 break;
a0d0e21e 2789#endif
a687059c
LW		 2790 }
2791 return tot;
20408e3c 2792
20408e3c 2793#undef APPLY_TAINT_PROPER
a687059c
LW		 2794}
2795
bd93adf5 2796/* Do the permissions in *statbufp allow some operation? */
a0d0e21e 2797#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 2798bool
5aaab254 2799Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC		 2800/* effective is a flag, true for EUID, or for checking if the effective gid
2801 * is in the list of groups returned from getgroups().
2802 */
a687059c 2803{
7918f24d 2804 PERL_ARGS_ASSERT_CANDO;
81611534 2805 PERL_UNUSED_CONTEXT;
7918f24d 2806
bee1dbe2 2807#ifdef DOSISH
fe14fcc3
LW		 2808 /* [Comments and code from Len Reed]
2809 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
2810 * to write-protected files. The execute permission bit is set
486ec47a 2811 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW		 2812 * .exe files
2813 * .com files
2814 * .bat files
2815 * directories
2816 * All files and directories are readable.
2817 * Directories and special files, e.g. "CON", cannot be
2818 * write-protected.
2819 * [Comment by Tom Dinger -- a directory can have the write-protect
2820 * bit set in the file system, but DOS permits changes to
2821 * the directory anyway. In addition, all bets are off
2822 * here for networked software, such as Novell and
2823 * Sun's PC-NFS.]
2824 */
2825
bee1dbe2
LW		 2826 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
2827 * too so it will actually look into the files for magic numbers
2828 */
8298454c 2829 return cBOOL(mode & statbufp->st_mode);
fe14fcc3 2830
55497cff 2831#else /* ! DOSISH */
b595cd4b
RU		 2832# ifdef __CYGWIN__
2833 if (ingroup(544,effective)) { /* member of Administrators */
2834# else
985213f2 2835 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 2836# endif
7f4774ae 2837 if (mode == S_IXUSR) {
c623bd54 2838 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW		 2839 return TRUE;
2840 }
2841 else
2842 return TRUE; /* root reads and writes anything */
2843 return FALSE;
2844 }
985213f2 2845 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 2846 if (statbufp->st_mode & mode)
a687059c
LW		 2847 return TRUE; /* ok as "user" */
2848 }
d8eceb89 2849 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 2850 if (statbufp->st_mode & mode >> 3)
a687059c
LW		 2851 return TRUE; /* ok as "group" */
2852 }
7f4774ae 2853 else if (statbufp->st_mode & mode >> 6)
a687059c
LW		 2854 return TRUE; /* ok as "other" */
2855 return FALSE;
55497cff 2856#endif /* ! DOSISH */
a687059c 2857}
a0d0e21e 2858#endif /* ! VMS */
a687059c 2859
1f676739 2860static bool
0da8eb3a 2861S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 2862{
81611534
JH		 2863#ifndef PERL_IMPLICIT_SYS
2864 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */
2865 PERL_UNUSED_CONTEXT;
2866#endif
985213f2 2867 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 2868 return TRUE;
fe14fcc3 2869#ifdef HAS_GETGROUPS
a687059c 2870 {
331b57bc 2871 Groups_t *gary = NULL;
79072805 2872 I32 anum;
331b57bc 2873 bool rc = FALSE;
a687059c 2874
331b57bc 2875 anum = getgroups(0, gary);
375ed12a
JH		 2876 if (anum > 0) {
2877 Newx(gary, anum, Groups_t);
2878 anum = getgroups(anum, gary);
2879 while (--anum >= 0)
2880 if (gary[anum] == testgid) {
2881 rc = TRUE;
2882 break;
2883 }
331b57bc 2884
375ed12a
JH		 2885 Safefree(gary);
2886 }
331b57bc 2887 return rc;
a687059c 2888 }
c685562b 2889#else
a687059c 2890 return FALSE;
cd39f2b6 2891#endif
a687059c 2892}
c2ab57d4 2893
fe14fcc3 2894#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2895
79072805 2896I32
864dbfa3 2897Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2898{
0bcc34c2 2899 const key_t key = (key_t)SvNVx(*++mark);
c3312966 2900 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 2901 const I32 flags = SvIVx(*++mark);
294a48e9 2902
7918f24d 2903 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 2904 PERL_UNUSED_ARG(sp);
c2ab57d4 2905
748a9306 2906 SETERRNO(0,0);
c2ab57d4
LW		 2907 switch (optype)
2908 {
fe14fcc3 2909#ifdef HAS_MSG
79072805 2910 case OP_MSGGET:
c2ab57d4 2911 return msgget(key, flags);
e5d73d77 2912#endif
fe14fcc3 2913#ifdef HAS_SEM
79072805 2914 case OP_SEMGET:
c3312966 2915 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2916#endif
fe14fcc3 2917#ifdef HAS_SHM
79072805 2918 case OP_SHMGET:
c3312966 2919 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 2920#endif
fe14fcc3 2921#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2922 default:
fe13d51d 2923 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2924 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2925#endif
c2ab57d4
LW		 2926 }
2927 return -1; /* should never happen */
2928}
2929
79072805 2930I32
864dbfa3 2931Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2932{
c2ab57d4 2933 char *a;
a0d0e21e 2934 I32 ret = -1;
6867be6d 2935 const I32 id = SvIVx(*++mark);
95b63a38 2936#ifdef Semctl
6867be6d 2937 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2938#endif
6867be6d 2939 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL		 2940 SV * const astr = *++mark;
2941 STRLEN infosize = 0;
2942 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2943
7918f24d 2944 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2945 PERL_UNUSED_ARG(sp);
c2ab57d4
LW		 2946
2947 switch (optype)
2948 {
fe14fcc3 2949#ifdef HAS_MSG
79072805 2950 case OP_MSGCTL:
c2ab57d4
LW		 2951 if (cmd == IPC_STAT || cmd == IPC_SET)
2952 infosize = sizeof(struct msqid_ds);
2953 break;
e5d73d77 2954#endif
fe14fcc3 2955#ifdef HAS_SHM
79072805 2956 case OP_SHMCTL:
c2ab57d4
LW		 2957 if (cmd == IPC_STAT || cmd == IPC_SET)
2958 infosize = sizeof(struct shmid_ds);
2959 break;
e5d73d77 2960#endif
fe14fcc3 2961#ifdef HAS_SEM
79072805 2962 case OP_SEMCTL:
39398f3f 2963#ifdef Semctl
c2ab57d4
LW		 2964 if (cmd == IPC_STAT || cmd == IPC_SET)
2965 infosize = sizeof(struct semid_ds);
2966 else if (cmd == GETALL || cmd == SETALL)
2967 {
8e591e46 2968 struct semid_ds semds;
bd89102f 2969 union semun semun;
e6f0bdd6
GS		 2970#ifdef EXTRA_F_IN_SEMUN_BUF
2971 semun.buff = &semds;
2972#else
84902520 2973 semun.buf = &semds;
e6f0bdd6 2974#endif
c2ab57d4 2975 getinfo = (cmd == GETALL);
9b89d93d
GB		 2976 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2977 return -1;
6e21c824
LW		 2978 infosize = semds.sem_nsems * sizeof(short);
2979 /* "short" is technically wrong but much more portable
2980 than guessing about u_?short(_t)? */
c2ab57d4 2981 }
39398f3f 2982#else
fe13d51d 2983 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2984 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2985#endif
c2ab57d4 2986 break;
e5d73d77 2987#endif
fe14fcc3 2988#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2989 default:
fe13d51d 2990 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2991 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2992#endif
c2ab57d4
LW		 2993 }
2994
2995 if (infosize)
2996 {
2997 if (getinfo)
2998 {
93524f2b 2999 SvPV_force_nolen(astr);
a0d0e21e 3000 a = SvGROW(astr, infosize+1);
c2ab57d4
LW		 3001 }
3002 else
3003 {
93524f2b 3004 STRLEN len;
463ee0b2
LW		 3005 a = SvPV(astr, len);
3006 if (len != infosize)
cea2e8a9 3007 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH		 3008 PL_op_desc[optype],
3009 (unsigned long)len,
3010 (long)infosize);
c2ab57d4
LW		 3011 }
3012 }
3013 else
3014 {
0bcc34c2 3015 const IV i = SvIV(astr);
56431972 3016 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 3017 }
748a9306 3018 SETERRNO(0,0);
c2ab57d4
LW		 3019 switch (optype)
3020 {
fe14fcc3 3021#ifdef HAS_MSG
79072805 3022 case OP_MSGCTL:
bee1dbe2 3023 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 3024 break;
e5d73d77 3025#endif
fe14fcc3 3026#ifdef HAS_SEM
bd89102f 3027 case OP_SEMCTL: {
39398f3f 3028#ifdef Semctl
bd89102f
AD		 3029 union semun unsemds;
3030
64d76282
BC		 3031 if(cmd == SETVAL) {
3032 unsemds.val = PTR2nat(a);
3033 }
3034 else {
e6f0bdd6 3035#ifdef EXTRA_F_IN_SEMUN_BUF
64d76282 3036 unsemds.buff = (struct semid_ds *)a;
e6f0bdd6 3037#else
64d76282 3038 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 3039#endif
64d76282 3040 }
bd89102f 3041 ret = Semctl(id, n, cmd, unsemds);
39398f3f 3042#else
fe13d51d 3043 /* diag_listed_as: sem%s not implemented */
cea2e8a9 3044 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 3045#endif
bd89102f 3046 }
c2ab57d4 3047 break;
e5d73d77 3048#endif
fe14fcc3 3049#ifdef HAS_SHM
79072805 3050 case OP_SHMCTL:
bee1dbe2 3051 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 3052 break;
e5d73d77 3053#endif
c2ab57d4
LW		 3054 }
3055 if (getinfo && ret >= 0) {
79072805
LW		 3056 SvCUR_set(astr, infosize);
3057 *SvEND(astr) = '\0';
a0d0e21e 3058 SvSETMAGIC(astr);
c2ab57d4
LW		 3059 }
3060 return ret;
3061}
3062
79072805 3063I32
864dbfa3 3064Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 3065{
fe14fcc3 3066#ifdef HAS_MSG
463ee0b2 3067 STRLEN len;
6867be6d 3068 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 3069 SV * const mstr = *++mark;
3070 const I32 flags = SvIVx(*++mark);
3071 const char * const mbuf = SvPV_const(mstr, len);
3072 const I32 msize = len - sizeof(long);
3073
7918f24d 3074 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 3075 PERL_UNUSED_ARG(sp);
c2ab57d4 3076
0bcc34c2 3077 if (msize < 0)
cea2e8a9 3078 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 3079 SETERRNO(0,0);
681fb693
JH		 3080 if (id >= 0 && flags >= 0) {
3081 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
3082 } else {
3083 SETERRNO(EINVAL,LIB_INVARG);
3084 return -1;
3085 }
e5d73d77 3086#else
2d51fa4d
RGS		 3087 PERL_UNUSED_ARG(sp);
3088 PERL_UNUSED_ARG(mark);
fe13d51d 3089 /* diag_listed_as: msg%s not implemented */
cea2e8a9 3090 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 3091 return -1;
e5d73d77 3092#endif
c2ab57d4
LW		 3093}
3094
79072805 3095I32
864dbfa3 3096Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 3097{
fe14fcc3 3098#ifdef HAS_MSG
c2ab57d4
LW		 3099 char *mbuf;
3100 long mtype;
6867be6d 3101 I32 msize, flags, ret;
6867be6d 3102 const I32 id = SvIVx(*++mark);
0bcc34c2 3103 SV * const mstr = *++mark;
7918f24d
NC		 3104
3105 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 3106 PERL_UNUSED_ARG(sp);
79072805 3107
c2e66d9e
GS		 3108 /* suppress warning when reading into undef var --jhi */
3109 if (! SvOK(mstr))
8062ff11 3110 SvPVCLEAR(mstr);
463ee0b2
LW		 3111 msize = SvIVx(*++mark);
3112 mtype = (long)SvIVx(*++mark);
3113 flags = SvIVx(*++mark);
93524f2b 3114 SvPV_force_nolen(mstr);
a0d0e21e 3115 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 3116
748a9306 3117 SETERRNO(0,0);
d2607e1e
JH		 3118 if (id >= 0 && msize >= 0 && flags >= 0) {
3119 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
3120 } else {
3121 SETERRNO(EINVAL,LIB_INVARG);
3122 ret = -1;
3123 }
c2ab57d4 3124 if (ret >= 0) {
79072805
LW		 3125 SvCUR_set(mstr, sizeof(long)+ret);
3126 *SvEND(mstr) = '\0';
41d6edb2
JH		 3127 /* who knows who has been playing with this message? */
3128 SvTAINTED_on(mstr);
c2ab57d4
LW		 3129 }
3130 return ret;
e5d73d77 3131#else
2d51fa4d
RGS		 3132 PERL_UNUSED_ARG(sp);
3133 PERL_UNUSED_ARG(mark);
fe13d51d 3134 /* diag_listed_as: msg%s not implemented */
cea2e8a9 3135 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 3136 return -1;
e5d73d77 3137#endif
c2ab57d4
LW		 3138}
3139
79072805 3140I32
864dbfa3 3141Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 3142{
fe14fcc3 3143#ifdef HAS_SEM
463ee0b2 3144 STRLEN opsize;
6867be6d 3145 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 3146 SV * const opstr = *++mark;
3147 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC		 3148
3149 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 3150 PERL_UNUSED_ARG(sp);
c2ab57d4 3151
248ff010
NC		 3152 if (opsize < 3 * SHORTSIZE
3153 || (opsize % (3 * SHORTSIZE))) {
93189314 3154 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW		 3155 return -1;
3156 }
748a9306 3157 SETERRNO(0,0);
248ff010
NC		 3158 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
3159 {
6867be6d 3160 const int nsops = opsize / (3 * sizeof (short));
248ff010 3161 int i = nsops;
0bcc34c2 3162 short * const ops = (short *) opbuf;
248ff010
NC		 3163 short *o = ops;
3164 struct sembuf *temps, *t;
3165 I32 result;
3166
a02a5408 3167 Newx (temps, nsops, struct sembuf);
248ff010
NC		 3168 t = temps;
3169 while (i--) {
3170 t->sem_num = *o++;
3171 t->sem_op = *o++;
3172 t->sem_flg = *o++;
3173 t++;
3174 }
3175 result = semop(id, temps, nsops);
248ff010
NC		 3176 Safefree(temps);
3177 return result;
3178 }
e5d73d77 3179#else
fe13d51d 3180 /* diag_listed_as: sem%s not implemented */
cea2e8a9 3181 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 3182#endif
c2ab57d4
LW		 3183}
3184
79072805 3185I32
864dbfa3 3186Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 3187{
fe14fcc3 3188#ifdef HAS_SHM
4373e329 3189 char *shm;
c2ab57d4 3190 struct shmid_ds shmds;
6867be6d 3191 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 3192 SV * const mstr = *++mark;
3193 const I32 mpos = SvIVx(*++mark);
3194 const I32 msize = SvIVx(*++mark);
7918f24d
NC		 3195
3196 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 3197 PERL_UNUSED_ARG(sp);
c2ab57d4 3198
748a9306 3199 SETERRNO(0,0);
c2ab57d4
LW		 3200 if (shmctl(id, IPC_STAT, &shmds) == -1)
3201 return -1;
7f39519f
NC		 3202 if (mpos < 0 || msize < 0
3203 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 3204 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW		 3205 return -1;
3206 }
568fc267
JH		 3207 if (id >= 0) {
3208 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
3209 } else {
3210 SETERRNO(EINVAL,LIB_INVARG);
3211 return -1;
3212 }
c2ab57d4
LW		 3213 if (shm == (char *)-1) /* I hate System V IPC, I really do */
3214 return -1;
79072805 3215 if (optype == OP_SHMREAD) {
c8ae91a8 3216 char *mbuf;
9f538c04 3217 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS		 3218 SvGETMAGIC(mstr);
3219 SvUPGRADE(mstr, SVt_PV);
9f538c04 3220 if (! SvOK(mstr))
8062ff11 3221 SvPVCLEAR(mstr);
af8ff727 3222 SvPOK_only(mstr);
bb7a0f54 3223 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 3224
bee1dbe2 3225 Copy(shm + mpos, mbuf, msize, char);
79072805
LW		 3226 SvCUR_set(mstr, msize);
3227 *SvEND(mstr) = '\0';
a0d0e21e 3228 SvSETMAGIC(mstr);
d929ce6f
JH		 3229 /* who knows who has been playing with this shared memory? */
3230 SvTAINTED_on(mstr);
c2ab57d4
LW		 3231 }
3232 else {
93524f2b 3233 STRLEN len;
c2ab57d4 3234
93524f2b 3235 const char *mbuf = SvPV_const(mstr, len);
027aa12d 3236 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 3237 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 3238 if (n < msize)
bee1dbe2 3239 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW		 3240 }
3241 return shmdt(shm);
e5d73d77 3242#else
fe13d51d 3243 /* diag_listed_as: shm%s not implemented */
cea2e8a9 3244 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 3245 return -1;
e5d73d77 3246#endif
c2ab57d4
LW		 3247}
3248
fe14fcc3 3249#endif /* SYSV IPC */
4e35701f 3250
0d44d22b 3251/*
ccfc67b7
JH		 3252=head1 IO Functions
3253
0d44d22b
NC		 3254=for apidoc start_glob
3255
3256Function called by C<do_readline> to spawn a glob (or do the glob inside
154e47c8 3257perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
25047fde
KW		 3258this glob starter is only used by miniperl during the build process,
3259or when PERL_EXTERNAL_GLOB is defined.
75af9d73 3260Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
fab3f3a7 3261
0d44d22b
NC		 3262=cut
3263*/
3264
3265PerlIO *
3266Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
3267{
561b68a9 3268 SV * const tmpcmd = newSV(0);
0d44d22b 3269 PerlIO *fp;
41188aa0
TC		 3270 STRLEN len;
3271 const char *s = SvPV(tmpglob, len);
7918f24d
NC		 3272
3273 PERL_ARGS_ASSERT_START_GLOB;
3274
41188aa0 3275 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC		 3276 return NULL;
3277
0d44d22b
NC		 3278 ENTER;
3279 SAVEFREESV(tmpcmd);
3280#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
3281 /* since spawning off a process is a real performance hit */
dca5a913 3282
1cc9774b
CB		 3283PerlIO *
3284Perl_vms_start_glob
3285 (pTHX_ SV *tmpglob,
3286 IO *io);
3287
49a7a762 3288 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 3289
0d44d22b 3290#else /* !VMS */
4009c3ff
AC		 3291# ifdef DOSISH
3292# if defined(OS2)
0d44d22b
NC		 3293 sv_setpv(tmpcmd, "for a in ");
3294 sv_catsv(tmpcmd, tmpglob);
f8db7d5b 3295 sv_catpvs(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
4009c3ff 3296# elif defined(DJGPP)
0d44d22b
NC		 3297 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
3298 sv_catsv(tmpcmd, tmpglob);
4009c3ff 3299# else
0d44d22b
NC		 3300 sv_setpv(tmpcmd, "perlglob ");
3301 sv_catsv(tmpcmd, tmpglob);
f8db7d5b 3302 sv_catpvs(tmpcmd, " |");
4009c3ff
AC		 3303# endif
3304# elif defined(CSH)
0d44d22b 3305 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
f8db7d5b 3306 sv_catpvs(tmpcmd, " -cf 'set nonomatch; glob ");
0d44d22b 3307 sv_catsv(tmpcmd, tmpglob);
f8db7d5b 3308 sv_catpvs(tmpcmd, "' 2>/dev/null |");
4009c3ff 3309# else
0d44d22b
NC		 3310 sv_setpv(tmpcmd, "echo ");
3311 sv_catsv(tmpcmd, tmpglob);
f8db7d5b 3312 sv_catpvs(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
4009c3ff 3313# endif /* !DOSISH && !CSH */
93b2dae1 3314 {
acffc8af
FC		 3315 SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
3316 if (svp && *svp)
3317 save_helem_flags(GvHV(PL_envgv),
3318 newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
3319 SAVEf_SETMAGIC);
93b2dae1 3320 }
d5eb9a46
NC		 3321 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
3322 NULL, NULL, 0);
0d44d22b
NC		 3323 fp = IoIFP(io);
3324#endif /* !VMS */
3325 LEAVE;
de7dabb6
TC		 3326
3327 if (!fp && ckWARN(WARN_GLOB)) {
3328 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
3329 Strerror(errno));
3330 }
3331
0d44d22b
NC		 3332 return fp;
3333}
66610fdd
RGS		 3334
3335/*
14d04a33 3336 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3337 */
Unnamed repository; edit this file 'description' to name the repository.