doio.c

   1 /*    doio.c
   2  *
   3  *    Copyright (c) 1991-2000, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "Far below them they saw the white waters pour into a foaming bowl, and
  12  * then swirl darkly about a deep oval basin in the rocks, until they found
  13  * their way out again through a narrow gate, and flowed away, fuming and
  14  * chattering, into calmer and more level reaches."
  15  */
  16
  17 #include "EXTERN.h"
  18 #define PERL_IN_DOIO_C
  19 #include "perl.h"
  20
  21 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  22 #ifndef HAS_SEM
  23 #include <sys/ipc.h>
  24 #endif
  25 #ifdef HAS_MSG
  26 #include <sys/msg.h>
  27 #endif
  28 #ifdef HAS_SHM
  29 #include <sys/shm.h>
  30 # ifndef HAS_SHMAT_PROTOTYPE
  31     extern Shmat_t shmat (int, char *, int);
  32 # endif
  33 #endif
  34 #endif
  35
  36 #ifdef I_UTIME
  37 #  if defined(_MSC_VER) || defined(__MINGW32__)
  38 #    include <sys/utime.h>
  39 #  else
  40 #    include <utime.h>
  41 #  endif
  42 #endif
  43
  44 #ifdef O_EXCL
  45 #  define OPEN_EXCL O_EXCL
  46 #else
  47 #  define OPEN_EXCL 0
  48 #endif
  49
  50 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  51 #include <signal.h>
  52 #endif
  53
  54 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  55 #ifdef I_UNISTD
  56 #  include <unistd.h>
  57 #endif
  58
  59 #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
  60 # include <sys/socket.h>
  61 # if defined(USE_SOCKS) && defined(I_SOCKS)
  62 #   include <socks.h>
  63 # endif
  64 # ifdef I_NETBSD
  65 #  include <netdb.h>
  66 # endif
  67 # ifndef ENOTSOCK
  68 #  ifdef I_NET_ERRNO
  69 #   include <net/errno.h>
  70 #  endif
  71 # endif
  72 #endif
  73
  74 /* Put this after #includes because <unistd.h> defines _XOPEN_*. */
  75 #ifndef Sock_size_t
  76 #  if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
  77 #    define Sock_size_t Size_t
  78 #  else
  79 #    define Sock_size_t int
  80 #  endif
  81 #endif
  82
  83 bool
  84 Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
  85              int rawmode, int rawperm, PerlIO *supplied_fp)
  86 {
  87     return do_open9(gv, name, len, as_raw, rawmode, rawperm,
  88                     supplied_fp, Nullsv, 0);
  89 }
  90
  91 bool
  92 Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
  93               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
  94               I32 num_svs)
  95 {
  96     register IO *io = GvIOn(gv);
  97     PerlIO *saveifp = Nullfp;
  98     PerlIO *saveofp = Nullfp;
  99     char savetype = ' ';
 100     int writing = 0;
 101     PerlIO *fp;
 102     int fd;
 103     int result;
 104     bool was_fdopen = FALSE;
 105
 106     PL_forkprocess = 1;         /* assume true if no fork */
 107
 108     if (IoIFP(io)) {
 109         fd = PerlIO_fileno(IoIFP(io));
 110         if (IoTYPE(io) == '-')
 111             result = 0;
 112         else if (fd <= PL_maxsysfd) {
 113             saveifp = IoIFP(io);
 114             saveofp = IoOFP(io);
 115             savetype = IoTYPE(io);
 116             result = 0;
 117         }
 118         else if (IoTYPE(io) == '|')
 119             result = PerlProc_pclose(IoIFP(io));
 120         else if (IoIFP(io) != IoOFP(io)) {
 121             if (IoOFP(io)) {
 122                 result = PerlIO_close(IoOFP(io));
 123                 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
 124             }
 125             else
 126                 result = PerlIO_close(IoIFP(io));
 127         }
 128         else
 129             result = PerlIO_close(IoIFP(io));
 130         if (result == EOF && fd > PL_maxsysfd)
 131             PerlIO_printf(Perl_error_log,
 132                           "Warning: unable to close filehandle %s properly.\n",
 133                           GvENAME(gv));
 134         IoOFP(io) = IoIFP(io) = Nullfp;
 135     }
 136
 137     if (as_raw) {
 138 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
 139         rawmode |= O_LARGEFILE;
 140 #endif
 141
 142 #ifndef O_ACCMODE
 143 #define O_ACCMODE 3             /* Assume traditional implementation */
 144 #endif
 145
 146         switch (result = rawmode & O_ACCMODE) {
 147         case O_RDONLY:
 148              IoTYPE(io) = '<';
 149              break;
 150         case O_WRONLY:
 151              IoTYPE(io) = '>';
 152              break;
 153         case O_RDWR:
 154         default:
 155              IoTYPE(io) = '+';
 156              break;
 157         }
 158
 159         writing = (result > 0);
 160         fd = PerlLIO_open3(name, rawmode, rawperm);
 161
 162         if (fd == -1)
 163             fp = NULL;
 164         else {
 165             char *fpmode;
 166             if (result == O_RDONLY)
 167                 fpmode = "r";
 168 #ifdef O_APPEND
 169             else if (rawmode & O_APPEND)
 170                 fpmode = (result == O_WRONLY) ? "a" : "a+";
 171 #endif
 172             else
 173                 fpmode = (result == O_WRONLY) ? "w" : "r+";
 174             fp = PerlIO_fdopen(fd, fpmode);
 175             if (!fp)
 176                 PerlLIO_close(fd);
 177         }
 178     }
 179     else {
 180         char *type;
 181         char *oname = name;
 182         STRLEN tlen;
 183         STRLEN olen = len;
 184         char mode[3];           /* stdio file mode ("r\0" or "r+\0") */
 185         int dodup;
 186
 187         type = savepvn(name, len);
 188         tlen = len;
 189         SAVEFREEPV(type);
 190         if (num_svs) {
 191             STRLEN l;
 192             name = SvPV(svs, l) ;
 193             len = (I32)l;
 194             name = savepvn(name, len);
 195             SAVEFREEPV(name);
 196         }
 197         else {
 198             while (tlen && isSPACE(type[tlen-1]))
 199                 type[--tlen] = '\0';
 200             name = type;
 201             len = tlen;
 202         }
 203         mode[0] = mode[1] = mode[2] = '\0';
 204         IoTYPE(io) = *type;
 205         if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */
 206             mode[1] = *type++;
 207             --tlen;
 208             writing = 1;
 209         }
 210
 211         if (*type == '|') {
 212             if (num_svs && (tlen != 2 || type[1] != '-')) {
 213               unknown_desr:
 214                 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
 215             }
 216             /*SUPPRESS 530*/
 217             for (type++, tlen--; isSPACE(*type); type++, tlen--) ;
 218             if (!num_svs) {
 219                 name = type;
 220                 len = tlen;
 221             }
 222             if (*name == '\0') { /* command is missing 19990114 */
 223                 dTHR;
 224                 if (ckWARN(WARN_PIPE))
 225                     Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
 226                 errno = EPIPE;
 227                 goto say_false;
 228             }
 229             if (strNE(name,"-") || num_svs)
 230                 TAINT_ENV();
 231             TAINT_PROPER("piped open");
 232             if (name[len-1] == '|') {
 233                 dTHR;
 234                 name[--len] = '\0' ;
 235                 if (ckWARN(WARN_PIPE))
 236                     Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
 237             }
 238             fp = PerlProc_popen(name,"w");
 239             writing = 1;
 240         }
 241         else if (*type == '>') {
 242             TAINT_PROPER("open");
 243             type++;
 244             if (*type == '>') {
 245                 mode[0] = IoTYPE(io) = 'a';
 246                 type++;
 247                 tlen--;
 248             }
 249             else
 250                 mode[0] = 'w';
 251             writing = 1;
 252
 253             if (num_svs && tlen != 1)
 254                 goto unknown_desr;
 255             if (*type == '&') {
 256                 name = type;
 257               duplicity:
 258                 dodup = 1;
 259                 name++;
 260                 if (*name == '=') {
 261                     dodup = 0;
 262                     name++;
 263                 }
 264                 if (!*name && supplied_fp)
 265                     fp = supplied_fp;
 266                 else {
 267                     /*SUPPRESS 530*/
 268                     for (; isSPACE(*name); name++) ;
 269                     if (isDIGIT(*name))
 270                         fd = atoi(name);
 271                     else {
 272                         IO* thatio;
 273                         gv = gv_fetchpv(name,FALSE,SVt_PVIO);
 274                         thatio = GvIO(gv);
 275                         if (!thatio) {
 276 #ifdef EINVAL
 277                             SETERRNO(EINVAL,SS$_IVCHAN);
 278 #endif
 279                             goto say_false;
 280                         }
 281                         if (IoIFP(thatio)) {
 282                             PerlIO *fp = IoIFP(thatio);
 283                             /* Flush stdio buffer before dup. --mjd
 284                              * Unfortunately SEEK_CURing 0 seems to
 285                              * be optimized away on most platforms;
 286                              * only Solaris and Linux seem to flush
 287                              * on that. --jhi */
 288                             PerlIO_seek(fp, 0, SEEK_CUR);
 289                             /* On the other hand, do all platforms
 290                              * take gracefully to flushing a read-only
 291                              * filehandle?  Perhaps we should do
 292                              * fsetpos(src)+fgetpos(dst)?  --nik */
 293                             PerlIO_flush(fp);
 294                             fd = PerlIO_fileno(fp);
 295                             if (IoTYPE(thatio) == 's')
 296                                 IoTYPE(io) = 's';
 297                         }
 298                         else
 299                             fd = -1;
 300                     }
 301                     if (dodup)
 302                         fd = PerlLIO_dup(fd);
 303                     else
 304                         was_fdopen = TRUE;
 305                     if (!(fp = PerlIO_fdopen(fd,mode))) {
 306                         if (dodup)
 307                             PerlLIO_close(fd);
 308                     }
 309                 }
 310             }
 311             else {
 312                 /*SUPPRESS 530*/
 313                 for (; isSPACE(*type); type++) ;
 314                 if (strEQ(type,"-")) {
 315                     fp = PerlIO_stdout();
 316                     IoTYPE(io) = '-';
 317                 }
 318                 else  {
 319                     fp = PerlIO_open((num_svs ? name : type), mode);
 320                 }
 321             }
 322         }
 323         else if (*type == '<') {
 324             if (num_svs && tlen != 1)
 325                 goto unknown_desr;
 326             /*SUPPRESS 530*/
 327             for (type++; isSPACE(*type); type++) ;
 328             mode[0] = 'r';
 329             if (*type == '&') {
 330                 name = type;
 331                 goto duplicity;
 332             }
 333             if (strEQ(type,"-")) {
 334                 fp = PerlIO_stdin();
 335                 IoTYPE(io) = '-';
 336             }
 337             else
 338                 fp = PerlIO_open((num_svs ? name : type), mode);
 339         }
 340         else if (tlen > 1 && type[tlen-1] == '|') {
 341             if (num_svs) {
 342                 if (tlen != 2 || type[0] != '-')
 343                     goto unknown_desr;
 344             }
 345             else {
 346                 type[--tlen] = '\0';
 347                 while (tlen && isSPACE(type[tlen-1]))
 348                     type[--tlen] = '\0';
 349                 /*SUPPRESS 530*/
 350                 for (; isSPACE(*type); type++) ;
 351                 name = type;
 352             }
 353             if (*name == '\0') { /* command is missing 19990114 */
 354                 dTHR;
 355                 if (ckWARN(WARN_PIPE))
 356                     Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
 357                 errno = EPIPE;
 358                 goto say_false;
 359             }
 360             if (strNE(name,"-") || num_svs)
 361                 TAINT_ENV();
 362             TAINT_PROPER("piped open");
 363             fp = PerlProc_popen(name,"r");
 364             IoTYPE(io) = '|';
 365         }
 366         else {
 367             if (num_svs)
 368                 goto unknown_desr;
 369             name = type;
 370             IoTYPE(io) = '<';
 371             /*SUPPRESS 530*/
 372             for (; isSPACE(*name); name++) ;
 373             if (strEQ(name,"-")) {
 374                 fp = PerlIO_stdin();
 375                 IoTYPE(io) = '-';
 376             }
 377             else
 378                 fp = PerlIO_open(name,"r");
 379         }
 380     }
 381     if (!fp) {
 382         dTHR;
 383         if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n'))
 384             Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
 385         goto say_false;
 386     }
 387     if (IoTYPE(io) &&
 388       IoTYPE(io) != '|' && IoTYPE(io) != '-') {
 389         dTHR;
 390         if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
 391             (void)PerlIO_close(fp);
 392             goto say_false;
 393         }
 394         if (S_ISSOCK(PL_statbuf.st_mode))
 395             IoTYPE(io) = 's';   /* in case a socket was passed in to us */
 396 #ifdef HAS_SOCKET
 397         else if (
 398 #ifdef S_IFMT
 399             !(PL_statbuf.st_mode & S_IFMT)
 400 #else
 401             !PL_statbuf.st_mode
 402 #endif
 403         ) {
 404             char tmpbuf[256];
 405             Sock_size_t buflen = sizeof tmpbuf;
 406             if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
 407                             &buflen) >= 0
 408                   || errno != ENOTSOCK)
 409                 IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
 410                                 /* but some return 0 for streams too, sigh */
 411         }
 412 #endif
 413     }
 414     if (saveifp) {              /* must use old fp? */
 415         fd = PerlIO_fileno(saveifp);
 416         if (saveofp) {
 417             PerlIO_flush(saveofp);              /* emulate PerlIO_close() */
 418             if (saveofp != saveifp) {   /* was a socket? */
 419                 PerlIO_close(saveofp);
 420                 if (fd > 2)
 421                     Safefree(saveofp);
 422             }
 423         }
 424         if (fd != PerlIO_fileno(fp)) {
 425             Pid_t pid;
 426             SV *sv;
 427
 428             PerlLIO_dup2(PerlIO_fileno(fp), fd);
 429             sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
 430             (void)SvUPGRADE(sv, SVt_IV);
 431             pid = SvIVX(sv);
 432             SvIVX(sv) = 0;
 433             sv = *av_fetch(PL_fdpid,fd,TRUE);
 434             (void)SvUPGRADE(sv, SVt_IV);
 435             SvIVX(sv) = pid;
 436             if (!was_fdopen)
 437                 PerlIO_close(fp);
 438
 439         }
 440         fp = saveifp;
 441         PerlIO_clearerr(fp);
 442     }
 443 #if defined(HAS_FCNTL) && defined(F_SETFD)
 444     {
 445         int save_errno = errno;
 446         fd = PerlIO_fileno(fp);
 447         fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
 448         errno = save_errno;
 449     }
 450 #endif
 451     IoIFP(io) = fp;
 452     IoFLAGS(io) &= ~IOf_NOLINE;
 453     if (writing) {
 454         dTHR;
 455         if (IoTYPE(io) == 's'
 456           || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) {
 457             if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
 458                 PerlIO_close(fp);
 459                 IoIFP(io) = Nullfp;
 460                 goto say_false;
 461             }
 462         }
 463         else
 464             IoOFP(io) = fp;
 465     }
 466     return TRUE;
 467
 468 say_false:
 469     IoIFP(io) = saveifp;
 470     IoOFP(io) = saveofp;
 471     IoTYPE(io) = savetype;
 472     return FALSE;
 473 }
 474
 475 PerlIO *
 476 Perl_nextargv(pTHX_ register GV *gv)
 477 {
 478     register SV *sv;
 479 #ifndef FLEXFILENAMES
 480     int filedev;
 481     int fileino;
 482 #endif
 483     Uid_t fileuid;
 484     Gid_t filegid;
 485     IO *io = GvIOp(gv);
 486
 487     if (!PL_argvoutgv)
 488         PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
 489     if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
 490         IoFLAGS(io) &= ~IOf_START;
 491         if (PL_inplace) {
 492             if (!PL_argvout_stack)
 493                 PL_argvout_stack = newAV();
 494             av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv));
 495         }
 496     }
 497     if (PL_filemode & (S_ISUID|S_ISGID)) {
 498         PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv)));  /* chmod must follow last write */
 499 #ifdef HAS_FCHMOD
 500         (void)fchmod(PL_lastfd,PL_filemode);
 501 #else
 502         (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 503 #endif
 504     }
 505     PL_filemode = 0;
 506     while (av_len(GvAV(gv)) >= 0) {
 507         dTHR;
 508         STRLEN oldlen;
 509         sv = av_shift(GvAV(gv));
 510         SAVEFREESV(sv);
 511         sv_setsv(GvSV(gv),sv);
 512         SvSETMAGIC(GvSV(gv));
 513         PL_oldname = SvPVx(GvSV(gv), oldlen);
 514         if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
 515             if (PL_inplace) {
 516                 TAINT_PROPER("inplace open");
 517                 if (oldlen == 1 && *PL_oldname == '-') {
 518                     setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
 519                     return IoIFP(GvIOp(gv));
 520                 }
 521 #ifndef FLEXFILENAMES
 522                 filedev = PL_statbuf.st_dev;
 523                 fileino = PL_statbuf.st_ino;
 524 #endif
 525                 PL_filemode = PL_statbuf.st_mode;
 526                 fileuid = PL_statbuf.st_uid;
 527                 filegid = PL_statbuf.st_gid;
 528                 if (!S_ISREG(PL_filemode)) {
 529                     if (ckWARN_d(WARN_INPLACE))
 530                         Perl_warner(aTHX_ WARN_INPLACE,
 531                             "Can't do inplace edit: %s is not a regular file",
 532                             PL_oldname );
 533                     do_close(gv,FALSE);
 534                     continue;
 535                 }
 536                 if (*PL_inplace) {
 537                     char *star = strchr(PL_inplace, '*');
 538                     if (star) {
 539                         char *begin = PL_inplace;
 540                         sv_setpvn(sv, "", 0);
 541                         do {
 542                             sv_catpvn(sv, begin, star - begin);
 543                             sv_catpvn(sv, PL_oldname, oldlen);
 544                             begin = ++star;
 545                         } while ((star = strchr(begin, '*')));
 546                         if (*begin)
 547                             sv_catpv(sv,begin);
 548                     }
 549                     else {
 550                         sv_catpv(sv,PL_inplace);
 551                     }
 552 #ifndef FLEXFILENAMES
 553                     if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
 554                       && PL_statbuf.st_dev == filedev
 555                       && PL_statbuf.st_ino == fileino
 556 #ifdef DJGPP
 557                       || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
 558 #endif
 559                       )
 560                     {
 561                         if (ckWARN_d(WARN_INPLACE))
 562                             Perl_warner(aTHX_ WARN_INPLACE,
 563                               "Can't do inplace edit: %s would not be unique",
 564                               SvPVX(sv));
 565                         do_close(gv,FALSE);
 566                         continue;
 567                     }
 568 #endif
 569 #ifdef HAS_RENAME
 570 #if !defined(DOSISH) && !defined(__CYGWIN__)
 571                     if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
 572                         if (ckWARN_d(WARN_INPLACE))
 573                             Perl_warner(aTHX_ WARN_INPLACE,
 574                               "Can't rename %s to %s: %s, skipping file",
 575                               PL_oldname, SvPVX(sv), Strerror(errno) );
 576                         do_close(gv,FALSE);
 577                         continue;
 578                     }
 579 #else
 580                     do_close(gv,FALSE);
 581                     (void)PerlLIO_unlink(SvPVX(sv));
 582                     (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
 583                     do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
 584 #endif /* DOSISH */
 585 #else
 586                     (void)UNLINK(SvPVX(sv));
 587                     if (link(PL_oldname,SvPVX(sv)) < 0) {
 588                         if (ckWARN_d(WARN_INPLACE))
 589                             Perl_warner(aTHX_ WARN_INPLACE,
 590                               "Can't rename %s to %s: %s, skipping file",
 591                               PL_oldname, SvPVX(sv), Strerror(errno) );
 592                         do_close(gv,FALSE);
 593                         continue;
 594                     }
 595                     (void)UNLINK(PL_oldname);
 596 #endif
 597                 }
 598                 else {
 599 #if !defined(DOSISH) && !defined(AMIGAOS)
 600 #  ifndef VMS  /* Don't delete; use automatic file versioning */
 601                     if (UNLINK(PL_oldname) < 0) {
 602                         if (ckWARN_d(WARN_INPLACE))
 603                             Perl_warner(aTHX_ WARN_INPLACE,
 604                               "Can't remove %s: %s, skipping file",
 605                               PL_oldname, Strerror(errno) );
 606                         do_close(gv,FALSE);
 607                         continue;
 608                     }
 609 #  endif
 610 #else
 611                     Perl_croak(aTHX_ "Can't do inplace edit without backup");
 612 #endif
 613                 }
 614
 615                 sv_setpvn(sv,">",!PL_inplace);
 616                 sv_catpvn(sv,PL_oldname,oldlen);
 617                 SETERRNO(0,0);          /* in case sprintf set errno */
 618 #ifdef VMS
 619                 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
 620                  O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp))
 621 #else
 622                 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
 623                              O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp))
 624 #endif
 625                 {
 626                     if (ckWARN_d(WARN_INPLACE))
 627                         Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s",
 628                           PL_oldname, Strerror(errno) );
 629                     do_close(gv,FALSE);
 630                     continue;
 631                 }
 632                 setdefout(PL_argvoutgv);
 633                 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
 634                 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 635 #ifdef HAS_FCHMOD
 636                 (void)fchmod(PL_lastfd,PL_filemode);
 637 #else
 638 #  if !(defined(WIN32) && defined(__BORLANDC__))
 639                 /* Borland runtime creates a readonly file! */
 640                 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 641 #  endif
 642 #endif
 643                 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
 644 #ifdef HAS_FCHOWN
 645                     (void)fchown(PL_lastfd,fileuid,filegid);
 646 #else
 647 #ifdef HAS_CHOWN
 648                     (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
 649 #endif
 650 #endif
 651                 }
 652             }
 653             return IoIFP(GvIOp(gv));
 654         }
 655         else {
 656             dTHR;
 657             if (ckWARN_d(WARN_INPLACE)) {
 658                 if (!S_ISREG(PL_statbuf.st_mode))
 659                     Perl_warner(aTHX_ WARN_INPLACE,
 660                                 "Can't do inplace edit: %s is not a regular file",
 661                                 PL_oldname);
 662                 else
 663                     Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s",
 664                                 PL_oldname, Strerror(errno));
 665             }
 666         }
 667     }
 668     if (io && (IoFLAGS(io) & IOf_ARGV))
 669         IoFLAGS(io) |= IOf_START;
 670     if (PL_inplace) {
 671         (void)do_close(PL_argvoutgv,FALSE);
 672         if (io && (IoFLAGS(io) & IOf_ARGV)
 673             && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
 674         {
 675             GV *oldout = (GV*)av_pop(PL_argvout_stack);
 676             setdefout(oldout);
 677             SvREFCNT_dec(oldout);
 678             return Nullfp;
 679         }
 680         setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
 681     }
 682     return Nullfp;
 683 }
 684
 685 #ifdef HAS_PIPE
 686 void
 687 Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
 688 {
 689     register IO *rstio;
 690     register IO *wstio;
 691     int fd[2];
 692
 693     if (!rgv)
 694         goto badexit;
 695     if (!wgv)
 696         goto badexit;
 697
 698     rstio = GvIOn(rgv);
 699     wstio = GvIOn(wgv);
 700
 701     if (IoIFP(rstio))
 702         do_close(rgv,FALSE);
 703     if (IoIFP(wstio))
 704         do_close(wgv,FALSE);
 705
 706     if (PerlProc_pipe(fd) < 0)
 707         goto badexit;
 708     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 709     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 710     IoIFP(wstio) = IoOFP(wstio);
 711     IoTYPE(rstio) = '<';
 712     IoTYPE(wstio) = '>';
 713     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 714         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 715         else PerlLIO_close(fd[0]);
 716         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 717         else PerlLIO_close(fd[1]);
 718         goto badexit;
 719     }
 720
 721     sv_setsv(sv,&PL_sv_yes);
 722     return;
 723
 724 badexit:
 725     sv_setsv(sv,&PL_sv_undef);
 726     return;
 727 }
 728 #endif
 729
 730 /* explicit renamed to avoid C++ conflict    -- kja */
 731 bool
 732 Perl_do_close(pTHX_ GV *gv, bool not_implicit)
 733 {
 734     bool retval;
 735     IO *io;
 736
 737     if (!gv)
 738         gv = PL_argvgv;
 739     if (!gv || SvTYPE(gv) != SVt_PVGV) {
 740         if (not_implicit)
 741             SETERRNO(EBADF,SS$_IVCHAN);
 742         return FALSE;
 743     }
 744     io = GvIO(gv);
 745     if (!io) {          /* never opened */
 746         if (not_implicit) {
 747             dTHR;
 748             if (ckWARN(WARN_UNOPENED))
 749                 Perl_warner(aTHX_ WARN_UNOPENED,
 750                        "Close on unopened file <%s>",GvENAME(gv));
 751             SETERRNO(EBADF,SS$_IVCHAN);
 752         }
 753         return FALSE;
 754     }
 755     retval = io_close(io, not_implicit);
 756     if (not_implicit) {
 757         IoLINES(io) = 0;
 758         IoPAGE(io) = 0;
 759         IoLINES_LEFT(io) = IoPAGE_LEN(io);
 760     }
 761     IoTYPE(io) = ' ';
 762     return retval;
 763 }
 764
 765 bool
 766 Perl_io_close(pTHX_ IO *io, bool not_implicit)
 767 {
 768     bool retval = FALSE;
 769     int status;
 770
 771     if (IoIFP(io)) {
 772         if (IoTYPE(io) == '|') {
 773             status = PerlProc_pclose(IoIFP(io));
 774             if (not_implicit) {
 775                 STATUS_NATIVE_SET(status);
 776                 retval = (STATUS_POSIX == 0);
 777             }
 778             else {
 779                 retval = (status != -1);
 780             }
 781         }
 782         else if (IoTYPE(io) == '-')
 783             retval = TRUE;
 784         else {
 785             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {          /* a socket */
 786                 retval = (PerlIO_close(IoOFP(io)) != EOF);
 787                 PerlIO_close(IoIFP(io));        /* clear stdio, fd already closed */
 788             }
 789             else
 790                 retval = (PerlIO_close(IoIFP(io)) != EOF);
 791         }
 792         IoOFP(io) = IoIFP(io) = Nullfp;
 793     }
 794     else if (not_implicit) {
 795         SETERRNO(EBADF,SS$_IVCHAN);
 796     }
 797
 798     return retval;
 799 }
 800
 801 bool
 802 Perl_do_eof(pTHX_ GV *gv)
 803 {
 804     dTHR;
 805     register IO *io;
 806     int ch;
 807
 808     io = GvIO(gv);
 809
 810     if (!io)
 811         return TRUE;
 812     else if (ckWARN(WARN_IO)
 813              && (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
 814                  || IoIFP(io) == PerlIO_stderr()))
 815     {
 816         SV* sv = sv_newmortal();
 817         gv_efullname3(sv, gv, Nullch);
 818         Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
 819                     SvPV_nolen(sv));
 820     }
 821
 822     while (IoIFP(io)) {
 823
 824         if (PerlIO_has_cntptr(IoIFP(io))) {     /* (the code works without this) */
 825             if (PerlIO_get_cnt(IoIFP(io)) > 0)  /* cheat a little, since */
 826                 return FALSE;                   /* this is the most usual case */
 827         }
 828
 829         ch = PerlIO_getc(IoIFP(io));
 830         if (ch != EOF) {
 831             (void)PerlIO_ungetc(IoIFP(io),ch);
 832             return FALSE;
 833         }
 834         if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
 835             if (PerlIO_get_cnt(IoIFP(io)) < -1)
 836                 PerlIO_set_cnt(IoIFP(io),-1);
 837         }
 838         if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
 839             if (!nextargv(PL_argvgv))   /* get another fp handy */
 840                 return TRUE;
 841         }
 842         else
 843             return TRUE;                /* normal fp, definitely end of file */
 844     }
 845     return TRUE;
 846 }
 847
 848 Off_t
 849 Perl_do_tell(pTHX_ GV *gv)
 850 {
 851     register IO *io;
 852     register PerlIO *fp;
 853
 854     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
 855 #ifdef ULTRIX_STDIO_BOTCH
 856         if (PerlIO_eof(fp))
 857             (void)PerlIO_seek(fp, 0L, 2);       /* ultrix 1.2 workaround */
 858 #endif
 859         return PerlIO_tell(fp);
 860     }
 861     {
 862         dTHR;
 863         if (ckWARN(WARN_UNOPENED))
 864             Perl_warner(aTHX_ WARN_UNOPENED, "tell() on unopened file");
 865     }
 866     SETERRNO(EBADF,RMS$_IFI);
 867     return (Off_t)-1;
 868 }
 869
 870 bool
 871 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
 872 {
 873     register IO *io;
 874     register PerlIO *fp;
 875
 876     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
 877 #ifdef ULTRIX_STDIO_BOTCH
 878         if (PerlIO_eof(fp))
 879             (void)PerlIO_seek(fp, 0L, 2);       /* ultrix 1.2 workaround */
 880 #endif
 881         return PerlIO_seek(fp, pos, whence) >= 0;
 882     }
 883     {
 884         dTHR;
 885         if (ckWARN(WARN_UNOPENED))
 886             Perl_warner(aTHX_ WARN_UNOPENED, "seek() on unopened file");
 887     }
 888     SETERRNO(EBADF,RMS$_IFI);
 889     return FALSE;
 890 }
 891
 892 Off_t
 893 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 894 {
 895     register IO *io;
 896     register PerlIO *fp;
 897
 898     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
 899         return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
 900     {
 901         dTHR;
 902         if (ckWARN(WARN_UNOPENED))
 903             Perl_warner(aTHX_ WARN_UNOPENED, "sysseek() on unopened file");
 904     }
 905     SETERRNO(EBADF,RMS$_IFI);
 906     return (Off_t)-1;
 907 }
 908
 909 int
 910 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int flag)
 911 {
 912     if (flag != TRUE)
 913         Perl_croak(aTHX_ "panic: unsetting binmode"); /* Not implemented yet */
 914 #ifdef DOSISH
 915 #if defined(atarist) || defined(__MINT__)
 916     if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
 917         return 1;
 918     else
 919         return 0;
 920 #else
 921     if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
 922 #if defined(WIN32) && defined(__BORLANDC__)
 923         /* The translation mode of the stream is maintained independent
 924          * of the translation mode of the fd in the Borland RTL (heavy
 925          * digging through their runtime sources reveal).  User has to
 926          * set the mode explicitly for the stream (though they don't
 927          * document this anywhere). GSAR 97-5-24
 928          */
 929         PerlIO_seek(fp,0L,0);
 930         ((FILE*)fp)->flags |= _F_BIN;
 931 #endif
 932         return 1;
 933     }
 934     else
 935         return 0;
 936 #endif
 937 #else
 938 #if defined(USEMYBINMODE)
 939     if (my_binmode(fp,iotype) != FALSE)
 940         return 1;
 941     else
 942         return 0;
 943 #else
 944     return 1;
 945 #endif
 946 #endif
 947 }
 948
 949 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
 950         /* code courtesy of William Kucharski */
 951 #define HAS_CHSIZE
 952
 953 I32 my_chsize(fd, length)
 954 I32 fd;                 /* file descriptor */
 955 Off_t length;           /* length to set file to */
 956 {
 957     struct flock fl;
 958     struct stat filebuf;
 959
 960     if (PerlLIO_fstat(fd, &filebuf) < 0)
 961         return -1;
 962
 963     if (filebuf.st_size < length) {
 964
 965         /* extend file length */
 966
 967         if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
 968             return -1;
 969
 970         /* write a "0" byte */
 971
 972         if ((PerlLIO_write(fd, "", 1)) != 1)
 973             return -1;
 974     }
 975     else {
 976         /* truncate length */
 977
 978         fl.l_whence = 0;
 979         fl.l_len = 0;
 980         fl.l_start = length;
 981         fl.l_type = F_WRLCK;    /* write lock on file space */
 982
 983         /*
 984         * This relies on the UNDOCUMENTED F_FREESP argument to
 985         * fcntl(2), which truncates the file so that it ends at the
 986         * position indicated by fl.l_start.
 987         *
 988         * Will minor miracles never cease?
 989         */
 990
 991         if (fcntl(fd, F_FREESP, &fl) < 0)
 992             return -1;
 993
 994     }
 995
 996     return 0;
 997 }
 998 #endif /* F_FREESP */
 999
