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         if (S_ISSOCK(statbuf.st_mode))
1037             IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
1038 #ifdef HAS_SOCKET
1039         else if (
1040             !(statbuf.st_mode & S_IFMT)
1041             && IoTYPE(io) != IoTYPE_WRONLY  /* Dups of STD* filehandles already have */
1042             && IoTYPE(io) != IoTYPE_RDONLY  /* type so they aren't marked as sockets */
1043         ) {                                 /* on OS's that return 0 on fstat()ed pipe */
1044              char tmpbuf[256];
1045              Sock_size_t buflen = sizeof tmpbuf;
1046              if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
1047                       || errno != ENOTSOCK)
1048                     IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
1049                                                 /* but some return 0 for streams too, sigh */
1050         }
1051 #endif /* HAS_SOCKET */
1052     }
1053
1054     /* Eeek - FIXME !!!
1055      * If this is a standard handle we discard all the layer stuff
1056      * and just dup the fd into whatever was on the handle before !
1057      */
1058
1059     if (saveifp) {              /* must use old fp? */
1060         /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
1061            then dup the new fileno down
1062          */
1063         if (saveofp) {
1064             PerlIO_flush(saveofp);      /* emulate PerlIO_close() */
1065             if (saveofp != saveifp) {   /* was a socket? */
1066                 PerlIO_close(saveofp);
1067             }
1068         }
1069         if (savefd != fd) {
1070             /* Still a small can-of-worms here if (say) PerlIO::scalar
1071                is assigned to (say) STDOUT - for now let dup2() fail
1072                and provide the error
1073              */
1074             if (fd < 0) {
1075                 SETERRNO(EBADF,RMS_IFI);
1076                 goto say_false;
1077             } else if (PerlLIO_dup2(fd, savefd) < 0) {
1078                 (void)PerlIO_close(fp);
1079                 goto say_false;
1080             }
1081 #ifdef VMS
1082             if (savefd != PerlIO_fileno(PerlIO_stdin())) {
1083                 char newname[FILENAME_MAX+1];
1084                 if (PerlIO_getname(fp, newname)) {
1085                     if (fd == PerlIO_fileno(PerlIO_stdout()))
1086                         vmssetuserlnm("SYS$OUTPUT", newname);
1087                     if (fd == PerlIO_fileno(PerlIO_stderr()))
1088                         vmssetuserlnm("SYS$ERROR", newname);
1089                 }
1090             }
1091 #endif
1092
1093 #if !defined(WIN32)
1094            /* PL_fdpid isn't used on Windows, so avoid this useless work.
1095             * XXX Probably the same for a lot of other places. */
1096             {
1097                 Pid_t pid;
1098                 SV *sv;
1099
1100                 sv = *av_fetch(PL_fdpid,fd,TRUE);
1101                 SvUPGRADE(sv, SVt_IV);
1102                 pid = SvIVX(sv);
1103                 SvIV_set(sv, 0);
1104                 sv = *av_fetch(PL_fdpid,savefd,TRUE);
1105                 SvUPGRADE(sv, SVt_IV);
1106                 SvIV_set(sv, pid);
1107             }
1108 #endif
1109
1110             if (was_fdopen) {
1111                 /* need to close fp without closing underlying fd */
1112                 int ofd = PerlIO_fileno(fp);
1113                 int dupfd = ofd >= 0 ? PerlLIO_dup_cloexec(ofd) : -1;
1114                 if (ofd < 0 || dupfd < 0) {
1115                     if (dupfd >= 0)
1116                         PerlLIO_close(dupfd);
1117                     goto say_false;
1118                 }
1119                 PerlIO_close(fp);
1120                 PerlLIO_dup2_cloexec(dupfd, ofd);
1121                 setfd_inhexec_for_sysfd(ofd);
1122                 PerlLIO_close(dupfd);
1123             }
1124             else
1125                 PerlIO_close(fp);
1126         }
1127         fp = saveifp;
1128         PerlIO_clearerr(fp);
1129         fd = PerlIO_fileno(fp);
1130     }
1131     IoIFP(io) = fp;
1132
1133     IoFLAGS(io) &= ~IOf_NOLINE;
1134     if (writing) {
1135         if (IoTYPE(io) == IoTYPE_SOCKET
1136             || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) {
1137             char *s = mode;
1138             if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
1139               s++;
1140             *s = 'w';
1141             if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
1142                 PerlIO_close(fp);
1143                 goto say_false;
1144             }
1145         }
1146         else
1147             IoOFP(io) = fp;
1148     }
1149     if (statbufp)
1150         *statbufp = statbuf;
1151
1152     return TRUE;
1153
1154   say_false:
1155     IoIFP(io) = saveifp;
1156     IoOFP(io) = saveofp;
1157     IoTYPE(io) = savetype;
1158     return FALSE;
1159 }
1160
1161 /* Open a temp file in the same directory as an original name.
1162 */
1163
1164 static bool
1165 S_openindirtemp(pTHX_ GV *gv, SV *orig_name, SV *temp_out_name) {
1166     int fd;
1167     PerlIO *fp;
1168     const char *p = SvPV_nolen(orig_name);
1169     const char *sep;
1170
1171     /* look for the last directory separator */
1172     sep = strrchr(p, '/');
1173
1174 #ifdef DOSISH
1175     {
1176         const char *sep2;
1177         if ((sep2 = strrchr(sep ? sep : p, '\\')))
1178             sep = sep2;
1179     }
1180 #endif
1181 #ifdef VMS
1182     if (!sep) {
1183         const char *openp = strchr(p, '[');
1184         if (openp)
1185             sep = strchr(openp, ']');
1186         else {
1187             sep = strchr(p, ':');
1188         }
1189     }
1190 #endif
1191     if (sep) {
1192         sv_setpvn(temp_out_name, p, sep - p + 1);
1193         sv_catpvs(temp_out_name, "XXXXXXXX");
1194     }
1195     else
1196         sv_setpvs(temp_out_name, "XXXXXXXX");
1197
1198     {
1199       int old_umask = umask(0177);
1200       fd = Perl_my_mkstemp_cloexec(SvPVX(temp_out_name));
1201       umask(old_umask);
1202     }
1203
1204     if (fd < 0)
1205         return FALSE;
1206
1207     fp = PerlIO_fdopen(fd, "w+");
1208     if (!fp)
1209         return FALSE;
1210
1211     return do_openn(gv, "+>&", 3, 0, 0, 0, fp, NULL, 0);
1212 }
1213
1214 #if defined(HAS_UNLINKAT) && defined(HAS_RENAMEAT) && defined(HAS_FCHMODAT) && \
1215     (defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)) && !defined(NO_USE_ATFUNCTIONS) && \
1216     defined(HAS_LINKAT)
1217 #  define ARGV_USE_ATFUNCTIONS
1218 #endif
1219
1220 /* Win32 doesn't necessarily return useful information
1221  * in st_dev, st_ino.
1222  */
1223 #ifndef DOSISH
1224 #  define ARGV_USE_STAT_INO
1225 #endif
1226
1227 #define ARGVMG_BACKUP_NAME 0
1228 #define ARGVMG_TEMP_NAME 1
1229 #define ARGVMG_ORIG_NAME 2
1230 #define ARGVMG_ORIG_MODE 3
1231 #define ARGVMG_ORIG_PID 4
1232
1233 /* we store the entire stat_t since the ino_t and dev_t values might
1234    not fit in an IV.  I could have created a new structure and
1235    transferred them across, but this seemed too much effort for very
1236    little win.
1237
1238    We store it even when the *at() functions are available, since
1239    while the C runtime might have definitions for these functions, the
1240    operating system or a specific filesystem might not implement them.
1241    eg. NetBSD 6 implements linkat() but only where the fds are AT_FDCWD.
1242  */
1243 #ifdef ARGV_USE_STAT_INO
1244 #  define ARGVMG_ORIG_CWD_STAT 5
1245 #endif
1246
1247 #ifdef ARGV_USE_ATFUNCTIONS
1248 #  define ARGVMG_ORIG_DIRP 6
1249 #endif
1250
1251 #ifdef ENOTSUP
1252 #define NotSupported(e) ((e) == ENOSYS || (e) == ENOTSUP)
1253 #else
1254 #define NotSupported(e) ((e) == ENOSYS)
1255 #endif
1256
1257 static int
1258 S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
1259     PERL_UNUSED_ARG(io);
1260
1261     /* note this can be entered once the file has been
1262        successfully deleted too */
1263     assert(IoTYPE(io) != IoTYPE_PIPE);
1264
1265     /* mg_obj can be NULL if a thread is created with the handle open, in which
1266      case we leave any clean up to the parent thread */
1267     if (mg->mg_obj) {
1268 #ifdef ARGV_USE_ATFUNCTIONS
1269         SV **dir_psv;
1270         DIR *dir;
1271
1272         dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
1273         assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
1274         dir = INT2PTR(DIR *, SvIV(*dir_psv));
1275 #endif
1276         if (IoIFP(io)) {
1277             if (PL_phase == PERL_PHASE_DESTRUCT && PL_statusvalue == 0) {
1278                 (void)argvout_final(mg, (IO*)io, FALSE);
1279             }
1280             else {
1281                 SV **pid_psv;
1282                 PerlIO *iop = IoIFP(io);
1283
1284                 assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
1285
1286                 pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
1287
1288                 assert(pid_psv && *pid_psv);
1289
1290                 if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
1291                     /* if we get here the file hasn't been closed explicitly by the
1292                        user and hadn't been closed implicitly by nextargv(), so
1293                        abandon the edit */
1294                     SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1295                     const char *temp_pv = SvPVX(*temp_psv);
1296
1297                     assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
1298                     (void)PerlIO_close(iop);
1299                     IoIFP(io) = IoOFP(io) = NULL;
1300 #ifdef ARGV_USE_ATFUNCTIONS
1301                     if (dir) {
1302                         if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
1303                             NotSupported(errno))
1304                             (void)UNLINK(temp_pv);
1305                     }
1306 #else
1307                     (void)UNLINK(temp_pv);
1308 #endif
1309                 }
1310             }
1311         }
1312 #ifdef ARGV_USE_ATFUNCTIONS
1313         if (dir)
1314             closedir(dir);
1315 #endif
1316     }
1317
1318     return 0;
1319 }
1320
1321 static int
1322 S_argvout_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
1323     PERL_UNUSED_ARG(param);
1324
1325     /* ideally we could just remove the magic from the SV but we don't get the SV here */
1326     SvREFCNT_dec(mg->mg_obj);
1327     mg->mg_obj = NULL;
1328
1329     return 0;
1330 }
1331
1332 /* Magic of this type has an AV containing the following:
1333    0: name of the backup file (if any)
1334    1: name of the temp output file
1335    2: name of the original file
1336    3: file mode of the original file
1337    4: pid of the process we opened at, to prevent doing the renaming
1338       etc in both the child and the parent after a fork
1339
1340 If we have useful inode/device ids in stat_t we also keep:
1341    5: a stat of the original current working directory
1342
1343 If we have unlinkat(), renameat(), fchmodat(), dirfd() we also keep:
1344    6: the DIR * for the current directory when we open the file, stored as an IV
1345  */
1346
1347 static const MGVTBL argvout_vtbl =
1348     {
1349         NULL, /* svt_get */
1350         NULL, /* svt_set */
1351         NULL, /* svt_len */
1352         NULL, /* svt_clear */
1353         S_argvout_free, /* svt_free */
1354         NULL, /* svt_copy */
1355         S_argvout_dup,  /* svt_dup */
1356         NULL /* svt_local */
1357     };
1358
1359 static bool
1360 S_is_fork_open(const char *name) {
1361     /* return true if name matches /^\A\s*(\|\s+-|\-\s+|)\s*\z/ */
1362     while (isSPACE(*name))
1363         name++;
1364     if (*name == '|') {
1365         ++name;
1366         while (isSPACE(*name))
1367             name++;
1368         if (*name != '-')
1369             return false;
1370         ++name;
1371     }
1372     else if (*name == '-') {
1373         ++name;
1374         while (isSPACE(*name))
1375             name++;
1376         if (*name != '|')
1377             return false;
1378         ++name;
1379     }
1380     else
1381         return false;
1382
1383     while (isSPACE(*name))
1384         name++;
1385
1386     return *name == 0;
1387 }
1388
1389 PerlIO *
1390 Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
1391 {
1392     IO * const io = GvIOp(gv);
1393     SV *const old_out_name = PL_inplace ? newSVsv(GvSV(gv)) : NULL;
1394
1395     PERL_ARGS_ASSERT_NEXTARGV;
1396
1397     if (old_out_name)
1398         SAVEFREESV(old_out_name);
1399
1400     if (!PL_argvoutgv)
1401         PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
1402     if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
1403         IoFLAGS(io) &= ~IOf_START;
1404         if (PL_inplace) {
1405             assert(PL_defoutgv);
1406             Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
1407                                     SvREFCNT_inc_simple_NN(PL_defoutgv));
1408         }
1409     }
1410
1411     {
1412         IO * const io = GvIOp(PL_argvoutgv);
1413         if (io && IoIFP(io) && old_out_name) {
1414             do_close(PL_argvoutgv, FALSE);
1415         }
1416     }
1417
1418     PL_lastfd = -1;
1419     PL_filemode = 0;
1420     if (!GvAV(gv))
1421         return NULL;
1422     while (av_count(GvAV(gv)) > 0) {
1423         STRLEN oldlen;
1424         SV *const sv = av_shift(GvAV(gv));
1425         SAVEFREESV(sv);
1426         SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
1427         sv_setsv(GvSVn(gv),sv);
1428         SvSETMAGIC(GvSV(gv));
1429         PL_oldname = SvPVx(GvSV(gv), oldlen);
1430         if (LIKELY(!PL_inplace)) {
1431             if (nomagicopen) {
1432                 if (do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)) {
1433                     return IoIFP(GvIOp(gv));
1434                 }
1435             }
1436             else {
1437                 if (is_fork_open(PL_oldname)) {
1438                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1439                                      "Forked open '%s' not meaningful in <>",
1440                                      PL_oldname);
1441                     continue;
1442                 }
1443
1444                 if ( do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0) ) {
1445                     return IoIFP(GvIOp(gv));
1446                 }
1447             }
1448         }
1449         else {
1450             Stat_t statbuf;
1451             /* This very long block ends with return IoIFP(GvIOp(gv));
1452                Both this block and the block above fall through on open
1453                failure to the warning code, and then the while loop above tries
1454                the next entry. */
1455             if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0, &statbuf)) {
1456 #ifndef FLEXFILENAMES
1457                 int filedev;
1458                 int fileino;
1459 #endif
1460 #ifdef ARGV_USE_ATFUNCTIONS
1461                 DIR *curdir;
1462 #endif
1463                 Uid_t fileuid;
1464                 Gid_t filegid;
1465                 AV *magic_av = NULL;
1466                 SV *temp_name_sv = NULL;
1467                 MAGIC *mg;
1468
1469                 TAINT_PROPER("inplace open");
1470                 if (oldlen == 1 && *PL_oldname == '-') {
1471                     setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
1472                                           SVt_PVIO));
1473                     return IoIFP(GvIOp(gv));
1474                 }
1475 #ifndef FLEXFILENAMES
1476                 filedev = statbuf.st_dev;
1477                 fileino = statbuf.st_ino;
1478 #endif
1479                 PL_filemode = statbuf.st_mode;
1480                 fileuid = statbuf.st_uid;
1481                 filegid = statbuf.st_gid;
1482                 if (!S_ISREG(PL_filemode)) {
1483                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1484                                      "Can't do inplace edit: %s is not a regular file",
1485                                      PL_oldname );
1486                     do_close(gv,FALSE);
1487                     continue;
1488                 }
1489                 magic_av = newAV();
1490                 if (*PL_inplace && strNE(PL_inplace, "*")) {
1491                     const char *star = strchr(PL_inplace, '*');
1492                     if (star) {
1493                         const char *begin = PL_inplace;
1494                         SvPVCLEAR(sv);
1495                         do {
1496                             sv_catpvn(sv, begin, star - begin);
1497                             sv_catpvn(sv, PL_oldname, oldlen);
1498                             begin = ++star;
1499                         } while ((star = strchr(begin, '*')));
1500                         if (*begin)
1501                             sv_catpv(sv,begin);
1502                     }
1503                     else {
1504                         sv_catpv(sv,PL_inplace);
1505                     }
1506 #ifndef FLEXFILENAMES
1507                     if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0
1508                          && statbuf.st_dev == filedev
1509                          && statbuf.st_ino == fileino)
1510                       )
1511                     {
1512                         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1513                                          "Can't do inplace edit: %"
1514                                          SVf " would not be unique",
1515                                          SVfARG(sv));
1516                         goto cleanup_argv;
1517                     }
1518 #endif
1519                     av_store(magic_av, ARGVMG_BACKUP_NAME, newSVsv(sv));
1520                 }
1521
1522                 sv_setpvn(sv,PL_oldname,oldlen);
1523                 SETERRNO(0,0);          /* in case sprintf set errno */
1524                 temp_name_sv = newSV(0);
1525                 if (!S_openindirtemp(aTHX_ PL_argvoutgv, GvSV(gv), temp_name_sv)) {
1526                     SvREFCNT_dec(temp_name_sv);
1527                     /* diag_listed_as: Can't do inplace edit on %s: %s */
1528                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: Cannot make temp name: %s",
1529                                      PL_oldname, Strerror(errno) );
1530 #ifndef FLEXFILENAMES
1531                 cleanup_argv:
1532 #endif
1533                     do_close(gv,FALSE);
1534                     SvREFCNT_dec(magic_av);
1535                     continue;
1536                 }
1537                 av_store(magic_av, ARGVMG_TEMP_NAME, temp_name_sv);
1538                 av_store(magic_av, ARGVMG_ORIG_NAME, newSVsv(sv));
1539                 av_store(magic_av, ARGVMG_ORIG_MODE, newSVuv(PL_filemode));
1540                 av_store(magic_av, ARGVMG_ORIG_PID, newSViv((IV)PerlProc_getpid()));
1541 #if defined(ARGV_USE_ATFUNCTIONS)
1542                 curdir = opendir(".");
1543                 av_store(magic_av, ARGVMG_ORIG_DIRP, newSViv(PTR2IV(curdir)));
1544 #elif defined(ARGV_USE_STAT_INO)
1545                 if (PerlLIO_stat(".", &statbuf) >= 0) {
1546                     av_store(magic_av, ARGVMG_ORIG_CWD_STAT,
1547                              newSVpvn((char *)&statbuf, sizeof(statbuf)));
1548                 }
1549 #endif
1550                 setdefout(PL_argvoutgv);
1551                 sv_setsv(GvSVn(PL_argvoutgv), temp_name_sv);
1552                 mg = sv_magicext((SV*)GvIOp(PL_argvoutgv), (SV*)magic_av, PERL_MAGIC_uvar, &argvout_vtbl, NULL, 0);
1553                 mg->mg_flags |= MGf_DUP;
1554                 SvREFCNT_dec(magic_av);
1555                 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
1556                 if (PL_lastfd >= 0) {
1557                     (void)PerlLIO_fstat(PL_lastfd,&statbuf);
1558 #ifdef HAS_FCHMOD
1559                     (void)fchmod(PL_lastfd,PL_filemode);
1560 #else
1561                     (void)PerlLIO_chmod(PL_oldname,PL_filemode);
1562 #endif
1563                     if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
1564                         /* XXX silently ignore failures */
1565 #ifdef HAS_FCHOWN
1566                         PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
1567 #elif defined(HAS_CHOWN)
1568                         PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid));
1569 #endif
1570                     }
1571                 }
1572                 return IoIFP(GvIOp(gv));
1573             }
1574         } /* successful do_open_raw(), PL_inplace non-NULL */
1575
1576         if (ckWARN_d(WARN_INPLACE)) {
1577             const int eno = errno;
1578             Stat_t statbuf;
1579             if (PerlLIO_stat(PL_oldname, &statbuf) >= 0
1580                 && !S_ISREG(statbuf.st_mode)) {
1581                 Perl_warner(aTHX_ packWARN(WARN_INPLACE),
1582                             "Can't do inplace edit: %s is not a regular file",
1583                             PL_oldname);
1584             }
1585             else {
1586                 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
1587                             PL_oldname, Strerror(eno));
1588             }
1589         }
1590     }
1591     if (io && (IoFLAGS(io) & IOf_ARGV))
1592         IoFLAGS(io) |= IOf_START;
1593     if (PL_inplace) {
1594         if (io && (IoFLAGS(io) & IOf_ARGV)
1595             && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
1596         {
1597             GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
1598             setdefout(oldout);
1599             SvREFCNT_dec_NN(oldout);
1600             return NULL;
1601         }
1602         setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
1603     }
1604     return NULL;
1605 }
1606
1607 #ifdef ARGV_USE_ATFUNCTIONS
1608 #  if defined(__FreeBSD__) || defined(__FreeBSD_kernel__)
1609
1610 /* FreeBSD 11 renameat() mis-behaves strangely with absolute paths in cases where the
1611  * equivalent rename() succeeds
1612  */
1613 static int
1614 S_my_renameat(int olddfd, const char *oldpath, int newdfd, const char *newpath) {
1615     /* this is intended only for use in Perl_do_close() */
1616     assert(olddfd == newdfd);
1617     assert(PERL_FILE_IS_ABSOLUTE(oldpath) == PERL_FILE_IS_ABSOLUTE(newpath));
1618     if (PERL_FILE_IS_ABSOLUTE(oldpath)) {
1619         return PerlLIO_rename(oldpath, newpath);
1620     }
1621     else {
1622         return renameat(olddfd, oldpath, newdfd, newpath);
1623     }
1624 }
1625
1626 #  else
1627 #    define S_my_renameat(dh1, pv1, dh2, pv2) renameat((dh1), (pv1), (dh2), (pv2))
1628 #  endif /* if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) */
1629 #endif
1630
1631 static bool
1632 S_dir_unchanged(pTHX_ const char *orig_pv, MAGIC *mg) {
1633     Stat_t statbuf;
1634
1635 #ifdef ARGV_USE_STAT_INO
1636     SV **stat_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_CWD_STAT, FALSE);
1637     Stat_t *orig_cwd_stat = stat_psv && *stat_psv ? (Stat_t *)SvPVX(*stat_psv) : NULL;
1638
1639     /* if the path is absolute the possible moving of cwd (which the file
1640        might be in) isn't our problem.
1641        This code tries to be reasonably balanced about detecting a changed
1642        CWD, if we have the information needed to check that curdir has changed, we
1643        check it
1644     */
1645     if (!PERL_FILE_IS_ABSOLUTE(orig_pv)
1646         && orig_cwd_stat
1647         && PerlLIO_stat(".", &statbuf) >= 0
1648         && ( statbuf.st_dev != orig_cwd_stat->st_dev
1649                      || statbuf.st_ino != orig_cwd_stat->st_ino)) {
1650         Perl_croak(aTHX_ "Cannot complete in-place edit of %s: %s",
1651                    orig_pv, "Current directory has changed");
1652     }
1653 #else
1654     SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1655
1656     /* Some platforms don't have useful st_ino etc, so just
1657        check we can see the work file.
1658     */
1659     if (!PERL_FILE_IS_ABSOLUTE(orig_pv)
1660         && PerlLIO_stat(SvPVX(*temp_psv), &statbuf) < 0) {
1661         Perl_croak(aTHX_ "Cannot complete in-place edit of %s: %s",
1662                    orig_pv,
1663                    "Work file is missing - did you change directory?");
1664     }
1665 #endif
1666
1667     return TRUE;
1668 }
1669
1670 #define dir_unchanged(orig_psv, mg) \
1671     S_dir_unchanged(aTHX_ (orig_psv), (mg))
1672
1673 STATIC bool
1674 S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool is_explict) {
1675     bool retval;
1676
1677     /* ensure args are checked before we start using them */
1678     PERL_ARGS_ASSERT_ARGVOUT_FINAL;
1679
1680     {
1681         /* handle to an in-place edit work file */
1682         SV **back_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_BACKUP_NAME, FALSE);
1683         SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1684         /* PL_oldname may have been modified by a nested ARGV use at this point */
1685         SV **orig_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_NAME, FALSE);
1686         SV **mode_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_MODE, FALSE);
1687         SV **pid_psv  = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
1688 #if defined(ARGV_USE_ATFUNCTIONS)
1689         SV **dir_psv  = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
1690         DIR *dir;
1691         int dfd;
1692 #endif
1693         UV mode;
1694         int fd;
1695
1696         const char *orig_pv;
1697
1698         assert(temp_psv && *temp_psv);
1699         assert(orig_psv && *orig_psv);
1700         assert(mode_psv && *mode_psv);
1701         assert(pid_psv && *pid_psv);
1702 #ifdef ARGV_USE_ATFUNCTIONS
1703         assert(dir_psv && *dir_psv);
1704         dir = INT2PTR(DIR *, SvIVX(*dir_psv));
1705         dfd = my_dirfd(dir);
1706 #endif
1707
1708         orig_pv = SvPVX(*orig_psv);
1709         mode = SvUV(*mode_psv);
1710
1711         if ((mode & (S_ISUID|S_ISGID)) != 0
1712             && (fd = PerlIO_fileno(IoIFP(io))) >= 0) {
1713             (void)PerlIO_flush(IoIFP(io));
1714 #ifdef HAS_FCHMOD
1715             (void)fchmod(fd, mode);
1716 #else
1717             (void)PerlLIO_chmod(orig_pv, mode);
1718 #endif
1719         }
1720
1721         retval = io_close(io, NULL, is_explict, FALSE);
1722
1723         if (SvIV(*pid_psv) != (IV)PerlProc_getpid()) {
1724             /* this is a child process, don't duplicate our rename() etc
1725                processing below */
1726             goto freext;
1727         }
1728
1729         if (retval) {
1730 #if defined(DOSISH) || defined(__CYGWIN__)
1731             if (PL_argvgv && GvIOp(PL_argvgv)
1732                 && IoIFP(GvIOp(PL_argvgv))
1733                 && (IoFLAGS(GvIOp(PL_argvgv)) & (IOf_ARGV|IOf_START)) == IOf_ARGV) {
1734                 do_close(PL_argvgv, FALSE);
1735             }
1736 #endif
1737 #ifndef ARGV_USE_ATFUNCTIONS
1738             if (!dir_unchanged(orig_pv, mg))
1739                 goto abort_inplace;
1740 #endif
1741             if (back_psv && *back_psv) {
1742 #if defined(HAS_LINK) && !defined(DOSISH) && !defined(__CYGWIN__) && defined(HAS_RENAME)
1743                 if (
1744 #  ifdef ARGV_USE_ATFUNCTIONS
1745                     linkat(dfd, orig_pv, dfd, SvPVX(*back_psv), 0) < 0 &&
1746                     !(UNLIKELY(NotSupported(errno)) &&
1747                       dir_unchanged(orig_pv, mg) &&
1748                                link(orig_pv, SvPVX(*back_psv)) == 0)
1749 #  else
1750                     link(orig_pv, SvPVX(*back_psv)) < 0
1751 #  endif
1752                     )
1753 #endif
1754                 {
1755 #ifdef HAS_RENAME
1756                     if (
1757 #  ifdef ARGV_USE_ATFUNCTIONS
1758                         S_my_renameat(dfd, orig_pv, dfd, SvPVX(*back_psv)) < 0 &&
1759                         !(UNLIKELY(NotSupported(errno)) &&
1760                           dir_unchanged(orig_pv, mg) &&
1761                           PerlLIO_rename(orig_pv, SvPVX(*back_psv)) == 0)
1762 #  else
1763                         PerlLIO_rename(orig_pv, SvPVX(*back_psv)) < 0
1764 #  endif
1765                         ) {
1766                         if (!is_explict) {
1767 #  ifdef ARGV_USE_ATFUNCTIONS
1768                             if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) < 0 &&
1769                                 UNLIKELY(NotSupported(errno)) &&
1770                                 dir_unchanged(orig_pv, mg))
1771                                 (void)UNLINK(SvPVX_const(*temp_psv));
1772 #  else
1773                             UNLINK(SvPVX(*temp_psv));
1774 #  endif
1775                             Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file",
1776                                        SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno));
1777                         }
1778                         /* should we warn here? */
1779                         goto abort_inplace;
1780                     }
1781 #else
1782                     (void)UNLINK(SvPVX(*back_psv));
1783                     if (link(orig_pv, SvPVX(*back_psv))) {
1784                         if (!is_explict) {
1785                             Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file",
1786                                        SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno));
1787                         }
1788                         goto abort_inplace;
1789                     }
1790                     /* we need to use link() to get the temp into place too, and linK()
1791                        fails if the new link name exists */
1792                     (void)UNLINK(orig_pv);
1793 #endif
1794                 }
1795             }
1796 #if defined(DOSISH) || defined(__CYGWIN__) || !defined(HAS_RENAME)
1797             else {
1798                 UNLINK(orig_pv);
1799             }
1800 #endif
1801             if (
1802 #if !defined(HAS_RENAME)
1803                 link(SvPVX(*temp_psv), orig_pv) < 0
1804 #elif defined(ARGV_USE_ATFUNCTIONS)
1805                 S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 &&
1806                 !(UNLIKELY(NotSupported(errno)) &&
1807                   dir_unchanged(orig_pv, mg) &&
1808                   PerlLIO_rename(SvPVX(*temp_psv), orig_pv) == 0)
1809 #else
1810                 PerlLIO_rename(SvPVX(*temp_psv), orig_pv) < 0
1811 #endif
1812                 ) {
1813                 if (!is_explict) {
1814 #ifdef ARGV_USE_ATFUNCTIONS
1815                     if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) < 0 &&
1816                         NotSupported(errno))
1817                         UNLINK(SvPVX(*temp_psv));
1818 #else
1819                     UNLINK(SvPVX(*temp_psv));
1820 #endif
1821                     /* diag_listed_as: Cannot complete in-place edit of %s: %s */
1822                     Perl_croak(aTHX_ "Cannot complete in-place edit of %s: failed to rename work file '%s' to '%s': %s",
1823                                orig_pv, SvPVX(*temp_psv), orig_pv, Strerror(errno));
1824                 }
1825             abort_inplace:
1826                 UNLINK(SvPVX_const(*temp_psv));
1827                 retval = FALSE;
1828             }
1829 #ifndef HAS_RENAME
1830             UNLINK(SvPVX(*temp_psv));
1831 #endif
1832         }
1833         else {
1834 #ifdef ARGV_USE_ATFUNCTIONS
1835             if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) &&
1836                 NotSupported(errno))
1837                 UNLINK(SvPVX_const(*temp_psv));
1838
1839 #else
1840             UNLINK(SvPVX_const(*temp_psv));
1841 #endif
1842             if (!is_explict) {
1843                 Perl_croak(aTHX_ "Failed to close in-place work file %s: %s",
1844                            SvPVX(*temp_psv), Strerror(errno));
1845             }
1846         }
1847  freext:
1848         ;
1849     }
1850     return retval;
1851 }
1852
1853 /*
1854 =for apidoc do_close
1855
1856 Close an I/O stream.  This implements Perl L<perlfunc/C<close>>.
1857
1858 C<gv> is the glob associated with the stream.
1859
1860 C<is_explict> is C<true> if this is an explicit close of the stream; C<false>
1861 if it is part of another operation, such as closing a pipe (which involves
1862 implicitly closing both ends).
1863
1864 Returns C<true> if successful; otherwise returns C<false> and sets C<errno> to
1865 indicate the cause.
1866
1867 =cut
1868 */
1869
1870 bool
1871 Perl_do_close(pTHX_ GV *gv, bool is_explict)
1872 {
1873     bool retval;
1874     IO *io;
1875     MAGIC *mg;
1876
1877     if (!gv)
1878         gv = PL_argvgv;
1879     if (!gv || !isGV_with_GP(gv)) {
1880         if (is_explict)
1881             SETERRNO(EBADF,SS_IVCHAN);
1882         return FALSE;
1883     }
1884     io = GvIO(gv);
1885     if (!io) {          /* never opened */
1886         if (is_explict) {
1887             report_evil_fh(gv);
1888             SETERRNO(EBADF,SS_IVCHAN);
1889         }
1890         return FALSE;
1891     }
1892     if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl))
1893         && mg->mg_obj) {
1894         retval = argvout_final(mg, io, is_explict);
1895         mg_freeext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl);
1896     }
1897     else {
1898         retval = io_close(io, NULL, is_explict, FALSE);
1899     }
1900     if (is_explict) {
1901         IoLINES(io) = 0;
1902         IoPAGE(io) = 0;
1903         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1904     }
1905     IoTYPE(io) = IoTYPE_CLOSED;
1906     return retval;
1907 }
1908
1909 bool
1910 Perl_io_close(pTHX_ IO *io, GV *gv, bool is_explict, bool warn_on_fail)
1911 {
1912     bool retval = FALSE;
1913
1914     PERL_ARGS_ASSERT_IO_CLOSE;
1915
1916     if (IoIFP(io)) {
1917         if (IoTYPE(io) == IoTYPE_PIPE) {
1918             PerlIO *fh = IoIFP(io);
1919             int status;
1920
1921             /* my_pclose() can propagate signals which might bypass any code
1922                after the call here if the signal handler throws an exception.
1923                This would leave the handle in the IO object and try to close it again
1924                when the SV is destroyed on unwind or global destruction.
1925                So NULL it early.
1926             */
1927             IoOFP(io) = IoIFP(io) = NULL;
1928             status = PerlProc_pclose(fh);
1929             if (is_explict) {
1930                 STATUS_NATIVE_CHILD_SET(status);
1931                 retval = (STATUS_UNIX == 0);
1932             }
1933             else {
1934                 retval = (status != -1);
1935             }
1936         }
1937         else if (IoTYPE(io) == IoTYPE_STD)
1938             retval = TRUE;
1939         else {
1940             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {          /* a socket */
1941                 const bool prev_err = PerlIO_error(IoOFP(io));
1942 #ifdef USE_PERLIO
1943                 if (prev_err)
1944                     PerlIO_restore_errno(IoOFP(io));
1945 #endif
1946                 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
1947                 PerlIO_close(IoIFP(io));        /* clear stdio, fd already closed */
1948             }
1949             else {
1950                 const bool prev_err = PerlIO_error(IoIFP(io));
1951 #ifdef USE_PERLIO
1952                 if (prev_err)
1953                     PerlIO_restore_errno(IoIFP(io));
1954 #endif
1955                 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1956             }
1957         }
1958         IoOFP(io) = IoIFP(io) = NULL;
1959
1960         if (warn_on_fail && !retval) {
1961             if (gv)
1962                 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1963                                 "Warning: unable to close filehandle %"
1964                                  HEKf " properly: %" SVf,
1965                                  HEKfARG(GvNAME_HEK(gv)),
1966                                  SVfARG(get_sv("!",GV_ADD)));
1967             else
1968                 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1969                                 "Warning: unable to close filehandle "
1970                                 "properly: %" SVf,
1971                                  SVfARG(get_sv("!",GV_ADD)));
1972         }
1973     }
1974     else if (is_explict) {
1975         SETERRNO(EBADF,SS_IVCHAN);
1976     }
1977
1978     return retval;
1979 }
1980
1981 bool
1982 Perl_do_eof(pTHX_ GV *gv)
1983 {
1984     IO * const io = GvIO(gv);
1985
1986     PERL_ARGS_ASSERT_DO_EOF;
1987
1988     if (!io)
1989         return TRUE;
1990     else if (IoTYPE(io) == IoTYPE_WRONLY)
1991         report_wrongway_fh(gv, '>');
1992
1993     while (IoIFP(io)) {
1994         if (PerlIO_has_cntptr(IoIFP(io))) {     /* (the code works without this) */
1995             if (PerlIO_get_cnt(IoIFP(io)) > 0)  /* cheat a little, since */
1996                 return FALSE;                   /* this is the most usual case */
1997         }
1998
1999         {
2000              /* getc and ungetc can stomp on errno */
2001             dSAVE_ERRNO;
2002             const int ch = PerlIO_getc(IoIFP(io));
2003             if (ch != EOF) {
2004                 (void)PerlIO_ungetc(IoIFP(io),ch);
2005                 RESTORE_ERRNO;
2006                 return FALSE;
2007             }
2008             RESTORE_ERRNO;
2009         }
2010
2011         if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
2012             if (PerlIO_get_cnt(IoIFP(io)) < -1)
2013                 PerlIO_set_cnt(IoIFP(io),-1);
2014         }
2015         if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
2016             if (gv != PL_argvgv || !nextargv(gv, FALSE))        /* get another fp handy */
2017                 return TRUE;
2018         }
2019         else
2020             return TRUE;                /* normal fp, definitely end of file */
2021     }
2022     return TRUE;
2023 }
2024
2025 Off_t
2026 Perl_do_tell(pTHX_ GV *gv)
2027 {
2028     IO *const io = GvIO(gv);
2029     PerlIO *fp;
2030
2031     PERL_ARGS_ASSERT_DO_TELL;
2032
2033     if (io && (fp = IoIFP(io))) {
2034         return PerlIO_tell(fp);
2035     }
2036     report_evil_fh(gv);
2037     SETERRNO(EBADF,RMS_IFI);
2038     return (Off_t)-1;
2039 }
2040
2041 bool
2042 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
2043 {
2044     IO *const io = GvIO(gv);
2045     PerlIO *fp;
2046
2047     if (io && (fp = IoIFP(io))) {
2048         return PerlIO_seek(fp, pos, whence) >= 0;
2049     }
2050     report_evil_fh(gv);
2051     SETERRNO(EBADF,RMS_IFI);
2052     return FALSE;
2053 }
2054
2055 Off_t
2056 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
2057 {
2058     IO *const io = GvIO(gv);
2059     PerlIO *fp;
2060
2061     PERL_ARGS_ASSERT_DO_SYSSEEK;
2062
2063     if (io && (fp = IoIFP(io))) {
2064         int fd = PerlIO_fileno(fp);
2065         if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
2066             SETERRNO(EINVAL,LIB_INVARG);
2067             return -1;
2068         } else {
2069             return PerlLIO_lseek(fd, pos, whence);
2070         }
2071     }
2072     report_evil_fh(gv);
2073     SETERRNO(EBADF,RMS_IFI);
2074     return (Off_t)-1;
2075 }
2076
2077 int
2078 Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
2079 {
2080     int mode = O_BINARY;
2081     PERL_UNUSED_CONTEXT;
2082     if (s) {
2083         while (*s) {
2084             if (*s == ':') {
2085                 switch (s[1]) {
2086                 case 'r':
2087                     if (s[2] == 'a' && s[3] == 'w'
2088                         && (!s[4] || s[4] == ':' || isSPACE(s[4])))
2089                     {
2090                         mode = O_BINARY;
2091                         s += 4;
2092                         len -= 4;
2093                         break;
2094                     }
2095                     /* FALLTHROUGH */
2096                 case 'c':
2097                     if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
2098                         && (!s[5] || s[5] == ':' || isSPACE(s[5])))
2099                     {
2100                         mode = O_TEXT;
2101                         s += 5;
2102                         len -= 5;
2103                         break;
2104                     }
2105                     /* FALLTHROUGH */
2106                 default:
2107                     goto fail_discipline;
2108                 }
2109             }
2110             else if (isSPACE(*s)) {
2111                 ++s;
2112                 --len;
2113             }
2114             else {
2115                 const char *end;
2116   fail_discipline:
2117                 end = (char *) memchr(s+1, ':', len);
2118                 if (!end)
2119                     end = s+len;
2120 #ifndef PERLIO_LAYERS
2121                 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
2122 #else
2123                 len -= end-s;
2124                 s = end;
2125 #endif
2126             }
2127         }
2128     }
2129     return mode;
2130 }
2131
2132 /*
2133 =for apidoc my_chsize
2134
2135 The C library L<chsize(3)> if available, or a Perl implementation of it.
2136
2137 =cut
2138 */
2139
2140 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
2141 I32
2142 my_chsize(int fd, Off_t length)
2143 {
2144 #  ifdef F_FREESP
2145         /* code courtesy of William Kucharski */
2146 #  define HAS_CHSIZE
2147
2148     Stat_t filebuf;
2149
2150     if (PerlLIO_fstat(fd, &filebuf) < 0)
2151         return -1;
2152
2153     if (filebuf.st_size < length) {
2154
2155         /* extend file length */
2156
2157         if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
2158             return -1;
2159
2160         /* write a "0" byte */
2161
2162         if ((PerlLIO_write(fd, "", 1)) != 1)
2163             return -1;
2164     }
2165     else {
2166         /* truncate length */
2167         struct flock fl;
2168         fl.l_whence = 0;
2169         fl.l_len = 0;
2170         fl.l_start = length;
2171         fl.l_type = F_WRLCK;    /* write lock on file space */
2172
2173         /*
2174         * This relies on the UNDOCUMENTED F_FREESP argument to
2175         * fcntl(2), which truncates the file so that it ends at the
2176         * position indicated by fl.l_start.
2177         *
2178         * Will minor miracles never cease?
2179         */
2180
2181         if (fcntl(fd, F_FREESP, &fl) < 0)
2182             return -1;
2183
2184     }
2185     return 0;
2186 #  else
2187     Perl_croak_nocontext("truncate not implemented");
2188 #  endif /* F_FREESP */
2189     return -1;
2190 }
2191 #endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
2192
2193 bool
2194 Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
2195 {
2196     PERL_ARGS_ASSERT_DO_PRINT;
2197
2198     /* assuming fp is checked earlier */
2199     if (!sv)
2200         return TRUE;
2201     if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
2202         assert(!SvGMAGICAL(sv));
2203         if (SvIsUV(sv))
2204             PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv));
2205         else
2206             PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv));
2207         return !PerlIO_error(fp);
2208     }
2209     else {
2210         STRLEN len;
2211         /* Do this first to trigger any overloading.  */
2212         const char *tmps = SvPV_const(sv, len);
2213         U8 *tmpbuf = NULL;
2214         bool happy = TRUE;
2215
2216         if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
2217             if (!SvUTF8(sv)) {  /* Convert to utf8 if necessary */
2218                 /* We don't modify the original scalar.  */
2219                 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
2220                 tmps = (char *) tmpbuf;
2221             }
2222             else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
2223                 (void) check_utf8_print((const U8*) tmps, len);
2224             }
2225         } /* else stream isn't utf8 */
2226         else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
2227                                    convert to bytes */
2228             STRLEN tmplen = len;
2229             bool utf8 = TRUE;
2230             U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
2231             if (!utf8) {
2232
2233                 /* Here, succeeded in downgrading from utf8.  Set up to below
2234                  * output the converted value */
2235                 tmpbuf = result;
2236                 tmps = (char *) tmpbuf;
2237                 len = tmplen;
2238             }
2239             else {  /* Non-utf8 output stream, but string only representable in
2240                        utf8 */
2241                 assert((char *)result == tmps);
2242                 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2243                                  "Wide character in %s",
2244                                    PL_op ? OP_DESC(PL_op) : "print"
2245                                 );
2246                     /* Could also check that isn't one of the things to avoid
2247                      * in utf8 by using check_utf8_print(), but not doing so,
2248                      * since the stream isn't a UTF8 stream */
2249             }
2250         }
2251         /* To detect whether the process is about to overstep its
2252          * filesize limit we would need getrlimit().  We could then
2253          * also transparently raise the limit with setrlimit() --
2254          * but only until the system hard limit/the filesystem limit,
2255          * at which we would get EPERM.  Note that when using buffered
2256          * io the write failure can be delayed until the flush/close. --jhi */
2257         if (len && (PerlIO_write(fp,tmps,len) == 0))
2258             happy = FALSE;
2259         Safefree(tmpbuf);
2260         return happy ? !PerlIO_error(fp) : FALSE;
2261     }
2262 }
2263
2264 I32
2265 Perl_my_stat_flags(pTHX_ const U32 flags)
2266 {
2267     IO *io;
2268     GV* gv;
2269
2270     if (PL_op->op_flags & OPf_REF) {
2271         gv = cGVOP_gv;
2272       do_fstat:
2273         if (gv == PL_defgv) {
2274             if (PL_laststatval < 0)
2275                 SETERRNO(EBADF,RMS_IFI);
2276             return PL_laststatval;
2277         }
2278         io = GvIO(gv);
2279         do_fstat_have_io:
2280         PL_laststype = OP_STAT;
2281         PL_statgv = gv ? gv : (GV *)io;
2282         SvPVCLEAR(PL_statname);
2283         if (io) {
2284             if (IoIFP(io)) {
2285                 int fd = PerlIO_fileno(IoIFP(io));
2286                 if (fd < 0) {
2287                     /* E.g. PerlIO::scalar has no real fd. */
2288                     SETERRNO(EBADF,RMS_IFI);
2289                     return (PL_laststatval = -1);
2290                 } else {
2291                     return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
2292                 }
2293             } else if (IoDIRP(io)) {
2294                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
2295             }
2296         }
2297         PL_laststatval = -1;
2298         report_evil_fh(gv);
2299         SETERRNO(EBADF,RMS_IFI);
2300         return -1;
2301     }
2302     else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
2303              == OPpFT_STACKED)
2304         return PL_laststatval;
2305     else {
2306         SV* const sv = *PL_stack_sp;
2307         const char *s, *d;
2308         STRLEN len;
2309         if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
2310             goto do_fstat;
2311         }
2312         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2313             io = MUTABLE_IO(SvRV(sv));
2314             gv = NULL;
2315             goto do_fstat_have_io;
2316         }
2317
2318         s = SvPV_flags_const(sv, len, flags);
2319         PL_statgv = NULL;
2320         sv_setpvn(PL_statname, s, len);
2321         d = SvPVX_const(PL_statname);           /* s now NUL-terminated */
2322         PL_laststype = OP_STAT;
2323         if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
2324             PL_laststatval = -1;
2325         }
2326         else {
2327             PL_laststatval = PerlLIO_stat(d, &PL_statcache);
2328         }
2329         if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
2330             GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
2331             Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2332             GCC_DIAG_RESTORE_STMT;
2333         }
2334         return PL_laststatval;
2335     }
2336 }
2337
2338
2339 I32
2340 Perl_my_lstat_flags(pTHX_ const U32 flags)
2341 {
2342     static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
2343     const char *file;
2344     STRLEN len;
2345     SV* const sv = *PL_stack_sp;
2346     bool isio = FALSE;
2347     if (PL_op->op_flags & OPf_REF) {
2348         if (cGVOP_gv == PL_defgv) {
2349             if (PL_laststype != OP_LSTAT)
2350                 Perl_croak(aTHX_ "%s", no_prev_lstat);
2351             if (PL_laststatval < 0)
2352                 SETERRNO(EBADF,RMS_IFI);
2353             return PL_laststatval;
2354         }
2355         PL_laststatval = -1;
2356         if (ckWARN(WARN_IO)) {
2357             /* diag_listed_as: Use of -l on filehandle%s */
2358             Perl_warner(aTHX_ packWARN(WARN_IO),
2359                               "Use of -l on filehandle %" HEKf,
2360                               HEKfARG(GvENAME_HEK(cGVOP_gv)));
2361         }
2362         SETERRNO(EBADF,RMS_IFI);
2363         return -1;
2364     }
2365     if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
2366              == OPpFT_STACKED) {
2367       if (PL_laststype != OP_LSTAT)
2368         Perl_croak(aTHX_ "%s", no_prev_lstat);
2369       return PL_laststatval;
2370     }
2371
2372     PL_laststype = OP_LSTAT;
2373     PL_statgv = NULL;
2374     if ( (  (SvROK(sv) && (  isGV_with_GP(SvRV(sv))
2375                           || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO)  )
2376             )
2377          || isGV_with_GP(sv)
2378          )
2379       && ckWARN(WARN_IO)) {
2380         if (isio)
2381             /* diag_listed_as: Use of -l on filehandle%s */
2382             Perl_warner(aTHX_ packWARN(WARN_IO),
2383                              "Use of -l on filehandle");
2384         else
2385             /* diag_listed_as: Use of -l on filehandle%s */
2386             Perl_warner(aTHX_ packWARN(WARN_IO),
2387                              "Use of -l on filehandle %" HEKf,
2388                               HEKfARG(GvENAME_HEK((const GV *)
2389                                           (SvROK(sv) ? SvRV(sv) : sv))));
2390     }
2391     file = SvPV_flags_const(sv, len, flags);
2392     sv_setpv(PL_statname,file);
2393     if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
2394         PL_laststatval = -1;
2395     }
2396     else {
2397         PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
2398     }
2399     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2400         GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
2401         Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
2402         GCC_DIAG_RESTORE_STMT;
2403     }
2404     return PL_laststatval;
2405 }
2406
2407 static void
2408 S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
2409 {
2410     const int e = errno;
2411     PERL_ARGS_ASSERT_EXEC_FAILED;
2412
2413     if (ckWARN(WARN_EXEC))
2414         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
2415                     cmd, Strerror(e));
2416     if (do_report) {
2417         /* XXX silently ignore failures */
2418         PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
2419         PerlLIO_close(fd);
2420     }
2421 }
2422
2423 bool
2424 Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2425                int fd, int do_report)
2426 {
2427     PERL_ARGS_ASSERT_DO_AEXEC5;
2428 #if defined(__LIBCATAMOUNT__)
2429     Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
2430 #else
2431     assert(sp >= mark);
2432     ENTER;
2433     {
2434         const char **argv, **a;
2435         const char *tmps = NULL;
2436         Newx(argv, sp - mark + 1, const char*);
2437         SAVEFREEPV(argv);
2438         a = argv;
2439
2440         while (++mark <= sp) {
2441             if (*mark) {
2442                 char *arg = savepv(SvPV_nolen_const(*mark));
2443                 SAVEFREEPV(arg);
2444                 *a++ = arg;
2445             } else
2446                 *a++ = "";
2447         }
2448         *a = NULL;
2449         if (really) {
2450             tmps = savepv(SvPV_nolen_const(really));
2451             SAVEFREEPV(tmps);
2452         }
2453         if ((!really && argv[0] && *argv[0] != '/') ||
2454             (really && *tmps != '/'))           /* will execvp use PATH? */
2455             TAINT_ENV();                /* testing IFS here is overkill, probably */
2456         PERL_FPU_PRE_EXEC
2457         if (really && *tmps) {
2458             PerlProc_execvp(tmps,EXEC_ARGV_CAST(argv));
2459         } else if (argv[0]) {
2460             PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
2461         } else {
2462             SETERRNO(ENOENT,RMS_FNF);
2463         }
2464         PERL_FPU_POST_EXEC
2465         S_exec_failed(aTHX_ (really ? tmps : argv[0] ? argv[0] : ""), fd, do_report);
2466     }
2467     LEAVE;
2468 #endif
2469     return FALSE;
2470 }
2471
2472 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
2473
2474 bool
2475 Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
2476 {
2477     const char **argv, **a;
2478     char *s;
2479     char *buf;
2480     char *cmd;
2481     /* Make a copy so we can change it */
2482     const Size_t cmdlen = strlen(incmd) + 1;
2483
2484     PERL_ARGS_ASSERT_DO_EXEC3;
2485
2486     ENTER;
2487     Newx(buf, cmdlen, char);
2488     SAVEFREEPV(buf);
2489     cmd = buf;
2490     memcpy(cmd, incmd, cmdlen);
2491
2492     while (*cmd && isSPACE(*cmd))
2493         cmd++;
2494
2495     /* save an extra exec if possible */
2496
2497 #ifdef CSH
2498     {
2499         char flags[PERL_FLAGS_MAX];
2500         if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
2501             strBEGINs(cmd+PL_cshlen," -c")) {
2502           my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
2503           s = cmd+PL_cshlen+3;
2504           if (*s == 'f') {
2505               s++;
2506               my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
2507           }
2508           if (*s == ' ')
2509               s++;
2510           if (*s++ == '\'') {
2511               char * const ncmd = s;
2512
2513               while (*s)
2514                   s++;
2515               if (s[-1] == '\n')
2516                   *--s = '\0';
2517               if (s[-1] == '\'') {
2518                   *--s = '\0';
2519                   PERL_FPU_PRE_EXEC
2520                   PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
2521                   PERL_FPU_POST_EXEC
2522                   *s = '\'';
2523                   S_exec_failed(aTHX_ PL_cshname, fd, do_report);
2524                   goto leave;
2525               }
2526           }
2527         }
2528     }
2529 #endif /* CSH */
2530
2531     /* see if there are shell metacharacters in it */
2532
2533     if (*cmd == '.' && isSPACE(cmd[1]))
2534         goto doshell;
2535
2536     if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
2537         goto doshell;
2538
2539     s = cmd;
2540     while (isWORDCHAR(*s))
2541         s++;    /* catch VAR=val gizmo */
2542     if (*s == '=')
2543         goto doshell;
2544
2545     for (s = cmd; *s; s++) {
2546         if (*s != ' ' && !isALPHA(*s) &&
2547             memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) {
2548             if (*s == '\n' && !s[1]) {
2549                 *s = '\0';
2550                 break;
2551             }
2552             /* handle the 2>&1 construct at the end */
2553             if (*s == '>' && s[1] == '&' && s[2] == '1'
2554                 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
2555                 && (!s[3] || isSPACE(s[3])))
2556             {
2557                 const char *t = s + 3;
2558
2559                 while (*t && isSPACE(*t))
2560                     ++t;
2561                 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
2562                     s[-2] = '\0';
2563                     break;
2564                 }
2565             }
2566           doshell:
2567             PERL_FPU_PRE_EXEC
2568             PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
2569             PERL_FPU_POST_EXEC
2570             S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
2571             goto leave;
2572         }
2573     }
2574
2575     Newx(argv, (s - cmd) / 2 + 2, const char*);
2576     SAVEFREEPV(argv);
2577     cmd = savepvn(cmd, s-cmd);
2578     SAVEFREEPV(cmd);
2579     a = argv;
2580     for (s = cmd; *s;) {
2581         while (isSPACE(*s))
2582             s++;
2583         if (*s)
2584             *(a++) = s;
2585         while (*s && !isSPACE(*s))
2586             s++;
2587         if (*s)
2588             *s++ = '\0';
2589     }
2590     *a = NULL;
2591     if (argv[0]) {
2592         PERL_FPU_PRE_EXEC
2593         PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
2594         PERL_FPU_POST_EXEC
2595         if (errno == ENOEXEC)           /* for system V NIH syndrome */
2596             goto doshell;
2597         S_exec_failed(aTHX_ argv[0], fd, do_report);
2598     }
2599 leave:
2600     LEAVE;
2601     return FALSE;
2602 }
2603
2604 #endif /* OS2 || WIN32 */
2605
2606 SSize_t
2607 Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
2608 {
2609     I32 val;
2610     SSize_t tot = 0;
2611     const char *const what = PL_op_name[type];
2612     const char *s;
2613     STRLEN len;
2614     SV ** const oldmark = mark;
2615     bool killgp = FALSE;
2616
2617     PERL_ARGS_ASSERT_APPLY;
2618
2619     PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
2620
2621     /* Doing this ahead of the switch statement preserves the old behaviour,
2622        where attempting to use kill as a taint test would fail on
2623        platforms where kill was not defined.  */
2624 #ifndef HAS_KILL
2625     if (type == OP_KILL)
2626         Perl_die(aTHX_ PL_no_func, what);
2627 #endif
2628 #ifndef HAS_CHOWN
2629     if (type == OP_CHOWN)
2630         Perl_die(aTHX_ PL_no_func, what);
2631 #endif
2632
2633
2634 #define APPLY_TAINT_PROPER() \
2635     STMT_START {                                                        \
2636         if (TAINT_get) { TAINT_PROPER(what); }                          \
2637     } STMT_END
2638
2639     /* This is a first heuristic; it doesn't catch tainting magic. */
2640     if (TAINTING_get) {
2641         while (++mark <= sp) {
2642             if (SvTAINTED(*mark)) {
2643                 TAINT;
2644                 break;
2645             }
2646         }
2647         mark = oldmark;
2648     }
2649     switch (type) {
2650     case OP_CHMOD:
2651         APPLY_TAINT_PROPER();
2652         if (++mark <= sp) {
2653             val = SvIV(*mark);
2654             APPLY_TAINT_PROPER();
2655             tot = sp - mark;
2656             while (++mark <= sp) {
2657                 GV* gv;
2658                 if ((gv = MAYBE_DEREF_GV(*mark))) {
2659                     if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2660 #ifdef HAS_FCHMOD
2661                         int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
2662                         APPLY_TAINT_PROPER();
2663                         if (fd < 0) {
2664                             SETERRNO(EBADF,RMS_IFI);
2665                             tot--;
2666                         } else if (fchmod(fd, val))
2667                             tot--;
2668 #else
2669                         Perl_die(aTHX_ PL_no_func, "fchmod");
2670 #endif
2671                     }
2672                     else {
2673                         SETERRNO(EBADF,RMS_IFI);
2674                         tot--;
2675                     }
2676                 }
2677                 else {
2678                     const char *name = SvPV_nomg_const(*mark, len);
2679                     APPLY_TAINT_PROPER();
2680                     if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
2681                         PerlLIO_chmod(name, val)) {
2682                         tot--;
2683                     }
2684                 }
2685             }
2686         }
2687         break;
2688 #ifdef HAS_CHOWN
2689     case OP_CHOWN:
2690         APPLY_TAINT_PROPER();
2691         if (sp - mark > 2) {
2692             I32 val2;
2693             val = SvIVx(*++mark);
2694             val2 = SvIVx(*++mark);
2695             APPLY_TAINT_PROPER();
2696             tot = sp - mark;
2697             while (++mark <= sp) {
2698                 GV* gv;
2699                 if ((gv = MAYBE_DEREF_GV(*mark))) {
2700                     if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2701 #ifdef HAS_FCHOWN
2702                         int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
2703                         APPLY_TAINT_PROPER();
2704                         if (fd < 0) {
2705                             SETERRNO(EBADF,RMS_IFI);
2706                             tot--;
2707                         } else if (fchown(fd, val, val2))
2708                             tot--;
2709 #else
2710                         Perl_die(aTHX_ PL_no_func, "fchown");
2711 #endif
2712                     }
2713                     else {
2714                         SETERRNO(EBADF,RMS_IFI);
2715                         tot--;
2716                     }
2717                 }
2718                 else {
2719                     const char *name = SvPV_nomg_const(*mark, len);
2720                     APPLY_TAINT_PROPER();
2721                     if (!IS_SAFE_PATHNAME(name, len, "chown") ||
2722                         PerlLIO_chown(name, val, val2)) {
2723                         tot--;
2724                     }
2725                 }
2726             }
2727         }
2728         break;
2729 #endif
2730 /*
2731 XXX Should we make lchown() directly available from perl?
2732 For now, we'll let Configure test for HAS_LCHOWN, but do
2733 nothing in the core.
2734     --AD  5/1998
2735 */
2736 #ifdef HAS_KILL
2737     case OP_KILL:
2738         APPLY_TAINT_PROPER();
2739         if (mark == sp)
2740             break;
2741         s = SvPVx_const(*++mark, len);
2742         if (*s == '-' && isALPHA(s[1]))
2743         {
2744             s++;
2745             len--;
2746             killgp = TRUE;
2747         }
2748         if (isALPHA(*s)) {
2749             if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
2750                 s += 3;
2751                 len -= 3;
2752             }
2753            if ((val = whichsig_pvn(s, len)) < 0)
2754                Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"",
2755                                 SVfARG(*mark));
2756         }
2757         else
2758         {
2759             val = SvIV(*mark);
2760             if (val < 0)
2761             {
2762                 killgp = TRUE;
2763                 val = -val;
2764             }
2765         }
2766         APPLY_TAINT_PROPER();
2767         tot = sp - mark;
2768
2769         while (++mark <= sp) {
2770             Pid_t proc;
2771             SvGETMAGIC(*mark);
2772             if (!(SvNIOK(*mark) || looks_like_number(*mark)))
2773                 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
2774             proc = SvIV_nomg(*mark);
2775             APPLY_TAINT_PROPER();
2776 #ifdef HAS_KILLPG
2777             /* use killpg in preference, as the killpg() wrapper for Win32
2778              * understands process groups, but the kill() wrapper doesn't */
2779             if (killgp ? PerlProc_killpg(proc, val)
2780                        : PerlProc_kill(proc, val))
2781 #else
2782             if (PerlProc_kill(killgp ? -proc: proc, val))
2783 #endif
2784                 tot--;
2785         }
2786         PERL_ASYNC_CHECK();
2787         break;
2788 #endif
2789     case OP_UNLINK:
2790         APPLY_TAINT_PROPER();
2791         tot = sp - mark;
2792         while (++mark <= sp) {
2793             s = SvPV_const(*mark, len);
2794             APPLY_TAINT_PROPER();
2795             if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
2796                 tot--;
2797             }
2798             else if (PL_unsafe) {
2799                 if (UNLINK(s))
2800                 {
2801                     tot--;
2802                 }
2803 #if defined(__amigaos4__) && defined(NEWLIB)
2804                 else
2805                 {
2806                   /* Under AmigaOS4 unlink only 'fails' if the
2807                    * filename is invalid.  It may not remove the file
2808                    * if it's locked, so check if it's still around. */
2809                   if ((access(s,F_OK) != -1))
2810                   {
2811                     tot--;
2812                   }
2813                 }
2814 #endif
2815             }
2816             else {      /* don't let root wipe out directories without -U */
2817                 Stat_t statbuf;
2818                 if (PerlLIO_lstat(s, &statbuf) < 0)
2819                     tot--;
2820                 else if (S_ISDIR(statbuf.st_mode)) {
2821                     SETERRNO(EISDIR, SS_NOPRIV);
2822                     tot--;
2823                 }
2824                 else {
2825                     if (UNLINK(s))
2826                     {
2827                                 tot--;
2828                         }
2829 #if defined(__amigaos4__) && defined(NEWLIB)
2830                         else
2831                         {
2832                                 /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */
2833                                 /* It may not remove the file if it's Locked, so check if it's still */
2834                                 /* around */
2835                                 if((access(s,F_OK) != -1))
2836                                 {
2837                                         tot--;
2838                                 }
2839                         }
2840 #endif
2841                 }
2842             }
2843         }
2844         break;
2845 #if defined(HAS_UTIME) || defined(HAS_FUTIMES)
2846     case OP_UTIME:
2847         APPLY_TAINT_PROPER();
2848         if (sp - mark > 2) {
2849 #if defined(HAS_FUTIMES)
2850             struct timeval utbuf[2];
2851             void *utbufp = utbuf;
2852 #elif defined(I_UTIME) || defined(VMS)
2853             struct utimbuf utbuf;
2854             struct utimbuf *utbufp = &utbuf;
2855 #else
2856             struct {
2857                 Time_t  actime;
2858                 Time_t  modtime;
2859             } utbuf;
2860             void *utbufp = &utbuf;
2861 #endif
2862
2863            SV* const accessed = *++mark;
2864            SV* const modified = *++mark;
2865
2866            /* Be like C, and if both times are undefined, let the C
2867             * library figure out what to do.  This usually means
2868             * "current time". */
2869
2870            if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
2871                 utbufp = NULL;
2872            else {
2873                 Zero(&utbuf, sizeof utbuf, char);
2874 #ifdef HAS_FUTIMES
2875                 utbuf[0].tv_sec = (time_t)SvIV(accessed);  /* time accessed */
2876                 utbuf[0].tv_usec = 0;
2877                 utbuf[1].tv_sec = (time_t)SvIV(modified);  /* time modified */
2878                 utbuf[1].tv_usec = 0;
2879 #elif defined(BIG_TIME)
2880                 utbuf.actime = (Time_t)SvNV(accessed);  /* time accessed */
2881                 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
2882 #else
2883                 utbuf.actime = (Time_t)SvIV(accessed);  /* time accessed */
2884                 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
2885 #endif
2886             }
2887             APPLY_TAINT_PROPER();
2888             tot = sp - mark;
2889             while (++mark <= sp) {
2890                 GV* gv;
2891                 if ((gv = MAYBE_DEREF_GV(*mark))) {
2892                     if (GvIO(gv) && IoIFP(GvIOp(gv))) {
2893 #ifdef HAS_FUTIMES
2894                         int fd =  PerlIO_fileno(IoIFP(GvIOn(gv)));
2895                         APPLY_TAINT_PROPER();
2896                         if (fd < 0) {
2897                             SETERRNO(EBADF,RMS_IFI);
2898                             tot--;
2899                         } else if (futimes(fd, (struct timeval *) utbufp))
2900                             tot--;
2901 #else
2902                         Perl_die(aTHX_ PL_no_func, "futimes");
2903 #endif
2904                     }
2905                     else {
2906                         SETERRNO(EBADF,RMS_IFI);
2907                         tot--;
2908                     }
2909                 }
2910                 else {
2911                     const char * const name = SvPV_nomg_const(*mark, len);
2912                     APPLY_TAINT_PROPER();
2913                     if (!IS_SAFE_PATHNAME(name, len, "utime")) {
2914                         tot--;
2915                     }
2916                     else
2917 #ifdef HAS_FUTIMES
2918                     if (utimes(name, (struct timeval *)utbufp))
2919 #else
2920                     if (PerlLIO_utime(name, utbufp))
2921 #endif
2922                         tot--;
2923                 }
2924
2925             }
2926         }
2927         else
2928             tot = 0;
2929         break;
2930 #endif
2931     }
2932     return tot;
2933
2934 #undef APPLY_TAINT_PROPER
2935 }
2936
2937 /* Do the permissions in *statbufp allow some operation? */
2938 #ifndef VMS /* VMS' cando is in vms.c */
2939 bool
2940 Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
2941 /* effective is a flag, true for EUID, or for checking if the effective gid
2942  *  is in the list of groups returned from getgroups().
2943  */
2944 {
2945     PERL_ARGS_ASSERT_CANDO;
2946     PERL_UNUSED_CONTEXT;
2947
2948 #ifdef DOSISH
2949     /* [Comments and code from Len Reed]
2950      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
2951      * to write-protected files.  The execute permission bit is set
2952      * by the Microsoft C library stat() function for the following:
2953      *          .exe files
2954      *          .com files
2955      *          .bat files
2956      *          directories
2957      * All files and directories are readable.
2958      * Directories and special files, e.g. "CON", cannot be
2959      * write-protected.
2960      * [Comment by Tom Dinger -- a directory can have the write-protect
2961      *          bit set in the file system, but DOS permits changes to
2962      *          the directory anyway.  In addition, all bets are off
2963      *          here for networked software, such as Novell and
2964      *          Sun's PC-NFS.]
2965      */
2966
2967      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
2968       * too so it will actually look into the files for magic numbers
2969       */
2970     return cBOOL(mode & statbufp->st_mode);
2971
2972 #else /* ! DOSISH */
2973 # ifdef __CYGWIN__
2974     if (ingroup(544,effective)) {     /* member of Administrators */
2975 # else
2976     if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) {    /* root is special */
2977 # endif
2978         if (mode == S_IXUSR) {
2979             if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
2980                 return TRUE;
2981         }
2982         else
2983             return TRUE;                /* root reads and writes anything */
2984         return FALSE;
2985     }
2986     if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
2987         if (statbufp->st_mode & mode)
2988             return TRUE;        /* ok as "user" */
2989     }
2990     else if (ingroup(statbufp->st_gid,effective)) {
2991         if (statbufp->st_mode & mode >> 3)
2992             return TRUE;        /* ok as "group" */
2993     }
2994     else if (statbufp->st_mode & mode >> 6)
2995         return TRUE;    /* ok as "other" */
2996     return FALSE;
2997 #endif /* ! DOSISH */
2998 }
2999 #endif /* ! VMS */
3000
3001 static bool
3002 S_ingroup(pTHX_ Gid_t testgid, bool effective)
3003 {
3004 #ifndef PERL_IMPLICIT_SYS
3005     /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */
3006     PERL_UNUSED_CONTEXT;
3007 #endif
3008     if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
3009         return TRUE;
3010 #ifdef HAS_GETGROUPS
3011     {
3012         Groups_t *gary = NULL;
3013         I32 anum;
3014         bool rc = FALSE;
3015
3016         anum = getgroups(0, gary);
3017         if (anum > 0) {
3018             Newx(gary, anum, Groups_t);
3019             anum = getgroups(anum, gary);
3020             while (--anum >= 0)
3021                 if (gary[anum] == testgid) {
3022                     rc = TRUE;
3023                     break;
3024                 }
3025
3026             Safefree(gary);
3027         }
3028         return rc;
3029     }
3030 #else
3031     return FALSE;
3032 #endif
3033 }
3034
3035 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3036
3037 I32
3038 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
3039 {
3040     const key_t key = (key_t)SvNVx(*++mark);
3041     SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
3042     const I32 flags = SvIVx(*++mark);
3043
3044     PERL_ARGS_ASSERT_DO_IPCGET;
3045     PERL_UNUSED_ARG(sp);
3046
3047     SETERRNO(0,0);
3048     switch (optype)
3049     {
3050 #ifdef HAS_MSG
3051     case OP_MSGGET:
3052         return msgget(key, flags);
3053 #endif
3054 #ifdef HAS_SEM
3055     case OP_SEMGET:
3056         return semget(key, (int) SvIV(nsv), flags);
3057 #endif
3058 #ifdef HAS_SHM
3059     case OP_SHMGET:
3060         return shmget(key, (size_t) SvUV(nsv), flags);
3061 #endif
3062 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
3063     default:
3064         /* diag_listed_as: msg%s not implemented */
3065         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
3066 #endif
3067     }
3068     return -1;                  /* should never happen */
3069 }
3070
3071 I32
3072 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
3073 {
3074     char *a;
3075     I32 ret = -1;
3076     const I32 id  = SvIVx(*++mark);
3077 #ifdef Semctl
3078     const I32 n   = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
3079 #endif
3080     const I32 cmd = SvIVx(*++mark);
3081     SV * const astr = *++mark;
3082     STRLEN infosize = 0;
3083     I32 getinfo = (cmd == IPC_STAT);
3084
3085     PERL_ARGS_ASSERT_DO_IPCCTL;
3086     PERL_UNUSED_ARG(sp);
3087
3088     switch (optype)
3089     {
3090 #ifdef HAS_MSG
3091     case OP_MSGCTL:
3092         if (cmd == IPC_STAT || cmd == IPC_SET)
3093             infosize = sizeof(struct msqid_ds);
3094         break;
3095 #endif
3096 #ifdef HAS_SHM
3097     case OP_SHMCTL:
3098         if (cmd == IPC_STAT || cmd == IPC_SET)
3099             infosize = sizeof(struct shmid_ds);
3100         break;
3101 #endif
3102 #ifdef HAS_SEM
3103     case OP_SEMCTL:
3104 #ifdef Semctl
3105         if (cmd == IPC_STAT || cmd == IPC_SET)
3106             infosize = sizeof(struct semid_ds);
3107         else if (cmd == GETALL || cmd == SETALL)
3108         {
3109             struct semid_ds semds;
3110             union semun semun;
3111 #ifdef EXTRA_F_IN_SEMUN_BUF
3112             semun.buff = &semds;
3113 #else
3114             semun.buf = &semds;
3115 #endif
3116             getinfo = (cmd == GETALL);
3117             if (Semctl(id, 0, IPC_STAT, semun) == -1)
3118                 return -1;
3119             infosize = semds.sem_nsems * sizeof(short);
3120                 /* "short" is technically wrong but much more portable
3121                    than guessing about u_?short(_t)? */
3122         }
3123 #else
3124         /* diag_listed_as: sem%s not implemented */
3125         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
3126 #endif
3127         break;
3128 #endif
3129 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
3130     default:
3131         /* diag_listed_as: shm%s not implemented */
3132         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
3133 #endif
3134     }
3135
3136     if (infosize)
3137     {
3138         if (getinfo)
3139         {
3140             /* we're not using the value here, so don't SvPVanything */
3141             SvUPGRADE(astr, SVt_PV);
3142             SvGETMAGIC(astr);
3143             if (SvTHINKFIRST(astr))
3144                 sv_force_normal_flags(astr, 0);
3145             a = SvGROW(astr, infosize+1);
3146         }
3147         else
3148         {
3149             STRLEN len;
3150             a = SvPVbyte(astr, len);
3151             if (len != infosize)
3152                 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
3153                       PL_op_desc[optype],
3154                       (unsigned long)len,
3155                       (long)infosize);
3156         }
3157     }
3158     else
3159     {
3160         /* We historically treat this as a pointer if we don't otherwise recognize
3161            the op, but for many ops the value is simply ignored anyway, so
3162            don't warn on undef.
3163         */
3164         SvGETMAGIC(astr);
3165         if (SvOK(astr)) {
3166             const IV i = SvIV_nomg(astr);
3167             a = INT2PTR(char *,i);              /* ouch */
3168         }
3169         else {
3170             a = NULL;
3171         }
3172     }
3173     SETERRNO(0,0);
3174     switch (optype)
3175     {
3176 #ifdef HAS_MSG
3177     case OP_MSGCTL:
3178         ret = msgctl(id, cmd, (struct msqid_ds *)a);
3179         break;
3180 #endif
3181 #ifdef HAS_SEM
3182     case OP_SEMCTL: {
3183 #ifdef Semctl
3184             union semun unsemds;
3185
3186             if(cmd == SETVAL) {
3187                 unsemds.val = PTR2nat(a);
3188             }
3189             else {
3190 #ifdef EXTRA_F_IN_SEMUN_BUF
3191                 unsemds.buff = (struct semid_ds *)a;
3192 #else
3193                 unsemds.buf = (struct semid_ds *)a;
3194 #endif
3195             }
3196             ret = Semctl(id, n, cmd, unsemds);
3197 #else
3198             /* diag_listed_as: sem%s not implemented */
3199             Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
3200 #endif
3201         }
3202         break;
3203 #endif
3204 #ifdef HAS_SHM
3205     case OP_SHMCTL:
3206         ret = shmctl(id, cmd, (struct shmid_ds *)a);
3207         break;
3208 #endif
3209     }
3210     if (getinfo && ret >= 0) {
3211         SvCUR_set(astr, infosize);
3212         *SvEND(astr) = '\0';
3213         SvPOK_only(astr);
3214         SvSETMAGIC(astr);
3215     }
3216     return ret;
3217 }
3218
3219 I32
3220 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
3221 {
3222 #ifdef HAS_MSG
3223     PERL_ARGS_ASSERT_DO_MSGSND;
3224     PERL_UNUSED_ARG(sp);
3225
3226     STRLEN len;
3227     const I32 id = SvIVx(*++mark);
3228     SV * const mstr = *++mark;
3229     const I32 flags = SvIVx(*++mark);
3230     const char * const mbuf = SvPVbyte(mstr, len);
3231
3232     if (len < sizeof(long))
3233         Perl_croak(aTHX_ "Arg too short for msgsnd");
3234
3235     const STRLEN msize = len - sizeof(long);
3236
3237     SETERRNO(0,0);
3238     if (id >= 0 && flags >= 0) {
3239       return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
3240     } else {
3241       SETERRNO(EINVAL,LIB_INVARG);
3242       return -1;
3243     }
3244 #else
3245     PERL_UNUSED_ARG(sp);
3246     PERL_UNUSED_ARG(mark);
3247     /* diag_listed_as: msg%s not implemented */
3248     Perl_croak(aTHX_ "msgsnd not implemented");
3249     return -1;
3250 #endif
3251 }
3252
3253 SSize_t
3254 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
3255 {
3256 #ifdef HAS_MSG
3257     char *mbuf;
3258     long mtype;
3259     I32 flags;
3260     const I32 id = SvIVx(*++mark);
3261     SV * const mstr = *++mark;
3262
3263     PERL_ARGS_ASSERT_DO_MSGRCV;
3264     PERL_UNUSED_ARG(sp);
3265
3266     /* suppress warning when reading into undef var --jhi */
3267     if (! SvOK(mstr))
3268         SvPVCLEAR(mstr);
3269     SSize_t msize = SvIVx(*++mark);
3270     mtype = (long)SvIVx(*++mark);
3271     flags = SvIVx(*++mark);
3272     SvPV_force_nomg_nolen(mstr);
3273
3274     SETERRNO(0,0);
3275     SSize_t ret;
3276     if (id >= 0 && msize >= 0 && flags >= 0) {
3277         mbuf = SvGROW(mstr, sizeof(long)+msize+1);
3278         ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
3279     } else {
3280         SETERRNO(EINVAL,LIB_INVARG);
3281         ret = -1;
3282     }
3283     if (ret >= 0) {
3284         SvCUR_set(mstr, sizeof(long)+ret);
3285         SvPOK_only(mstr);
3286         *SvEND(mstr) = '\0';
3287         SvSETMAGIC(mstr);
3288         /* who knows who has been playing with this message? */
3289         SvTAINTED_on(mstr);
3290     }
3291
3292     return ret;
3293 #else
3294     PERL_UNUSED_ARG(sp);
3295     PERL_UNUSED_ARG(mark);
3296     /* diag_listed_as: msg%s not implemented */
3297     Perl_croak(aTHX_ "msgrcv not implemented");
3298     return -1;
3299 #endif
3300 }
3301
3302 I32
3303 Perl_do_semop(pTHX_ SV **mark, SV **sp)
3304 {
3305 #ifdef HAS_SEM
3306     STRLEN opsize;
3307     const I32 id = SvIVx(*++mark);
3308     SV * const opstr = *++mark;
3309     const char * const opbuf = SvPVbyte(opstr, opsize);
3310
3311     PERL_ARGS_ASSERT_DO_SEMOP;
3312     PERL_UNUSED_ARG(sp);
3313
3314     if (opsize < 3 * SHORTSIZE
3315         || (opsize % (3 * SHORTSIZE))) {
3316         SETERRNO(EINVAL,LIB_INVARG);
3317         return -1;
3318     }
3319     SETERRNO(0,0);
3320     /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
3321     {
3322         const int nsops  = opsize / (3 * sizeof (short));
3323         int i      = nsops;
3324         short * const ops = (short *) opbuf;
3325         short *o   = ops;
3326         struct sembuf *temps, *t;
3327         I32 result;
3328
3329         Newx (temps, nsops, struct sembuf);
3330         t = temps;
3331         while (i--) {
3332             t->sem_num = *o++;
3333             t->sem_op  = *o++;
3334             t->sem_flg = *o++;
3335             t++;
3336         }
3337         result = semop(id, temps, nsops);
3338         Safefree(temps);
3339         return result;
3340     }
3341 #else
3342     /* diag_listed_as: sem%s not implemented */
3343     Perl_croak(aTHX_ "semop not implemented");
3344 #endif
3345 }
3346
3347 I32
3348 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
3349 {
3350 #ifdef HAS_SHM
3351     char *shm;
3352     struct shmid_ds shmds;
3353     const I32 id = SvIVx(*++mark);
3354     SV * const mstr = *++mark;
3355     const I32 mpos = SvIVx(*++mark);
3356     const I32 msize = SvIVx(*++mark);
3357
3358     PERL_ARGS_ASSERT_DO_SHMIO;
3359     PERL_UNUSED_ARG(sp);
3360
3361     SETERRNO(0,0);
3362     if (shmctl(id, IPC_STAT, &shmds) == -1)
3363         return -1;
3364     if (mpos < 0 || msize < 0
3365         || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
3366         SETERRNO(EFAULT,SS_ACCVIO);             /* can't do as caller requested */
3367         return -1;
3368     }
3369     if (id >= 0) {
3370         shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
3371     } else {
3372         SETERRNO(EINVAL,LIB_INVARG);
3373         return -1;
3374     }
3375     if (shm == (char *)-1)      /* I hate System V IPC, I really do */
3376         return -1;
3377     if (optype == OP_SHMREAD) {
3378         char *mbuf;
3379         /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
3380         SvGETMAGIC(mstr);
3381         SvUPGRADE(mstr, SVt_PV);
3382         if (! SvOK(mstr))
3383             SvPVCLEAR(mstr);
3384         SvPOK_only(mstr);
3385         mbuf = SvGROW(mstr, (STRLEN)msize+1);
3386
3387         Copy(shm + mpos, mbuf, msize, char);
3388         SvCUR_set(mstr, msize);
3389         *SvEND(mstr) = '\0';
3390         SvSETMAGIC(mstr);
3391         /* who knows who has been playing with this shared memory? */
3392         SvTAINTED_on(mstr);
3393     }
3394     else {
3395         STRLEN len;
3396
3397         const char *mbuf = SvPVbyte(mstr, len);
3398         const I32 n = ((I32)len > msize) ? msize : (I32)len;
3399         Copy(mbuf, shm + mpos, n, char);
3400         if (n < msize)
3401             memzero(shm + mpos + n, msize - n);
3402     }
3403     return shmdt(shm);
3404 #else
3405     /* diag_listed_as: shm%s not implemented */
3406     Perl_croak(aTHX_ "shm I/O not implemented");
3407     return -1;
3408 #endif
3409 }
3410
3411 #endif /* SYSV IPC */
3412
3413 /*
3414 =for apidoc start_glob
3415
3416 Function called by C<do_readline> to spawn a glob (or do the glob inside
3417 perl on VMS).  This code used to be inline, but now perl uses C<File::Glob>
3418 this glob starter is only used by miniperl during the build process,
3419 or when PERL_EXTERNAL_GLOB is defined.
3420 Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
3421
3422 =cut
3423 */
3424
3425 PerlIO *
3426 Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
3427 {
3428     SV * const tmpcmd = newSV(0);
3429     PerlIO *fp;
3430     STRLEN len;
3431     const char *s = SvPV(tmpglob, len);
3432
3433     PERL_ARGS_ASSERT_START_GLOB;
3434
3435     if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
3436         return NULL;
3437
3438     ENTER;
3439     SAVEFREESV(tmpcmd);
3440 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
3441            /* since spawning off a process is a real performance hit */
3442
3443 PerlIO *
3444 Perl_vms_start_glob
3445    (pTHX_ SV *tmpglob,
3446     IO *io);
3447
3448     fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
3449
3450 #else /* !VMS */
3451 # ifdef DOSISH
3452 #  if defined(OS2)
3453     sv_setpv(tmpcmd, "for a in ");
3454     sv_catsv(tmpcmd, tmpglob);
3455     sv_catpvs(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
3456 #  else
3457     sv_setpv(tmpcmd, "perlglob ");
3458     sv_catsv(tmpcmd, tmpglob);
3459     sv_catpvs(tmpcmd, " |");
3460 #  endif
3461 # elif defined(CSH)
3462     sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
3463     sv_catpvs(tmpcmd, " -cf 'set nonomatch; glob ");
3464     sv_catsv(tmpcmd, tmpglob);
3465     sv_catpvs(tmpcmd, "' 2>/dev/null |");
3466 # else
3467     sv_setpv(tmpcmd, "echo ");
3468     sv_catsv(tmpcmd, tmpglob);
3469     sv_catpvs(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
3470 # endif /* !DOSISH && !CSH */
3471     {
3472         SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
3473         if (svp && *svp)
3474             save_helem_flags(GvHV(PL_envgv),
3475                              newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
3476                              SAVEf_SETMAGIC);
3477     }
3478     (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
3479                    NULL, NULL, 0);
3480     fp = IoIFP(io);
3481 #endif /* !VMS */
3482     LEAVE;
3483
3484     if (!fp && ckWARN(WARN_GLOB)) {
3485         Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
3486                     Strerror(errno));
3487     }
3488
3489     return fp;
3490 }
3491
3492 /*
3493  * ex: set ts=8 sts=4 sw=4 et:
3494  */