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