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