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