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
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.
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.
17 * [p.684 of _The Lord of the Rings_, IV/vi: "The Forbidden Pool"]
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.
26 #define PERL_IN_DOIO_C
29 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
38 # ifndef HAS_SHMAT_PROTOTYPE
39 extern Shmat_t shmat (int, char *, int);
45 # if defined(_MSC_VER) || defined(__MINGW32__)
46 # include <sys/utime.h>
53 # define OPEN_EXCL O_EXCL
58 #define PERL_MODE_MAX 8
59 #define PERL_FLAGS_MAX 10
64 Perl_setfd_cloexec(int fd)
67 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
68 (void) fcntl(fd, F_SETFD, FD_CLOEXEC);
73 Perl_setfd_inhexec(int fd)
76 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
77 (void) fcntl(fd, F_SETFD, 0);
82 Perl_setfd_cloexec_for_nonsysfd(pTHX_ int fd)
90 Perl_setfd_inhexec_for_sysfd(pTHX_ int fd)
97 Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd)
100 if(fd <= PL_maxsysfd)
107 #define DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
109 int res = (GENOPEN_NORMAL); \
110 if(LIKELY(res != -1)) GENSETFD_CLOEXEC; \
113 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \
115 enum { CLOEXEC_EXPERIMENT = 0, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
116 # define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
117 GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
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; \
128 strategy = CLOEXEC_AFTER_OPEN; \
131 } else if (UNLIKELY((eno = errno) == EINVAL || \
133 res = (GENOPEN_NORMAL); \
134 if (LIKELY(res != -1)) { \
135 strategy = CLOEXEC_AFTER_OPEN; \
137 } else if (!LIKELY((eno = errno) == EINVAL || \
139 strategy = CLOEXEC_AFTER_OPEN; \
144 case CLOEXEC_AT_OPEN: \
145 return (GENOPEN_CLOEXEC); \
146 case CLOEXEC_AFTER_OPEN: \
147 DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC); \
151 # define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
152 GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
153 DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC)
156 #define DO_ONEOPEN_THEN_CLOEXEC(ONEOPEN_NORMAL) \
159 DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \
160 setfd_cloexec(fd)); \
162 #define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \
163 ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \
166 DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
168 fd = (ONEOPEN_CLOEXEC), \
169 fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \
172 #define DO_PIPESETFD_CLOEXEC(PIPEFD) \
174 setfd_cloexec((PIPEFD)[0]); \
175 setfd_cloexec((PIPEFD)[1]); \
177 #define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \
178 DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
179 #define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \
181 DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
182 (PIPEFD)[0], PIPEOPEN_CLOEXEC, \
183 PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
186 Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd)
188 #if !defined(PERL_IMPLICIT_SYS) && defined(F_DUPFD_CLOEXEC)
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.
195 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
197 fcntl(oldfd, F_DUPFD_CLOEXEC, 0),
200 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup(oldfd));
205 Perl_PerlLIO_dup2_cloexec(pTHX_ int oldfd, int newfd)
207 #if !defined(PERL_IMPLICIT_SYS) && defined(HAS_DUP3) && defined(O_CLOEXEC)
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.
214 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
216 dup3(oldfd, newfd, O_CLOEXEC),
217 PerlLIO_dup2(oldfd, newfd));
219 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup2(oldfd, newfd));
224 Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag)
227 PERL_ARGS_ASSERT_PERLLIO_OPEN_CLOEXEC;
228 #if defined(O_CLOEXEC)
229 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
231 PerlLIO_open(file, flag | O_CLOEXEC),
232 PerlLIO_open(file, flag));
234 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open(file, flag));
239 Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm)
242 PERL_ARGS_ASSERT_PERLLIO_OPEN3_CLOEXEC;
243 #if defined(O_CLOEXEC)
244 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
246 PerlLIO_open3(file, flag | O_CLOEXEC, perm),
247 PerlLIO_open3(file, flag, perm));
249 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open3(file, flag, perm));
254 Perl_my_mkstemp_cloexec(char *templte)
257 PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC;
258 #if defined(O_CLOEXEC)
259 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
261 Perl_my_mkostemp(templte, O_CLOEXEC),
262 Perl_my_mkstemp(templte));
264 DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkstemp(templte));
269 Perl_my_mkostemp_cloexec(char *templte, int flags)
272 PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC;
273 #if defined(O_CLOEXEC)
274 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
276 Perl_my_mkostemp(templte, flags | O_CLOEXEC),
277 Perl_my_mkostemp(templte, flags));
279 DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags));
285 Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
288 PERL_ARGS_ASSERT_PERLPROC_PIPE_CLOEXEC;
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.
294 # if !defined(PERL_IMPLICIT_SYS) && defined(HAS_PIPE2) && defined(O_CLOEXEC)
295 DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_pipe, pipefd,
296 pipe2(pipefd, O_CLOEXEC),
297 PerlProc_pipe(pipefd));
299 DO_PIPEOPEN_THEN_CLOEXEC(pipefd, PerlProc_pipe(pipefd));
307 Perl_PerlSock_socket_cloexec(pTHX_ int domain, int type, int protocol)
309 # if defined(SOCK_CLOEXEC)
311 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
313 PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol),
314 PerlSock_socket(domain, type, protocol));
316 DO_ONEOPEN_THEN_CLOEXEC(PerlSock_socket(domain, type, protocol));
321 Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr,
322 Sock_size_t *addrlen)
324 # if !defined(PERL_IMPLICIT_SYS) && \
325 defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC)
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.
332 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
334 accept4(listenfd, addr, addrlen, SOCK_CLOEXEC),
335 PerlSock_accept(listenfd, addr, addrlen));
337 DO_ONEOPEN_THEN_CLOEXEC(PerlSock_accept(listenfd, addr, addrlen));
343 #if defined (HAS_SOCKETPAIR) || \
344 (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && \
345 defined(AF_INET) && defined(PF_INET))
347 Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol,
351 PERL_ARGS_ASSERT_PERLSOCK_SOCKETPAIR_CLOEXEC;
353 DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_socketpair, pairfd,
354 PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd),
355 PerlSock_socketpair(domain, type, protocol, pairfd));
357 DO_PIPEOPEN_THEN_CLOEXEC(pairfd,
358 PerlSock_socketpair(domain, type, protocol, pairfd));
364 S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp,
365 int *savefd, char *savetype)
367 IO * const io = GvIOn(gv);
369 PERL_ARGS_ASSERT_OPENN_SETUP;
374 *savetype = IoTYPE_CLOSED;
376 Zero(mode,sizeof(mode),char);
377 PL_forkprocess = 1; /* assume true if no fork */
379 /* If currently open - close before we re-open */
381 if (IoTYPE(io) == IoTYPE_STD) {
382 /* This is a clone of one of STD* handles */
385 const int old_fd = PerlIO_fileno(IoIFP(io));
387 if (old_fd >= 0 && old_fd <= PL_maxsysfd) {
388 /* This is one of the original STD* handles */
389 *saveifp = IoIFP(io);
390 *saveofp = IoOFP(io);
391 *savetype = IoTYPE(io);
397 if (IoTYPE(io) == IoTYPE_PIPE)
398 result = PerlProc_pclose(IoIFP(io));
399 else if (IoIFP(io) != IoOFP(io)) {
401 result = PerlIO_close(IoOFP(io));
402 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
405 result = PerlIO_close(IoIFP(io));
408 result = PerlIO_close(IoIFP(io));
410 if (result == EOF && old_fd > PL_maxsysfd) {
411 /* Why is this not Perl_warn*() call ? */
412 PerlIO_printf(Perl_error_log,
413 "Warning: unable to close filehandle %" HEKf
415 HEKfARG(GvENAME_HEK(gv))
420 IoOFP(io) = IoIFP(io) = NULL;
426 Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
427 int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
430 PERL_ARGS_ASSERT_DO_OPENN;
433 /* sysopen style args, i.e. integer mode and permissions */
436 Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld",
439 return do_open_raw(gv, oname, len, rawmode, rawperm, NULL);
441 return do_open6(gv, oname, len, supplied_fp, svp, num_svs);
445 Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len,
446 int rawmode, int rawperm, Stat_t *statbufp)
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);
457 PERL_ARGS_ASSERT_DO_OPEN_RAW;
459 /* For ease of blame back to 5.000, keep the existing indenting. */
461 /* sysopen style args, i.e. integer mode and permissions */
463 const int appendtrunc =
465 #ifdef O_APPEND /* Not fully portable. */
468 #ifdef O_TRUNC /* Not fully portable. */
472 const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc;
482 It might be (in OS/390 and Mac OS Classic it is)
488 This means that simple & with O_RDWR would look
489 like O_RDONLY is present. Therefore we have to
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");
498 mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */
500 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
501 rawmode |= O_LARGEFILE; /* Transparently largefiley. */
504 IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
506 namesv = newSVpvn_flags(oname, len, SVs_TEMP);
507 fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv);
509 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
510 savetype, writing, 0, NULL, statbufp);
514 Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len,
515 PerlIO *supplied_fp, SV **svp, U32 num_svs)
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);
525 bool was_fdopen = FALSE;
528 PERL_ARGS_ASSERT_DO_OPEN6;
530 /* For ease of blame back to 5.000, keep the existing indenting. */
532 /* Regular (non-sys) open */
537 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
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);
549 type = savepvn(oname, len);
553 /* Lose leading and trailing white space */
554 while (isSPACE(*type))
556 while (tend > type && isSPACE(tend[-1]))
562 /* New style explicit name, type is just mode and layer info */
564 if (SvROK(*svp) && !memchr(oname, '&', len)) {
566 Perl_warner(aTHX_ packWARN(WARN_IO),
567 "Can't open a reference");
568 SETERRNO(EINVAL, LIB_INVARG);
572 #endif /* USE_STDIO */
573 p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL;
575 if (p && !IS_SAFE_PATHNAME(p, nlen, "open")) {
580 name = p ? savepvn(p, nlen) : savepvs("");
589 if ((*type == IoTYPE_RDWR) && /* scary */
590 (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) &&
591 ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) {
592 TAINT_PROPER("open");
597 if (*type == IoTYPE_PIPE) {
599 if (type[1] != IoTYPE_STD) {
601 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
607 } while (isSPACE(*type));
613 /* command is missing 19990114 */
614 if (ckWARN(WARN_PIPE))
615 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
620 if (!(*name == '-' && name[1] == '\0') || num_svs)
622 TAINT_PROPER("piped open");
623 if (!num_svs && name[len-1] == '|') {
625 if (ckWARN(WARN_PIPE))
626 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe");
635 fp = PerlProc_popen_list(mode, num_svs, svp);
638 fp = PerlProc_popen(name,mode);
642 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
649 else if (*type == IoTYPE_WRONLY) {
650 TAINT_PROPER("open");
652 if (*type == IoTYPE_WRONLY) {
653 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
654 mode[0] = IoTYPE(io) = IoTYPE_APPEND;
668 dodup = PERLIO_DUP_FD;
674 if (!num_svs && !*type && supplied_fp) {
675 /* "<+&" etc. is used by typemaps */
679 PerlIO *that_fp = NULL;
683 /* diag_listed_as: More than one argument to '%s' open */
684 Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
686 while (isSPACE(*type))
690 || (SvPOKp(*svp) && looks_like_number(*svp))
692 wanted_fd = SvUV(*svp);
695 else if (isDIGIT(*type)
696 && grok_atoUV(type, &uv, NULL)
704 thatio = sv_2io(*svp);
707 GV * const thatgv = gv_fetchpvn_flags(type, tend - type,
709 thatio = GvIO(thatgv);
713 SETERRNO(EINVAL,SS_IVCHAN);
718 if ((that_fp = IoIFP(thatio))) {
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
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 */
728 PerlIO_flush(that_fp);
729 wanted_fd = PerlIO_fileno(that_fp);
730 /* When dup()ing STDIN, STDOUT or STDERR
731 * explicitly set appropriate access mode */
732 if (that_fp == PerlIO_stdout()
733 || that_fp == PerlIO_stderr())
734 IoTYPE(io) = IoTYPE_WRONLY;
735 else if (that_fp == PerlIO_stdin())
736 IoTYPE(io) = IoTYPE_RDONLY;
737 /* When dup()ing a socket, say result is
739 else if (IoTYPE(thatio) == IoTYPE_SOCKET)
740 IoTYPE(io) = IoTYPE_SOCKET;
743 SETERRNO(EBADF, RMS_IFI);
751 fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
755 wanted_fd = PerlLIO_dup_cloexec(wanted_fd);
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);
766 while (isSPACE(*type))
768 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
770 fp = PerlIO_stdout();
771 IoTYPE(io) = IoTYPE_STD;
773 /* diag_listed_as: More than one argument to '%s' open */
774 Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
779 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
782 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
784 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
788 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
789 goto unknown_open_mode;
790 } /* IoTYPE_WRONLY */
791 else if (*type == IoTYPE_RDONLY) {
794 } while (isSPACE(*type));
803 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
806 IoTYPE(io) = IoTYPE_STD;
808 /* diag_listed_as: More than one argument to '%s' open */
809 Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
814 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
817 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
819 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
822 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
823 goto unknown_open_mode;
824 } /* IoTYPE_RDONLY */
825 else if ((num_svs && /* '-|...' or '...|' */
826 type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
827 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
829 type += 2; /* skip over '-|' */
833 while (tend > type && isSPACE(tend[-1]))
835 for (; isSPACE(*type); type++)
841 /* command is missing 19990114 */
842 if (ckWARN(WARN_PIPE))
843 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
848 if (!(*name == '-' && name[1] == '\0') || num_svs)
850 TAINT_PROPER("piped open");
859 fp = PerlProc_popen_list(mode,num_svs,svp);
862 fp = PerlProc_popen(name,mode);
864 IoTYPE(io) = IoTYPE_PIPE;
866 while (isSPACE(*type))
869 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
876 else { /* layer(Args) */
878 goto unknown_open_mode;
880 IoTYPE(io) = IoTYPE_RDONLY;
881 for (; isSPACE(*name); name++)
890 if (*name == '-' && name[1] == '\0') {
892 IoTYPE(io) = IoTYPE_STD;
896 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
899 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
901 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
908 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
909 savetype, writing, was_fdopen, type, NULL);
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. */
915 S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
916 PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype,
917 int writing, bool was_fdopen, const char *type, Stat_t *statbufp)
922 PERL_ARGS_ASSERT_OPENN_CLEANUP;
924 Zero(&statbuf, 1, Stat_t);
927 if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE)
928 && should_warn_nl(oname)
932 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
933 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
934 GCC_DIAG_RESTORE_STMT;
939 if (ckWARN(WARN_IO)) {
940 if ((IoTYPE(io) == IoTYPE_RDONLY) &&
941 (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
942 Perl_warner(aTHX_ packWARN(WARN_IO),
943 "Filehandle STD%s reopened as %" HEKf
945 ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
946 HEKfARG(GvENAME_HEK(gv)));
948 else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
949 Perl_warner(aTHX_ packWARN(WARN_IO),
950 "Filehandle STDIN reopened as %" HEKf " only for output",
951 HEKfARG(GvENAME_HEK(gv))
956 fd = PerlIO_fileno(fp);
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.
961 if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
962 if (PerlLIO_fstat(fd,&statbuf) < 0) {
963 /* If PerlIO claims to have fd we had better be able to fstat() it. */
964 (void) PerlIO_close(fp);
968 if (S_ISSOCK(statbuf.st_mode))
969 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
972 !(statbuf.st_mode & S_IFMT)
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 */
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 */
983 #endif /* HAS_SOCKET */
984 #endif /* !PERL_MICRO */
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 !
992 if (saveifp) { /* must use old fp? */
993 /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
994 then dup the new fileno down
997 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
998 if (saveofp != saveifp) { /* was a socket? */
999 PerlIO_close(saveofp);
1003 /* Still a small can-of-worms here if (say) PerlIO::scalar
1004 is assigned to (say) STDOUT - for now let dup2() fail
1005 and provide the error
1008 SETERRNO(EBADF,RMS_IFI);
1010 } else if (PerlLIO_dup2(fd, savefd) < 0) {
1011 (void)PerlIO_close(fp);
1015 if (savefd != PerlIO_fileno(PerlIO_stdin())) {
1016 char newname[FILENAME_MAX+1];
1017 if (PerlIO_getname(fp, newname)) {
1018 if (fd == PerlIO_fileno(PerlIO_stdout()))
1019 vmssetuserlnm("SYS$OUTPUT", newname);
1020 if (fd == PerlIO_fileno(PerlIO_stderr()))
1021 vmssetuserlnm("SYS$ERROR", newname);
1027 /* PL_fdpid isn't used on Windows, so avoid this useless work.
1028 * XXX Probably the same for a lot of other places. */
1033 sv = *av_fetch(PL_fdpid,fd,TRUE);
1034 SvUPGRADE(sv, SVt_IV);
1037 sv = *av_fetch(PL_fdpid,savefd,TRUE);
1038 SvUPGRADE(sv, SVt_IV);
1044 /* need to close fp without closing underlying fd */
1045 int ofd = PerlIO_fileno(fp);
1046 int dupfd = ofd >= 0 ? PerlLIO_dup_cloexec(ofd) : -1;
1047 if (ofd < 0 || dupfd < 0) {
1049 PerlLIO_close(dupfd);
1053 PerlLIO_dup2_cloexec(dupfd, ofd);
1054 setfd_inhexec_for_sysfd(ofd);
1055 PerlLIO_close(dupfd);
1061 PerlIO_clearerr(fp);
1062 fd = PerlIO_fileno(fp);
1066 IoFLAGS(io) &= ~IOf_NOLINE;
1068 if (IoTYPE(io) == IoTYPE_SOCKET
1069 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) {
1071 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
1074 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
1083 *statbufp = statbuf;
1088 IoIFP(io) = saveifp;
1089 IoOFP(io) = saveofp;
1090 IoTYPE(io) = savetype;
1094 /* Open a temp file in the same directory as an original name.
1098 S_openindirtemp(pTHX_ GV *gv, SV *orig_name, SV *temp_out_name) {
1101 const char *p = SvPV_nolen(orig_name);
1104 /* look for the last directory separator */
1105 sep = strrchr(p, '/');
1110 if ((sep2 = strrchr(sep ? sep : p, '\\')))
1116 const char *openp = strchr(p, '[');
1118 sep = strchr(openp, ']');
1120 sep = strchr(p, ':');
1125 sv_setpvn(temp_out_name, p, sep - p + 1);
1126 sv_catpvs(temp_out_name, "XXXXXXXX");
1129 sv_setpvs(temp_out_name, "XXXXXXXX");
1132 int old_umask = umask(0177);
1133 fd = Perl_my_mkstemp_cloexec(SvPVX(temp_out_name));
1140 fp = PerlIO_fdopen(fd, "w+");
1144 return do_openn(gv, "+>&", 3, 0, 0, 0, fp, NULL, 0);
1147 #if defined(HAS_UNLINKAT) && defined(HAS_RENAMEAT) && defined(HAS_FCHMODAT) && \
1148 (defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)) && !defined(NO_USE_ATFUNCTIONS) && \
1150 # define ARGV_USE_ATFUNCTIONS
1153 /* Win32 doesn't necessarily return useful information
1154 * in st_dev, st_ino.
1157 # define ARGV_USE_STAT_INO
1160 #define ARGVMG_BACKUP_NAME 0
1161 #define ARGVMG_TEMP_NAME 1
1162 #define ARGVMG_ORIG_NAME 2
1163 #define ARGVMG_ORIG_MODE 3
1164 #define ARGVMG_ORIG_PID 4
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
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.
1176 #ifdef ARGV_USE_STAT_INO
1177 # define ARGVMG_ORIG_CWD_STAT 5
1180 #ifdef ARGV_USE_ATFUNCTIONS
1181 # define ARGVMG_ORIG_DIRP 6
1185 #define NotSupported(e) ((e) == ENOSYS || (e) == ENOTSUP)
1187 #define NotSupported(e) ((e) == ENOSYS)
1191 S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
1192 PERL_UNUSED_ARG(io);
1194 /* note this can be entered once the file has been
1195 successfully deleted too */
1196 assert(IoTYPE(io) != IoTYPE_PIPE);
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 */
1201 #ifdef ARGV_USE_ATFUNCTIONS
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));
1210 if (PL_phase == PERL_PHASE_DESTRUCT && PL_statusvalue == 0) {
1211 (void)argvout_final(mg, (IO*)io, FALSE);
1215 PerlIO *iop = IoIFP(io);
1217 assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
1219 pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
1221 assert(pid_psv && *pid_psv);
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
1227 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1228 const char *temp_pv = SvPVX(*temp_psv);
1230 assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
1231 (void)PerlIO_close(iop);
1232 IoIFP(io) = IoOFP(io) = NULL;
1233 #ifdef ARGV_USE_ATFUNCTIONS
1235 if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
1236 NotSupported(errno))
1237 (void)UNLINK(temp_pv);
1240 (void)UNLINK(temp_pv);
1245 #ifdef ARGV_USE_ATFUNCTIONS
1255 S_argvout_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
1256 PERL_UNUSED_ARG(param);
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);
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
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
1273 If we have useful inode/device ids in stat_t we also keep:
1274 5: a stat of the original current working directory
1276 If we have unlinkat(), renameat(), fchmodat(), dirfd() we also keep:
1277 6: the DIR * for the current directory when we open the file, stored as an IV
1280 static const MGVTBL argvout_vtbl =
1285 NULL, /* svt_clear */
1286 S_argvout_free, /* svt_free */
1287 NULL, /* svt_copy */
1288 S_argvout_dup, /* svt_dup */
1289 NULL /* svt_local */
1293 Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
1295 IO * const io = GvIOp(gv);
1296 SV *const old_out_name = PL_inplace ? newSVsv(GvSV(gv)) : NULL;
1298 PERL_ARGS_ASSERT_NEXTARGV;
1301 SAVEFREESV(old_out_name);
1304 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
1305 if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
1306 IoFLAGS(io) &= ~IOf_START;
1308 assert(PL_defoutgv);
1309 Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
1310 SvREFCNT_inc_simple_NN(PL_defoutgv));
1315 IO * const io = GvIOp(PL_argvoutgv);
1316 if (io && IoIFP(io) && old_out_name) {
1317 do_close(PL_argvoutgv, FALSE);
1325 while (av_tindex(GvAV(gv)) >= 0) {
1327 SV *const sv = av_shift(GvAV(gv));
1329 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
1330 sv_setsv(GvSVn(gv),sv);
1331 SvSETMAGIC(GvSV(gv));
1332 PL_oldname = SvPVx(GvSV(gv), oldlen);
1333 if (LIKELY(!PL_inplace)) {
1335 ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)
1336 : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)
1338 return IoIFP(GvIOp(gv));
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
1347 if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0, &statbuf)) {
1348 #ifndef FLEXFILENAMES
1352 #ifdef ARGV_USE_ATFUNCTIONS
1357 AV *magic_av = NULL;
1358 SV *temp_name_sv = NULL;
1361 TAINT_PROPER("inplace open");
1362 if (oldlen == 1 && *PL_oldname == '-') {
1363 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
1365 return IoIFP(GvIOp(gv));
1367 #ifndef FLEXFILENAMES
1368 filedev = statbuf.st_dev;
1369 fileino = statbuf.st_ino;
1371 PL_filemode = statbuf.st_mode;
1372 fileuid = statbuf.st_uid;
1373 filegid = statbuf.st_gid;
1374 if (!S_ISREG(PL_filemode)) {
1375 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1376 "Can't do inplace edit: %s is not a regular file",
1382 if (*PL_inplace && strNE(PL_inplace, "*")) {
1383 const char *star = strchr(PL_inplace, '*');
1385 const char *begin = PL_inplace;
1388 sv_catpvn(sv, begin, star - begin);
1389 sv_catpvn(sv, PL_oldname, oldlen);
1391 } while ((star = strchr(begin, '*')));
1396 sv_catpv(sv,PL_inplace);
1398 #ifndef FLEXFILENAMES
1399 if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0
1400 && statbuf.st_dev == filedev
1401 && statbuf.st_ino == fileino)
1403 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
1407 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1408 "Can't do inplace edit: %"
1409 SVf " would not be unique",
1414 av_store(magic_av, ARGVMG_BACKUP_NAME, newSVsv(sv));
1417 sv_setpvn(sv,PL_oldname,oldlen);
1418 SETERRNO(0,0); /* in case sprintf set errno */
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",
1424 PL_oldname, Strerror(errno) );
1425 #ifndef FLEXFILENAMES
1429 SvREFCNT_dec(magic_av);
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));
1435 av_store(magic_av, ARGVMG_ORIG_PID, newSViv((IV)PerlProc_getpid()));
1436 #if defined(ARGV_USE_ATFUNCTIONS)
1437 curdir = opendir(".");
1438 av_store(magic_av, ARGVMG_ORIG_DIRP, newSViv(PTR2IV(curdir)));
1439 #elif defined(ARGV_USE_STAT_INO)
1440 if (PerlLIO_stat(".", &statbuf) >= 0) {
1441 av_store(magic_av, ARGVMG_ORIG_CWD_STAT,
1442 newSVpvn((char *)&statbuf, sizeof(statbuf)));
1445 setdefout(PL_argvoutgv);
1446 sv_setsv(GvSVn(PL_argvoutgv), temp_name_sv);
1447 mg = sv_magicext((SV*)GvIOp(PL_argvoutgv), (SV*)magic_av, PERL_MAGIC_uvar, &argvout_vtbl, NULL, 0);
1448 mg->mg_flags |= MGf_DUP;
1449 SvREFCNT_dec(magic_av);
1450 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
1451 if (PL_lastfd >= 0) {
1452 (void)PerlLIO_fstat(PL_lastfd,&statbuf);
1454 (void)fchmod(PL_lastfd,PL_filemode);
1456 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
1458 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
1459 /* XXX silently ignore failures */
1461 PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
1462 #elif defined(HAS_CHOWN)
1463 PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid));
1467 return IoIFP(GvIOp(gv));
1469 } /* successful do_open_raw(), PL_inplace non-NULL */
1471 if (ckWARN_d(WARN_INPLACE)) {
1472 const int eno = errno;
1474 if (PerlLIO_stat(PL_oldname, &statbuf) >= 0
1475 && !S_ISREG(statbuf.st_mode)) {
1476 Perl_warner(aTHX_ packWARN(WARN_INPLACE),
1477 "Can't do inplace edit: %s is not a regular file",
1481 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
1482 PL_oldname, Strerror(eno));
1486 if (io && (IoFLAGS(io) & IOf_ARGV))
1487 IoFLAGS(io) |= IOf_START;
1489 if (io && (IoFLAGS(io) & IOf_ARGV)
1490 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
1492 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
1494 SvREFCNT_dec_NN(oldout);
1497 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
1502 #ifdef ARGV_USE_ATFUNCTIONS
1503 # if defined(__FreeBSD__) || defined(__FreeBSD_kernel__)
1505 /* FreeBSD 11 renameat() mis-behaves strangely with absolute paths in cases where the
1506 * equivalent rename() succeeds
1509 S_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);
1517 return renameat(olddfd, oldpath, newdfd, newpath);
1522 # define S_my_renameat(dh1, pv1, dh2, pv2) renameat((dh1), (pv1), (dh2), (pv2))
1523 # endif /* if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) */
1527 S_dir_unchanged(pTHX_ const char *orig_pv, MAGIC *mg) {
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;
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
1540 if (!PERL_FILE_IS_ABSOLUTE(orig_pv)
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");
1549 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1551 /* Some platforms don't have useful st_ino etc, so just
1552 check we can see the work file.
1554 if (!PERL_FILE_IS_ABSOLUTE(orig_pv)
1555 && PerlLIO_stat(SvPVX(*temp_psv), &statbuf) < 0) {
1556 Perl_croak(aTHX_ "Cannot complete in-place edit of %s: %s",
1558 "Work file is missing - did you change directory?");
1565 #define dir_unchanged(orig_psv, mg) \
1566 S_dir_unchanged(aTHX_ (orig_psv), (mg))
1569 S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool not_implicit) {
1572 /* ensure args are checked before we start using them */
1573 PERL_ARGS_ASSERT_ARGVOUT_FINAL;
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);
1582 SV **pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
1583 #if defined(ARGV_USE_ATFUNCTIONS)
1584 SV **dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
1591 const char *orig_pv;
1593 assert(temp_psv && *temp_psv);
1594 assert(orig_psv && *orig_psv);
1595 assert(mode_psv && *mode_psv);
1596 assert(pid_psv && *pid_psv);
1597 #ifdef ARGV_USE_ATFUNCTIONS
1598 assert(dir_psv && *dir_psv);
1599 dir = INT2PTR(DIR *, SvIVX(*dir_psv));
1600 dfd = my_dirfd(dir);
1603 orig_pv = SvPVX(*orig_psv);
1604 mode = SvUV(*mode_psv);
1606 if ((mode & (S_ISUID|S_ISGID)) != 0
1607 && (fd = PerlIO_fileno(IoIFP(io))) >= 0) {
1608 (void)PerlIO_flush(IoIFP(io));
1610 (void)fchmod(fd, mode);
1612 (void)PerlLIO_chmod(orig_pv, mode);
1616 retval = io_close(io, NULL, not_implicit, FALSE);
1618 if (SvIV(*pid_psv) != (IV)PerlProc_getpid()) {
1619 /* this is a child process, don't duplicate our rename() etc
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);
1632 #ifndef ARGV_USE_ATFUNCTIONS
1633 if (!dir_unchanged(orig_pv, mg))
1636 if (back_psv && *back_psv) {
1637 #if defined(HAS_LINK) && !defined(DOSISH) && !defined(__CYGWIN__) && defined(HAS_RENAME)
1639 # ifdef ARGV_USE_ATFUNCTIONS
1640 linkat(dfd, orig_pv, dfd, SvPVX(*back_psv), 0) < 0 &&
1641 !(UNLIKELY(NotSupported(errno)) &&
1642 dir_unchanged(orig_pv, mg) &&
1643 link(orig_pv, SvPVX(*back_psv)) == 0)
1645 link(orig_pv, SvPVX(*back_psv)) < 0
1652 # ifdef ARGV_USE_ATFUNCTIONS
1653 S_my_renameat(dfd, orig_pv, dfd, SvPVX(*back_psv)) < 0 &&
1654 !(UNLIKELY(NotSupported(errno)) &&
1655 dir_unchanged(orig_pv, mg) &&
1656 PerlLIO_rename(orig_pv, SvPVX(*back_psv)) == 0)
1658 PerlLIO_rename(orig_pv, SvPVX(*back_psv)) < 0
1661 if (!not_implicit) {
1662 # ifdef ARGV_USE_ATFUNCTIONS
1663 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) < 0 &&
1664 UNLIKELY(NotSupported(errno)) &&
1665 dir_unchanged(orig_pv, mg))
1666 (void)UNLINK(SvPVX_const(*temp_psv));
1668 UNLINK(SvPVX(*temp_psv));
1670 Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file",
1671 SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno));
1673 /* should we warn here? */
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));
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);
1691 #if defined(DOSISH) || defined(__CYGWIN__) || !defined(HAS_RENAME)
1697 #if !defined(HAS_RENAME)
1698 link(SvPVX(*temp_psv), orig_pv) < 0
1699 #elif defined(ARGV_USE_ATFUNCTIONS)
1700 S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 &&
1701 !(UNLIKELY(NotSupported(errno)) &&
1702 dir_unchanged(orig_pv, mg) &&
1703 PerlLIO_rename(SvPVX(*temp_psv), orig_pv) == 0)
1705 PerlLIO_rename(SvPVX(*temp_psv), orig_pv) < 0
1708 if (!not_implicit) {
1709 #ifdef ARGV_USE_ATFUNCTIONS
1710 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) < 0 &&
1711 NotSupported(errno))
1712 UNLINK(SvPVX(*temp_psv));
1714 UNLINK(SvPVX(*temp_psv));
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));
1721 UNLINK(SvPVX_const(*temp_psv));
1725 UNLINK(SvPVX(*temp_psv));
1729 #ifdef ARGV_USE_ATFUNCTIONS
1730 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) &&
1731 NotSupported(errno))
1732 UNLINK(SvPVX_const(*temp_psv));
1735 UNLINK(SvPVX_const(*temp_psv));
1737 if (!not_implicit) {
1738 Perl_croak(aTHX_ "Failed to close in-place work file %s: %s",
1739 SvPVX(*temp_psv), Strerror(errno));
1748 /* explicit renamed to avoid C++ conflict -- kja */
1750 Perl_do_close(pTHX_ GV *gv, bool not_implicit)
1758 if (!gv || !isGV_with_GP(gv)) {
1760 SETERRNO(EBADF,SS_IVCHAN);
1764 if (!io) { /* never opened */
1767 SETERRNO(EBADF,SS_IVCHAN);
1771 if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl))
1773 retval = argvout_final(mg, io, not_implicit);
1774 mg_freeext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl);
1777 retval = io_close(io, NULL, not_implicit, FALSE);
1782 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1784 IoTYPE(io) = IoTYPE_CLOSED;
1789 Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
1791 bool retval = FALSE;
1793 PERL_ARGS_ASSERT_IO_CLOSE;
1796 if (IoTYPE(io) == IoTYPE_PIPE) {
1797 PerlIO *fh = IoIFP(io);
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.
1806 IoOFP(io) = IoIFP(io) = NULL;
1807 status = PerlProc_pclose(fh);
1809 STATUS_NATIVE_CHILD_SET(status);
1810 retval = (STATUS_UNIX == 0);
1813 retval = (status != -1);
1816 else if (IoTYPE(io) == IoTYPE_STD)
1819 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
1820 const bool prev_err = PerlIO_error(IoOFP(io));
1823 PerlIO_restore_errno(IoOFP(io));
1825 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
1826 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
1829 const bool prev_err = PerlIO_error(IoIFP(io));
1832 PerlIO_restore_errno(IoIFP(io));
1834 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1837 IoOFP(io) = IoIFP(io) = NULL;
1839 if (warn_on_fail && !retval) {
1841 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1842 "Warning: unable to close filehandle %"
1843 HEKf " properly: %" SVf,
1844 HEKfARG(GvNAME_HEK(gv)),
1845 SVfARG(get_sv("!",GV_ADD)));
1847 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1848 "Warning: unable to close filehandle "
1850 SVfARG(get_sv("!",GV_ADD)));
1853 else if (not_implicit) {
1854 SETERRNO(EBADF,SS_IVCHAN);
1861 Perl_do_eof(pTHX_ GV *gv)
1863 IO * const io = GvIO(gv);
1865 PERL_ARGS_ASSERT_DO_EOF;
1869 else if (IoTYPE(io) == IoTYPE_WRONLY)
1870 report_wrongway_fh(gv, '>');
1873 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
1874 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
1875 return FALSE; /* this is the most usual case */
1879 /* getc and ungetc can stomp on errno */
1881 const int ch = PerlIO_getc(IoIFP(io));
1883 (void)PerlIO_ungetc(IoIFP(io),ch);
1890 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
1891 if (PerlIO_get_cnt(IoIFP(io)) < -1)
1892 PerlIO_set_cnt(IoIFP(io),-1);
1894 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
1895 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */
1899 return TRUE; /* normal fp, definitely end of file */
1905 Perl_do_tell(pTHX_ GV *gv)
1907 IO *const io = GvIO(gv);
1910 PERL_ARGS_ASSERT_DO_TELL;
1912 if (io && (fp = IoIFP(io))) {
1913 return PerlIO_tell(fp);
1916 SETERRNO(EBADF,RMS_IFI);
1921 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
1923 IO *const io = GvIO(gv);
1926 if (io && (fp = IoIFP(io))) {
1927 return PerlIO_seek(fp, pos, whence) >= 0;
1930 SETERRNO(EBADF,RMS_IFI);
1935 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
1937 IO *const io = GvIO(gv);
1940 PERL_ARGS_ASSERT_DO_SYSSEEK;
1942 if (io && (fp = IoIFP(io))) {
1943 int fd = PerlIO_fileno(fp);
1944 if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
1945 SETERRNO(EINVAL,LIB_INVARG);
1948 return PerlLIO_lseek(fd, pos, whence);
1952 SETERRNO(EBADF,RMS_IFI);
1957 Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
1959 int mode = O_BINARY;
1960 PERL_UNUSED_CONTEXT;
1966 if (s[2] == 'a' && s[3] == 'w'
1967 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1976 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
1977 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1986 goto fail_discipline;
1989 else if (isSPACE(*s)) {
1996 end = (char *) memchr(s+1, ':', len);
1999 #ifndef PERLIO_LAYERS
2000 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
2011 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
2013 my_chsize(int fd, Off_t length)
2016 /* code courtesy of William Kucharski */
2021 if (PerlLIO_fstat(fd, &filebuf) < 0)
2024 if (filebuf.st_size < length) {
2026 /* extend file length */
2028 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
2031 /* write a "0" byte */
2033 if ((PerlLIO_write(fd, "", 1)) != 1)
2037 /* truncate length */
2041 fl.l_start = length;
2042 fl.l_type = F_WRLCK; /* write lock on file space */
2045 * This relies on the UNDOCUMENTED F_FREESP argument to
2046 * fcntl(2), which truncates the file so that it ends at the
2047 * position indicated by fl.l_start.
2049 * Will minor miracles never cease?
2052 if (fcntl(fd, F_FREESP, &fl) < 0)
2058 Perl_croak_nocontext("truncate not implemented");
2059 #endif /* F_FREESP */
2062 #endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
2065 Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
2067 PERL_ARGS_ASSERT_DO_PRINT;
2069 /* assuming fp is checked earlier */
2072 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
2073 assert(!SvGMAGICAL(sv));
2075 PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv));
2077 PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv));
2078 return !PerlIO_error(fp);
2082 /* Do this first to trigger any overloading. */
2083 const char *tmps = SvPV_const(sv, len);
2087 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
2088 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
2089 /* We don't modify the original scalar. */
2090 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
2091 tmps = (char *) tmpbuf;
2093 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
2094 (void) check_utf8_print((const U8*) tmps, len);
2096 } /* else stream isn't utf8 */
2097 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
2099 STRLEN tmplen = len;
2101 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
2104 /* Here, succeeded in downgrading from utf8. Set up to below
2105 * output the converted value */
2107 tmps = (char *) tmpbuf;
2110 else { /* Non-utf8 output stream, but string only representable in
2112 assert((char *)result == tmps);
2113 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2114 "Wide character in %s",
2115 PL_op ? OP_DESC(PL_op) : "print"
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 */
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))
2131 return happy ? !PerlIO_error(fp) : FALSE;
2136 Perl_my_stat_flags(pTHX_ const U32 flags)
2142 if (PL_op->op_flags & OPf_REF) {
2145 if (gv == PL_defgv) {
2146 if (PL_laststatval < 0)
2147 SETERRNO(EBADF,RMS_IFI);
2148 return PL_laststatval;
2152 PL_laststype = OP_STAT;
2153 PL_statgv = gv ? gv : (GV *)io;
2154 SvPVCLEAR(PL_statname);
2157 int fd = PerlIO_fileno(IoIFP(io));
2159 /* E.g. PerlIO::scalar has no real fd. */
2160 SETERRNO(EBADF,RMS_IFI);
2161 return (PL_laststatval = -1);
2163 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
2165 } else if (IoDIRP(io)) {
2166 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
2169 PL_laststatval = -1;
2171 SETERRNO(EBADF,RMS_IFI);
2174 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
2176 return PL_laststatval;
2178 SV* const sv = TOPs;
2181 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
2184 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2185 io = MUTABLE_IO(SvRV(sv));
2187 goto do_fstat_have_io;
2190 s = SvPV_flags_const(sv, len, flags);
2192 sv_setpvn(PL_statname, s, len);
2193 d = SvPVX_const(PL_statname); /* s now NUL-terminated */
2194 PL_laststype = OP_STAT;
2195 if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
2196 PL_laststatval = -1;
2199 PL_laststatval = PerlLIO_stat(d, &PL_statcache);
2201 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
2202 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
2203 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2204 GCC_DIAG_RESTORE_STMT;
2206 return PL_laststatval;
2212 Perl_my_lstat_flags(pTHX_ const U32 flags)
2214 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
2218 SV* const sv = TOPs;
2220 if (PL_op->op_flags & OPf_REF) {
2221 if (cGVOP_gv == PL_defgv) {
2222 if (PL_laststype != OP_LSTAT)
2223 Perl_croak(aTHX_ "%s", no_prev_lstat);
2224 if (PL_laststatval < 0)
2225 SETERRNO(EBADF,RMS_IFI);
2226 return PL_laststatval;
2228 PL_laststatval = -1;
2229 if (ckWARN(WARN_IO)) {
2230 /* diag_listed_as: Use of -l on filehandle%s */
2231 Perl_warner(aTHX_ packWARN(WARN_IO),
2232 "Use of -l on filehandle %" HEKf,
2233 HEKfARG(GvENAME_HEK(cGVOP_gv)));
2235 SETERRNO(EBADF,RMS_IFI);
2238 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
2240 if (PL_laststype != OP_LSTAT)
2241 Perl_croak(aTHX_ "%s", no_prev_lstat);
2242 return PL_laststatval;
2245 PL_laststype = OP_LSTAT;
2247 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
2248 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
2252 && ckWARN(WARN_IO)) {
2254 /* diag_listed_as: Use of -l on filehandle%s */
2255 Perl_warner(aTHX_ packWARN(WARN_IO),
2256 "Use of -l on filehandle");
2258 /* diag_listed_as: Use of -l on filehandle%s */
2259 Perl_warner(aTHX_ packWARN(WARN_IO),
2260 "Use of -l on filehandle %" HEKf,
2261 HEKfARG(GvENAME_HEK((const GV *)
2262 (SvROK(sv) ? SvRV(sv) : sv))));
2264 file = SvPV_flags_const(sv, len, flags);
2265 sv_setpv(PL_statname,file);
2266 if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
2267 PL_laststatval = -1;
2270 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
2272 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2273 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
2274 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
2275 GCC_DIAG_RESTORE_STMT;
2277 return PL_laststatval;
2281 S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
2283 const int e = errno;
2284 PERL_ARGS_ASSERT_EXEC_FAILED;
2286 if (ckWARN(WARN_EXEC))
2287 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
2290 /* XXX silently ignore failures */
2291 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
2297 Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2298 int fd, int do_report)
2301 PERL_ARGS_ASSERT_DO_AEXEC5;
2302 #if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
2303 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
2308 const char **argv, **a;
2309 const char *tmps = NULL;
2310 Newx(argv, sp - mark + 1, const char*);
2314 while (++mark <= sp) {
2316 char *arg = savepv(SvPV_nolen_const(*mark));
2324 tmps = savepv(SvPV_nolen_const(really));
2327 if ((!really && argv[0] && *argv[0] != '/') ||
2328 (really && *tmps != '/')) /* will execvp use PATH? */
2329 TAINT_ENV(); /* testing IFS here is overkill, probably */
2331 if (really && *tmps) {
2332 PerlProc_execvp(tmps,EXEC_ARGV_CAST(argv));
2333 } else if (argv[0]) {
2334 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
2336 SETERRNO(ENOENT,RMS_FNF);
2339 S_exec_failed(aTHX_ (really ? tmps : argv[0] ? argv[0] : ""), fd, do_report);
2346 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
2349 Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
2352 const char **argv, **a;
2356 /* Make a copy so we can change it */
2357 const Size_t cmdlen = strlen(incmd) + 1;
2359 PERL_ARGS_ASSERT_DO_EXEC3;
2362 Newx(buf, cmdlen, char);
2365 memcpy(cmd, incmd, cmdlen);
2367 while (*cmd && isSPACE(*cmd))
2370 /* save an extra exec if possible */
2374 char flags[PERL_FLAGS_MAX];
2375 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
2376 strBEGINs(cmd+PL_cshlen," -c")) {
2377 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
2378 s = cmd+PL_cshlen+3;
2381 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
2386 char * const ncmd = s;
2392 if (s[-1] == '\'') {
2395 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
2398 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
2406 /* see if there are shell metacharacters in it */
2408 if (*cmd == '.' && isSPACE(cmd[1]))
2411 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
2415 while (isWORDCHAR(*s))
2416 s++; /* catch VAR=val gizmo */
2420 for (s = cmd; *s; s++) {
2421 if (*s != ' ' && !isALPHA(*s) &&
2422 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
2423 if (*s == '\n' && !s[1]) {
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])))
2432 const char *t = s + 3;
2434 while (*t && isSPACE(*t))
2436 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
2443 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
2445 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
2450 Newx(argv, (s - cmd) / 2 + 2, const char*);
2452 cmd = savepvn(cmd, s-cmd);
2455 for (s = cmd; *s;) {
2460 while (*s && !isSPACE(*s))
2468 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
2470 if (errno == ENOEXEC) /* for system V NIH syndrome */
2472 S_exec_failed(aTHX_ argv[0], fd, do_report);
2479 #endif /* OS2 || WIN32 */
2482 Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
2486 const char *const what = PL_op_name[type];
2489 SV ** const oldmark = mark;
2490 bool killgp = FALSE;
2492 PERL_ARGS_ASSERT_APPLY;
2494 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
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. */
2500 if (type == OP_KILL)
2501 Perl_die(aTHX_ PL_no_func, what);
2504 if (type == OP_CHOWN)
2505 Perl_die(aTHX_ PL_no_func, what);
2509 #define APPLY_TAINT_PROPER() \
2511 if (TAINT_get) { TAINT_PROPER(what); } \
2514 /* This is a first heuristic; it doesn't catch tainting magic. */
2516 while (++mark <= sp) {
2517 if (SvTAINTED(*mark)) {
2526 APPLY_TAINT_PROPER();
2529 APPLY_TAINT_PROPER();
2531 while (++mark <= sp) {
2533 if ((gv = MAYBE_DEREF_GV(*mark))) {
2534 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2536 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
2537 APPLY_TAINT_PROPER();
2539 SETERRNO(EBADF,RMS_IFI);
2541 } else if (fchmod(fd, val))
2544 Perl_die(aTHX_ PL_no_func, "fchmod");
2548 SETERRNO(EBADF,RMS_IFI);
2553 const char *name = SvPV_nomg_const(*mark, len);
2554 APPLY_TAINT_PROPER();
2555 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
2556 PerlLIO_chmod(name, val)) {
2565 APPLY_TAINT_PROPER();
2566 if (sp - mark > 2) {
2568 val = SvIVx(*++mark);
2569 val2 = SvIVx(*++mark);
2570 APPLY_TAINT_PROPER();
2572 while (++mark <= sp) {
2574 if ((gv = MAYBE_DEREF_GV(*mark))) {
2575 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2577 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
2578 APPLY_TAINT_PROPER();
2580 SETERRNO(EBADF,RMS_IFI);
2582 } else if (fchown(fd, val, val2))
2585 Perl_die(aTHX_ PL_no_func, "fchown");
2589 SETERRNO(EBADF,RMS_IFI);
2594 const char *name = SvPV_nomg_const(*mark, len);
2595 APPLY_TAINT_PROPER();
2596 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
2597 PerlLIO_chown(name, val, val2)) {
2606 XXX Should we make lchown() directly available from perl?
2607 For now, we'll let Configure test for HAS_LCHOWN, but do
2608 nothing in the core.
2613 APPLY_TAINT_PROPER();
2616 s = SvPVx_const(*++mark, len);
2617 if (*s == '-' && isALPHA(s[1]))
2624 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
2628 if ((val = whichsig_pvn(s, len)) < 0)
2629 Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"",
2641 APPLY_TAINT_PROPER();
2644 while (++mark <= sp) {
2647 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
2648 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
2649 proc = SvIV_nomg(*mark);
2650 APPLY_TAINT_PROPER();
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))
2657 if (PerlProc_kill(killgp ? -proc: proc, val))
2665 APPLY_TAINT_PROPER();
2667 while (++mark <= sp) {
2668 s = SvPV_const(*mark, len);
2669 APPLY_TAINT_PROPER();
2670 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
2673 else if (PL_unsafe) {
2678 #if defined(__amigaos4__) && defined(NEWLIB)
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))
2691 else { /* don't let root wipe out directories without -U */
2693 if (PerlLIO_lstat(s, &statbuf) < 0)
2695 else if (S_ISDIR(statbuf.st_mode)) {
2696 SETERRNO(EISDIR, SS_NOPRIV);
2704 #if defined(__amigaos4__) && defined(NEWLIB)
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 */
2710 if((access(s,F_OK) != -1))
2720 #if defined(HAS_UTIME) || defined(HAS_FUTIMES)
2722 APPLY_TAINT_PROPER();
2723 if (sp - mark > 2) {
2724 #if defined(HAS_FUTIMES)
2725 struct timeval utbuf[2];
2726 void *utbufp = utbuf;
2727 #elif defined(I_UTIME) || defined(VMS)
2728 struct utimbuf utbuf;
2729 struct utimbuf *utbufp = &utbuf;
2735 void *utbufp = &utbuf;
2738 SV* const accessed = *++mark;
2739 SV* const modified = *++mark;
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". */
2745 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
2748 Zero(&utbuf, sizeof utbuf, char);
2750 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
2751 utbuf[0].tv_usec = 0;
2752 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
2753 utbuf[1].tv_usec = 0;
2754 #elif defined(BIG_TIME)
2755 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
2756 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
2758 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
2759 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
2762 APPLY_TAINT_PROPER();
2764 while (++mark <= sp) {
2766 if ((gv = MAYBE_DEREF_GV(*mark))) {
2767 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2769 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
2770 APPLY_TAINT_PROPER();
2772 SETERRNO(EBADF,RMS_IFI);
2774 } else if (futimes(fd, (struct timeval *) utbufp))
2777 Perl_die(aTHX_ PL_no_func, "futimes");
2785 const char * const name = SvPV_nomg_const(*mark, len);
2786 APPLY_TAINT_PROPER();
2787 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
2792 if (utimes(name, (struct timeval *)utbufp))
2794 if (PerlLIO_utime(name, utbufp))
2808 #undef APPLY_TAINT_PROPER
2811 /* Do the permissions in *statbufp allow some operation? */
2812 #ifndef VMS /* VMS' cando is in vms.c */
2814 Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
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().
2819 PERL_ARGS_ASSERT_CANDO;
2820 PERL_UNUSED_CONTEXT;
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
2826 * by the Microsoft C library stat() function for the following:
2831 * All files and directories are readable.
2832 * Directories and special files, e.g. "CON", cannot be
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
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
2844 return cBOOL(mode & statbufp->st_mode);
2846 #else /* ! DOSISH */
2848 if (ingroup(544,effective)) { /* member of Administrators */
2850 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
2852 if (mode == S_IXUSR) {
2853 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
2857 return TRUE; /* root reads and writes anything */
2860 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
2861 if (statbufp->st_mode & mode)
2862 return TRUE; /* ok as "user" */
2864 else if (ingroup(statbufp->st_gid,effective)) {
2865 if (statbufp->st_mode & mode >> 3)
2866 return TRUE; /* ok as "group" */
2868 else if (statbufp->st_mode & mode >> 6)
2869 return TRUE; /* ok as "other" */
2871 #endif /* ! DOSISH */
2876 S_ingroup(pTHX_ Gid_t testgid, bool effective)
2878 #ifndef PERL_IMPLICIT_SYS
2879 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */
2880 PERL_UNUSED_CONTEXT;
2882 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
2884 #ifdef HAS_GETGROUPS
2886 Groups_t *gary = NULL;
2890 anum = getgroups(0, gary);
2892 Newx(gary, anum, Groups_t);
2893 anum = getgroups(anum, gary);
2895 if (gary[anum] == testgid) {
2909 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
2912 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
2914 const key_t key = (key_t)SvNVx(*++mark);
2915 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
2916 const I32 flags = SvIVx(*++mark);
2918 PERL_ARGS_ASSERT_DO_IPCGET;
2919 PERL_UNUSED_ARG(sp);
2926 return msgget(key, flags);
2930 return semget(key, (int) SvIV(nsv), flags);
2934 return shmget(key, (size_t) SvUV(nsv), flags);
2936 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
2938 /* diag_listed_as: msg%s not implemented */
2939 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
2942 return -1; /* should never happen */
2946 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
2950 const I32 id = SvIVx(*++mark);
2952 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
2954 const I32 cmd = SvIVx(*++mark);
2955 SV * const astr = *++mark;
2956 STRLEN infosize = 0;
2957 I32 getinfo = (cmd == IPC_STAT);
2959 PERL_ARGS_ASSERT_DO_IPCCTL;
2960 PERL_UNUSED_ARG(sp);
2966 if (cmd == IPC_STAT || cmd == IPC_SET)
2967 infosize = sizeof(struct msqid_ds);
2972 if (cmd == IPC_STAT || cmd == IPC_SET)
2973 infosize = sizeof(struct shmid_ds);
2979 if (cmd == IPC_STAT || cmd == IPC_SET)
2980 infosize = sizeof(struct semid_ds);
2981 else if (cmd == GETALL || cmd == SETALL)
2983 struct semid_ds semds;
2985 #ifdef EXTRA_F_IN_SEMUN_BUF
2986 semun.buff = &semds;
2990 getinfo = (cmd == GETALL);
2991 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2993 infosize = semds.sem_nsems * sizeof(short);
2994 /* "short" is technically wrong but much more portable
2995 than guessing about u_?short(_t)? */
2998 /* diag_listed_as: sem%s not implemented */
2999 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
3003 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
3005 /* diag_listed_as: shm%s not implemented */
3006 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
3014 SvPV_force_nolen(astr);
3015 a = SvGROW(astr, infosize+1);
3020 a = SvPV(astr, len);
3021 if (len != infosize)
3022 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
3030 const IV i = SvIV(astr);
3031 a = INT2PTR(char *,i); /* ouch */
3038 ret = msgctl(id, cmd, (struct msqid_ds *)a);
3044 union semun unsemds;
3047 unsemds.val = PTR2nat(a);
3050 #ifdef EXTRA_F_IN_SEMUN_BUF
3051 unsemds.buff = (struct semid_ds *)a;
3053 unsemds.buf = (struct semid_ds *)a;
3056 ret = Semctl(id, n, cmd, unsemds);
3058 /* diag_listed_as: sem%s not implemented */
3059 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
3066 ret = shmctl(id, cmd, (struct shmid_ds *)a);
3070 if (getinfo && ret >= 0) {
3071 SvCUR_set(astr, infosize);
3072 *SvEND(astr) = '\0';
3079 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
3083 const I32 id = SvIVx(*++mark);
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);
3089 PERL_ARGS_ASSERT_DO_MSGSND;
3090 PERL_UNUSED_ARG(sp);
3093 Perl_croak(aTHX_ "Arg too short for msgsnd");
3095 if (id >= 0 && flags >= 0) {
3096 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
3098 SETERRNO(EINVAL,LIB_INVARG);
3102 PERL_UNUSED_ARG(sp);
3103 PERL_UNUSED_ARG(mark);
3104 /* diag_listed_as: msg%s not implemented */
3105 Perl_croak(aTHX_ "msgsnd not implemented");
3111 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
3116 I32 msize, flags, ret;
3117 const I32 id = SvIVx(*++mark);
3118 SV * const mstr = *++mark;
3120 PERL_ARGS_ASSERT_DO_MSGRCV;
3121 PERL_UNUSED_ARG(sp);
3123 /* suppress warning when reading into undef var --jhi */
3126 msize = SvIVx(*++mark);
3127 mtype = (long)SvIVx(*++mark);
3128 flags = SvIVx(*++mark);
3129 SvPV_force_nolen(mstr);
3130 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
3133 if (id >= 0 && msize >= 0 && flags >= 0) {
3134 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
3136 SETERRNO(EINVAL,LIB_INVARG);
3140 SvCUR_set(mstr, sizeof(long)+ret);
3141 *SvEND(mstr) = '\0';
3142 /* who knows who has been playing with this message? */
3147 PERL_UNUSED_ARG(sp);
3148 PERL_UNUSED_ARG(mark);
3149 /* diag_listed_as: msg%s not implemented */
3150 Perl_croak(aTHX_ "msgrcv not implemented");
3156 Perl_do_semop(pTHX_ SV **mark, SV **sp)
3160 const I32 id = SvIVx(*++mark);
3161 SV * const opstr = *++mark;
3162 const char * const opbuf = SvPV_const(opstr, opsize);
3164 PERL_ARGS_ASSERT_DO_SEMOP;
3165 PERL_UNUSED_ARG(sp);
3167 if (opsize < 3 * SHORTSIZE
3168 || (opsize % (3 * SHORTSIZE))) {
3169 SETERRNO(EINVAL,LIB_INVARG);
3173 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
3175 const int nsops = opsize / (3 * sizeof (short));
3177 short * const ops = (short *) opbuf;
3179 struct sembuf *temps, *t;
3182 Newx (temps, nsops, struct sembuf);
3190 result = semop(id, temps, nsops);
3195 /* diag_listed_as: sem%s not implemented */
3196 Perl_croak(aTHX_ "semop not implemented");
3201 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
3205 struct shmid_ds shmds;
3206 const I32 id = SvIVx(*++mark);
3207 SV * const mstr = *++mark;
3208 const I32 mpos = SvIVx(*++mark);
3209 const I32 msize = SvIVx(*++mark);
3211 PERL_ARGS_ASSERT_DO_SHMIO;
3212 PERL_UNUSED_ARG(sp);
3215 if (shmctl(id, IPC_STAT, &shmds) == -1)
3217 if (mpos < 0 || msize < 0
3218 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
3219 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
3223 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
3225 SETERRNO(EINVAL,LIB_INVARG);
3228 if (shm == (char *)-1) /* I hate System V IPC, I really do */
3230 if (optype == OP_SHMREAD) {
3232 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
3234 SvUPGRADE(mstr, SVt_PV);
3238 mbuf = SvGROW(mstr, (STRLEN)msize+1);
3240 Copy(shm + mpos, mbuf, msize, char);
3241 SvCUR_set(mstr, msize);
3242 *SvEND(mstr) = '\0';
3244 /* who knows who has been playing with this shared memory? */
3250 const char *mbuf = SvPV_const(mstr, len);
3251 const I32 n = ((I32)len > msize) ? msize : (I32)len;
3252 Copy(mbuf, shm + mpos, n, char);
3254 memzero(shm + mpos + n, msize - n);
3258 /* diag_listed_as: shm%s not implemented */
3259 Perl_croak(aTHX_ "shm I/O not implemented");
3264 #endif /* SYSV IPC */
3269 =for apidoc start_glob
3271 Function called by C<do_readline> to spawn a glob (or do the glob inside
3272 perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
3273 this glob starter is only used by miniperl during the build process,
3274 or when PERL_EXTERNAL_GLOB is defined.
3275 Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
3281 Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
3283 SV * const tmpcmd = newSV(0);
3286 const char *s = SvPV(tmpglob, len);
3288 PERL_ARGS_ASSERT_START_GLOB;
3290 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
3295 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
3296 /* since spawning off a process is a real performance hit */
3303 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
3308 sv_setpv(tmpcmd, "for a in ");
3309 sv_catsv(tmpcmd, tmpglob);
3310 sv_catpvs(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
3311 # elif defined(DJGPP)
3312 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
3313 sv_catsv(tmpcmd, tmpglob);
3315 sv_setpv(tmpcmd, "perlglob ");
3316 sv_catsv(tmpcmd, tmpglob);
3317 sv_catpvs(tmpcmd, " |");
3320 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
3321 sv_catpvs(tmpcmd, " -cf 'set nonomatch; glob ");
3322 sv_catsv(tmpcmd, tmpglob);
3323 sv_catpvs(tmpcmd, "' 2>/dev/null |");
3325 sv_setpv(tmpcmd, "echo ");
3326 sv_catsv(tmpcmd, tmpglob);
3327 sv_catpvs(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
3328 # endif /* !DOSISH && !CSH */
3330 SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
3332 save_helem_flags(GvHV(PL_envgv),
3333 newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
3336 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
3342 if (!fp && ckWARN(WARN_GLOB)) {
3343 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
3351 * ex: set ts=8 sts=4 sw=4 et: