doio.c

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