1000 bool
1001 Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
1002 {
1003     register char *tmps;
1004     STRLEN len;
1005
1006     /* assuming fp is checked earlier */
1007     if (!sv)
1008         return TRUE;
1009     if (PL_ofmt) {
1010         if (SvGMAGICAL(sv))
1011             mg_get(sv);
1012         if (SvIOK(sv) && SvIVX(sv) != 0) {
1013             PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
1014             return !PerlIO_error(fp);
1015         }
1016         if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
1017            || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
1018             PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
1019             return !PerlIO_error(fp);
1020         }
1021     }
1022     switch (SvTYPE(sv)) {
1023     case SVt_NULL:
1024         {
1025             dTHR;
1026             if (ckWARN(WARN_UNINITIALIZED))
1027                 report_uninit();
1028         }
1029         return TRUE;
1030     case SVt_IV:
1031         if (SvIOK(sv)) {
1032             if (SvGMAGICAL(sv))
1033                 mg_get(sv);
1034             if (SvIsUV(sv))
1035                 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
1036             else
1037                 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
1038             return !PerlIO_error(fp);
1039         }
1040         /* FALL THROUGH */
1041     default:
1042         tmps = SvPV(sv, len);
1043         break;
1044     }
1045     /* To detect whether the process is about to overstep its
1046      * filesize limit we would need getrlimit().  We could then
1047      * also transparently raise the limit with setrlimit() --
1048      * but only until the system hard limit/the filesystem limit,
1049      * at which we would get EPERM.  Note that when using buffered
1050      * io the write failure can be delayed until the flush/close. --jhi */
1051     if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
1052         return FALSE;
1053     return !PerlIO_error(fp);
1054 }
1055
1056 I32
1057 Perl_my_stat(pTHX)
1058 {
1059     djSP;
1060     IO *io;
1061     GV* tmpgv;
1062
1063     if (PL_op->op_flags & OPf_REF) {
1064         EXTEND(SP,1);
1065         tmpgv = cGVOP_gv;
1066       do_fstat:
1067         io = GvIO(tmpgv);
1068         if (io && IoIFP(io)) {
1069             PL_statgv = tmpgv;
1070             sv_setpv(PL_statname,"");
1071             PL_laststype = OP_STAT;
1072             return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
1073         }
1074         else {
1075             if (tmpgv == PL_defgv)
1076                 return PL_laststatval;
1077             if (ckWARN(WARN_UNOPENED))
1078                 Perl_warner(aTHX_ WARN_UNOPENED, "Stat on unopened file <%s>",
1079                   GvENAME(tmpgv));
1080             PL_statgv = Nullgv;
1081             sv_setpv(PL_statname,"");
1082             return (PL_laststatval = -1);
1083         }
1084     }
1085     else {
1086         SV* sv = POPs;
1087         char *s;
1088         STRLEN n_a;
1089         PUTBACK;
1090         if (SvTYPE(sv) == SVt_PVGV) {
1091             tmpgv = (GV*)sv;
1092             goto do_fstat;
1093         }
1094         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1095             tmpgv = (GV*)SvRV(sv);
1096             goto do_fstat;
1097         }
1098
1099         s = SvPV(sv, n_a);
1100         PL_statgv = Nullgv;
1101         sv_setpv(PL_statname, s);
1102         PL_laststype = OP_STAT;
1103         PL_laststatval = PerlLIO_stat(s, &PL_statcache);
1104         if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
1105             Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
1106         return PL_laststatval;
1107     }
1108 }
1109
1110 I32
1111 Perl_my_lstat(pTHX)
1112 {
1113     djSP;
1114     SV *sv;
1115     STRLEN n_a;
1116     if (PL_op->op_flags & OPf_REF) {
1117         EXTEND(SP,1);
1118         if (cGVOP_gv == PL_defgv) {
1119             if (PL_laststype != OP_LSTAT)
1120                 Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
1121             return PL_laststatval;
1122         }
1123         Perl_croak(aTHX_ "You can't use -l on a filehandle");
1124     }
1125
1126     PL_laststype = OP_LSTAT;
1127     PL_statgv = Nullgv;
1128     sv = POPs;
1129     PUTBACK;
1130     sv_setpv(PL_statname,SvPV(sv, n_a));
1131     PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
1132     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
1133         Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "lstat");
1134     return PL_laststatval;
1135 }
1136
1137 bool
1138 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
1139 {
1140     return do_aexec5(really, mark, sp, 0, 0);
1141 }
1142
1143 bool
1144 Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
1145                int fd, int do_report)
1146 {
1147 #ifdef MACOS_TRADITIONAL
1148     Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1149 #else
1150     register char **a;
1151     char *tmps;
1152     STRLEN n_a;
1153
1154     if (sp > mark) {
1155         dTHR;
1156         New(401,PL_Argv, sp - mark + 1, char*);
1157         a = PL_Argv;
1158         while (++mark <= sp) {
1159             if (*mark)
1160                 *a++ = SvPVx(*mark, n_a);
1161             else
1162                 *a++ = "";
1163         }
1164         *a = Nullch;
1165         if (*PL_Argv[0] != '/') /* will execvp use PATH? */
1166             TAINT_ENV();                /* testing IFS here is overkill, probably */
1167         if (really && *(tmps = SvPV(really, n_a)))
1168             PerlProc_execvp(tmps,PL_Argv);
1169         else
1170             PerlProc_execvp(PL_Argv[0],PL_Argv);
1171         if (ckWARN(WARN_EXEC))
1172             Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
1173                 PL_Argv[0], Strerror(errno));
1174         if (do_report) {
1175             int e = errno;
1176
1177             PerlLIO_write(fd, (void*)&e, sizeof(int));
1178             PerlLIO_close(fd);
1179         }
1180     }
1181     do_execfree();
1182 #endif
1183     return FALSE;
1184 }
1185
1186 void
1187 Perl_do_execfree(pTHX)
1188 {
1189     if (PL_Argv) {
1190         Safefree(PL_Argv);
1191         PL_Argv = Null(char **);
1192     }
1193     if (PL_Cmd) {
1194         Safefree(PL_Cmd);
1195         PL_Cmd = Nullch;
1196     }
1197 }
1198
1199 #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1200
1201 bool
1202 Perl_do_exec(pTHX_ char *cmd)
1203 {
1204     return do_exec3(cmd,0,0);
1205 }
1206
1207 bool
1208 Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
1209 {
1210     register char **a;
1211     register char *s;
1212     char flags[10];
1213
1214     while (*cmd && isSPACE(*cmd))
1215         cmd++;
1216
1217     /* save an extra exec if possible */
1218
1219 #ifdef CSH
1220     if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
1221         strcpy(flags,"-c");
1222         s = cmd+PL_cshlen+3;
1223         if (*s == 'f') {
1224             s++;
1225             strcat(flags,"f");
1226         }
1227         if (*s == ' ')
1228             s++;
1229         if (*s++ == '\'') {
1230             char *ncmd = s;
1231
1232             while (*s)
1233                 s++;
1234             if (s[-1] == '\n')
1235                 *--s = '\0';
1236             if (s[-1] == '\'') {
1237                 *--s = '\0';
1238                 PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
1239                 *s = '\'';
1240                 return FALSE;
1241             }
1242         }
1243     }
1244 #endif /* CSH */
1245
1246     /* see if there are shell metacharacters in it */
1247
1248     if (*cmd == '.' && isSPACE(cmd[1]))
1249         goto doshell;
1250
1251     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1252         goto doshell;
1253
1254     for (s = cmd; *s && isALNUM(*s); s++) ;     /* catch VAR=val gizmo */
1255     if (*s == '=')
1256         goto doshell;
1257
1258     for (s = cmd; *s; s++) {
1259         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1260             if (*s == '\n' && !s[1]) {
1261                 *s = '\0';
1262                 break;
1263             }
1264             /* handle the 2>&1 construct at the end */
1265             if (*s == '>' && s[1] == '&' && s[2] == '1'
1266                 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1267                 && (!s[3] || isSPACE(s[3])))
1268             {
1269                 char *t = s + 3;
1270
1271                 while (*t && isSPACE(*t))
1272                     ++t;
1273                 if (!*t && (dup2(1,2) != -1)) {
1274                     s[-2] = '\0';
1275                     break;
1276                 }
1277             }
1278           doshell:
1279             PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
1280             return FALSE;
1281         }
1282     }
1283
1284     New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
1285     PL_Cmd = savepvn(cmd, s-cmd);
1286     a = PL_Argv;
1287     for (s = PL_Cmd; *s;) {
1288         while (*s && isSPACE(*s)) s++;
1289         if (*s)
1290             *(a++) = s;
1291         while (*s && !isSPACE(*s)) s++;
1292         if (*s)
1293             *s++ = '\0';
1294     }
1295     *a = Nullch;
1296     if (PL_Argv[0]) {
1297         PerlProc_execvp(PL_Argv[0],PL_Argv);
1298         if (errno == ENOEXEC) {         /* for system V NIH syndrome */
1299             do_execfree();
1300             goto doshell;
1301         }
1302         {
1303             dTHR;
1304             int e = errno;
1305
1306             if (ckWARN(WARN_EXEC))
1307                 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
1308                     PL_Argv[0], Strerror(errno));
1309             if (do_report) {
1310                 PerlLIO_write(fd, (void*)&e, sizeof(int));
1311                 PerlLIO_close(fd);
1312             }
1313         }
1314     }
1315     do_execfree();
1316     return FALSE;
1317 }
1318
1319 #endif /* OS2 || WIN32 */
1320
1321 I32
1322 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
1323 {
1324     dTHR;
1325     register I32 val;
1326     register I32 val2;
1327     register I32 tot = 0;
1328     char *what;
1329     char *s;
1330     SV **oldmark = mark;
1331     STRLEN n_a;
1332
1333 #define APPLY_TAINT_PROPER() \
1334     STMT_START {                                                        \
1335         if (PL_tainted) { TAINT_PROPER(what); }                         \
1336     } STMT_END
1337
1338     /* This is a first heuristic; it doesn't catch tainting magic. */
1339     if (PL_tainting) {
1340         while (++mark <= sp) {
1341             if (SvTAINTED(*mark)) {
1342                 TAINT;
1343                 break;
1344             }
1345         }
1346         mark = oldmark;
1347     }
1348     switch (type) {
1349     case OP_CHMOD:
1350         what = "chmod";
1351         APPLY_TAINT_PROPER();
1352         if (++mark <= sp) {
1353             val = SvIVx(*mark);
1354             APPLY_TAINT_PROPER();
1355             tot = sp - mark;
1356             while (++mark <= sp) {
1357                 char *name = SvPVx(*mark, n_a);
1358                 APPLY_TAINT_PROPER();
1359                 if (PerlLIO_chmod(name, val))
1360                     tot--;
1361             }
1362         }
1363         break;
1364 #ifdef HAS_CHOWN
1365     case OP_CHOWN:
1366         what = "chown";
1367         APPLY_TAINT_PROPER();
1368         if (sp - mark > 2) {
1369             val = SvIVx(*++mark);
1370             val2 = SvIVx(*++mark);
1371             APPLY_TAINT_PROPER();
1372             tot = sp - mark;
1373             while (++mark <= sp) {
1374                 char *name = SvPVx(*mark, n_a);
1375                 APPLY_TAINT_PROPER();
1376                 if (PerlLIO_chown(name, val, val2))
1377                     tot--;
1378             }
1379         }
1380         break;
1381 #endif
1382 /*
1383 XXX Should we make lchown() directly available from perl?
1384 For now, we'll let Configure test for HAS_LCHOWN, but do
1385 nothing in the core.
1386     --AD  5/1998
1387 */
1388 #ifdef HAS_KILL
1389     case OP_KILL:
1390         what = "kill";
1391         APPLY_TAINT_PROPER();
1392         if (mark == sp)
1393             break;
1394         s = SvPVx(*++mark, n_a);
1395         if (isUPPER(*s)) {
1396             if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1397                 s += 3;
1398             if (!(val = whichsig(s)))
1399                 Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
1400         }
1401         else
1402             val = SvIVx(*mark);
1403         APPLY_TAINT_PROPER();
1404         tot = sp - mark;
1405 #ifdef VMS
1406         /* kill() doesn't do process groups (job trees?) under VMS */
1407         if (val < 0) val = -val;
1408         if (val == SIGKILL) {
1409 #           include <starlet.h>
1410             /* Use native sys$delprc() to insure that target process is
1411              * deleted; supervisor-mode images don't pay attention to
1412              * CRTL's emulation of Unix-style signals and kill()
1413              */
1414             while (++mark <= sp) {
1415                 I32 proc = SvIVx(*mark);
1416                 register unsigned long int __vmssts;
1417                 APPLY_TAINT_PROPER();
1418                 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1419                     tot--;
1420                     switch (__vmssts) {
1421                         case SS$_NONEXPR:
1422                         case SS$_NOSUCHNODE:
1423                             SETERRNO(ESRCH,__vmssts);
1424                             break;
1425                         case SS$_NOPRIV:
1426                             SETERRNO(EPERM,__vmssts);
1427                             break;
1428                         default:
1429                             SETERRNO(EVMSERR,__vmssts);
1430                     }
1431                 }
1432             }
1433             break;
1434         }
1435 #endif
1436         if (val < 0) {
1437             val = -val;
1438             while (++mark <= sp) {
1439                 I32 proc = SvIVx(*mark);
1440                 APPLY_TAINT_PROPER();
1441 #ifdef HAS_KILLPG
1442                 if (PerlProc_killpg(proc,val))  /* BSD */
1443 #else
1444                 if (PerlProc_kill(-proc,val))   /* SYSV */
1445 #endif
1446                     tot--;
1447             }
1448         }
1449         else {
1450             while (++mark <= sp) {
1451                 I32 proc = SvIVx(*mark);
1452                 APPLY_TAINT_PROPER();
1453                 if (PerlProc_kill(proc, val))
1454                     tot--;
1455             }
1456         }
1457         break;
1458 #endif
1459     case OP_UNLINK:
1460         what = "unlink";
1461         APPLY_TAINT_PROPER();
1462         tot = sp - mark;
1463         while (++mark <= sp) {
1464             s = SvPVx(*mark, n_a);
1465             APPLY_TAINT_PROPER();
1466             if (PL_euid || PL_unsafe) {
1467                 if (UNLINK(s))
1468                     tot--;
1469             }
1470             else {      /* don't let root wipe out directories without -U */
1471                 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
1472                     tot--;
1473                 else {
1474                     if (UNLINK(s))
1475                         tot--;
1476                 }
1477             }
1478         }
1479         break;
1480 #ifdef HAS_UTIME
1481     case OP_UTIME:
1482         what = "utime";
1483         APPLY_TAINT_PROPER();
1484         if (sp - mark > 2) {
1485 #if defined(I_UTIME) || defined(VMS)
1486             struct utimbuf utbuf;
1487 #else
1488             struct {
1489                 Time_t  actime;
1490                 Time_t  modtime;
1491             } utbuf;
1492 #endif
1493
1494             Zero(&utbuf, sizeof utbuf, char);
1495 #ifdef BIG_TIME
1496             utbuf.actime = (Time_t)SvNVx(*++mark);      /* time accessed */
1497             utbuf.modtime = (Time_t)SvNVx(*++mark);     /* time modified */
1498 #else
1499             utbuf.actime = (Time_t)SvIVx(*++mark);      /* time accessed */
1500             utbuf.modtime = (Time_t)SvIVx(*++mark);     /* time modified */
1501 #endif
1502             APPLY_TAINT_PROPER();
1503             tot = sp - mark;
1504             while (++mark <= sp) {
1505                 char *name = SvPVx(*mark, n_a);
1506                 APPLY_TAINT_PROPER();
1507                 if (PerlLIO_utime(name, &utbuf))
1508                     tot--;
1509             }
1510         }
1511         else
1512             tot = 0;
1513         break;
1514 #endif
1515     }
1516     return tot;
1517
1518 #undef APPLY_TAINT_PROPER
1519 }
1520
1521 /* Do the permissions allow some operation?  Assumes statcache already set. */
1522 #ifndef VMS /* VMS' cando is in vms.c */
1523 bool
1524 Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
1525 /* Note: we use `effective' both for uids and gids.
1526  * Here we are betting on Uid_t being equal or wider than Gid_t.  */
1527 {
1528 #ifdef DOSISH
1529     /* [Comments and code from Len Reed]
1530      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1531      * to write-protected files.  The execute permission bit is set
1532      * by the Miscrosoft C library stat() function for the following:
1533      *          .exe files
1534      *          .com files
1535      *          .bat files
1536      *          directories
1537      * All files and directories are readable.
1538      * Directories and special files, e.g. "CON", cannot be
1539      * write-protected.
1540      * [Comment by Tom Dinger -- a directory can have the write-protect
1541      *          bit set in the file system, but DOS permits changes to
1542      *          the directory anyway.  In addition, all bets are off
1543      *          here for networked software, such as Novell and
1544      *          Sun's PC-NFS.]
1545      */
1546
1547      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1548       * too so it will actually look into the files for magic numbers
1549       */
1550      return (mode & statbufp->st_mode) ? TRUE : FALSE;
1551
1552 #else /* ! DOSISH */
1553     if ((effective ? PL_euid : PL_uid) == 0) {  /* root is special */
1554         if (mode == S_IXUSR) {
1555             if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1556                 return TRUE;
1557         }
1558         else
1559             return TRUE;                /* root reads and writes anything */
1560         return FALSE;
1561     }
1562     if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
1563         if (statbufp->st_mode & mode)
1564             return TRUE;        /* ok as "user" */
1565     }
1566     else if (ingroup(statbufp->st_gid,effective)) {
1567         if (statbufp->st_mode & mode >> 3)
1568             return TRUE;        /* ok as "group" */
1569     }
1570     else if (statbufp->st_mode & mode >> 6)
1571         return TRUE;    /* ok as "other" */
1572     return FALSE;
1573 #endif /* ! DOSISH */
1574 }
1575 #endif /* ! VMS */
1576
1577 bool
1578 Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
1579 {
1580 #ifdef MACOS_TRADITIONAL
1581     /* This is simply not correct for AppleShare, but fix it yerself. */
1582     return TRUE;
1583 #else
1584     if (testgid == (effective ? PL_egid : PL_gid))
1585         return TRUE;
1586 #ifdef HAS_GETGROUPS
1587 #ifndef NGROUPS
1588 #define NGROUPS 32
1589 #endif
1590     {
1591         Groups_t gary[NGROUPS];
1592         I32 anum;
1593
1594         anum = getgroups(NGROUPS,gary);
1595         while (--anum >= 0)
1596             if (gary[anum] == testgid)
1597                 return TRUE;
1598     }
1599 #endif
1600     return FALSE;
1601 #endif
1602 }
1603
1604 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1605
1606 I32
1607 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
1608 {
1609     dTHR;
1610     key_t key;
1611     I32 n, flags;
1612
1613     key = (key_t)SvNVx(*++mark);
1614     n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1615     flags = SvIVx(*++mark);
1616     SETERRNO(0,0);
1617     switch (optype)
1618     {
1619 #ifdef HAS_MSG
1620     case OP_MSGGET:
1621         return msgget(key, flags);
1622 #endif
1623 #ifdef HAS_SEM
1624     case OP_SEMGET:
1625         return semget(key, n, flags);
1626 #endif
1627 #ifdef HAS_SHM
1628     case OP_SHMGET:
1629         return shmget(key, n, flags);
1630 #endif
1631 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1632     default:
1633         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1634 #endif
1635     }
1636     return -1;                  /* should never happen */
1637 }
1638
1639 I32
1640 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
1641 {
1642     dTHR;
1643     SV *astr;
1644     char *a;
1645     I32 id, n, cmd, infosize, getinfo;
1646     I32 ret = -1;
1647
1648     id = SvIVx(*++mark);
1649     n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1650     cmd = SvIVx(*++mark);
1651     astr = *++mark;
1652     infosize = 0;
1653     getinfo = (cmd == IPC_STAT);
1654
1655     switch (optype)
1656     {
1657 #ifdef HAS_MSG
1658     case OP_MSGCTL:
1659         if (cmd == IPC_STAT || cmd == IPC_SET)
1660             infosize = sizeof(struct msqid_ds);
1661         break;
1662 #endif
1663 #ifdef HAS_SHM
1664     case OP_SHMCTL:
1665         if (cmd == IPC_STAT || cmd == IPC_SET)
1666             infosize = sizeof(struct shmid_ds);
1667         break;
1668 #endif
1669 #ifdef HAS_SEM
1670     case OP_SEMCTL:
1671 #ifdef Semctl
1672         if (cmd == IPC_STAT || cmd == IPC_SET)
1673             infosize = sizeof(struct semid_ds);
1674         else if (cmd == GETALL || cmd == SETALL)
1675         {
1676             struct semid_ds semds;
1677             union semun semun;
1678
1679             semun.buf = &semds;
1680             getinfo = (cmd == GETALL);
1681             if (Semctl(id, 0, IPC_STAT, semun) == -1)
1682                 return -1;
1683             infosize = semds.sem_nsems * sizeof(short);
1684                 /* "short" is technically wrong but much more portable
1685                    than guessing about u_?short(_t)? */
1686         }
1687 #else
1688         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1689 #endif
1690         break;
1691 #endif
1692 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1693     default:
1694         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1695 #endif
1696     }
1697
1698     if (infosize)
1699     {
1700         STRLEN len;
1701         if (getinfo)
1702         {
1703             SvPV_force(astr, len);
1704             a = SvGROW(astr, infosize+1);
1705         }
1706         else
1707         {
1708             a = SvPV(astr, len);
1709             if (len != infosize)
1710                 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
1711                       PL_op_desc[optype],
1712                       (unsigned long)len,
1713                       (long)infosize);
1714         }
1715     }
1716     else
1717     {
1718         IV i = SvIV(astr);
1719         a = INT2PTR(char *,i);          /* ouch */
1720     }
1721     SETERRNO(0,0);
1722     switch (optype)
1723     {
1724 #ifdef HAS_MSG
1725     case OP_MSGCTL:
1726         ret = msgctl(id, cmd, (struct msqid_ds *)a);
1727         break;
1728 #endif
1729 #ifdef HAS_SEM
1730     case OP_SEMCTL: {
1731 #ifdef Semctl
1732             union semun unsemds;
1733
1734             unsemds.buf = (struct semid_ds *)a;
1735             ret = Semctl(id, n, cmd, unsemds);
1736 #else
1737             Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1738 #endif
1739         }
1740         break;
1741 #endif
1742 #ifdef HAS_SHM
1743     case OP_SHMCTL:
1744         ret = shmctl(id, cmd, (struct shmid_ds *)a);
1745         break;
1746 #endif
1747     }
1748     if (getinfo && ret >= 0) {
1749         SvCUR_set(astr, infosize);
1750         *SvEND(astr) = '\0';
1751         SvSETMAGIC(astr);
1752     }
1753     return ret;
1754 }
1755
1756 I32
1757 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
1758 {
1759 #ifdef HAS_MSG
1760     dTHR;
1761     SV *mstr;
1762     char *mbuf;
1763     I32 id, msize, flags;
1764     STRLEN len;
1765
1766     id = SvIVx(*++mark);
1767     mstr = *++mark;
1768     flags = SvIVx(*++mark);
1769     mbuf = SvPV(mstr, len);
1770     if ((msize = len - sizeof(long)) < 0)
1771         Perl_croak(aTHX_ "Arg too short for msgsnd");
1772     SETERRNO(0,0);
1773     return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
1774 #else
1775     Perl_croak(aTHX_ "msgsnd not implemented");
1776 #endif
1777 }
1778
1779 I32
1780 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
1781 {
1782 #ifdef HAS_MSG
1783     dTHR;
1784     SV *mstr;
1785     char *mbuf;
1786     long mtype;
1787     I32 id, msize, flags, ret;
1788     STRLEN len;
1789
1790     id = SvIVx(*++mark);
1791     mstr = *++mark;
1792     msize = SvIVx(*++mark);
1793     mtype = (long)SvIVx(*++mark);
1794     flags = SvIVx(*++mark);
1795     SvPV_force(mstr, len);
1796     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1797
1798     SETERRNO(0,0);
1799     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
1800     if (ret >= 0) {
1801         SvCUR_set(mstr, sizeof(long)+ret);
1802         *SvEND(mstr) = '\0';
1803     }
1804     return ret;
1805 #else
1806     Perl_croak(aTHX_ "msgrcv not implemented");
1807 #endif
1808 }
1809
1810 I32
1811 Perl_do_semop(pTHX_ SV **mark, SV **sp)
1812 {
1813 #ifdef HAS_SEM
1814     dTHR;
1815     SV *opstr;
1816     char *opbuf;
1817     I32 id;
1818     STRLEN opsize;
1819
1820     id = SvIVx(*++mark);
1821     opstr = *++mark;
1822     opbuf = SvPV(opstr, opsize);
1823     if (opsize < sizeof(struct sembuf)
1824         || (opsize % sizeof(struct sembuf)) != 0) {
1825         SETERRNO(EINVAL,LIB$_INVARG);
1826         return -1;
1827     }
1828     SETERRNO(0,0);
1829     return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
1830 #else
1831     Perl_croak(aTHX_ "semop not implemented");
1832 #endif
1833 }
1834
1835 I32
1836 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
1837 {
1838 #ifdef HAS_SHM
1839     dTHR;
1840     SV *mstr;
1841     char *mbuf, *shm;
1842     I32 id, mpos, msize;
1843     STRLEN len;
1844     struct shmid_ds shmds;
1845
1846     id = SvIVx(*++mark);
1847     mstr = *++mark;
1848     mpos = SvIVx(*++mark);
1849     msize = SvIVx(*++mark);
1850     SETERRNO(0,0);
1851     if (shmctl(id, IPC_STAT, &shmds) == -1)
1852         return -1;
1853     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
1854         SETERRNO(EFAULT,SS$_ACCVIO);            /* can't do as caller requested */
1855         return -1;
1856     }
1857     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
1858     if (shm == (char *)-1)      /* I hate System V IPC, I really do */
1859         return -1;
1860     if (optype == OP_SHMREAD) {
1861         SvPV_force(mstr, len);
1862         mbuf = SvGROW(mstr, msize+1);
1863
1864         Copy(shm + mpos, mbuf, msize, char);
1865         SvCUR_set(mstr, msize);
1866         *SvEND(mstr) = '\0';
1867         SvSETMAGIC(mstr);
1868     }
1869     else {
1870         I32 n;
1871
1872         mbuf = SvPV(mstr, len);
1873         if ((n = len) > msize)
1874             n = msize;
1875         Copy(mbuf, shm + mpos, n, char);
1876         if (n < msize)
1877             memzero(shm + mpos + n, msize - n);
1878     }
1879     return shmdt(shm);
1880 #else
1881     Perl_croak(aTHX_ "shm I/O not implemented");
1882 #endif
1883 }
1884
1885 #endif /* SYSV IPC */
1886