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