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