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