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