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