doio.c

   1 /*    doio.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 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
  18 #include "EXTERN.h"
  19 #define PERL_IN_DOIO_C
  20 #include "perl.h"
  21
  22 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  23 #ifndef HAS_SEM
  24 #include <sys/ipc.h>
  25 #endif
  26 #ifdef HAS_MSG
  27 #include <sys/msg.h>
  28 #endif
  29 #ifdef HAS_SHM
  30 #include <sys/shm.h>
  31 # ifndef HAS_SHMAT_PROTOTYPE
  32     extern Shmat_t shmat (int, char *, int);
  33 # endif
  34 #endif
  35 #endif
  36
  37 #ifdef I_UTIME
  38 #  if defined(_MSC_VER) || defined(__MINGW32__)
  39 #    include <sys/utime.h>
  40 #  else
  41 #    include <utime.h>
  42 #  endif
  43 #endif
  44
  45 #ifdef O_EXCL
  46 #  define OPEN_EXCL O_EXCL
  47 #else
  48 #  define OPEN_EXCL 0
  49 #endif
  50
  51 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  52 #include <signal.h>
  53 #endif
  54
  55 bool
  56 Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
  57              int rawmode, int rawperm, PerlIO *supplied_fp)
  58 {
  59     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
  60                     supplied_fp, (SV **) NULL, 0);
  61 }
  62
  63 bool
  64 Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
  65               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
  66               I32 num_svs)
  67 {
  68     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
  69                     supplied_fp, &svs, 1);
  70 }
  71
  72 bool
  73 Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
  74               int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
  75               I32 num_svs)
  76 {
  77     register IO *io = GvIOn(gv);
  78     PerlIO *saveifp = Nullfp;
  79     PerlIO *saveofp = Nullfp;
  80     int savefd = -1;
  81     char savetype = IoTYPE_CLOSED;
  82     int writing = 0;
  83     PerlIO *fp;
  84     int fd;
  85     int result;
  86     bool was_fdopen = FALSE;
  87     bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
  88     char *type  = NULL;
  89     char mode[8];               /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
  90     SV *namesv;
  91
  92     Zero(mode,sizeof(mode),char);
  93     PL_forkprocess = 1;         /* assume true if no fork */
  94
  95     /* Collect default raw/crlf info from the op */
  96     if (PL_op && PL_op->op_type == OP_OPEN) {
  97         /* set up IO layers */
  98         U8 flags = PL_op->op_private;
  99         in_raw = (flags & OPpOPEN_IN_RAW);
 100         in_crlf = (flags & OPpOPEN_IN_CRLF);
 101         out_raw = (flags & OPpOPEN_OUT_RAW);
 102         out_crlf = (flags & OPpOPEN_OUT_CRLF);
 103     }
 104
 105     /* If currently open - close before we re-open */
 106     if (IoIFP(io)) {
 107         fd = PerlIO_fileno(IoIFP(io));
 108         if (IoTYPE(io) == IoTYPE_STD) {
 109             /* This is a clone of one of STD* handles */
 110             result = 0;
 111         }
 112         else if (fd >= 0 && fd <= PL_maxsysfd) {
 113             /* This is one of the original STD* handles */
 114             saveifp  = IoIFP(io);
 115             saveofp  = IoOFP(io);
 116             savetype = IoTYPE(io);
 117             savefd   = fd;
 118             result   = 0;
 119         }
 120         else if (IoTYPE(io) == IoTYPE_PIPE)
 121             result = PerlProc_pclose(IoIFP(io));
 122         else if (IoIFP(io) != IoOFP(io)) {
 123             if (IoOFP(io)) {
 124                 result = PerlIO_close(IoOFP(io));
 125                 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
 126             }
 127             else
 128                 result = PerlIO_close(IoIFP(io));
 129         }
 130         else
 131             result = PerlIO_close(IoIFP(io));
 132         if (result == EOF && fd > PL_maxsysfd) {
 133             /* Why is this not Perl_warn*() call ? */
 134             PerlIO_printf(Perl_error_log,
 135                           "Warning: unable to close filehandle %s properly.\n",
 136                           GvENAME(gv));
 137         }
 138         IoOFP(io) = IoIFP(io) = Nullfp;
 139     }
 140
 141     if (as_raw) {
 142         /* sysopen style args, i.e. integer mode and permissions */
 143         STRLEN ix = 0;
 144         int appendtrunc =
 145              0
 146 #ifdef O_APPEND /* Not fully portable. */
 147              |O_APPEND
 148 #endif
 149 #ifdef O_TRUNC  /* Not fully portable. */
 150              |O_TRUNC
 151 #endif
 152              ;
 153         int modifyingmode =
 154              O_WRONLY|O_RDWR|O_CREAT|appendtrunc;
 155         int ismodifying;
 156
 157         if (num_svs != 0) {
 158              Perl_croak(aTHX_ "panic: sysopen with multiple args");
 159         }
 160         /* It's not always
 161
 162            O_RDONLY 0
 163            O_WRONLY 1
 164            O_RDWR   2
 165
 166            It might be (in OS/390 and Mac OS Classic it is)
 167
 168            O_WRONLY 1
 169            O_RDONLY 2
 170            O_RDWR   3
 171
 172            This means that simple & with O_RDWR would look
 173            like O_RDONLY is present.  Therefore we have to
 174            be more careful.
 175         */
 176         if ((ismodifying = (rawmode & modifyingmode))) {
 177              if ((ismodifying & O_WRONLY) == O_WRONLY ||
 178                  (ismodifying & O_RDWR)   == O_RDWR   ||
 179                  (ismodifying & (O_CREAT|appendtrunc)))
 180                   TAINT_PROPER("sysopen");
 181         }
 182         mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */
 183
 184 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
 185         rawmode |= O_LARGEFILE; /* Transparently largefiley. */
 186 #endif
 187
 188         IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
 189
 190         namesv = sv_2mortal(newSVpvn(name,strlen(name)));
 191         num_svs = 1;
 192         svp = &namesv;
 193         type = Nullch;
 194         fp = PerlIO_openn(aTHX_ type, mode, -1, rawmode, rawperm, NULL, num_svs, svp);
 195     }
 196     else {
 197         /* Regular (non-sys) open */
 198         char *oname = name;
 199         STRLEN olen = len;
 200         char *tend;
 201         int dodup = 0;
 202         PerlIO *that_fp = NULL;
 203
 204         type = savepvn(name, len);
 205         tend = type+len;
 206         SAVEFREEPV(type);
 207
 208         /* Lose leading and trailing white space */
 209         /*SUPPRESS 530*/
 210         for (; isSPACE(*type); type++) ;
 211         while (tend > type && isSPACE(tend[-1]))
 212             *--tend = '\0';
 213
 214         if (num_svs) {
 215             /* New style explicit name, type is just mode and layer info */
 216             STRLEN l = 0;
 217 #ifdef USE_STDIO
 218             if (SvROK(*svp) && !strchr(name,'&')) {
 219                 if (ckWARN(WARN_IO))
 220                     Perl_warner(aTHX_ packWARN(WARN_IO),
 221                             "Can't open a reference");
 222                 SETERRNO(EINVAL, LIB_INVARG);
 223                 goto say_false;
 224             }
 225 #endif /* USE_STDIO */
 226             name = SvOK(*svp) ? SvPV(*svp, l) : "";
 227             len = (I32)l;
 228             name = savepvn(name, len);
 229             SAVEFREEPV(name);
 230         }
 231         else {
 232             name = type;
 233             len  = tend-type;
 234         }
 235         IoTYPE(io) = *type;
 236         if ((*type == IoTYPE_RDWR) && /* scary */
 237            (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) &&
 238             ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) {
 239             TAINT_PROPER("open");
 240             mode[1] = *type++;
 241             writing = 1;
 242         }
 243
 244         if (*type == IoTYPE_PIPE) {
 245             if (num_svs) {
 246                 if (type[1] != IoTYPE_STD) {
 247                   unknown_open_mode:
 248                     Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
 249                 }
 250                 type++;
 251             }
 252             /*SUPPRESS 530*/
 253             for (type++; isSPACE(*type); type++) ;
 254             if (!num_svs) {
 255                 name = type;
 256                 len = tend-type;
 257             }
 258             if (*name == '\0') {
 259                 /* command is missing 19990114 */
 260                 if (ckWARN(WARN_PIPE))
 261                     Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
 262                 errno = EPIPE;
 263                 goto say_false;
 264             }
 265             if (strNE(name,"-") || num_svs)
 266                 TAINT_ENV();
 267             TAINT_PROPER("piped open");
 268             if (!num_svs && name[len-1] == '|') {
 269                 name[--len] = '\0' ;
 270                 if (ckWARN(WARN_PIPE))
 271                     Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe");
 272             }
 273             mode[0] = 'w';
 274             writing = 1;
 275             if (out_raw)
 276                 strcat(mode, "b");
 277             else if (out_crlf)
 278                 strcat(mode, "t");
 279             if (num_svs > 1) {
 280                 fp = PerlProc_popen_list(mode, num_svs, svp);
 281             }
 282             else {
 283                 fp = PerlProc_popen(name,mode);
 284             }
 285             if (num_svs) {
 286                 if (*type) {
 287                     if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
 288                         goto say_false;
 289                     }
 290                 }
 291             }
 292         } /* IoTYPE_PIPE */
 293         else if (*type == IoTYPE_WRONLY) {
 294             TAINT_PROPER("open");
 295             type++;
 296             if (*type == IoTYPE_WRONLY) {
 297                 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
 298                 mode[0] = IoTYPE(io) = IoTYPE_APPEND;
 299                 type++;
 300             }
 301             else {
 302                 mode[0] = 'w';
 303             }
 304             writing = 1;
 305
 306             if (out_raw)
 307                 strcat(mode, "b");
 308             else if (out_crlf)
 309                 strcat(mode, "t");
 310
 311             if (*type == '&') {
 312               duplicity:
 313                 dodup = PERLIO_DUP_FD;
 314                 type++;
 315                 if (*type == '=') {
 316                     dodup = 0;
 317                     type++;
 318                 }
 319                 if (!num_svs && !*type && supplied_fp) {
 320                     /* "<+&" etc. is used by typemaps */
 321                     fp = supplied_fp;
 322                 }
 323                 else {
 324                     if (num_svs > 1) {
 325                         Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
 326                     }
 327                     /*SUPPRESS 530*/
 328                     for (; isSPACE(*type); type++) ;
 329                     if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
 330                         fd = SvUV(*svp);
 331                         num_svs = 0;
 332                     }
 333                     else if (isDIGIT(*type)) {
 334                         fd = atoi(type);
 335                     }
 336                     else {
 337                         IO* thatio;
 338                         if (num_svs) {
 339                             thatio = sv_2io(*svp);
 340                         }
 341                         else {
 342                             GV *thatgv;
 343                             thatgv = gv_fetchpv(type,FALSE,SVt_PVIO);
 344                             thatio = GvIO(thatgv);
 345                         }
 346                         if (!thatio) {
 347 #ifdef EINVAL
 348                             SETERRNO(EINVAL,SS_IVCHAN);
 349 #endif
 350                             goto say_false;
 351                         }
 352                         if ((that_fp = IoIFP(thatio))) {
 353                             /* Flush stdio buffer before dup. --mjd
 354                              * Unfortunately SEEK_CURing 0 seems to
 355                              * be optimized away on most platforms;
 356                              * only Solaris and Linux seem to flush
 357                              * on that. --jhi */
 358 #ifdef USE_SFIO
 359                             /* sfio fails to clear error on next
 360                                sfwrite, contrary to documentation.
 361                                -- Nick Clark */
 362                             if (PerlIO_seek(that_fp, 0, SEEK_CUR) == -1)
 363                                 PerlIO_clearerr(that_fp);
 364 #endif
 365                             /* On the other hand, do all platforms
 366                              * take gracefully to flushing a read-only
 367                              * filehandle?  Perhaps we should do
 368                              * fsetpos(src)+fgetpos(dst)?  --nik */
 369                             PerlIO_flush(that_fp);
 370                             fd = PerlIO_fileno(that_fp);
 371                             /* When dup()ing STDIN, STDOUT or STDERR
 372                              * explicitly set appropriate access mode */
 373                             if (that_fp == PerlIO_stdout()
 374                                 || that_fp == PerlIO_stderr())
 375                                 IoTYPE(io) = IoTYPE_WRONLY;
 376                             else if (that_fp == PerlIO_stdin())
 377                                 IoTYPE(io) = IoTYPE_RDONLY;
 378                             /* When dup()ing a socket, say result is
 379                              * one as well */
 380                             else if (IoTYPE(thatio) == IoTYPE_SOCKET)
 381                                 IoTYPE(io) = IoTYPE_SOCKET;
 382                         }
 383                         else
 384                             fd = -1;
 385                     }
 386                     if (!num_svs)
 387                         type = Nullch;
 388                     if (that_fp) {
 389                         fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
 390                     }
 391                     else {
 392                         if (dodup)
 393                             fd = PerlLIO_dup(fd);
 394                         else
 395                             was_fdopen = TRUE;
 396                         if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
 397                             if (dodup)
 398                                 PerlLIO_close(fd);
 399                         }
 400                     }
 401                 }
 402             } /* & */
 403             else {
 404                 /*SUPPRESS 530*/
 405                 for (; isSPACE(*type); type++) ;
 406                 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
 407                     /*SUPPRESS 530*/
 408                     type++;
 409                     fp = PerlIO_stdout();
 410                     IoTYPE(io) = IoTYPE_STD;
 411                     if (num_svs > 1) {
 412                         Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
 413                     }
 414                 }
 415                 else  {
 416                     if (!num_svs) {
 417                         namesv = sv_2mortal(newSVpvn(type,strlen(type)));
 418                         num_svs = 1;
 419                         svp = &namesv;
 420                         type = Nullch;
 421                     }
 422                     fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
 423                 }
 424             } /* !& */
 425         } /* IoTYPE_WRONLY */
 426         else if (*type == IoTYPE_RDONLY) {
 427             /*SUPPRESS 530*/
 428             for (type++; isSPACE(*type); type++) ;
 429             mode[0] = 'r';
 430             if (in_raw)
 431                 strcat(mode, "b");
 432             else if (in_crlf)
 433                 strcat(mode, "t");
 434
 435             if (*type == '&') {
 436                 goto duplicity;
 437             }
 438             if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
 439                 /*SUPPRESS 530*/
 440                 type++;
 441                 fp = PerlIO_stdin();
 442                 IoTYPE(io) = IoTYPE_STD;
 443                 if (num_svs > 1) {
 444                     Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
 445                 }
 446             }
 447             else {
 448                 if (!num_svs) {
 449                     namesv = sv_2mortal(newSVpvn(type,strlen(type)));
 450                     num_svs = 1;
 451                     svp = &namesv;
 452                     type = Nullch;
 453                 }
 454                 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
 455             }
 456         } /* IoTYPE_RDONLY */
 457         else if ((num_svs && /* '-|...' or '...|' */
 458                   type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
 459                  (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
 460             if (num_svs) {
 461                 type += 2;   /* skip over '-|' */
 462             }
 463             else {
 464                 *--tend = '\0';
 465                 while (tend > type && isSPACE(tend[-1]))
 466                     *--tend = '\0';
 467                 /*SUPPRESS 530*/
 468                 for (; isSPACE(*type); type++) ;
 469                 name = type;
 470                 len  = tend-type;
 471             }
 472             if (*name == '\0') {
 473                 /* command is missing 19990114 */
 474                 if (ckWARN(WARN_PIPE))
 475                     Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
 476                 errno = EPIPE;
 477                 goto say_false;
 478             }
 479             if (strNE(name,"-") || num_svs)
 480                 TAINT_ENV();
 481             TAINT_PROPER("piped open");
 482             mode[0] = 'r';
 483             if (in_raw)
 484                 strcat(mode, "b");
 485             else if (in_crlf)
 486                 strcat(mode, "t");
 487             if (num_svs > 1) {
 488                 fp = PerlProc_popen_list(mode,num_svs,svp);
 489             }
 490             else {
 491                 fp = PerlProc_popen(name,mode);
 492             }
 493             IoTYPE(io) = IoTYPE_PIPE;
 494             if (num_svs) {
 495                 for (; isSPACE(*type); type++) ;
 496                 if (*type) {
 497                     if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
 498                         goto say_false;
 499                     }
 500                 }
 501             }
 502         }
 503         else { /* layer(Args) */
 504             if (num_svs)
 505                 goto unknown_open_mode;
 506             name = type;
 507             IoTYPE(io) = IoTYPE_RDONLY;
 508             /*SUPPRESS 530*/
 509             for (; isSPACE(*name); name++) ;
 510             mode[0] = 'r';
 511             if (in_raw)
 512                 strcat(mode, "b");
 513             else if (in_crlf)
 514                 strcat(mode, "t");
 515             if (strEQ(name,"-")) {
 516                 fp = PerlIO_stdin();
 517                 IoTYPE(io) = IoTYPE_STD;
 518             }
 519             else {
 520                 if (!num_svs) {
 521                     namesv = sv_2mortal(newSVpvn(type,strlen(type)));
 522                     num_svs = 1;
 523                     svp = &namesv;
 524                     type = Nullch;
 525                 }
 526                 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
 527             }
 528         }
 529     }
 530     if (!fp) {
 531         if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n'))
 532             Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
 533         goto say_false;
 534     }
 535
 536     if (ckWARN(WARN_IO)) {
 537         if ((IoTYPE(io) == IoTYPE_RDONLY) &&
 538             (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
 539                 Perl_warner(aTHX_ packWARN(WARN_IO),
 540                             "Filehandle STD%s reopened as %s only for input",
 541                             ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
 542                             GvENAME(gv));
 543         }
 544         else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
 545                 Perl_warner(aTHX_ packWARN(WARN_IO),
 546                             "Filehandle STDIN reopened as %s only for output",
 547                             GvENAME(gv));
 548         }
 549     }
 550
 551     fd = PerlIO_fileno(fp);
 552     /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
 553      * socket - this covers PerlIO::scalar - otherwise unless we "know" the
 554      * type probe for socket-ness.
 555      */
 556     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
 557         if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
 558             /* If PerlIO claims to have fd we had better be able to fstat() it. */
 559             (void) PerlIO_close(fp);
 560             goto say_false;
 561         }
 562 #ifndef PERL_MICRO
 563         if (S_ISSOCK(PL_statbuf.st_mode))
 564             IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
 565 #ifdef HAS_SOCKET
 566         else if (
 567 #ifdef S_IFMT
 568             !(PL_statbuf.st_mode & S_IFMT)
 569 #else
 570             !PL_statbuf.st_mode
 571 #endif
 572             && IoTYPE(io) != IoTYPE_WRONLY  /* Dups of STD* filehandles already have */
 573             && IoTYPE(io) != IoTYPE_RDONLY  /* type so they aren't marked as sockets */
 574         ) {                                 /* on OS's that return 0 on fstat()ed pipe */
 575              char tmpbuf[256];
 576              Sock_size_t buflen = sizeof tmpbuf;
 577              if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
 578                       || errno != ENOTSOCK)
 579                     IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
 580                                                 /* but some return 0 for streams too, sigh */
 581         }
 582 #endif /* HAS_SOCKET */
 583 #endif /* !PERL_MICRO */
 584     }
 585
 586     /* Eeek - FIXME !!!
 587      * If this is a standard handle we discard all the layer stuff
 588      * and just dup the fd into whatever was on the handle before !
 589      */
 590
 591     if (saveifp) {              /* must use old fp? */
 592         /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
 593            then dup the new fileno down
 594          */
 595         if (saveofp) {
 596             PerlIO_flush(saveofp);      /* emulate PerlIO_close() */
 597             if (saveofp != saveifp) {   /* was a socket? */
 598                 PerlIO_close(saveofp);
 599             }
 600         }
 601         if (savefd != fd) {
 602             /* Still a small can-of-worms here if (say) PerlIO::scalar
 603                is assigned to (say) STDOUT - for now let dup2() fail
 604                and provide the error
 605              */
 606             if (PerlLIO_dup2(fd, savefd) < 0) {
 607                 (void)PerlIO_close(fp);
 608                 goto say_false;
 609             }
 610 #ifdef VMS
 611             if (savefd != PerlIO_fileno(PerlIO_stdin())) {
 612                 char newname[FILENAME_MAX+1];
 613                 if (PerlIO_getname(fp, newname)) {
 614                     if (fd == PerlIO_fileno(PerlIO_stdout()))
 615                         Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
 616                     if (fd == PerlIO_fileno(PerlIO_stderr()))
 617                         Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",  newname);
 618                 }
 619             }
 620 #endif
 621
 622 #if !defined(WIN32)
 623            /* PL_fdpid isn't used on Windows, so avoid this useless work.
 624             * XXX Probably the same for a lot of other places. */
 625             {
 626                 Pid_t pid;
 627                 SV *sv;
 628
 629                 LOCK_FDPID_MUTEX;
 630                 sv = *av_fetch(PL_fdpid,fd,TRUE);
 631                 (void)SvUPGRADE(sv, SVt_IV);
 632                 pid = SvIVX(sv);
 633                 SvIVX(sv) = 0;
 634                 sv = *av_fetch(PL_fdpid,savefd,TRUE);
 635                 (void)SvUPGRADE(sv, SVt_IV);
 636                 SvIVX(sv) = pid;
 637                 UNLOCK_FDPID_MUTEX;
 638             }
 639 #endif
 640
 641             if (was_fdopen) {
 642                 /* need to close fp without closing underlying fd */
 643                 int ofd = PerlIO_fileno(fp);
 644                 int dupfd = PerlLIO_dup(ofd);
 645 #if defined(HAS_FCNTL) && defined(F_SETFD)
 646                 /* Assume if we have F_SETFD we have F_GETFD */
 647                 int coe = fcntl(ofd,F_GETFD);
 648 #endif
 649                 PerlIO_close(fp);
 650                 PerlLIO_dup2(dupfd,ofd);
 651 #if defined(HAS_FCNTL) && defined(F_SETFD)
 652                 /* The dup trick has lost close-on-exec on ofd */
 653                 fcntl(ofd,F_SETFD, coe);
 654 #endif
 655                 PerlLIO_close(dupfd);
 656             }
 657             else
 658                 PerlIO_close(fp);
 659         }
 660         fp = saveifp;
 661         PerlIO_clearerr(fp);
 662         fd = PerlIO_fileno(fp);
 663     }
 664 #if defined(HAS_FCNTL) && defined(F_SETFD)
 665     if (fd >= 0) {
 666         int save_errno = errno;
 667         fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
 668         errno = save_errno;
 669     }
 670 #endif
 671     IoIFP(io) = fp;
 672
 673     IoFLAGS(io) &= ~IOf_NOLINE;
 674     if (writing) {
 675         if (IoTYPE(io) == IoTYPE_SOCKET
 676             || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
 677             char *s = mode;
 678             if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
 679               s++;
 680             *s = 'w';
 681             if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) {
 682                 PerlIO_close(fp);
 683                 IoIFP(io) = Nullfp;
 684                 goto say_false;
 685             }
 686         }
 687         else
 688             IoOFP(io) = fp;
 689     }
 690     return TRUE;
 691
 692 say_false:
 693     IoIFP(io) = saveifp;
 694     IoOFP(io) = saveofp;
 695     IoTYPE(io) = savetype;
 696     return FALSE;
 697 }
 698
 699 PerlIO *
 700 Perl_nextargv(pTHX_ register GV *gv)
 701 {
 702     register SV *sv;
 703 #ifndef FLEXFILENAMES
 704     int filedev;
 705     int fileino;
 706 #endif
 707     Uid_t fileuid;
 708     Gid_t filegid;
 709     IO *io = GvIOp(gv);
 710
 711     if (!PL_argvoutgv)
 712         PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
 713     if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
 714         IoFLAGS(io) &= ~IOf_START;
 715         if (PL_inplace) {
 716             if (!PL_argvout_stack)
 717                 PL_argvout_stack = newAV();
 718             av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv));
 719         }
 720     }
 721     if (PL_filemode & (S_ISUID|S_ISGID)) {
 722         PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv)));  /* chmod must follow last write */
 723 #ifdef HAS_FCHMOD
 724         (void)fchmod(PL_lastfd,PL_filemode);
 725 #else
 726         (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 727 #endif
 728     }
 729     PL_filemode = 0;
 730     if (!GvAV(gv))
 731         return Nullfp;
 732     while (av_len(GvAV(gv)) >= 0) {
 733         STRLEN oldlen;
 734         sv = av_shift(GvAV(gv));
 735         SAVEFREESV(sv);
 736         sv_setsv(GvSV(gv),sv);
 737         SvSETMAGIC(GvSV(gv));
 738         PL_oldname = SvPVx(GvSV(gv), oldlen);
 739         if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
 740             if (PL_inplace) {
 741                 TAINT_PROPER("inplace open");
 742                 if (oldlen == 1 && *PL_oldname == '-') {
 743                     setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
 744                     return IoIFP(GvIOp(gv));
 745                 }
 746 #ifndef FLEXFILENAMES
 747                 filedev = PL_statbuf.st_dev;
 748                 fileino = PL_statbuf.st_ino;
 749 #endif
 750                 PL_filemode = PL_statbuf.st_mode;
 751                 fileuid = PL_statbuf.st_uid;
 752                 filegid = PL_statbuf.st_gid;
 753                 if (!S_ISREG(PL_filemode)) {
 754                     if (ckWARN_d(WARN_INPLACE))
 755                         Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 756                             "Can't do inplace edit: %s is not a regular file",
 757                             PL_oldname );
 758                     do_close(gv,FALSE);
 759                     continue;
 760                 }
 761                 if (*PL_inplace) {
 762                     char *star = strchr(PL_inplace, '*');
 763                     if (star) {
 764                         char *begin = PL_inplace;
 765                         sv_setpvn(sv, "", 0);
 766                         do {
 767                             sv_catpvn(sv, begin, star - begin);
 768                             sv_catpvn(sv, PL_oldname, oldlen);
 769                             begin = ++star;
 770                         } while ((star = strchr(begin, '*')));
 771                         if (*begin)
 772                             sv_catpv(sv,begin);
 773                     }
 774                     else {
 775                         sv_catpv(sv,PL_inplace);
 776                     }
 777 #ifndef FLEXFILENAMES
 778                     if ((PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
 779                          && PL_statbuf.st_dev == filedev
 780                          && PL_statbuf.st_ino == fileino)
 781 #ifdef DJGPP
 782                         || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
 783 #endif
 784                       )
 785                     {
 786                         if (ckWARN_d(WARN_INPLACE))
 787                             Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 788                               "Can't do inplace edit: %"SVf" would not be unique",
 789                               sv);
 790                         do_close(gv,FALSE);
 791                         continue;
 792                     }
 793 #endif
 794 #ifdef HAS_RENAME
 795 #if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC)
 796                     if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
 797                         if (ckWARN_d(WARN_INPLACE))
 798                             Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 799                               "Can't rename %s to %"SVf": %s, skipping file",
 800                               PL_oldname, sv, Strerror(errno) );
 801                         do_close(gv,FALSE);
 802                         continue;
 803                     }
 804 #else
 805                     do_close(gv,FALSE);
 806                     (void)PerlLIO_unlink(SvPVX(sv));
 807                     (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
 808                     do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
 809 #endif /* DOSISH */
 810 #else
 811                     (void)UNLINK(SvPVX(sv));
 812                     if (link(PL_oldname,SvPVX(sv)) < 0) {
 813                         if (ckWARN_d(WARN_INPLACE))
 814                             Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 815                               "Can't rename %s to %"SVf": %s, skipping file",
 816                               PL_oldname, sv, Strerror(errno) );
 817                         do_close(gv,FALSE);
 818                         continue;
 819                     }
 820                     (void)UNLINK(PL_oldname);
 821 #endif
 822                 }
 823                 else {
 824 #if !defined(DOSISH) && !defined(AMIGAOS)
 825 #  ifndef VMS  /* Don't delete; use automatic file versioning */
 826                     if (UNLINK(PL_oldname) < 0) {
 827                         if (ckWARN_d(WARN_INPLACE))
 828                             Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 829                               "Can't remove %s: %s, skipping file",
 830                               PL_oldname, Strerror(errno) );
 831                         do_close(gv,FALSE);
 832                         continue;
 833                     }
 834 #  endif
 835 #else
 836                     Perl_croak(aTHX_ "Can't do inplace edit without backup");
 837 #endif
 838                 }
 839
 840                 sv_setpvn(sv,">",!PL_inplace);
 841                 sv_catpvn(sv,PL_oldname,oldlen);
 842                 SETERRNO(0,0);          /* in case sprintf set errno */
 843 #ifdef VMS
 844                 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
 845                  O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp))
 846 #else
 847                 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
 848                              O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp))
 849 #endif
 850                 {
 851                     if (ckWARN_d(WARN_INPLACE))
 852                         Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
 853                           PL_oldname, Strerror(errno) );
 854                     do_close(gv,FALSE);
 855                     continue;
 856                 }
 857                 setdefout(PL_argvoutgv);
 858                 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
 859                 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 860 #ifdef HAS_FCHMOD
 861                 (void)fchmod(PL_lastfd,PL_filemode);
 862 #else
 863 #  if !(defined(WIN32) && defined(__BORLANDC__))
 864                 /* Borland runtime creates a readonly file! */
 865                 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 866 #  endif
 867 #endif
 868                 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
 869 #ifdef HAS_FCHOWN
 870                     (void)fchown(PL_lastfd,fileuid,filegid);
 871 #else
 872 #ifdef HAS_CHOWN
 873                     (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
 874 #endif
 875 #endif
 876                 }
 877             }
 878             return IoIFP(GvIOp(gv));
 879         }
 880         else {
 881             if (ckWARN_d(WARN_INPLACE)) {
 882                 int eno = errno;
 883                 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
 884                     && !S_ISREG(PL_statbuf.st_mode))
 885                 {
 886                     Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 887                                 "Can't do inplace edit: %s is not a regular file",
 888                                 PL_oldname);
 889                 }
 890                 else
 891                     Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
 892                                 PL_oldname, Strerror(eno));
 893             }
 894         }
 895     }
 896     if (io && (IoFLAGS(io) & IOf_ARGV))
 897         IoFLAGS(io) |= IOf_START;
 898     if (PL_inplace) {
 899         (void)do_close(PL_argvoutgv,FALSE);
 900         if (io && (IoFLAGS(io) & IOf_ARGV)
 901             && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
 902         {
 903             GV *oldout = (GV*)av_pop(PL_argvout_stack);
 904             setdefout(oldout);
 905             SvREFCNT_dec(oldout);
 906             return Nullfp;
 907         }
 908         setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
 909     }
 910     return Nullfp;
 911 }
 912
 913 #ifdef HAS_PIPE
 914 void
 915 Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
 916 {
 917     register IO *rstio;
 918     register IO *wstio;
 919     int fd[2];
 920
 921     if (!rgv)
 922         goto badexit;
 923     if (!wgv)
 924         goto badexit;
 925
 926     rstio = GvIOn(rgv);
 927     wstio = GvIOn(wgv);
 928
 929     if (IoIFP(rstio))
 930         do_close(rgv,FALSE);
 931     if (IoIFP(wstio))
 932         do_close(wgv,FALSE);
 933
 934     if (PerlProc_pipe(fd) < 0)
 935         goto badexit;
 936     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE);
 937     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE);
 938     IoOFP(rstio) = IoIFP(rstio);
 939     IoIFP(wstio) = IoOFP(wstio);
 940     IoTYPE(rstio) = IoTYPE_RDONLY;
 941     IoTYPE(wstio) = IoTYPE_WRONLY;
 942     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 943         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 944         else PerlLIO_close(fd[0]);
 945         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 946         else PerlLIO_close(fd[1]);
 947         goto badexit;
 948     }
 949
 950     sv_setsv(sv,&PL_sv_yes);
 951     return;
 952
 953 badexit:
 954     sv_setsv(sv,&PL_sv_undef);
 955     return;
 956 }
 957 #endif
 958
 959 /* explicit renamed to avoid C++ conflict    -- kja */
 960 bool
 961 Perl_do_close(pTHX_ GV *gv, bool not_implicit)
 962 {
 963     bool retval;
 964     IO *io;
 965
 966     if (!gv)
 967         gv = PL_argvgv;
 968     if (!gv || SvTYPE(gv) != SVt_PVGV) {
 969         if (not_implicit)
 970             SETERRNO(EBADF,SS_IVCHAN);
 971         return FALSE;
 972     }
 973     io = GvIO(gv);
 974     if (!io) {          /* never opened */
 975         if (not_implicit) {
 976             if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
 977                 report_evil_fh(gv, io, PL_op->op_type);
 978             SETERRNO(EBADF,SS_IVCHAN);
 979         }
 980         return FALSE;
 981     }
 982     retval = io_close(io, not_implicit);
 983     if (not_implicit) {
 984         IoLINES(io) = 0;
 985         IoPAGE(io) = 0;
 986         IoLINES_LEFT(io) = IoPAGE_LEN(io);
 987     }
 988     IoTYPE(io) = IoTYPE_CLOSED;
 989     return retval;
 990 }
 991
 992 bool
 993 Perl_io_close(pTHX_ IO *io, bool not_implicit)
 994 {
 995     bool retval = FALSE;
 996     int status;
 997
 998     if (IoIFP(io)) {
 999         if (IoTYPE(io) == IoTYPE_PIPE) {
1000             status = PerlProc_pclose(IoIFP(io));
1001             if (not_implicit) {
1002                 STATUS_NATIVE_SET(status);
1003                 retval = (STATUS_POSIX == 0);
1004             }
1005             else {
1006                 retval = (status != -1);
1007             }
1008         }
1009         else if (IoTYPE(io) == IoTYPE_STD)
1010             retval = TRUE;
1011         else {
1012             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {          /* a socket */
1013                 retval = (PerlIO_close(IoOFP(io)) != EOF);
1014                 PerlIO_close(IoIFP(io));        /* clear stdio, fd already closed */
1015             }
1016             else
1017                 retval = (PerlIO_close(IoIFP(io)) != EOF);
1018         }
1019         IoOFP(io) = IoIFP(io) = Nullfp;
1020     }
1021     else if (not_implicit) {
1022         SETERRNO(EBADF,SS_IVCHAN);
1023     }
1024
1025     return retval;
1026 }
1027
1028 bool
1029 Perl_do_eof(pTHX_ GV *gv)
1030 {
1031     register IO *io;
1032     int ch;
1033
1034     io = GvIO(gv);
1035
1036     if (!io)
1037         return TRUE;
1038     else if (ckWARN(WARN_IO) && (IoTYPE(io) == IoTYPE_WRONLY))
1039         report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1040
1041     while (IoIFP(io)) {
1042         int saverrno;
1043
1044         if (PerlIO_has_cntptr(IoIFP(io))) {     /* (the code works without this) */
1045             if (PerlIO_get_cnt(IoIFP(io)) > 0)  /* cheat a little, since */
1046                 return FALSE;                   /* this is the most usual case */
1047         }
1048
1049         saverrno = errno; /* getc and ungetc can stomp on errno */
1050         ch = PerlIO_getc(IoIFP(io));
1051         if (ch != EOF) {
1052             (void)PerlIO_ungetc(IoIFP(io),ch);
1053             errno = saverrno;
1054             return FALSE;
1055         }
1056         errno = saverrno;
1057
1058         if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
1059             if (PerlIO_get_cnt(IoIFP(io)) < -1)
1060                 PerlIO_set_cnt(IoIFP(io),-1);
1061         }
1062         if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
1063             if (gv != PL_argvgv || !nextargv(gv))       /* get another fp handy */
1064                 return TRUE;
1065         }
1066         else
1067             return TRUE;                /* normal fp, definitely end of file */
1068     }
1069     return TRUE;
1070 }
1071
1072 Off_t
1073 Perl_do_tell(pTHX_ GV *gv)
1074 {
1075     register IO *io = 0;
1076     register PerlIO *fp;
1077
1078     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
1079 #ifdef ULTRIX_STDIO_BOTCH
1080         if (PerlIO_eof(fp))
1081             (void)PerlIO_seek(fp, 0L, 2);       /* ultrix 1.2 workaround */
1082 #endif
1083         return PerlIO_tell(fp);
1084     }
1085     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1086         report_evil_fh(gv, io, PL_op->op_type);
1087     SETERRNO(EBADF,RMS_IFI);
1088     return (Off_t)-1;
1089 }
1090
1091 bool
1092 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
1093 {
1094     register IO *io = 0;
1095     register PerlIO *fp;
1096
1097     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
1098 #ifdef ULTRIX_STDIO_BOTCH
1099         if (PerlIO_eof(fp))
1100             (void)PerlIO_seek(fp, 0L, 2);       /* ultrix 1.2 workaround */
1101 #endif
1102         return PerlIO_seek(fp, pos, whence) >= 0;
1103     }
1104     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1105         report_evil_fh(gv, io, PL_op->op_type);
1106     SETERRNO(EBADF,RMS_IFI);
1107     return FALSE;
1108 }
1109
1110 Off_t
1111 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
1112 {
1113     register IO *io = 0;
1114     register PerlIO *fp;
1115
1116     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
1117         return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
1118     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1119         report_evil_fh(gv, io, PL_op->op_type);
1120     SETERRNO(EBADF,RMS_IFI);
1121     return (Off_t)-1;
1122 }
1123
1124 int
1125 Perl_mode_from_discipline(pTHX_ SV *discp)
1126 {
1127     int mode = O_BINARY;
1128     if (discp) {
1129         STRLEN len;
1130         char *s = SvPV(discp,len);
1131         while (*s) {
1132             if (*s == ':') {
1133                 switch (s[1]) {
1134                 case 'r':
1135                     if (len > 3 && strnEQ(s+1, "raw", 3)
1136                         && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1137                     {
1138                         mode = O_BINARY;
1139                         s += 4;
1140                         len -= 4;
1141                         break;
1142                     }
1143                     /* FALL THROUGH */
1144                 case 'c':
1145                     if (len > 4 && strnEQ(s+1, "crlf", 4)
1146                         && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1147                     {
1148                         mode = O_TEXT;
1149                         s += 5;
1150                         len -= 5;
1151                         break;
1152                     }
1153                     /* FALL THROUGH */
1154                 default:
1155                     goto fail_discipline;
1156                 }
1157             }
1158             else if (isSPACE(*s)) {
1159                 ++s;
1160                 --len;
1161             }
1162             else {
1163                 char *end;
1164 fail_discipline:
1165                 end = strchr(s+1, ':');
1166                 if (!end)
1167                     end = s+len;
1168 #ifndef PERLIO_LAYERS
1169                 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
1170 #else
1171                 s = end;
1172 #endif
1173             }
1174         }
1175     }
1176     return mode;
1177 }
1178
1179 int
1180 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
1181 {
1182  /* The old body of this is now in non-LAYER part of perlio.c
1183   * This is a stub for any XS code which might have been calling it.
1184   */
1185  char *name = ":raw";
1186 #ifdef PERLIO_USING_CRLF
1187  if (!(mode & O_BINARY))
1188      name = ":crlf";
1189 #endif
1190  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
1191 }
1192
1193 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
1194         /* code courtesy of William Kucharski */
1195 #define HAS_CHSIZE
1196
1197 I32 my_chsize(fd, length)
1198 I32 fd;                 /* file descriptor */
1199 Off_t length;           /* length to set file to */
1200 {
1201     struct flock fl;
1202     Stat_t filebuf;
1203
1204     if (PerlLIO_fstat(fd, &filebuf) < 0)
1205         return -1;
1206
1207     if (filebuf.st_size < length) {
1208
1209         /* extend file length */
1210
1211         if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
1212             return -1;
1213
1214         /* write a "0" byte */
1215
1216         if ((PerlLIO_write(fd, "", 1)) != 1)
1217             return -1;
1218     }
1219     else {
1220         /* truncate length */
1221
1222         fl.l_whence = 0;
1223         fl.l_len = 0;
1224         fl.l_start = length;
1225         fl.l_type = F_WRLCK;    /* write lock on file space */
1226
1227         /*
1228         * This relies on the UNDOCUMENTED F_FREESP argument to
1229         * fcntl(2), which truncates the file so that it ends at the
1230         * position indicated by fl.l_start.
1231         *
1232         * Will minor miracles never cease?
1233         */
1234
1235         if (fcntl(fd, F_FREESP, &fl) < 0)
1236             return -1;
1237
1238     }
1239
1240     return 0;
1241 }
1242 #endif /* F_FREESP */
1243
1244 bool
1245 Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
1246 {
1247     register char *tmps;
1248     STRLEN len;
1249
1250     /* assuming fp is checked earlier */
1251     if (!sv)
1252         return TRUE;
1253     if (PL_ofmt) {
1254         if (SvGMAGICAL(sv))
1255             mg_get(sv);
1256         if (SvIOK(sv) && SvIVX(sv) != 0) {
1257             PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
1258             return !PerlIO_error(fp);
1259         }
1260         if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
1261            || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
1262             PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
1263             return !PerlIO_error(fp);
1264         }
1265     }
1266     switch (SvTYPE(sv)) {
1267     case SVt_NULL:
1268         if (ckWARN(WARN_UNINITIALIZED))
1269             report_uninit();
1270         return TRUE;
1271     case SVt_IV:
1272         if (SvIOK(sv)) {
1273             if (SvGMAGICAL(sv))
1274                 mg_get(sv);
1275             if (SvIsUV(sv))
1276                 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
1277             else
1278                 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
1279             return !PerlIO_error(fp);
1280         }
1281         /* FALL THROUGH */
1282     default:
1283         if (PerlIO_isutf8(fp)) {
1284             if (!SvUTF8(sv))
1285                 sv_utf8_upgrade_flags(sv = sv_mortalcopy(sv),
1286                                       SV_GMAGIC|SV_UTF8_NO_ENCODING);
1287         }
1288         else if (DO_UTF8(sv)) {
1289             if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
1290                 && ckWARN_d(WARN_UTF8))
1291             {
1292                 Perl_warner(aTHX_ packWARN(WARN_UTF8), "Wide character in print");
1293             }
1294         }
1295         tmps = SvPV(sv, len);
1296         break;
1297     }
1298     /* To detect whether the process is about to overstep its
1299      * filesize limit we would need getrlimit().  We could then
1300      * also transparently raise the limit with setrlimit() --
1301      * but only until the system hard limit/the filesystem limit,
1302      * at which we would get EPERM.  Note that when using buffered
1303      * io the write failure can be delayed until the flush/close. --jhi */
1304     if (len && (PerlIO_write(fp,tmps,len) == 0))
1305         return FALSE;
1306     return !PerlIO_error(fp);
1307 }
1308
1309 I32
1310 Perl_my_stat(pTHX)
1311 {
1312     dSP;
1313     IO *io;
1314     GV* gv;
1315
1316     if (PL_op->op_flags & OPf_REF) {
1317         EXTEND(SP,1);
1318         gv = cGVOP_gv;
1319       do_fstat:
1320         io = GvIO(gv);
1321         if (io && IoIFP(io)) {
1322             PL_statgv = gv;
1323             sv_setpv(PL_statname,"");
1324             PL_laststype = OP_STAT;
1325             return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
1326         }
1327         else {
1328             if (gv == PL_defgv)
1329                 return PL_laststatval;
1330             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1331                 report_evil_fh(gv, io, PL_op->op_type);
1332             PL_statgv = Nullgv;
1333             sv_setpv(PL_statname,"");
1334             return (PL_laststatval = -1);
1335         }
1336     }
1337     else {
1338         SV* sv = POPs;
1339         char *s;
1340         STRLEN len;
1341         PUTBACK;
1342         if (SvTYPE(sv) == SVt_PVGV) {
1343             gv = (GV*)sv;
1344             goto do_fstat;
1345         }
1346         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1347             gv = (GV*)SvRV(sv);
1348             goto do_fstat;
1349         }
1350
1351         s = SvPV(sv, len);
1352         PL_statgv = Nullgv;
1353         sv_setpvn(PL_statname, s, len);
1354         s = SvPVX(PL_statname);         /* s now NUL-terminated */
1355         PL_laststype = OP_STAT;
1356         PL_laststatval = PerlLIO_stat(s, &PL_statcache);
1357         if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
1358             Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
1359         return PL_laststatval;
1360     }
1361 }
1362
1363 I32
1364 Perl_my_lstat(pTHX)
1365 {
1366     dSP;
1367     SV *sv;
1368     STRLEN n_a;
1369     if (PL_op->op_flags & OPf_REF) {
1370         EXTEND(SP,1);
1371         if (cGVOP_gv == PL_defgv) {
1372             if (PL_laststype != OP_LSTAT)
1373                 Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
1374             return PL_laststatval;
1375         }
1376         if (ckWARN(WARN_IO)) {
1377             Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
1378                     GvENAME(cGVOP_gv));
1379             return (PL_laststatval = -1);
1380         }
1381     }
1382
1383     PL_laststype = OP_LSTAT;
1384     PL_statgv = Nullgv;
1385     sv = POPs;
1386     PUTBACK;
1387     if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV && ckWARN(WARN_IO)) {
1388         Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
1389                 GvENAME((GV*) SvRV(sv)));
1390         return (PL_laststatval = -1);
1391     }
1392     sv_setpv(PL_statname,SvPV(sv, n_a));
1393     PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
1394     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
1395         Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
1396     return PL_laststatval;
1397 }
1398
1399 #ifndef OS2
1400 bool
1401 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
1402 {
1403     return do_aexec5(really, mark, sp, 0, 0);
1404 }
1405 #endif
1406
1407 bool
1408 Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
1409                int fd, int do_report)
1410 {
1411 #ifdef MACOS_TRADITIONAL
1412     Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1413 #else
1414     register char **a;
1415     char *tmps = Nullch;
1416     STRLEN n_a;
1417
1418     if (sp > mark) {
1419         New(401,PL_Argv, sp - mark + 1, char*);
1420         a = PL_Argv;
1421         while (++mark <= sp) {
1422             if (*mark)
1423                 *a++ = SvPVx(*mark, n_a);
1424             else
1425                 *a++ = "";
1426         }
1427         *a = Nullch;
1428         if (really)
1429             tmps = SvPV(really, n_a);
1430         if ((!really && *PL_Argv[0] != '/') ||
1431             (really && *tmps != '/'))           /* will execvp use PATH? */
1432             TAINT_ENV();                /* testing IFS here is overkill, probably */
1433         PERL_FPU_PRE_EXEC
1434         if (really && *tmps)
1435             PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
1436         else
1437             PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
1438         PERL_FPU_POST_EXEC
1439         if (ckWARN(WARN_EXEC))
1440             Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1441                 (really ? tmps : PL_Argv[0]), Strerror(errno));
1442         if (do_report) {
1443             int e = errno;
1444
1445             PerlLIO_write(fd, (void*)&e, sizeof(int));
1446             PerlLIO_close(fd);
1447         }
1448     }
1449     do_execfree();
1450 #endif
1451     return FALSE;
1452 }
1453
1454 void
1455 Perl_do_execfree(pTHX)
1456 {
1457     if (PL_Argv) {
1458         Safefree(PL_Argv);
1459         PL_Argv = Null(char **);
1460     }
1461     if (PL_Cmd) {
1462         Safefree(PL_Cmd);
1463         PL_Cmd = Nullch;
1464     }
1465 }
1466
1467 #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1468
1469 bool
1470 Perl_do_exec(pTHX_ char *cmd)
1471 {
1472     return do_exec3(cmd,0,0);
1473 }
1474
1475 bool
1476 Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
1477 {
1478     register char **a;
1479     register char *s;
1480
1481     while (*cmd && isSPACE(*cmd))
1482         cmd++;
1483
1484     /* save an extra exec if possible */
1485
1486 #ifdef CSH
1487     {
1488         char flags[10];
1489         if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
1490             strnEQ(cmd+PL_cshlen," -c",3)) {
1491           strcpy(flags,"-c");
1492           s = cmd+PL_cshlen+3;
1493           if (*s == 'f') {
1494               s++;
1495               strcat(flags,"f");
1496           }
1497           if (*s == ' ')
1498               s++;
1499           if (*s++ == '\'') {
1500               char *ncmd = s;
1501
1502               while (*s)
1503                   s++;
1504               if (s[-1] == '\n')
1505                   *--s = '\0';
1506               if (s[-1] == '\'') {
1507                   *--s = '\0';
1508                   PERL_FPU_PRE_EXEC
1509                   PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0);
1510                   PERL_FPU_POST_EXEC
1511                   *s = '\'';
1512                   return FALSE;
1513               }
1514           }
1515         }
1516     }
1517 #endif /* CSH */
1518
1519     /* see if there are shell metacharacters in it */
1520
1521     if (*cmd == '.' && isSPACE(cmd[1]))
1522         goto doshell;
1523
1524     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1525         goto doshell;
1526
1527     for (s = cmd; *s && isALNUM(*s); s++) ;     /* catch VAR=val gizmo */
1528     if (*s == '=')
1529         goto doshell;
1530
1531     for (s = cmd; *s; s++) {
1532         if (*s != ' ' && !isALPHA(*s) &&
1533             strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1534             if (*s == '\n' && !s[1]) {
1535                 *s = '\0';
1536                 break;
1537             }
1538             /* handle the 2>&1 construct at the end */
1539             if (*s == '>' && s[1] == '&' && s[2] == '1'
1540                 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1541                 && (!s[3] || isSPACE(s[3])))
1542             {
1543                 char *t = s + 3;
1544
1545                 while (*t && isSPACE(*t))
1546                     ++t;
1547                 if (!*t && (dup2(1,2) != -1)) {
1548                     s[-2] = '\0';
1549                     break;
1550                 }
1551             }
1552           doshell:
1553             PERL_FPU_PRE_EXEC
1554             PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
1555             PERL_FPU_POST_EXEC
1556             return FALSE;
1557         }
1558     }
1559
1560     New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
1561     PL_Cmd = savepvn(cmd, s-cmd);
1562     a = PL_Argv;
1563     for (s = PL_Cmd; *s;) {
1564         while (*s && isSPACE(*s)) s++;
1565         if (*s)
1566             *(a++) = s;
1567         while (*s && !isSPACE(*s)) s++;
1568         if (*s)
1569             *s++ = '\0';
1570     }
1571     *a = Nullch;
1572     if (PL_Argv[0]) {
1573         PERL_FPU_PRE_EXEC
1574         PerlProc_execvp(PL_Argv[0],PL_Argv);
1575         PERL_FPU_POST_EXEC
1576         if (errno == ENOEXEC) {         /* for system V NIH syndrome */
1577             do_execfree();
1578             goto doshell;
1579         }
1580         {
1581             int e = errno;
1582
1583             if (ckWARN(WARN_EXEC))
1584                 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1585                     PL_Argv[0], Strerror(errno));
1586             if (do_report) {
1587                 PerlLIO_write(fd, (void*)&e, sizeof(int));
1588                 PerlLIO_close(fd);
1589             }
1590         }
1591     }
1592     do_execfree();
1593     return FALSE;
1594 }
1595
1596 #endif /* OS2 || WIN32 */
1597
1598 I32
1599 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
1600 {
1601     register I32 val;
1602     register I32 val2;
1603     register I32 tot = 0;
1604     char *what;
1605     char *s;
1606     SV **oldmark = mark;
1607     STRLEN n_a;
1608
1609 #define APPLY_TAINT_PROPER() \
1610     STMT_START {                                                        \
1611         if (PL_tainted) { TAINT_PROPER(what); }                         \
1612     } STMT_END
1613
1614     /* This is a first heuristic; it doesn't catch tainting magic. */
1615     if (PL_tainting) {
1616         while (++mark <= sp) {
1617             if (SvTAINTED(*mark)) {
1618                 TAINT;
1619                 break;
1620             }
1621         }
1622         mark = oldmark;
1623     }
1624     switch (type) {
1625     case OP_CHMOD:
1626         what = "chmod";
1627         APPLY_TAINT_PROPER();
1628         if (++mark <= sp) {
1629             val = SvIVx(*mark);
1630             APPLY_TAINT_PROPER();
1631             tot = sp - mark;
1632             while (++mark <= sp) {
1633                 char *name = SvPVx(*mark, n_a);
1634                 APPLY_TAINT_PROPER();
1635                 if (PerlLIO_chmod(name, val))
1636                     tot--;
1637             }
1638         }
1639         break;
1640 #ifdef HAS_CHOWN
1641     case OP_CHOWN:
1642         what = "chown";
1643         APPLY_TAINT_PROPER();
1644         if (sp - mark > 2) {
1645             val = SvIVx(*++mark);
1646             val2 = SvIVx(*++mark);
1647             APPLY_TAINT_PROPER();
1648             tot = sp - mark;
1649             while (++mark <= sp) {
1650                 char *name = SvPVx(*mark, n_a);
1651                 APPLY_TAINT_PROPER();
1652                 if (PerlLIO_chown(name, val, val2))
1653                     tot--;
1654             }
1655         }
1656         break;
1657 #endif
1658 /*
1659 XXX Should we make lchown() directly available from perl?
1660 For now, we'll let Configure test for HAS_LCHOWN, but do
1661 nothing in the core.
1662     --AD  5/1998
1663 */
1664 #ifdef HAS_KILL
1665     case OP_KILL:
1666         what = "kill";
1667         APPLY_TAINT_PROPER();
1668         if (mark == sp)
1669             break;
1670         s = SvPVx(*++mark, n_a);
1671         if (isALPHA(*s)) {
1672             if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1673                 s += 3;
1674             if ((val = whichsig(s)) < 0)
1675                 Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
1676         }
1677         else
1678             val = SvIVx(*mark);
1679         APPLY_TAINT_PROPER();
1680         tot = sp - mark;
1681 #ifdef VMS
1682         /* kill() doesn't do process groups (job trees?) under VMS */
1683         if (val < 0) val = -val;
1684         if (val == SIGKILL) {
1685 #           include <starlet.h>
1686             /* Use native sys$delprc() to insure that target process is
1687              * deleted; supervisor-mode images don't pay attention to
1688              * CRTL's emulation of Unix-style signals and kill()
1689              */
1690             while (++mark <= sp) {
1691                 I32 proc = SvIVx(*mark);
1692                 register unsigned long int __vmssts;
1693                 APPLY_TAINT_PROPER();
1694                 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1695                     tot--;
1696                     switch (__vmssts) {
1697                         case SS$_NONEXPR:
1698                         case SS$_NOSUCHNODE:
1699                             SETERRNO(ESRCH,__vmssts);
1700                             break;
1701                         case SS$_NOPRIV:
1702                             SETERRNO(EPERM,__vmssts);
1703                             break;
1704                         default:
1705                             SETERRNO(EVMSERR,__vmssts);
1706                     }
1707                 }
1708             }
1709             break;
1710         }
1711 #endif
1712         if (val < 0) {
1713             val = -val;
1714             while (++mark <= sp) {
1715                 I32 proc = SvIVx(*mark);
1716                 APPLY_TAINT_PROPER();
1717 #ifdef HAS_KILLPG
1718                 if (PerlProc_killpg(proc,val))  /* BSD */
1719 #else
1720                 if (PerlProc_kill(-proc,val))   /* SYSV */
1721 #endif
1722                     tot--;
1723             }
1724         }
1725         else {
1726             while (++mark <= sp) {
1727                 I32 proc = SvIVx(*mark);
1728                 APPLY_TAINT_PROPER();
1729                 if (PerlProc_kill(proc, val))
1730                     tot--;
1731             }
1732         }
1733         break;
1734 #endif
1735     case OP_UNLINK:
1736         what = "unlink";
1737         APPLY_TAINT_PROPER();
1738         tot = sp - mark;
1739         while (++mark <= sp) {
1740             s = SvPVx(*mark, n_a);
1741             APPLY_TAINT_PROPER();
1742             if (PL_euid || PL_unsafe) {
1743                 if (UNLINK(s))
1744                     tot--;
1745             }
1746             else {      /* don't let root wipe out directories without -U */
1747                 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
1748                     tot--;
1749                 else {
1750                     if (UNLINK(s))
1751                         tot--;
1752                 }
1753             }
1754         }
1755         break;
1756 #ifdef HAS_UTIME
1757     case OP_UTIME:
1758         what = "utime";
1759         APPLY_TAINT_PROPER();
1760         if (sp - mark > 2) {
1761 #if defined(I_UTIME) || defined(VMS)
1762             struct utimbuf utbuf;
1763 #else
1764             struct {
1765                 Time_t  actime;
1766                 Time_t  modtime;
1767             } utbuf;
1768 #endif
1769
1770            SV* accessed = *++mark;
1771            SV* modified = *++mark;
1772            void * utbufp = &utbuf;
1773
1774            /* Be like C, and if both times are undefined, let the C
1775             * library figure out what to do.  This usually means
1776             * "current time". */
1777
1778            if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
1779                 utbufp = NULL;
1780            else {
1781                 Zero(&utbuf, sizeof utbuf, char);
1782 #ifdef BIG_TIME
1783                 utbuf.actime = (Time_t)SvNVx(accessed);  /* time accessed */
1784                 utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */
1785 #else
1786                 utbuf.actime = (Time_t)SvIVx(accessed);  /* time accessed */
1787                 utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */
1788 #endif
1789             }
1790             APPLY_TAINT_PROPER();
1791             tot = sp - mark;
1792             while (++mark <= sp) {
1793                 char *name = SvPVx(*mark, n_a);
1794                 APPLY_TAINT_PROPER();
1795                if (PerlLIO_utime(name, utbufp))
1796                     tot--;
1797             }
1798         }
1799         else
1800             tot = 0;
1801         break;
1802 #endif
1803     }
1804     return tot;
1805
1806 #undef APPLY_TAINT_PROPER
1807 }
1808
1809 /* Do the permissions allow some operation?  Assumes statcache already set. */
1810 #ifndef VMS /* VMS' cando is in vms.c */
1811 bool
1812 Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
1813 /* Note: we use `effective' both for uids and gids.
1814  * Here we are betting on Uid_t being equal or wider than Gid_t.  */
1815 {
1816 #ifdef DOSISH
1817     /* [Comments and code from Len Reed]
1818      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1819      * to write-protected files.  The execute permission bit is set
1820      * by the Miscrosoft C library stat() function for the following:
1821      *          .exe files
1822      *          .com files
1823      *          .bat files
1824      *          directories
1825      * All files and directories are readable.
1826      * Directories and special files, e.g. "CON", cannot be
1827      * write-protected.
1828      * [Comment by Tom Dinger -- a directory can have the write-protect
1829      *          bit set in the file system, but DOS permits changes to
1830      *          the directory anyway.  In addition, all bets are off
1831      *          here for networked software, such as Novell and
1832      *          Sun's PC-NFS.]
1833      */
1834
1835      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1836       * too so it will actually look into the files for magic numbers
1837       */
1838      return (mode & statbufp->st_mode) ? TRUE : FALSE;
1839
1840 #else /* ! DOSISH */
1841     if ((effective ? PL_euid : PL_uid) == 0) {  /* root is special */
1842         if (mode == S_IXUSR) {
1843             if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1844                 return TRUE;
1845         }
1846         else
1847             return TRUE;                /* root reads and writes anything */
1848         return FALSE;
1849     }
1850     if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
1851         if (statbufp->st_mode & mode)
1852             return TRUE;        /* ok as "user" */
1853     }
1854     else if (ingroup(statbufp->st_gid,effective)) {
1855         if (statbufp->st_mode & mode >> 3)
1856             return TRUE;        /* ok as "group" */
1857     }
1858     else if (statbufp->st_mode & mode >> 6)
1859         return TRUE;    /* ok as "other" */
1860     return FALSE;
1861 #endif /* ! DOSISH */
1862 }
1863 #endif /* ! VMS */
1864
1865 bool
1866 Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
1867 {
1868 #ifdef MACOS_TRADITIONAL
1869     /* This is simply not correct for AppleShare, but fix it yerself. */
1870     return TRUE;
1871 #else
1872     if (testgid == (effective ? PL_egid : PL_gid))
1873         return TRUE;
1874 #ifdef HAS_GETGROUPS
1875 #ifndef NGROUPS
1876 #define NGROUPS 32
1877 #endif
1878     {
1879         Groups_t gary[NGROUPS];
1880         I32 anum;
1881
1882         anum = getgroups(NGROUPS,gary);
1883         while (--anum >= 0)
1884             if (gary[anum] == testgid)
1885                 return TRUE;
1886     }
1887 #endif
1888     return FALSE;
1889 #endif
1890 }
1891
1892 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1893
1894 I32
1895 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
1896 {
1897     key_t key;
1898     I32 n, flags;
1899
1900     key = (key_t)SvNVx(*++mark);
1901     n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1902     flags = SvIVx(*++mark);
1903     SETERRNO(0,0);
1904     switch (optype)
1905     {
1906 #ifdef HAS_MSG
1907     case OP_MSGGET:
1908         return msgget(key, flags);
1909 #endif
1910 #ifdef HAS_SEM
1911     case OP_SEMGET:
1912         return semget(key, n, flags);
1913 #endif
1914 #ifdef HAS_SHM
1915     case OP_SHMGET:
1916         return shmget(key, n, flags);
1917 #endif
1918 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1919     default:
1920         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1921 #endif
1922     }
1923     return -1;                  /* should never happen */
1924 }
1925
1926 I32
1927 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
1928 {
1929     SV *astr;
1930     char *a;
1931     I32 id, n, cmd, infosize, getinfo;
1932     I32 ret = -1;
1933
1934     id = SvIVx(*++mark);
1935     n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1936     cmd = SvIVx(*++mark);
1937     astr = *++mark;
1938     infosize = 0;
1939     getinfo = (cmd == IPC_STAT);
1940
1941     switch (optype)
1942     {
1943 #ifdef HAS_MSG
1944     case OP_MSGCTL:
1945         if (cmd == IPC_STAT || cmd == IPC_SET)
1946             infosize = sizeof(struct msqid_ds);
1947         break;
1948 #endif
1949 #ifdef HAS_SHM
1950     case OP_SHMCTL:
1951         if (cmd == IPC_STAT || cmd == IPC_SET)
1952             infosize = sizeof(struct shmid_ds);
1953         break;
1954 #endif
1955 #ifdef HAS_SEM
1956     case OP_SEMCTL:
1957 #ifdef Semctl
1958         if (cmd == IPC_STAT || cmd == IPC_SET)
1959             infosize = sizeof(struct semid_ds);
1960         else if (cmd == GETALL || cmd == SETALL)
1961         {
1962             struct semid_ds semds;
1963             union semun semun;
1964 #ifdef EXTRA_F_IN_SEMUN_BUF
1965             semun.buff = &semds;
1966 #else
1967             semun.buf = &semds;
1968 #endif
1969             getinfo = (cmd == GETALL);
1970             if (Semctl(id, 0, IPC_STAT, semun) == -1)
1971                 return -1;
1972             infosize = semds.sem_nsems * sizeof(short);
1973                 /* "short" is technically wrong but much more portable
1974                    than guessing about u_?short(_t)? */
1975         }
1976 #else
1977         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1978 #endif
1979         break;
1980 #endif
1981 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1982     default:
1983         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1984 #endif
1985     }
1986
1987     if (infosize)
1988     {
1989         STRLEN len;
1990         if (getinfo)
1991         {
1992             SvPV_force(astr, len);
1993             a = SvGROW(astr, infosize+1);
1994         }
1995         else
1996         {
1997             a = SvPV(astr, len);
1998             if (len != infosize)
1999                 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
2000                       PL_op_desc[optype],
2001                       (unsigned long)len,
2002                       (long)infosize);
2003         }
2004     }
2005     else
2006     {
2007         IV i = SvIV(astr);
2008         a = INT2PTR(char *,i);          /* ouch */
2009     }
2010     SETERRNO(0,0);
2011     switch (optype)
2012     {
2013 #ifdef HAS_MSG
2014     case OP_MSGCTL:
2015         ret = msgctl(id, cmd, (struct msqid_ds *)a);
2016         break;
2017 #endif
2018 #ifdef HAS_SEM
2019     case OP_SEMCTL: {
2020 #ifdef Semctl
2021             union semun unsemds;
2022
2023 #ifdef EXTRA_F_IN_SEMUN_BUF
2024             unsemds.buff = (struct semid_ds *)a;
2025 #else
2026             unsemds.buf = (struct semid_ds *)a;
2027 #endif
2028             ret = Semctl(id, n, cmd, unsemds);
2029 #else
2030             Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
2031 #endif
2032         }
2033         break;
2034 #endif
2035 #ifdef HAS_SHM
2036     case OP_SHMCTL:
2037         ret = shmctl(id, cmd, (struct shmid_ds *)a);
2038         break;
2039 #endif
2040     }
2041     if (getinfo && ret >= 0) {
2042         SvCUR_set(astr, infosize);
2043         *SvEND(astr) = '\0';
2044         SvSETMAGIC(astr);
2045     }
2046     return ret;
2047 }
2048
2049 I32
2050 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
2051 {
2052 #ifdef HAS_MSG
2053     SV *mstr;
2054     char *mbuf;
2055     I32 id, msize, flags;
2056     STRLEN len;
2057
2058     id = SvIVx(*++mark);
2059     mstr = *++mark;
2060     flags = SvIVx(*++mark);
2061     mbuf = SvPV(mstr, len);
2062     if ((msize = len - sizeof(long)) < 0)
2063         Perl_croak(aTHX_ "Arg too short for msgsnd");
2064     SETERRNO(0,0);
2065     return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
2066 #else
2067     Perl_croak(aTHX_ "msgsnd not implemented");
2068 #endif
2069 }
2070
2071 I32
2072 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
2073 {
2074 #ifdef HAS_MSG
2075     SV *mstr;
2076     char *mbuf;
2077     long mtype;
2078     I32 id, msize, flags, ret;
2079     STRLEN len;
2080
2081     id = SvIVx(*++mark);
2082     mstr = *++mark;
2083     /* suppress warning when reading into undef var --jhi */
2084     if (! SvOK(mstr))
2085         sv_setpvn(mstr, "", 0);
2086     msize = SvIVx(*++mark);
2087     mtype = (long)SvIVx(*++mark);
2088     flags = SvIVx(*++mark);
2089     SvPV_force(mstr, len);
2090     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
2091
2092     SETERRNO(0,0);
2093     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
2094     if (ret >= 0) {
2095         SvCUR_set(mstr, sizeof(long)+ret);
2096         *SvEND(mstr) = '\0';
2097 #ifndef INCOMPLETE_TAINTS
2098         /* who knows who has been playing with this message? */
2099         SvTAINTED_on(mstr);
2100 #endif
2101     }
2102     return ret;
2103 #else
2104     Perl_croak(aTHX_ "msgrcv not implemented");
2105 #endif
2106 }
2107
2108 I32
2109 Perl_do_semop(pTHX_ SV **mark, SV **sp)
2110 {
2111 #ifdef HAS_SEM
2112     SV *opstr;
2113     char *opbuf;
2114     I32 id;
2115     STRLEN opsize;
2116
2117     id = SvIVx(*++mark);
2118     opstr = *++mark;
2119     opbuf = SvPV(opstr, opsize);
2120     if (opsize < 3 * SHORTSIZE
2121         || (opsize % (3 * SHORTSIZE))) {
2122         SETERRNO(EINVAL,LIB_INVARG);
2123         return -1;
2124     }
2125     SETERRNO(0,0);
2126     /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2127     {
2128         int nsops  = opsize / (3 * sizeof (short));
2129         int i      = nsops;
2130         short *ops = (short *) opbuf;
2131         short *o   = ops;
2132         struct sembuf *temps, *t;
2133         I32 result;
2134
2135         New (0, temps, nsops, struct sembuf);
2136         t = temps;
2137         while (i--) {
2138             t->sem_num = *o++;
2139             t->sem_op  = *o++;
2140             t->sem_flg = *o++;
2141             t++;
2142         }
2143         result = semop(id, temps, nsops);
2144         t = temps;
2145         o = ops;
2146         i = nsops;
2147         while (i--) {
2148             *o++ = t->sem_num;
2149             *o++ = t->sem_op;
2150             *o++ = t->sem_flg;
2151             t++;
2152         }
2153         Safefree(temps);
2154         return result;
2155     }
2156 #else
2157     Perl_croak(aTHX_ "semop not implemented");
2158 #endif
2159 }
2160
2161 I32
2162 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
2163 {
2164 #ifdef HAS_SHM
2165     SV *mstr;
2166     char *mbuf, *shm;
2167     I32 id, mpos, msize;
2168     STRLEN len;
2169     struct shmid_ds shmds;
2170
2171     id = SvIVx(*++mark);
2172     mstr = *++mark;
2173     mpos = SvIVx(*++mark);
2174     msize = SvIVx(*++mark);
2175     SETERRNO(0,0);
2176     if (shmctl(id, IPC_STAT, &shmds) == -1)
2177         return -1;
2178     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
2179         SETERRNO(EFAULT,SS_ACCVIO);             /* can't do as caller requested */
2180         return -1;
2181     }
2182     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
2183     if (shm == (char *)-1)      /* I hate System V IPC, I really do */
2184         return -1;
2185     if (optype == OP_SHMREAD) {
2186         /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
2187         if (! SvOK(mstr))
2188             sv_setpvn(mstr, "", 0);
2189         SvPV_force(mstr, len);
2190         mbuf = SvGROW(mstr, msize+1);
2191
2192         Copy(shm + mpos, mbuf, msize, char);
2193         SvCUR_set(mstr, msize);
2194         *SvEND(mstr) = '\0';
2195         SvSETMAGIC(mstr);
2196 #ifndef INCOMPLETE_TAINTS
2197         /* who knows who has been playing with this shared memory? */
2198         SvTAINTED_on(mstr);
2199 #endif
2200     }
2201     else {
2202         I32 n;
2203
2204         mbuf = SvPV(mstr, len);
2205         if ((n = len) > msize)
2206             n = msize;
2207         Copy(mbuf, shm + mpos, n, char);
2208         if (n < msize)
2209             memzero(shm + mpos + n, msize - n);
2210     }
2211     return shmdt(shm);
2212 #else
2213     Perl_croak(aTHX_ "shm I/O not implemented");
2214 #endif
2215 }
2216
2217 #endif /* SYSV IPC */
2218
2219 /*
2220 =head1 IO Functions
2221
2222 =for apidoc start_glob
2223
2224 Function called by C<do_readline> to spawn a glob (or do the glob inside
2225 perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
2226 this glob starter is only used by miniperl during the build process.
2227 Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
2228
2229 =cut
2230 */
2231
2232 PerlIO *
2233 Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2234 {
2235     SV *tmpcmd = NEWSV(55, 0);
2236     PerlIO *fp;
2237     ENTER;
2238     SAVEFREESV(tmpcmd);
2239 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2240            /* since spawning off a process is a real performance hit */
2241     {
2242 #include <descrip.h>
2243 #include <lib$routines.h>
2244 #include <nam.h>
2245 #include <rmsdef.h>
2246         char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
2247         char vmsspec[NAM$C_MAXRSS+1];
2248         char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
2249         $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
2250         PerlIO *tmpfp;
2251         STRLEN i;
2252         struct dsc$descriptor_s wilddsc
2253             = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2254         struct dsc$descriptor_vs rsdsc
2255             = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
2256         unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
2257
2258         /* We could find out if there's an explicit dev/dir or version
2259            by peeking into lib$find_file's internal context at
2260            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
2261            but that's unsupported, so I don't want to do it now and
2262            have it bite someone in the future. */
2263         cp = SvPV(tmpglob,i);
2264         for (; i; i--) {
2265             if (cp[i] == ';') hasver = 1;
2266             if (cp[i] == '.') {
2267                 if (sts) hasver = 1;
2268                 else sts = 1;
2269             }
2270             if (cp[i] == '/') {
2271                 hasdir = isunix = 1;
2272                 break;
2273             }
2274             if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
2275                 hasdir = 1;
2276                 break;
2277             }
2278         }
2279        if ((tmpfp = PerlIO_tmpfile()) != NULL) {
2280             Stat_t st;
2281             if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
2282                 ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
2283             else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
2284             if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
2285             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
2286                 if (*cp == '?') *cp = '%';  /* VMS style single-char wildcard */
2287             while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
2288                                                &dfltdsc,NULL,NULL,NULL))&1)) {
2289                 end = rstr + (unsigned long int) *rslt;
2290                 if (!hasver) while (*end != ';') end--;
2291                 *(end++) = '\n';  *end = '\0';
2292                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
2293                 if (hasdir) {
2294                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
2295                     begin = rstr;
2296                 }
2297                 else {
2298                     begin = end;
2299                     while (*(--begin) != ']' && *begin != '>') ;
2300                     ++begin;
2301                 }
2302                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
2303             }
2304             if (cxt) (void)lib$find_file_end(&cxt);
2305             if (ok && sts != RMS$_NMF &&
2306                 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
2307             if (!ok) {
2308                 if (!(sts & 1)) {
2309                     SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
2310                 }
2311                 PerlIO_close(tmpfp);
2312                 fp = NULL;
2313             }
2314             else {
2315                 PerlIO_rewind(tmpfp);
2316                 IoTYPE(io) = IoTYPE_RDONLY;
2317                 IoIFP(io) = fp = tmpfp;
2318                 IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
2319             }
2320         }
2321     }
2322 #else /* !VMS */
2323 #ifdef MACOS_TRADITIONAL
2324     sv_setpv(tmpcmd, "glob ");
2325     sv_catsv(tmpcmd, tmpglob);
2326     sv_catpv(tmpcmd, " |");
2327 #else
2328 #ifdef DOSISH
2329 #ifdef OS2
2330     sv_setpv(tmpcmd, "for a in ");
2331     sv_catsv(tmpcmd, tmpglob);
2332     sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2333 #else
2334 #ifdef DJGPP
2335     sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2336     sv_catsv(tmpcmd, tmpglob);
2337 #else
2338     sv_setpv(tmpcmd, "perlglob ");
2339     sv_catsv(tmpcmd, tmpglob);
2340     sv_catpv(tmpcmd, " |");
2341 #endif /* !DJGPP */
2342 #endif /* !OS2 */
2343 #else /* !DOSISH */
2344 #if defined(CSH)
2345     sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2346     sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2347     sv_catsv(tmpcmd, tmpglob);
2348     sv_catpv(tmpcmd, "' 2>/dev/null |");
2349 #else
2350     sv_setpv(tmpcmd, "echo ");
2351     sv_catsv(tmpcmd, tmpglob);
2352 #if 'z' - 'a' == 25
2353     sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
2354 #else
2355     sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
2356 #endif
2357 #endif /* !CSH */
2358 #endif /* !DOSISH */
2359 #endif /* MACOS_TRADITIONAL */
2360     (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
2361                   FALSE, O_RDONLY, 0, Nullfp);
2362     fp = IoIFP(io);
2363 #endif /* !VMS */
2364     LEAVE;
2365     return fp;
2366 }