pp_sys.c

   1 /*    pp_sys.c
   2  *
   3  *    Copyright (c) 1991-2001, 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  * But only a short way ahead its floor and the walls on either side were
  12  * cloven by a great fissure, out of which the red glare came, now leaping
  13  * up, now dying down into darkness; and all the while far below there was
  14  * a rumour and a trouble as of great engines throbbing and labouring.
  15  */
  16
  17 #include "EXTERN.h"
  18 #define PERL_IN_PP_SYS_C
  19 #include "perl.h"
  20
  21 #ifdef I_SHADOW
  22 /* Shadow password support for solaris - pdo@cs.umd.edu
  23  * Not just Solaris: at least HP-UX, IRIX, Linux.
  24  * The API is from SysV.
  25  *
  26  * There are at least two more shadow interfaces,
  27  * see the comments in pp_gpwent().
  28  *
  29  * --jhi */
  30 #   ifdef __hpux__
  31 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
  32  * and another MAXINT from "perl.h" <- <sys/param.h>. */
  33 #       undef MAXINT
  34 #   endif
  35 #   include <shadow.h>
  36 #endif
  37
  38 #ifdef HAS_SYSCALL
  39 #ifdef __cplusplus
  40 extern "C" int syscall(unsigned long,...);
  41 #endif
  42 #endif
  43
  44 #ifdef I_SYS_WAIT
  45 # include <sys/wait.h>
  46 #endif
  47
  48 #ifdef I_SYS_RESOURCE
  49 # include <sys/resource.h>
  50 #endif
  51
  52 #ifdef HAS_SELECT
  53 # ifdef I_SYS_SELECT
  54 #  include <sys/select.h>
  55 # endif
  56 #endif
  57
  58 /* XXX Configure test needed.
  59    h_errno might not be a simple 'int', especially for multi-threaded
  60    applications, see "extern int errno in perl.h".  Creating such
  61    a test requires taking into account the differences between
  62    compiling multithreaded and singlethreaded ($ccflags et al).
  63    HOST_NOT_FOUND is typically defined in <netdb.h>.
  64 */
  65 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
  66 extern int h_errno;
  67 #endif
  68
  69 #ifdef HAS_PASSWD
  70 # ifdef I_PWD
  71 #  include <pwd.h>
  72 # else
  73 #  if !defined(VMS)
  74     struct passwd *getpwnam (char *);
  75     struct passwd *getpwuid (Uid_t);
  76 #  endif
  77 # endif
  78 # ifdef HAS_GETPWENT
  79   struct passwd *getpwent (void);
  80 # endif
  81 #endif
  82
  83 #ifdef HAS_GROUP
  84 # ifdef I_GRP
  85 #  include <grp.h>
  86 # else
  87     struct group *getgrnam (char *);
  88     struct group *getgrgid (Gid_t);
  89 # endif
  90 # ifdef HAS_GETGRENT
  91     struct group *getgrent (void);
  92 # endif
  93 #endif
  94
  95 #ifdef I_UTIME
  96 #  if defined(_MSC_VER) || defined(__MINGW32__)
  97 #    include <sys/utime.h>
  98 #  else
  99 #    include <utime.h>
 100 #  endif
 101 #endif
 102
 103 /* Put this after #includes because fork and vfork prototypes may conflict. */
 104 #ifndef HAS_VFORK
 105 #   define vfork fork
 106 #endif
 107
 108 #ifdef HAS_CHSIZE
 109 # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
 110 #   undef my_chsize
 111 # endif
 112 # define my_chsize PerlLIO_chsize
 113 #endif
 114
 115 #ifdef HAS_FLOCK
 116 #  define FLOCK flock
 117 #else /* no flock() */
 118
 119    /* fcntl.h might not have been included, even if it exists, because
 120       the current Configure only sets I_FCNTL if it's needed to pick up
 121       the *_OK constants.  Make sure it has been included before testing
 122       the fcntl() locking constants. */
 123 #  if defined(HAS_FCNTL) && !defined(I_FCNTL)
 124 #    include <fcntl.h>
 125 #  endif
 126
 127 #  if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
 128 #    define FLOCK fcntl_emulate_flock
 129 #    define FCNTL_EMULATE_FLOCK
 130 #  else /* no flock() or fcntl(F_SETLK,...) */
 131 #    ifdef HAS_LOCKF
 132 #      define FLOCK lockf_emulate_flock
 133 #      define LOCKF_EMULATE_FLOCK
 134 #    endif /* lockf */
 135 #  endif /* no flock() or fcntl(F_SETLK,...) */
 136
 137 #  ifdef FLOCK
 138      static int FLOCK (int, int);
 139
 140     /*
 141      * These are the flock() constants.  Since this sytems doesn't have
 142      * flock(), the values of the constants are probably not available.
 143      */
 144 #    ifndef LOCK_SH
 145 #      define LOCK_SH 1
 146 #    endif
 147 #    ifndef LOCK_EX
 148 #      define LOCK_EX 2
 149 #    endif
 150 #    ifndef LOCK_NB
 151 #      define LOCK_NB 4
 152 #    endif
 153 #    ifndef LOCK_UN
 154 #      define LOCK_UN 8
 155 #    endif
 156 #  endif /* emulating flock() */
 157
 158 #endif /* no flock() */
 159
 160 #define ZBTLEN 10
 161 static char zero_but_true[ZBTLEN + 1] = "0 but true";
 162
 163 #if defined(I_SYS_ACCESS) && !defined(R_OK)
 164 #  include <sys/access.h>
 165 #endif
 166
 167 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
 168 #  define FD_CLOEXEC 1          /* NeXT needs this */
 169 #endif
 170
 171 #undef PERL_EFF_ACCESS_R_OK     /* EFFective uid/gid ACCESS R_OK */
 172 #undef PERL_EFF_ACCESS_W_OK
 173 #undef PERL_EFF_ACCESS_X_OK
 174
 175 /* F_OK unused: if stat() cannot find it... */
 176
 177 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
 178     /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
 179 #   define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
 180 #   define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
 181 #   define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
 182 #endif
 183
 184 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
 185 #   ifdef I_SYS_SECURITY
 186 #       include <sys/security.h>
 187 #   endif
 188 #   ifdef ACC_SELF
 189         /* HP SecureWare */
 190 #       define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
 191 #       define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
 192 #       define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
 193 #   else
 194         /* SCO */
 195 #       define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
 196 #       define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
 197 #       define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
 198 #   endif
 199 #endif
 200
 201 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
 202     /* AIX */
 203 #   define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
 204 #   define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
 205 #   define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
 206 #endif
 207
 208 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS)       \
 209     && (defined(HAS_SETREUID) || defined(HAS_SETRESUID)         \
 210         || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
 211 /* The Hard Way. */
 212 STATIC int
 213 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
 214 {
 215     Uid_t ruid = getuid();
 216     Uid_t euid = geteuid();
 217     Gid_t rgid = getgid();
 218     Gid_t egid = getegid();
 219     int res;
 220
 221     LOCK_CRED_MUTEX;
 222 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
 223     Perl_croak(aTHX_ "switching effective uid is not implemented");
 224 #else
 225 #ifdef HAS_SETREUID
 226     if (setreuid(euid, ruid))
 227 #else
 228 #ifdef HAS_SETRESUID
 229     if (setresuid(euid, ruid, (Uid_t)-1))
 230 #endif
 231 #endif
 232         Perl_croak(aTHX_ "entering effective uid failed");
 233 #endif
 234
 235 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
 236     Perl_croak(aTHX_ "switching effective gid is not implemented");
 237 #else
 238 #ifdef HAS_SETREGID
 239     if (setregid(egid, rgid))
 240 #else
 241 #ifdef HAS_SETRESGID
 242     if (setresgid(egid, rgid, (Gid_t)-1))
 243 #endif
 244 #endif
 245         Perl_croak(aTHX_ "entering effective gid failed");
 246 #endif
 247
 248     res = access(path, mode);
 249
 250 #ifdef HAS_SETREUID
 251     if (setreuid(ruid, euid))
 252 #else
 253 #ifdef HAS_SETRESUID
 254     if (setresuid(ruid, euid, (Uid_t)-1))
 255 #endif
 256 #endif
 257         Perl_croak(aTHX_ "leaving effective uid failed");
 258
 259 #ifdef HAS_SETREGID
 260     if (setregid(rgid, egid))
 261 #else
 262 #ifdef HAS_SETRESGID
 263     if (setresgid(rgid, egid, (Gid_t)-1))
 264 #endif
 265 #endif
 266         Perl_croak(aTHX_ "leaving effective gid failed");
 267     UNLOCK_CRED_MUTEX;
 268
 269     return res;
 270 }
 271 #   define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
 272 #   define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
 273 #   define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
 274 #endif
 275
 276 #if !defined(PERL_EFF_ACCESS_R_OK)
 277 STATIC int
 278 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
 279 {
 280     Perl_croak(aTHX_ "switching effective uid is not implemented");
 281     /*NOTREACHED*/
 282     return -1;
 283 }
 284 #endif
 285
 286 PP(pp_backtick)
 287 {
 288     dSP; dTARGET;
 289     PerlIO *fp;
 290     STRLEN n_a;
 291     char *tmps = POPpx;
 292     I32 gimme = GIMME_V;
 293     char *mode = "r";
 294
 295     TAINT_PROPER("``");
 296     if (PL_op->op_private & OPpOPEN_IN_RAW)
 297         mode = "rb";
 298     else if (PL_op->op_private & OPpOPEN_IN_CRLF)
 299         mode = "rt";
 300     fp = PerlProc_popen(tmps, mode);
 301     if (fp) {
 302         char *type = NULL;
 303         if (PL_curcop->cop_io) {
 304             type = SvPV_nolen(PL_curcop->cop_io);
 305         }
 306         if (type && *type)
 307             PerlIO_apply_layers(aTHX_ fp,mode,type);
 308
 309         if (gimme == G_VOID) {
 310             char tmpbuf[256];
 311             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
 312                 /*SUPPRESS 530*/
 313                 ;
 314         }
 315         else if (gimme == G_SCALAR) {
 316             sv_setpv(TARG, ""); /* note that this preserves previous buffer */
 317             while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
 318                 /*SUPPRESS 530*/
 319                 ;
 320             XPUSHs(TARG);
 321             SvTAINTED_on(TARG);
 322         }
 323         else {
 324             SV *sv;
 325
 326             for (;;) {
 327                 sv = NEWSV(56, 79);
 328                 if (sv_gets(sv, fp, 0) == Nullch) {
 329                     SvREFCNT_dec(sv);
 330                     break;
 331                 }
 332                 XPUSHs(sv_2mortal(sv));
 333                 if (SvLEN(sv) - SvCUR(sv) > 20) {
 334                     SvLEN_set(sv, SvCUR(sv)+1);
 335                     Renew(SvPVX(sv), SvLEN(sv), char);
 336                 }
 337                 SvTAINTED_on(sv);
 338             }
 339         }
 340         STATUS_NATIVE_SET(PerlProc_pclose(fp));
 341         TAINT;          /* "I believe that this is not gratuitous!" */
 342     }
 343     else {
 344         STATUS_NATIVE_SET(-1);
 345         if (gimme == G_SCALAR)
 346             RETPUSHUNDEF;
 347     }
 348
 349     RETURN;
 350 }
 351
 352 PP(pp_glob)
 353 {
 354     OP *result;
 355     tryAMAGICunTARGET(iter, -1);
 356
 357     /* Note that we only ever get here if File::Glob fails to load
 358      * without at the same time croaking, for some reason, or if
 359      * perl was built with PERL_EXTERNAL_GLOB */
 360
 361     ENTER;
 362
 363 #ifndef VMS
 364     if (PL_tainting) {
 365         /*
 366          * The external globbing program may use things we can't control,
 367          * so for security reasons we must assume the worst.
 368          */
 369         TAINT;
 370         taint_proper(PL_no_security, "glob");
 371     }
 372 #endif /* !VMS */
 373
 374     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
 375     PL_last_in_gv = (GV*)*PL_stack_sp--;
 376
 377     SAVESPTR(PL_rs);            /* This is not permanent, either. */
 378     PL_rs = sv_2mortal(newSVpvn("\000", 1));
 379 #ifndef DOSISH
 380 #ifndef CSH
 381     *SvPVX(PL_rs) = '\n';
 382 #endif  /* !CSH */
 383 #endif  /* !DOSISH */
 384
 385     result = do_readline();
 386     LEAVE;
 387     return result;
 388 }
 389
 390 #if 0           /* XXX never used! */
 391 PP(pp_indread)
 392 {
 393     STRLEN n_a;
 394     PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
 395     return do_readline();
 396 }
 397 #endif
 398
 399 PP(pp_rcatline)
 400 {
 401     PL_last_in_gv = cGVOP_gv;
 402     return do_readline();
 403 }
 404
 405 PP(pp_warn)
 406 {
 407     dSP; dMARK;
 408     SV *tmpsv;
 409     char *tmps;
 410     STRLEN len;
 411     if (SP - MARK != 1) {
 412         dTARGET;
 413         do_join(TARG, &PL_sv_no, MARK, SP);
 414         tmpsv = TARG;
 415         SP = MARK + 1;
 416     }
 417     else {
 418         tmpsv = TOPs;
 419     }
 420     tmps = SvPV(tmpsv, len);
 421     if (!tmps || !len) {
 422         SV *error = ERRSV;
 423         (void)SvUPGRADE(error, SVt_PV);
 424         if (SvPOK(error) && SvCUR(error))
 425             sv_catpv(error, "\t...caught");
 426         tmpsv = error;
 427         tmps = SvPV(tmpsv, len);
 428     }
 429     if (!tmps || !len)
 430         tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
 431
 432     Perl_warn(aTHX_ "%"SVf, tmpsv);
 433     RETSETYES;
 434 }
 435
 436 PP(pp_die)
 437 {
 438     dSP; dMARK;
 439     char *tmps;
 440     SV *tmpsv;
 441     STRLEN len;
 442     bool multiarg = 0;
 443     if (SP - MARK != 1) {
 444         dTARGET;
 445         do_join(TARG, &PL_sv_no, MARK, SP);
 446         tmpsv = TARG;
 447         tmps = SvPV(tmpsv, len);
 448         multiarg = 1;
 449         SP = MARK + 1;
 450     }
 451     else {
 452         tmpsv = TOPs;
 453         tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len);
 454     }
 455     if (!tmps || !len) {
 456         SV *error = ERRSV;
 457         (void)SvUPGRADE(error, SVt_PV);
 458         if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
 459             if (!multiarg)
 460                 SvSetSV(error,tmpsv);
 461             else if (sv_isobject(error)) {
 462                 HV *stash = SvSTASH(SvRV(error));
 463                 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
 464                 if (gv) {
 465                     SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
 466                     SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
 467                     EXTEND(SP, 3);
 468                     PUSHMARK(SP);
 469                     PUSHs(error);
 470                     PUSHs(file);
 471                     PUSHs(line);
 472                     PUTBACK;
 473                     call_sv((SV*)GvCV(gv),
 474                             G_SCALAR|G_EVAL|G_KEEPERR);
 475                     sv_setsv(error,*PL_stack_sp--);
 476                 }
 477             }
 478             DIE(aTHX_ Nullch);
 479         }
 480         else {
 481             if (SvPOK(error) && SvCUR(error))
 482                 sv_catpv(error, "\t...propagated");
 483             tmpsv = error;
 484             tmps = SvPV(tmpsv, len);
 485         }
 486     }
 487     if (!tmps || !len)
 488         tmpsv = sv_2mortal(newSVpvn("Died", 4));
 489
 490     DIE(aTHX_ "%"SVf, tmpsv);
 491 }
 492
 493 /* I/O. */
 494
 495 PP(pp_open)
 496 {
 497     dSP;
 498     dMARK; dORIGMARK;
 499     dTARGET;
 500     GV *gv;
 501     SV *sv;
 502     char *tmps;
 503     STRLEN len;
 504     MAGIC *mg;
 505     bool  ok;
 506
 507     gv = (GV *)*++MARK;
 508     if (!isGV(gv))
 509         DIE(aTHX_ PL_no_usym, "filehandle");
 510     if (GvIOp(gv))
 511         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 512
 513     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
 514         /* Method's args are same as ours ... */
 515         /* ... except handle is replaced by the object */
 516         *MARK-- = SvTIED_obj((SV*)gv, mg);
 517         PUSHMARK(MARK);
 518         PUTBACK;
 519         ENTER;
 520         call_method("OPEN", G_SCALAR);
 521         LEAVE;
 522         SPAGAIN;
 523         RETURN;
 524     }
 525
 526     if (MARK < SP) {
 527         sv = *++MARK;
 528     }
 529     else {
 530         sv = GvSV(gv);
 531     }
 532
 533     tmps = SvPV(sv, len);
 534     ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
 535     SP = ORIGMARK;
 536     if (ok)
 537         PUSHi( (I32)PL_forkprocess );
 538     else if (PL_forkprocess == 0)               /* we are a new child */
 539         PUSHi(0);
 540     else
 541         RETPUSHUNDEF;
 542     RETURN;
 543 }
 544
 545 PP(pp_close)
 546 {
 547     dSP;
 548     GV *gv;
 549     MAGIC *mg;
 550
 551     if (MAXARG == 0)
 552         gv = PL_defoutgv;
 553     else
 554         gv = (GV*)POPs;
 555
 556     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
 557         PUSHMARK(SP);
 558         XPUSHs(SvTIED_obj((SV*)gv, mg));
 559         PUTBACK;
 560         ENTER;
 561         call_method("CLOSE", G_SCALAR);
 562         LEAVE;
 563         SPAGAIN;
 564         RETURN;
 565     }
 566     EXTEND(SP, 1);
 567     PUSHs(boolSV(do_close(gv, TRUE)));
 568     RETURN;
 569 }
 570
 571 PP(pp_pipe_op)
 572 {
 573     dSP;
 574 #ifdef HAS_PIPE
 575     GV *rgv;
 576     GV *wgv;
 577     register IO *rstio;
 578     register IO *wstio;
 579     int fd[2];
 580
 581     wgv = (GV*)POPs;
 582     rgv = (GV*)POPs;
 583
 584     if (!rgv || !wgv)
 585         goto badexit;
 586
 587     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
 588         DIE(aTHX_ PL_no_usym, "filehandle");
 589     rstio = GvIOn(rgv);
 590     wstio = GvIOn(wgv);
 591
 592     if (IoIFP(rstio))
 593         do_close(rgv, FALSE);
 594     if (IoIFP(wstio))
 595         do_close(wgv, FALSE);
 596
 597     if (PerlProc_pipe(fd) < 0)
 598         goto badexit;
 599
 600     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 601     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 602     IoIFP(wstio) = IoOFP(wstio);
 603     IoTYPE(rstio) = IoTYPE_RDONLY;
 604     IoTYPE(wstio) = IoTYPE_WRONLY;
 605
 606     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 607         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 608         else PerlLIO_close(fd[0]);
 609         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 610         else PerlLIO_close(fd[1]);
 611         goto badexit;
 612     }
 613 #if defined(HAS_FCNTL) && defined(F_SETFD)
 614     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
 615     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
 616 #endif
 617     RETPUSHYES;
 618
 619 badexit:
 620     RETPUSHUNDEF;
 621 #else
 622     DIE(aTHX_ PL_no_func, "pipe");
 623 #endif
 624 }
 625
 626 PP(pp_fileno)
 627 {
 628     dSP; dTARGET;
 629     GV *gv;
 630     IO *io;
 631     PerlIO *fp;
 632     MAGIC  *mg;
 633
 634     if (MAXARG < 1)
 635         RETPUSHUNDEF;
 636     gv = (GV*)POPs;
 637
 638     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 639         PUSHMARK(SP);
 640         XPUSHs(SvTIED_obj((SV*)gv, mg));
 641         PUTBACK;
 642         ENTER;
 643         call_method("FILENO", G_SCALAR);
 644         LEAVE;
 645         SPAGAIN;
 646         RETURN;
 647     }
 648
 649     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
 650         /* Can't do this because people seem to do things like
 651            defined(fileno($foo)) to check whether $foo is a valid fh.
 652           if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 653               report_evil_fh(gv, io, PL_op->op_type);
 654             */
 655         RETPUSHUNDEF;
 656     }
 657
 658     PUSHi(PerlIO_fileno(fp));
 659     RETURN;
 660 }
 661
 662 PP(pp_umask)
 663 {
 664     dSP; dTARGET;
 665     Mode_t anum;
 666
 667 #ifdef HAS_UMASK
 668     if (MAXARG < 1) {
 669         anum = PerlLIO_umask(0);
 670         (void)PerlLIO_umask(anum);
 671     }
 672     else
 673         anum = PerlLIO_umask(POPi);
 674     TAINT_PROPER("umask");
 675     XPUSHi(anum);
 676 #else
 677     /* Only DIE if trying to restrict permissions on `user' (self).
 678      * Otherwise it's harmless and more useful to just return undef
 679      * since 'group' and 'other' concepts probably don't exist here. */
 680     if (MAXARG >= 1 && (POPi & 0700))
 681         DIE(aTHX_ "umask not implemented");
 682     XPUSHs(&PL_sv_undef);
 683 #endif
 684     RETURN;
 685 }
 686
 687 PP(pp_binmode)
 688 {
 689     dSP;
 690     GV *gv;
 691     IO *io;
 692     PerlIO *fp;
 693     MAGIC *mg;
 694     SV *discp = Nullsv;
 695     STRLEN len  = 0;
 696     char *names = NULL;
 697
 698     if (MAXARG < 1)
 699         RETPUSHUNDEF;
 700     if (MAXARG > 1) {
 701         discp = POPs;
 702     }
 703
 704     gv = (GV*)POPs;
 705
 706     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 707         PUSHMARK(SP);
 708         XPUSHs(SvTIED_obj((SV*)gv, mg));
 709         if (discp)
 710             XPUSHs(discp);
 711         PUTBACK;
 712         ENTER;
 713         call_method("BINMODE", G_SCALAR);
 714         LEAVE;
 715         SPAGAIN;
 716         RETURN;
 717     }
 718
 719     EXTEND(SP, 1);
 720     if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
 721         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 722             report_evil_fh(gv, io, PL_op->op_type);
 723         RETPUSHUNDEF;
 724     }
 725
 726     if (discp) {
 727         names = SvPV(discp,len);
 728     }
 729
 730     if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
 731                        (discp) ? SvPV_nolen(discp) : Nullch))
 732         RETPUSHYES;
 733     else
 734         RETPUSHUNDEF;
 735 }
 736
 737 PP(pp_tie)
 738 {
 739     dSP;
 740     dMARK;
 741     SV *varsv;
 742     HV* stash;
 743     GV *gv;
 744     SV *sv;
 745     I32 markoff = MARK - PL_stack_base;
 746     char *methname;
 747     int how = 'P';
 748     U32 items;
 749     STRLEN n_a;
 750
 751     varsv = *++MARK;
 752     switch(SvTYPE(varsv)) {
 753         case SVt_PVHV:
 754             methname = "TIEHASH";
 755             break;
 756         case SVt_PVAV:
 757             methname = "TIEARRAY";
 758             break;
 759         case SVt_PVGV:
 760 #ifdef GV_SHARED_CHECK
 761             if (GvSHARED((GV*)varsv)) {
 762                 Perl_croak(aTHX_ "Attempt to tie shared GV");
 763             }
 764 #endif
 765             methname = "TIEHANDLE";
 766             how = 'q';
 767             break;
 768         default:
 769             methname = "TIESCALAR";
 770             how = 'q';
 771             break;
 772     }
 773     items = SP - MARK++;
 774     if (sv_isobject(*MARK)) {
 775         ENTER;
 776         PUSHSTACKi(PERLSI_MAGIC);
 777         PUSHMARK(SP);
 778         EXTEND(SP,items);
 779         while (items--)
 780             PUSHs(*MARK++);
 781         PUTBACK;
 782         call_method(methname, G_SCALAR);
 783     }
 784     else {
 785         /* Not clear why we don't call call_method here too.
 786          * perhaps to get different error message ?
 787          */
 788         stash = gv_stashsv(*MARK, FALSE);
 789         if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 790             DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
 791                  methname, SvPV(*MARK,n_a));
 792         }
 793         ENTER;
 794         PUSHSTACKi(PERLSI_MAGIC);
 795         PUSHMARK(SP);
 796         EXTEND(SP,items);
 797         while (items--)
 798             PUSHs(*MARK++);
 799         PUTBACK;
 800         call_sv((SV*)GvCV(gv), G_SCALAR);
 801     }
 802     SPAGAIN;
 803
 804     sv = TOPs;
 805     POPSTACK;
 806     if (sv_isobject(sv)) {
 807         sv_unmagic(varsv, how);
 808         /* Croak if a self-tie on an aggregate is attempted. */
 809         if (varsv == SvRV(sv) &&
 810             (SvTYPE(sv) == SVt_PVAV ||
 811              SvTYPE(sv) == SVt_PVHV))
 812             Perl_croak(aTHX_
 813                        "Self-ties of arrays and hashes are not supported");
 814         sv_magic(varsv, sv, how, Nullch, 0);
 815     }
 816     LEAVE;
 817     SP = PL_stack_base + markoff;
 818     PUSHs(sv);
 819     RETURN;
 820 }
 821
 822 PP(pp_untie)
 823 {
 824     dSP;
 825     SV *sv = POPs;
 826     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 827
 828         MAGIC * mg ;
 829         if ((mg = SvTIED_mg(sv, how))) {
 830         SV *obj = SvRV(mg->mg_obj);
 831         GV *gv;
 832         CV *cv = NULL;
 833         if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
 834             isGV(gv) && (cv = GvCV(gv))) {
 835             PUSHMARK(SP);
 836             XPUSHs(SvTIED_obj((SV*)gv, mg));
 837             XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
 838             PUTBACK;
 839             ENTER;
 840             call_sv((SV *)cv, G_VOID);
 841             LEAVE;
 842             SPAGAIN;
 843         }
 844         else if (ckWARN(WARN_UNTIE)) {
 845             if (mg && SvREFCNT(obj) > 1)
 846                 Perl_warner(aTHX_ WARN_UNTIE,
 847                     "untie attempted while %"UVuf" inner references still exist",
 848                     (UV)SvREFCNT(obj) - 1 ) ;
 849         }
 850     }
 851     sv_unmagic(sv, how);
 852     RETPUSHYES;
 853 }
 854
 855 PP(pp_tied)
 856 {
 857     dSP;
 858     SV *sv = POPs;
 859     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 860     MAGIC *mg;
 861
 862     if ((mg = SvTIED_mg(sv, how))) {
 863         SV *osv = SvTIED_obj(sv, mg);
 864         if (osv == mg->mg_obj)
 865             osv = sv_mortalcopy(osv);
 866         PUSHs(osv);
 867         RETURN;
 868     }
 869     RETPUSHUNDEF;
 870 }
 871
 872 PP(pp_dbmopen)
 873 {
 874     dSP;
 875     HV *hv;
 876     dPOPPOPssrl;
 877     HV* stash;
 878     GV *gv;
 879     SV *sv;
 880
 881     hv = (HV*)POPs;
 882
 883     sv = sv_mortalcopy(&PL_sv_no);
 884     sv_setpv(sv, "AnyDBM_File");
 885     stash = gv_stashsv(sv, FALSE);
 886     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
 887         PUTBACK;
 888         require_pv("AnyDBM_File.pm");
 889         SPAGAIN;
 890         if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
 891             DIE(aTHX_ "No dbm on this machine");
 892     }
 893
 894     ENTER;
 895     PUSHMARK(SP);
 896
 897     EXTEND(SP, 5);
 898     PUSHs(sv);
 899     PUSHs(left);
 900     if (SvIV(right))
 901         PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
 902     else
 903         PUSHs(sv_2mortal(newSVuv(O_RDWR)));
 904     PUSHs(right);
 905     PUTBACK;
 906     call_sv((SV*)GvCV(gv), G_SCALAR);
 907     SPAGAIN;
 908
 909     if (!sv_isobject(TOPs)) {
 910         SP--;
 911         PUSHMARK(SP);
 912         PUSHs(sv);
 913         PUSHs(left);
 914         PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
 915         PUSHs(right);
 916         PUTBACK;
 917         call_sv((SV*)GvCV(gv), G_SCALAR);
 918         SPAGAIN;
 919     }
 920
 921     if (sv_isobject(TOPs)) {
 922         sv_unmagic((SV *) hv, 'P');
 923         sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
 924     }
 925     LEAVE;
 926     RETURN;
 927 }
 928
 929 PP(pp_dbmclose)
 930 {
 931     return pp_untie();
 932 }
 933
 934 PP(pp_sselect)
 935 {
 936     dSP; dTARGET;
 937 #ifdef HAS_SELECT
 938     register I32 i;
 939     register I32 j;
 940     register char *s;
 941     register SV *sv;
 942     NV value;
 943     I32 maxlen = 0;
 944     I32 nfound;
 945     struct timeval timebuf;
 946     struct timeval *tbuf = &timebuf;
 947     I32 growsize;
 948     char *fd_sets[4];
 949     STRLEN n_a;
 950 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
 951         I32 masksize;
 952         I32 offset;
 953         I32 k;
 954
 955 #   if BYTEORDER & 0xf0000
 956 #       define ORDERBYTE (0x88888888 - BYTEORDER)
 957 #   else
 958 #       define ORDERBYTE (0x4444 - BYTEORDER)
 959 #   endif
 960
 961 #endif
 962
 963     SP -= 4;
 964     for (i = 1; i <= 3; i++) {
 965         if (!SvPOK(SP[i]))
 966             continue;
 967         j = SvCUR(SP[i]);
 968         if (maxlen < j)
 969             maxlen = j;
 970     }
 971
 972 /* little endians can use vecs directly */
 973 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
 974 #  if SELECT_MIN_BITS > 1
 975     /* If SELECT_MIN_BITS is greater than one we most probably will want
 976      * to align the sizes with SELECT_MIN_BITS/8 because for example
 977      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
 978      * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
 979      * on (sets/tests/clears bits) is 32 bits.  */
 980     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
 981 #  else
 982     growsize = sizeof(fd_set);
 983 #  endif
 984 # else
 985 #  ifdef NFDBITS
 986
 987 #    ifndef NBBY
 988 #     define NBBY 8
 989 #    endif
 990
 991     masksize = NFDBITS / NBBY;
 992 #  else
 993     masksize = sizeof(long);    /* documented int, everyone seems to use long */
 994 #  endif
 995     growsize = maxlen + (masksize - (maxlen % masksize));
 996     Zero(&fd_sets[0], 4, char*);
 997 #endif
 998
 999     sv = SP[4];
1000     if (SvOK(sv)) {
1001         value = SvNV(sv);
1002         if (value < 0.0)
1003             value = 0.0;
1004         timebuf.tv_sec = (long)value;
1005         value -= (NV)timebuf.tv_sec;
1006         timebuf.tv_usec = (long)(value * 1000000.0);
1007     }
1008     else
1009         tbuf = Null(struct timeval*);
1010
1011     for (i = 1; i <= 3; i++) {
1012         sv = SP[i];
1013         if (!SvOK(sv)) {
1014             fd_sets[i] = 0;
1015             continue;
1016         }
1017         else if (!SvPOK(sv))
1018             SvPV_force(sv,n_a); /* force string conversion */
1019         j = SvLEN(sv);
1020         if (j < growsize) {
1021             Sv_Grow(sv, growsize);
1022         }
1023         j = SvCUR(sv);
1024         s = SvPVX(sv) + j;
1025         while (++j <= growsize) {
1026             *s++ = '\0';
1027         }
1028
1029 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1030         s = SvPVX(sv);
1031         New(403, fd_sets[i], growsize, char);
1032         for (offset = 0; offset < growsize; offset += masksize) {
1033             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1034                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1035         }
1036 #else
1037         fd_sets[i] = SvPVX(sv);
1038 #endif
1039     }
1040
1041     nfound = PerlSock_select(
1042         maxlen * 8,
1043         (Select_fd_set_t) fd_sets[1],
1044         (Select_fd_set_t) fd_sets[2],
1045         (Select_fd_set_t) fd_sets[3],
1046         tbuf);
1047     for (i = 1; i <= 3; i++) {
1048         if (fd_sets[i]) {
1049             sv = SP[i];
1050 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1051             s = SvPVX(sv);
1052             for (offset = 0; offset < growsize; offset += masksize) {
1053                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1054                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1055             }
1056             Safefree(fd_sets[i]);
1057 #endif
1058             SvSETMAGIC(sv);
1059         }
1060     }
1061
1062     PUSHi(nfound);
1063     if (GIMME == G_ARRAY && tbuf) {
1064         value = (NV)(timebuf.tv_sec) +
1065                 (NV)(timebuf.tv_usec) / 1000000.0;
1066         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1067         sv_setnv(sv, value);
1068     }
1069     RETURN;
1070 #else
1071     DIE(aTHX_ "select not implemented");
1072 #endif
1073 }
1074
1075 void
1076 Perl_setdefout(pTHX_ GV *gv)
1077 {
1078     if (gv)
1079         (void)SvREFCNT_inc(gv);
1080     if (PL_defoutgv)
1081         SvREFCNT_dec(PL_defoutgv);
1082     PL_defoutgv = gv;
1083 }
1084
1085 PP(pp_select)
1086 {
1087     dSP; dTARGET;
1088     GV *newdefout, *egv;
1089     HV *hv;
1090
1091     newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
1092
1093     egv = GvEGV(PL_defoutgv);
1094     if (!egv)
1095         egv = PL_defoutgv;
1096     hv = GvSTASH(egv);
1097     if (! hv)
1098         XPUSHs(&PL_sv_undef);
1099     else {
1100         GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1101         if (gvp && *gvp == egv) {
1102             gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
1103             XPUSHTARG;
1104         }
1105         else {
1106             XPUSHs(sv_2mortal(newRV((SV*)egv)));
1107         }
1108     }
1109
1110     if (newdefout) {
1111         if (!GvIO(newdefout))
1112             gv_IOadd(newdefout);
1113         setdefout(newdefout);
1114     }
1115
1116     RETURN;
1117 }
1118
1119 PP(pp_getc)
1120 {
1121     dSP; dTARGET;
1122     GV *gv;
1123     MAGIC *mg;
1124
1125     if (MAXARG == 0)
1126         gv = PL_stdingv;
1127     else
1128         gv = (GV*)POPs;
1129
1130     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
1131         I32 gimme = GIMME_V;
1132         PUSHMARK(SP);
1133         XPUSHs(SvTIED_obj((SV*)gv, mg));
1134         PUTBACK;
1135         ENTER;
1136         call_method("GETC", gimme);
1137         LEAVE;
1138         SPAGAIN;
1139         if (gimme == G_SCALAR)
1140             SvSetMagicSV_nosteal(TARG, TOPs);
1141         RETURN;
1142     }
1143     if (!gv || do_eof(gv)) /* make sure we have fp with something */
1144         RETPUSHUNDEF;
1145     TAINT;
1146     sv_setpv(TARG, " ");
1147     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1148     if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1149         /* Find out how many bytes the char needs */
1150         Size_t len = UTF8SKIP(SvPVX(TARG));
1151         if (len > 1) {
1152             SvGROW(TARG,len+1);
1153             len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1154             SvCUR_set(TARG,1+len);
1155         }
1156         SvUTF8_on(TARG);
1157     }
1158     PUSHTARG;
1159     RETURN;
1160 }
1161
1162 PP(pp_read)
1163 {
1164     return pp_sysread();
1165 }
1166
1167 STATIC OP *
1168 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1169 {
1170     register PERL_CONTEXT *cx;
1171     I32 gimme = GIMME_V;
1172     AV* padlist = CvPADLIST(cv);
1173     SV** svp = AvARRAY(padlist);
1174
1175     ENTER;
1176     SAVETMPS;
1177
1178     push_return(retop);
1179     PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1180     PUSHFORMAT(cx);
1181     SAVEVPTR(PL_curpad);
1182     PL_curpad = AvARRAY((AV*)svp[1]);
1183
1184     setdefout(gv);          /* locally select filehandle so $% et al work */
1185     return CvSTART(cv);
1186 }
1187
1188 PP(pp_enterwrite)
1189 {
1190     dSP;
1191     register GV *gv;
1192     register IO *io;
1193     GV *fgv;
1194     CV *cv;
1195
1196     if (MAXARG == 0)
1197         gv = PL_defoutgv;
1198     else {
1199         gv = (GV*)POPs;
1200         if (!gv)
1201             gv = PL_defoutgv;
1202     }
1203     EXTEND(SP, 1);
1204     io = GvIO(gv);
1205     if (!io) {
1206         RETPUSHNO;
1207     }
1208     if (IoFMT_GV(io))
1209         fgv = IoFMT_GV(io);
1210     else
1211         fgv = gv;
1212
1213     cv = GvFORM(fgv);
1214     if (!cv) {
1215         char *name = NULL;
1216         if (fgv) {
1217             SV *tmpsv = sv_newmortal();
1218             gv_efullname4(tmpsv, fgv, Nullch, FALSE);
1219             name = SvPV_nolen(tmpsv);
1220         }
1221         if (name && *name)
1222             DIE(aTHX_ "Undefined format \"%s\" called", name);
1223         DIE(aTHX_ "Not a format reference");
1224     }
1225     if (CvCLONE(cv))
1226         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1227
1228     IoFLAGS(io) &= ~IOf_DIDTOP;
1229     return doform(cv,gv,PL_op->op_next);
1230 }
1231
1232 PP(pp_leavewrite)
1233 {
1234     dSP;
1235     GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1236     register IO *io = GvIOp(gv);
1237     PerlIO *ofp = IoOFP(io);
1238     PerlIO *fp;
1239     SV **newsp;
1240     I32 gimme;
1241     register PERL_CONTEXT *cx;
1242
1243     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1244           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1245     if (!io || !ofp)
1246         goto forget_top;
1247     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1248         PL_formtarget != PL_toptarget)
1249     {
1250         GV *fgv;
1251         CV *cv;
1252         if (!IoTOP_GV(io)) {
1253             GV *topgv;
1254             SV *topname;
1255
1256             if (!IoTOP_NAME(io)) {
1257                 if (!IoFMT_NAME(io))
1258                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1259                 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
1260                 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
1261                 if ((topgv && GvFORM(topgv)) ||
1262                   !gv_fetchpv("top",FALSE,SVt_PVFM))
1263                     IoTOP_NAME(io) = savepv(SvPVX(topname));
1264                 else
1265                     IoTOP_NAME(io) = savepv("top");
1266             }
1267             topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1268             if (!topgv || !GvFORM(topgv)) {
1269                 IoLINES_LEFT(io) = 100000000;
1270                 goto forget_top;
1271             }
1272             IoTOP_GV(io) = topgv;
1273         }
1274         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1275             I32 lines = IoLINES_LEFT(io);
1276             char *s = SvPVX(PL_formtarget);
1277             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1278                 goto forget_top;
1279             while (lines-- > 0) {
1280                 s = strchr(s, '\n');
1281                 if (!s)
1282                     break;
1283                 s++;
1284             }
1285             if (s) {
1286                 STRLEN save = SvCUR(PL_formtarget);
1287                 SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
1288                 do_print(PL_formtarget, ofp);
1289                 SvCUR_set(PL_formtarget, save);
1290                 sv_chop(PL_formtarget, s);
1291                 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1292             }
1293         }
1294         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1295             do_print(PL_formfeed, ofp);
1296         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1297         IoPAGE(io)++;
1298         PL_formtarget = PL_toptarget;
1299         IoFLAGS(io) |= IOf_DIDTOP;
1300         fgv = IoTOP_GV(io);
1301         if (!fgv)
1302             DIE(aTHX_ "bad top format reference");
1303         cv = GvFORM(fgv);
1304         {
1305             char *name = NULL;
1306             if (!cv) {
1307                 SV *sv = sv_newmortal();
1308                 gv_efullname4(sv, fgv, Nullch, FALSE);
1309                 name = SvPV_nolen(sv);
1310             }
1311             if (name && *name)
1312                 DIE(aTHX_ "Undefined top format \"%s\" called",name);
1313             /* why no:
1314             else
1315                 DIE(aTHX_ "Undefined top format called");
1316             ?*/
1317         }
1318         if (CvCLONE(cv))
1319             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1320         return doform(cv,gv,PL_op);
1321     }
1322
1323   forget_top:
1324     POPBLOCK(cx,PL_curpm);
1325     POPFORMAT(cx);
1326     LEAVE;
1327
1328     fp = IoOFP(io);
1329     if (!fp) {
1330         if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1331             if (IoIFP(io)) {
1332                 /* integrate with report_evil_fh()? */
1333                 char *name = NULL;
1334                 if (isGV(gv)) {
1335                     SV* sv = sv_newmortal();
1336                     gv_efullname4(sv, gv, Nullch, FALSE);
1337                     name = SvPV_nolen(sv);
1338                 }
1339                 if (name && *name)
1340                     Perl_warner(aTHX_ WARN_IO,
1341                                 "Filehandle %s opened only for input", name);
1342                 else
1343                     Perl_warner(aTHX_ WARN_IO,
1344                                 "Filehandle opened only for input");
1345             }
1346             else if (ckWARN(WARN_CLOSED))
1347                 report_evil_fh(gv, io, PL_op->op_type);
1348         }
1349         PUSHs(&PL_sv_no);
1350     }
1351     else {
1352         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1353             if (ckWARN(WARN_IO))
1354                 Perl_warner(aTHX_ WARN_IO, "page overflow");
1355         }
1356         if (!do_print(PL_formtarget, fp))
1357             PUSHs(&PL_sv_no);
1358         else {
1359             FmLINES(PL_formtarget) = 0;
1360             SvCUR_set(PL_formtarget, 0);
1361             *SvEND(PL_formtarget) = '\0';
1362             if (IoFLAGS(io) & IOf_FLUSH)
1363                 (void)PerlIO_flush(fp);
1364             PUSHs(&PL_sv_yes);
1365         }
1366     }
1367     /* bad_ofp: */
1368     PL_formtarget = PL_bodytarget;
1369     PUTBACK;
1370     return pop_return();
1371 }
1372
1373 PP(pp_prtf)
1374 {
1375     dSP; dMARK; dORIGMARK;
1376     GV *gv;
1377     IO *io;
1378     PerlIO *fp;
1379     SV *sv;
1380     MAGIC *mg;
1381
1382     if (PL_op->op_flags & OPf_STACKED)
1383         gv = (GV*)*++MARK;
1384     else
1385         gv = PL_defoutgv;
1386
1387     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
1388         if (MARK == ORIGMARK) {
1389             MEXTEND(SP, 1);
1390             ++MARK;
1391             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1392             ++SP;
1393         }
1394         PUSHMARK(MARK - 1);
1395         *MARK = SvTIED_obj((SV*)gv, mg);
1396         PUTBACK;
1397         ENTER;
1398         call_method("PRINTF", G_SCALAR);
1399         LEAVE;
1400         SPAGAIN;
1401         MARK = ORIGMARK + 1;
1402         *MARK = *SP;
1403         SP = MARK;
1404         RETURN;
1405     }
1406
1407     sv = NEWSV(0,0);
1408     if (!(io = GvIO(gv))) {
1409         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1410             report_evil_fh(gv, io, PL_op->op_type);
1411         SETERRNO(EBADF,RMS$_IFI);
1412         goto just_say_no;
1413     }
1414     else if (!(fp = IoOFP(io))) {
1415         if (ckWARN2(WARN_CLOSED,WARN_IO))  {
1416             /* integrate with report_evil_fh()? */
1417             if (IoIFP(io)) {
1418                 char *name = NULL;
1419                 if (isGV(gv)) {
1420                     gv_efullname4(sv, gv, Nullch, FALSE);
1421                     name = SvPV_nolen(sv);
1422                 }
1423                 if (name && *name)
1424                     Perl_warner(aTHX_ WARN_IO,
1425                                 "Filehandle %s opened only for input", name);
1426                 else
1427                     Perl_warner(aTHX_ WARN_IO,
1428                                 "Filehandle opened only for input");
1429             }
1430             else if (ckWARN(WARN_CLOSED))
1431                 report_evil_fh(gv, io, PL_op->op_type);
1432         }
1433         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
1434         goto just_say_no;
1435     }
1436     else {
1437         do_sprintf(sv, SP - MARK, MARK + 1);
1438         if (!do_print(sv, fp))
1439             goto just_say_no;
1440
1441         if (IoFLAGS(io) & IOf_FLUSH)
1442             if (PerlIO_flush(fp) == EOF)
1443                 goto just_say_no;
1444     }
1445     SvREFCNT_dec(sv);
1446     SP = ORIGMARK;
1447     PUSHs(&PL_sv_yes);
1448     RETURN;
1449
1450   just_say_no:
1451     SvREFCNT_dec(sv);
1452     SP = ORIGMARK;
1453     PUSHs(&PL_sv_undef);
1454     RETURN;
1455 }
1456
1457 PP(pp_sysopen)
1458 {
1459     dSP;
1460     GV *gv;
1461     SV *sv;
1462     char *tmps;
1463     STRLEN len;
1464     int mode, perm;
1465
1466     if (MAXARG > 3)
1467         perm = POPi;
1468     else
1469         perm = 0666;
1470     mode = POPi;
1471     sv = POPs;
1472     gv = (GV *)POPs;
1473
1474     /* Need TIEHANDLE method ? */
1475
1476     tmps = SvPV(sv, len);
1477     if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1478         IoLINES(GvIOp(gv)) = 0;
1479         PUSHs(&PL_sv_yes);
1480     }
1481     else {
1482         PUSHs(&PL_sv_undef);
1483     }
1484     RETURN;
1485 }
1486
1487 PP(pp_sysread)
1488 {
1489     dSP; dMARK; dORIGMARK; dTARGET;
1490     int offset;
1491     GV *gv;
1492     IO *io;
1493     char *buffer;
1494     SSize_t length;
1495     SSize_t count;
1496     Sock_size_t bufsize;
1497     SV *bufsv;
1498     STRLEN blen;
1499     MAGIC *mg;
1500     int fp_utf8;
1501     Size_t got = 0;
1502     Size_t wanted;
1503
1504     gv = (GV*)*++MARK;
1505     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
1506         (mg = SvTIED_mg((SV*)gv, 'q')))
1507     {
1508         SV *sv;
1509
1510         PUSHMARK(MARK-1);
1511         *MARK = SvTIED_obj((SV*)gv, mg);
1512         ENTER;
1513         call_method("READ", G_SCALAR);
1514         LEAVE;
1515         SPAGAIN;
1516         sv = POPs;
1517         SP = ORIGMARK;
1518         PUSHs(sv);
1519         RETURN;
1520     }
1521
1522     if (!gv)
1523         goto say_undef;
1524     bufsv = *++MARK;
1525     if (! SvOK(bufsv))
1526         sv_setpvn(bufsv, "", 0);
1527     length = SvIVx(*++MARK);
1528     SETERRNO(0,0);
1529     if (MARK < SP)
1530         offset = SvIVx(*++MARK);
1531     else
1532         offset = 0;
1533     io = GvIO(gv);
1534     if (!io || !IoIFP(io))
1535         goto say_undef;
1536     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTE) {
1537         buffer = SvPVutf8_force(bufsv, blen);
1538         /* UTF8 may not have been set if they are all low bytes */
1539         SvUTF8_on(bufsv);
1540     }
1541     else {
1542         buffer = SvPV_force(bufsv, blen);
1543     }
1544     if (length < 0)
1545         DIE(aTHX_ "Negative length");
1546     wanted = length;
1547
1548 #ifdef HAS_SOCKET
1549     if (PL_op->op_type == OP_RECV) {
1550         char namebuf[MAXPATHLEN];
1551 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
1552         bufsize = sizeof (struct sockaddr_in);
1553 #else
1554         bufsize = sizeof namebuf;
1555 #endif
1556 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1557         if (bufsize >= 256)
1558             bufsize = 255;
1559 #endif
1560         buffer = SvGROW(bufsv, length+1);
1561         /* 'offset' means 'flags' here */
1562         count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1563                           (struct sockaddr *)namebuf, &bufsize);
1564         if (count < 0)
1565             RETPUSHUNDEF;
1566 #ifdef EPOC
1567         /* Bogus return without padding */
1568         bufsize = sizeof (struct sockaddr_in);
1569 #endif
1570         SvCUR_set(bufsv, count);
1571         *SvEND(bufsv) = '\0';
1572         (void)SvPOK_only(bufsv);
1573         if (fp_utf8)
1574             SvUTF8_on(bufsv);
1575         SvSETMAGIC(bufsv);
1576         /* This should not be marked tainted if the fp is marked clean */
1577         if (!(IoFLAGS(io) & IOf_UNTAINT))
1578             SvTAINTED_on(bufsv);
1579         SP = ORIGMARK;
1580         sv_setpvn(TARG, namebuf, bufsize);
1581         PUSHs(TARG);
1582         RETURN;
1583     }
1584 #else
1585     if (PL_op->op_type == OP_RECV)
1586         DIE(aTHX_ PL_no_sock_func, "recv");
1587 #endif
1588     if (DO_UTF8(bufsv)) {
1589         /* offset adjust in characters not bytes */
1590         blen = sv_len_utf8(bufsv);
1591     }
1592     if (offset < 0) {
1593         if (-offset > blen)
1594             DIE(aTHX_ "Offset outside string");
1595         offset += blen;
1596     }
1597     if (DO_UTF8(bufsv)) {
1598         /* convert offset-as-chars to offset-as-bytes */
1599         offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1600     }
1601  more_bytes:
1602     bufsize = SvCUR(bufsv);
1603     buffer  = SvGROW(bufsv, length+offset+1);
1604     if (offset > bufsize) { /* Zero any newly allocated space */
1605         Zero(buffer+bufsize, offset-bufsize, char);
1606     }
1607     buffer = buffer + offset;
1608
1609     if (PL_op->op_type == OP_SYSREAD) {
1610 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1611         if (IoTYPE(io) == IoTYPE_SOCKET) {
1612             count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1613                                    buffer, length, 0);
1614         }
1615         else
1616 #endif
1617         {
1618             count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1619                                   buffer, length);
1620         }
1621     }
1622     else
1623 #ifdef HAS_SOCKET__bad_code_maybe
1624     if (IoTYPE(io) == IoTYPE_SOCKET) {
1625         char namebuf[MAXPATHLEN];
1626 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1627         bufsize = sizeof (struct sockaddr_in);
1628 #else
1629         bufsize = sizeof namebuf;
1630 #endif
1631         count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1632                           (struct sockaddr *)namebuf, &bufsize);
1633     }
1634     else
1635 #endif
1636     {
1637         count = PerlIO_read(IoIFP(io), buffer, length);
1638         /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1639         if (count == 0 && PerlIO_error(IoIFP(io)))
1640             count = -1;
1641     }
1642     if (count < 0) {
1643         if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1644         {
1645             /* integrate with report_evil_fh()? */
1646             char *name = NULL;
1647             if (isGV(gv)) {
1648                 SV* sv = sv_newmortal();
1649                 gv_efullname4(sv, gv, Nullch, FALSE);
1650                 name = SvPV_nolen(sv);
1651             }
1652             if (name && *name)
1653                 Perl_warner(aTHX_ WARN_IO,
1654                             "Filehandle %s opened only for output", name);
1655             else
1656                 Perl_warner(aTHX_ WARN_IO,
1657                             "Filehandle opened only for output");
1658         }
1659         goto say_undef;
1660     }
1661     SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
1662     *SvEND(bufsv) = '\0';
1663     (void)SvPOK_only(bufsv);
1664     if (fp_utf8 && !IN_BYTE) {
1665         /* Look at utf8 we got back and count the characters */
1666         char *bend = buffer + count;
1667         while (buffer < bend) {
1668             STRLEN skip = UTF8SKIP(buffer);
1669             if (buffer+skip > bend) {
1670                 /* partial character - try for rest of it */
1671                 length = skip - (bend-buffer);
1672                 offset = bend - SvPVX(bufsv);
1673                 goto more_bytes;
1674             }
1675             else {
1676                 got++;
1677                 buffer += skip;
1678             }
1679         }
1680         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1681            provided amount read (count) was what was requested (length)
1682          */
1683         if (got < wanted && count == length) {
1684             length = (wanted-got);
1685             offset = bend - SvPVX(bufsv);
1686             goto more_bytes;
1687         }
1688         /* return value is character count */
1689         count = got;
1690         SvUTF8_on(bufsv);
1691     }
1692     SvSETMAGIC(bufsv);
1693     /* This should not be marked tainted if the fp is marked clean */
1694     if (!(IoFLAGS(io) & IOf_UNTAINT))
1695         SvTAINTED_on(bufsv);
1696     SP = ORIGMARK;
1697     PUSHi(count);
1698     RETURN;
1699
1700   say_undef:
1701     SP = ORIGMARK;
1702     RETPUSHUNDEF;
1703 }
1704
1705 PP(pp_syswrite)
1706 {
1707     dSP;
1708     int items = (SP - PL_stack_base) - TOPMARK;
1709     if (items == 2) {
1710         SV *sv;
1711         EXTEND(SP, 1);
1712         sv = sv_2mortal(newSViv(sv_len(*SP)));
1713         PUSHs(sv);
1714         PUTBACK;
1715     }
1716     return pp_send();
1717 }
1718
1719 PP(pp_send)
1720 {
1721     dSP; dMARK; dORIGMARK; dTARGET;
1722     GV *gv;
1723     IO *io;
1724     SV *bufsv;
1725     char *buffer;
1726     Size_t length;
1727     SSize_t retval;
1728     STRLEN blen;
1729     MAGIC *mg;
1730
1731     gv = (GV*)*++MARK;
1732     if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1733         SV *sv;
1734
1735         PUSHMARK(MARK-1);
1736         *MARK = SvTIED_obj((SV*)gv, mg);
1737         ENTER;
1738         call_method("WRITE", G_SCALAR);
1739         LEAVE;
1740         SPAGAIN;
1741         sv = POPs;
1742         SP = ORIGMARK;
1743         PUSHs(sv);
1744         RETURN;
1745     }
1746     if (!gv)
1747         goto say_undef;
1748     bufsv = *++MARK;
1749 #if Size_t_size > IVSIZE
1750     length = (Size_t)SvNVx(*++MARK);
1751 #else
1752     length = (Size_t)SvIVx(*++MARK);
1753 #endif
1754     if ((SSize_t)length < 0)
1755         DIE(aTHX_ "Negative length");
1756     SETERRNO(0,0);
1757     io = GvIO(gv);
1758     if (!io || !IoIFP(io)) {
1759         retval = -1;
1760         if (ckWARN(WARN_CLOSED))
1761             report_evil_fh(gv, io, PL_op->op_type);
1762         goto say_undef;
1763     }
1764
1765     if (PerlIO_isutf8(IoIFP(io))) {
1766         buffer = SvPVutf8(bufsv, blen);
1767     }
1768     else {
1769         if (DO_UTF8(bufsv))
1770             sv_utf8_downgrade(bufsv, FALSE);
1771         buffer = SvPV(bufsv, blen);
1772     }
1773
1774     if (PL_op->op_type == OP_SYSWRITE) {
1775         IV offset;
1776         if (DO_UTF8(bufsv)) {
1777             /* length and offset are in chars */
1778             blen   = sv_len_utf8(bufsv);
1779         }
1780         if (MARK < SP) {
1781             offset = SvIVx(*++MARK);
1782             if (offset < 0) {
1783                 if (-offset > blen)
1784                     DIE(aTHX_ "Offset outside string");
1785                 offset += blen;
1786             } else if (offset >= blen && blen > 0)
1787                 DIE(aTHX_ "Offset outside string");
1788         } else
1789             offset = 0;
1790         if (length > blen - offset)
1791             length = blen - offset;
1792         if (DO_UTF8(bufsv)) {
1793             buffer = (char*)utf8_hop((U8 *)buffer, offset);
1794             length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1795         }
1796         else {
1797             buffer = buffer+offset;
1798         }
1799 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1800         if (IoTYPE(io) == IoTYPE_SOCKET) {
1801             retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1802                                    buffer, length, 0);
1803         }
1804         else
1805 #endif
1806         {
1807             /* See the note at doio.c:do_print about filesize limits. --jhi */
1808             retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1809                                    buffer, length);
1810         }
1811     }
1812 #ifdef HAS_SOCKET
1813     else if (SP > MARK) {
1814         char *sockbuf;
1815         STRLEN mlen;
1816         sockbuf = SvPVx(*++MARK, mlen);
1817         /* length is really flags */
1818         retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1819                                  length, (struct sockaddr *)sockbuf, mlen);
1820     }
1821     else
1822         /* length is really flags */
1823         retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1824 #else
1825     else
1826         DIE(aTHX_ PL_no_sock_func, "send");
1827 #endif
1828     if (retval < 0)
1829         goto say_undef;
1830     SP = ORIGMARK;
1831 #if Size_t_size > IVSIZE
1832     PUSHn(retval);
1833 #else
1834     PUSHi(retval);
1835 #endif
1836     RETURN;
1837
1838   say_undef:
1839     SP = ORIGMARK;
1840     RETPUSHUNDEF;
1841 }
1842
1843 PP(pp_recv)
1844 {
1845     return pp_sysread();
1846 }
1847
1848 PP(pp_eof)
1849 {
1850     dSP;
1851     GV *gv;
1852     MAGIC *mg;
1853
1854     if (MAXARG == 0) {
1855         if (PL_op->op_flags & OPf_SPECIAL) {    /* eof() */
1856             IO *io;
1857             gv = PL_last_in_gv = PL_argvgv;
1858             io = GvIO(gv);
1859             if (io && !IoIFP(io)) {
1860                 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1861                     IoLINES(io) = 0;
1862                     IoFLAGS(io) &= ~IOf_START;
1863                     do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1864                     sv_setpvn(GvSV(gv), "-", 1);
1865                     SvSETMAGIC(GvSV(gv));
1866                 }
1867                 else if (!nextargv(gv))
1868                     RETPUSHYES;
1869             }
1870         }
1871         else
1872             gv = PL_last_in_gv;                 /* eof */
1873     }
1874     else
1875         gv = PL_last_in_gv = (GV*)POPs;         /* eof(FH) */
1876
1877     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1878         PUSHMARK(SP);
1879         XPUSHs(SvTIED_obj((SV*)gv, mg));
1880         PUTBACK;
1881         ENTER;
1882         call_method("EOF", G_SCALAR);
1883         LEAVE;
1884         SPAGAIN;
1885         RETURN;
1886     }
1887
1888     PUSHs(boolSV(!gv || do_eof(gv)));
1889     RETURN;
1890 }
1891
1892 PP(pp_tell)
1893 {
1894     dSP; dTARGET;
1895     GV *gv;
1896     MAGIC *mg;
1897
1898     if (MAXARG == 0)
1899         gv = PL_last_in_gv;
1900     else
1901         gv = PL_last_in_gv = (GV*)POPs;
1902
1903     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1904         PUSHMARK(SP);
1905         XPUSHs(SvTIED_obj((SV*)gv, mg));
1906         PUTBACK;
1907         ENTER;
1908         call_method("TELL", G_SCALAR);
1909         LEAVE;
1910         SPAGAIN;
1911         RETURN;
1912     }
1913
1914 #if LSEEKSIZE > IVSIZE
1915     PUSHn( do_tell(gv) );
1916 #else
1917     PUSHi( do_tell(gv) );
1918 #endif
1919     RETURN;
1920 }
1921
1922 PP(pp_seek)
1923 {
1924     return pp_sysseek();
1925 }
1926
1927 PP(pp_sysseek)
1928 {
1929     dSP;
1930     GV *gv;
1931     int whence = POPi;
1932 #if LSEEKSIZE > IVSIZE
1933     Off_t offset = (Off_t)SvNVx(POPs);
1934 #else
1935     Off_t offset = (Off_t)SvIVx(POPs);
1936 #endif
1937     MAGIC *mg;
1938
1939     gv = PL_last_in_gv = (GV*)POPs;
1940
1941     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1942         PUSHMARK(SP);
1943         XPUSHs(SvTIED_obj((SV*)gv, mg));
1944 #if LSEEKSIZE > IVSIZE
1945         XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1946 #else
1947         XPUSHs(sv_2mortal(newSViv(offset)));
1948 #endif
1949         XPUSHs(sv_2mortal(newSViv(whence)));
1950         PUTBACK;
1951         ENTER;
1952         call_method("SEEK", G_SCALAR);
1953         LEAVE;
1954         SPAGAIN;
1955         RETURN;
1956     }
1957
1958     if (PL_op->op_type == OP_SEEK)
1959         PUSHs(boolSV(do_seek(gv, offset, whence)));
1960     else {
1961         Off_t sought = do_sysseek(gv, offset, whence);
1962         if (sought < 0)
1963             PUSHs(&PL_sv_undef);
1964         else {
1965             SV* sv = sought ?
1966 #if LSEEKSIZE > IVSIZE
1967                 newSVnv((NV)sought)
1968 #else
1969                 newSViv(sought)
1970 #endif
1971                 : newSVpvn(zero_but_true, ZBTLEN);
1972             PUSHs(sv_2mortal(sv));
1973         }
1974     }
1975     RETURN;
1976 }
1977
1978 PP(pp_truncate)
1979 {
1980     dSP;
1981     /* There seems to be no consensus on the length type of truncate()
1982      * and ftruncate(), both off_t and size_t have supporters. In
1983      * general one would think that when using large files, off_t is
1984      * at least as wide as size_t, so using an off_t should be okay. */
1985     /* XXX Configure probe for the length type of *truncate() needed XXX */
1986     Off_t len;
1987     int result = 1;
1988     GV *tmpgv;
1989     STRLEN n_a;
1990
1991 #if Size_t_size > IVSIZE
1992     len = (Off_t)POPn;
1993 #else
1994     len = (Off_t)POPi;
1995 #endif
1996     /* Checking for length < 0 is problematic as the type might or
1997      * might not be signed: if it is not, clever compilers will moan. */
1998     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
1999     SETERRNO(0,0);
2000 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
2001     if (PL_op->op_flags & OPf_SPECIAL) {
2002         tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
2003     do_ftruncate:
2004         TAINT_PROPER("truncate");
2005         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
2006             result = 0;
2007         else {
2008             PerlIO_flush(IoIFP(GvIOp(tmpgv)));
2009 #ifdef HAS_TRUNCATE
2010             if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
2011 #else
2012             if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
2013 #endif
2014                 result = 0;
2015         }
2016     }
2017     else {
2018         SV *sv = POPs;
2019         char *name;
2020         STRLEN n_a;
2021
2022         if (SvTYPE(sv) == SVt_PVGV) {
2023             tmpgv = (GV*)sv;            /* *main::FRED for example */
2024             goto do_ftruncate;
2025         }
2026         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2027             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
2028             goto do_ftruncate;
2029         }
2030
2031         name = SvPV(sv, n_a);
2032         TAINT_PROPER("truncate");
2033 #ifdef HAS_TRUNCATE
2034         if (truncate(name, len) < 0)
2035             result = 0;
2036 #else
2037         {
2038             int tmpfd;
2039             if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
2040                 result = 0;
2041             else {
2042                 if (my_chsize(tmpfd, len) < 0)
2043                     result = 0;
2044                 PerlLIO_close(tmpfd);
2045             }
2046         }
2047 #endif
2048     }
2049
2050     if (result)
2051         RETPUSHYES;
2052     if (!errno)
2053         SETERRNO(EBADF,RMS$_IFI);
2054     RETPUSHUNDEF;
2055 #else
2056     DIE(aTHX_ "truncate not implemented");
2057 #endif
2058 }
2059
2060 PP(pp_fcntl)
2061 {
2062     return pp_ioctl();
2063 }
2064
2065 PP(pp_ioctl)
2066 {
2067     dSP; dTARGET;
2068     SV *argsv = POPs;
2069     unsigned int func = U_I(POPn);
2070     int optype = PL_op->op_type;
2071     char *s;
2072     IV retval;
2073     GV *gv = (GV*)POPs;
2074     IO *io = gv ? GvIOn(gv) : 0;
2075
2076     if (!io || !argsv || !IoIFP(io)) {
2077         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2078             report_evil_fh(gv, io, PL_op->op_type);
2079         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
2080         RETPUSHUNDEF;
2081     }
2082
2083     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2084         STRLEN len;
2085         STRLEN need;
2086         s = SvPV_force(argsv, len);
2087         need = IOCPARM_LEN(func);
2088         if (len < need) {
2089             s = Sv_Grow(argsv, need + 1);
2090             SvCUR_set(argsv, need);
2091         }
2092
2093         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2094     }
2095     else {
2096         retval = SvIV(argsv);
2097         s = INT2PTR(char*,retval);              /* ouch */
2098     }
2099
2100     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
2101
2102     if (optype == OP_IOCTL)
2103 #ifdef HAS_IOCTL
2104         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2105 #else
2106         DIE(aTHX_ "ioctl is not implemented");
2107 #endif
2108     else
2109 #ifdef HAS_FCNTL
2110 #if defined(OS2) && defined(__EMX__)
2111         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2112 #else
2113         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2114 #endif
2115 #else
2116         DIE(aTHX_ "fcntl is not implemented");
2117 #endif
2118
2119     if (SvPOK(argsv)) {
2120         if (s[SvCUR(argsv)] != 17)
2121             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2122                 PL_op_name[optype]);
2123         s[SvCUR(argsv)] = 0;            /* put our null back */
2124         SvSETMAGIC(argsv);              /* Assume it has changed */
2125     }
2126
2127     if (retval == -1)
2128         RETPUSHUNDEF;
2129     if (retval != 0) {
2130         PUSHi(retval);
2131     }
2132     else {
2133         PUSHp(zero_but_true, ZBTLEN);
2134     }
2135     RETURN;
2136 }
2137
2138 PP(pp_flock)
2139 {
2140     dSP; dTARGET;
2141     I32 value;
2142     int argtype;
2143     GV *gv;
2144     IO *io = NULL;
2145     PerlIO *fp;
2146
2147 #ifdef FLOCK
2148     argtype = POPi;
2149     if (MAXARG == 0)
2150         gv = PL_last_in_gv;
2151     else
2152         gv = (GV*)POPs;
2153     if (gv && (io = GvIO(gv)))
2154         fp = IoIFP(io);
2155     else {
2156         fp = Nullfp;
2157         io = NULL;
2158     }
2159     if (fp) {
2160         (void)PerlIO_flush(fp);
2161         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2162     }
2163     else {
2164         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2165             report_evil_fh(gv, io, PL_op->op_type);
2166         value = 0;
2167         SETERRNO(EBADF,RMS$_IFI);
2168     }
2169     PUSHi(value);
2170     RETURN;
2171 #else
2172     DIE(aTHX_ PL_no_func, "flock()");
2173 #endif
2174 }
2175
2176 /* Sockets. */
2177
2178 PP(pp_socket)
2179 {
2180     dSP;
2181 #ifdef HAS_SOCKET
2182     GV *gv;
2183     register IO *io;
2184     int protocol = POPi;
2185     int type = POPi;
2186     int domain = POPi;
2187     int fd;
2188
2189     gv = (GV*)POPs;
2190     io = gv ? GvIOn(gv) : NULL;
2191
2192     if (!gv || !io) {
2193         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2194             report_evil_fh(gv, io, PL_op->op_type);
2195         if (IoIFP(io))
2196             do_close(gv, FALSE);
2197         SETERRNO(EBADF,LIB$_INVARG);
2198         RETPUSHUNDEF;
2199     }
2200
2201     if (IoIFP(io))
2202         do_close(gv, FALSE);
2203
2204     TAINT_PROPER("socket");
2205     fd = PerlSock_socket(domain, type, protocol);
2206     if (fd < 0)
2207         RETPUSHUNDEF;
2208     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2209     IoOFP(io) = PerlIO_fdopen(fd, "w");
2210     IoTYPE(io) = IoTYPE_SOCKET;
2211     if (!IoIFP(io) || !IoOFP(io)) {
2212         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2213         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2214         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2215         RETPUSHUNDEF;
2216     }
2217 #if defined(HAS_FCNTL) && defined(F_SETFD)
2218     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2219 #endif
2220
2221 #ifdef EPOC
2222     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2223 #endif
2224
2225     RETPUSHYES;
2226 #else
2227     DIE(aTHX_ PL_no_sock_func, "socket");
2228 #endif
2229 }
2230
2231 PP(pp_sockpair)
2232 {
2233     dSP;
2234 #ifdef HAS_SOCKETPAIR
2235     GV *gv1;
2236     GV *gv2;
2237     register IO *io1;
2238     register IO *io2;
2239     int protocol = POPi;
2240     int type = POPi;
2241     int domain = POPi;
2242     int fd[2];
2243
2244     gv2 = (GV*)POPs;
2245     gv1 = (GV*)POPs;
2246     io1 = gv1 ? GvIOn(gv1) : NULL;
2247     io2 = gv2 ? GvIOn(gv2) : NULL;
2248     if (!gv1 || !gv2 || !io1 || !io2) {
2249         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2250             if (!gv1 || !io1)
2251                 report_evil_fh(gv1, io1, PL_op->op_type);
2252             if (!gv2 || !io2)
2253                 report_evil_fh(gv1, io2, PL_op->op_type);
2254         }
2255         if (IoIFP(io1))
2256             do_close(gv1, FALSE);
2257         if (IoIFP(io2))
2258             do_close(gv2, FALSE);
2259         RETPUSHUNDEF;
2260     }
2261
2262     if (IoIFP(io1))
2263         do_close(gv1, FALSE);
2264     if (IoIFP(io2))
2265         do_close(gv2, FALSE);
2266
2267     TAINT_PROPER("socketpair");
2268     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2269         RETPUSHUNDEF;
2270     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2271     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2272     IoTYPE(io1) = IoTYPE_SOCKET;
2273     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2274     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2275     IoTYPE(io2) = IoTYPE_SOCKET;
2276     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2277         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2278         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2279         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2280         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2281         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2282         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2283         RETPUSHUNDEF;
2284     }
2285 #if defined(HAS_FCNTL) && defined(F_SETFD)
2286     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2287     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2288 #endif
2289
2290     RETPUSHYES;
2291 #else
2292     DIE(aTHX_ PL_no_sock_func, "socketpair");
2293 #endif
2294 }
2295
2296 PP(pp_bind)
2297 {
2298     dSP;
2299 #ifdef HAS_SOCKET
2300 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2301     extern GETPRIVMODE();
2302     extern GETUSERMODE();
2303 #endif
2304     SV *addrsv = POPs;
2305     char *addr;
2306     GV *gv = (GV*)POPs;
2307     register IO *io = GvIOn(gv);
2308     STRLEN len;
2309     int bind_ok = 0;
2310 #ifdef MPE
2311     int mpeprivmode = 0;
2312 #endif
2313
2314     if (!io || !IoIFP(io))
2315         goto nuts;
2316
2317     addr = SvPV(addrsv, len);
2318     TAINT_PROPER("bind");
2319 #ifdef MPE /* Deal with MPE bind() peculiarities */
2320     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2321         /* The address *MUST* stupidly be zero. */
2322         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2323         /* PRIV mode is required to bind() to ports < 1024. */
2324         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2325             ((struct sockaddr_in *)addr)->sin_port > 0) {
2326             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2327             mpeprivmode = 1;
2328         }
2329     }
2330 #endif /* MPE */
2331     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2332                       (struct sockaddr *)addr, len) >= 0)
2333         bind_ok = 1;
2334
2335 #ifdef MPE /* Switch back to USER mode */
2336     if (mpeprivmode)
2337         GETUSERMODE();
2338 #endif /* MPE */
2339
2340     if (bind_ok)
2341         RETPUSHYES;
2342     else
2343         RETPUSHUNDEF;
2344
2345 nuts:
2346     if (ckWARN(WARN_CLOSED))
2347         report_evil_fh(gv, io, PL_op->op_type);
2348     SETERRNO(EBADF,SS$_IVCHAN);
2349     RETPUSHUNDEF;
2350 #else
2351     DIE(aTHX_ PL_no_sock_func, "bind");
2352 #endif
2353 }
2354
2355 PP(pp_connect)
2356 {
2357     dSP;
2358 #ifdef HAS_SOCKET
2359     SV *addrsv = POPs;
2360     char *addr;
2361     GV *gv = (GV*)POPs;
2362     register IO *io = GvIOn(gv);
2363     STRLEN len;
2364
2365     if (!io || !IoIFP(io))
2366         goto nuts;
2367
2368     addr = SvPV(addrsv, len);
2369     TAINT_PROPER("connect");
2370     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2371         RETPUSHYES;
2372     else
2373         RETPUSHUNDEF;
2374
2375 nuts:
2376     if (ckWARN(WARN_CLOSED))
2377         report_evil_fh(gv, io, PL_op->op_type);
2378     SETERRNO(EBADF,SS$_IVCHAN);
2379     RETPUSHUNDEF;
2380 #else
2381     DIE(aTHX_ PL_no_sock_func, "connect");
2382 #endif
2383 }
2384
2385 PP(pp_listen)
2386 {
2387     dSP;
2388 #ifdef HAS_SOCKET
2389     int backlog = POPi;
2390     GV *gv = (GV*)POPs;
2391     register IO *io = gv ? GvIOn(gv) : NULL;
2392
2393     if (!gv || !io || !IoIFP(io))
2394         goto nuts;
2395
2396     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2397         RETPUSHYES;
2398     else
2399         RETPUSHUNDEF;
2400
2401 nuts:
2402     if (ckWARN(WARN_CLOSED))
2403         report_evil_fh(gv, io, PL_op->op_type);
2404     SETERRNO(EBADF,SS$_IVCHAN);
2405     RETPUSHUNDEF;
2406 #else
2407     DIE(aTHX_ PL_no_sock_func, "listen");
2408 #endif
2409 }
2410
2411 PP(pp_accept)
2412 {
2413     dSP; dTARGET;
2414 #ifdef HAS_SOCKET
2415     GV *ngv;
2416     GV *ggv;
2417     register IO *nstio;
2418     register IO *gstio;
2419     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2420     Sock_size_t len = sizeof saddr;
2421     int fd;
2422
2423     ggv = (GV*)POPs;
2424     ngv = (GV*)POPs;
2425
2426     if (!ngv)
2427         goto badexit;
2428     if (!ggv)
2429         goto nuts;
2430
2431     gstio = GvIO(ggv);
2432     if (!gstio || !IoIFP(gstio))
2433         goto nuts;
2434
2435     nstio = GvIOn(ngv);
2436     if (IoIFP(nstio))
2437         do_close(ngv, FALSE);
2438
2439     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2440     if (fd < 0)
2441         goto badexit;
2442     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2443     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2444     IoTYPE(nstio) = IoTYPE_SOCKET;
2445     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2446         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2447         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2448         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2449         goto badexit;
2450     }
2451 #if defined(HAS_FCNTL) && defined(F_SETFD)
2452     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2453 #endif
2454
2455 #ifdef EPOC
2456     len = sizeof saddr;          /* EPOC somehow truncates info */
2457     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2458 #endif
2459
2460     PUSHp((char *)&saddr, len);
2461     RETURN;
2462
2463 nuts:
2464     if (ckWARN(WARN_CLOSED))
2465         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2466     SETERRNO(EBADF,SS$_IVCHAN);
2467
2468 badexit:
2469     RETPUSHUNDEF;
2470
2471 #else
2472     DIE(aTHX_ PL_no_sock_func, "accept");
2473 #endif
2474 }
2475
2476 PP(pp_shutdown)
2477 {
2478     dSP; dTARGET;
2479 #ifdef HAS_SOCKET
2480     int how = POPi;
2481     GV *gv = (GV*)POPs;
2482     register IO *io = GvIOn(gv);
2483
2484     if (!io || !IoIFP(io))
2485         goto nuts;
2486
2487     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2488     RETURN;
2489
2490 nuts:
2491     if (ckWARN(WARN_CLOSED))
2492         report_evil_fh(gv, io, PL_op->op_type);
2493     SETERRNO(EBADF,SS$_IVCHAN);
2494     RETPUSHUNDEF;
2495 #else
2496     DIE(aTHX_ PL_no_sock_func, "shutdown");
2497 #endif
2498 }
2499
2500 PP(pp_gsockopt)
2501 {
2502 #ifdef HAS_SOCKET
2503     return pp_ssockopt();
2504 #else
2505     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2506 #endif
2507 }
2508
2509 PP(pp_ssockopt)
2510 {
2511     dSP;
2512 #ifdef HAS_SOCKET
2513     int optype = PL_op->op_type;
2514     SV *sv;
2515     int fd;
2516     unsigned int optname;
2517     unsigned int lvl;
2518     GV *gv;
2519     register IO *io;
2520     Sock_size_t len;
2521
2522     if (optype == OP_GSOCKOPT)
2523         sv = sv_2mortal(NEWSV(22, 257));
2524     else
2525         sv = POPs;
2526     optname = (unsigned int) POPi;
2527     lvl = (unsigned int) POPi;
2528
2529     gv = (GV*)POPs;
2530     io = GvIOn(gv);
2531     if (!io || !IoIFP(io))
2532         goto nuts;
2533
2534     fd = PerlIO_fileno(IoIFP(io));
2535     switch (optype) {
2536     case OP_GSOCKOPT:
2537         SvGROW(sv, 257);
2538         (void)SvPOK_only(sv);
2539         SvCUR_set(sv,256);
2540         *SvEND(sv) ='\0';
2541         len = SvCUR(sv);
2542         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2543             goto nuts2;
2544         SvCUR_set(sv, len);
2545         *SvEND(sv) ='\0';
2546         PUSHs(sv);
2547         break;
2548     case OP_SSOCKOPT: {
2549             char *buf;
2550             int aint;
2551             if (SvPOKp(sv)) {
2552                 STRLEN l;
2553                 buf = SvPV(sv, l);
2554                 len = l;
2555             }
2556             else {
2557                 aint = (int)SvIV(sv);
2558                 buf = (char*)&aint;
2559                 len = sizeof(int);
2560             }
2561             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2562                 goto nuts2;
2563             PUSHs(&PL_sv_yes);
2564         }
2565         break;
2566     }
2567     RETURN;
2568
2569 nuts:
2570     if (ckWARN(WARN_CLOSED))
2571         report_evil_fh(gv, io, optype);
2572     SETERRNO(EBADF,SS$_IVCHAN);
2573 nuts2:
2574     RETPUSHUNDEF;
2575
2576 #else
2577     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2578 #endif
2579 }
2580
2581 PP(pp_getsockname)
2582 {
2583 #ifdef HAS_SOCKET
2584     return pp_getpeername();
2585 #else
2586     DIE(aTHX_ PL_no_sock_func, "getsockname");
2587 #endif
2588 }
2589
2590 PP(pp_getpeername)
2591 {
2592     dSP;
2593 #ifdef HAS_SOCKET
2594     int optype = PL_op->op_type;
2595     SV *sv;
2596     int fd;
2597     GV *gv = (GV*)POPs;
2598     register IO *io = GvIOn(gv);
2599     Sock_size_t len;
2600
2601     if (!io || !IoIFP(io))
2602         goto nuts;
2603
2604     sv = sv_2mortal(NEWSV(22, 257));
2605     (void)SvPOK_only(sv);
2606     len = 256;
2607     SvCUR_set(sv, len);
2608     *SvEND(sv) ='\0';
2609     fd = PerlIO_fileno(IoIFP(io));
2610     switch (optype) {
2611     case OP_GETSOCKNAME:
2612         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2613             goto nuts2;
2614         break;
2615     case OP_GETPEERNAME:
2616         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2617             goto nuts2;
2618 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2619         {
2620             static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2621             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2622             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2623                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2624                         sizeof(u_short) + sizeof(struct in_addr))) {
2625                 goto nuts2;
2626             }
2627         }
2628 #endif
2629         break;
2630     }
2631 #ifdef BOGUS_GETNAME_RETURN
2632     /* Interactive Unix, getpeername() and getsockname()
2633       does not return valid namelen */
2634     if (len == BOGUS_GETNAME_RETURN)
2635         len = sizeof(struct sockaddr);
2636 #endif
2637     SvCUR_set(sv, len);
2638     *SvEND(sv) ='\0';
2639     PUSHs(sv);
2640     RETURN;
2641
2642 nuts:
2643     if (ckWARN(WARN_CLOSED))
2644         report_evil_fh(gv, io, optype);
2645     SETERRNO(EBADF,SS$_IVCHAN);
2646 nuts2:
2647     RETPUSHUNDEF;
2648
2649 #else
2650     DIE(aTHX_ PL_no_sock_func, "getpeername");
2651 #endif
2652 }
2653
2654 /* Stat calls. */
2655
2656 PP(pp_lstat)
2657 {
2658     return pp_stat();
2659 }
2660
2661 PP(pp_stat)
2662 {
2663     dSP;
2664     GV *gv;
2665     I32 gimme;
2666     I32 max = 13;
2667     STRLEN n_a;
2668
2669     if (PL_op->op_flags & OPf_REF) {
2670         gv = cGVOP_gv;
2671         if (PL_op->op_type == OP_LSTAT) {
2672             if (PL_laststype != OP_LSTAT)
2673                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2674             if (ckWARN(WARN_IO) && gv != PL_defgv)
2675                 Perl_warner(aTHX_ WARN_IO,
2676                         "lstat() on filehandle %s", GvENAME(gv));
2677                 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2678         }
2679
2680       do_fstat:
2681         if (gv != PL_defgv) {
2682             PL_laststype = OP_STAT;
2683             PL_statgv = gv;
2684             sv_setpv(PL_statname, "");
2685             PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2686                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2687         }
2688         if (PL_laststatval < 0) {
2689             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2690                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2691             max = 0;
2692         }
2693     }
2694     else {
2695         SV* sv = POPs;
2696         if (SvTYPE(sv) == SVt_PVGV) {
2697             gv = (GV*)sv;
2698             goto do_fstat;
2699         }
2700         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2701             gv = (GV*)SvRV(sv);
2702             goto do_fstat;
2703         }
2704         sv_setpv(PL_statname, SvPV(sv,n_a));
2705         PL_statgv = Nullgv;
2706 #ifdef HAS_LSTAT
2707         PL_laststype = PL_op->op_type;
2708         if (PL_op->op_type == OP_LSTAT)
2709             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2710         else
2711 #endif
2712             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2713         if (PL_laststatval < 0) {
2714             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2715                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2716             max = 0;
2717         }
2718     }
2719
2720     gimme = GIMME_V;
2721     if (gimme != G_ARRAY) {
2722         if (gimme != G_VOID)
2723             XPUSHs(boolSV(max));
2724         RETURN;
2725     }
2726     if (max) {
2727         EXTEND(SP, max);
2728         EXTEND_MORTAL(max);
2729         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2730         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2731         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2732         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2733 #if Uid_t_size > IVSIZE
2734         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2735 #else
2736 #   if Uid_t_sign <= 0
2737         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2738 #   else
2739         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2740 #   endif
2741 #endif
2742 #if Gid_t_size > IVSIZE
2743         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2744 #else
2745 #   if Gid_t_sign <= 0
2746         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2747 #   else
2748         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2749 #   endif
2750 #endif
2751 #ifdef USE_STAT_RDEV
2752         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2753 #else
2754         PUSHs(sv_2mortal(newSVpvn("", 0)));
2755 #endif
2756 #if Off_t_size > IVSIZE
2757         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2758 #else
2759         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2760 #endif
2761 #ifdef BIG_TIME
2762         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2763         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2764         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2765 #else
2766         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2767         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2768         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2769 #endif
2770 #ifdef USE_STAT_BLOCKS
2771         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2772         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2773 #else
2774         PUSHs(sv_2mortal(newSVpvn("", 0)));
2775         PUSHs(sv_2mortal(newSVpvn("", 0)));
2776 #endif
2777     }
2778     RETURN;
2779 }
2780
2781 PP(pp_ftrread)
2782 {
2783     I32 result;
2784     dSP;
2785 #if defined(HAS_ACCESS) && defined(R_OK)
2786     STRLEN n_a;
2787     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2788         result = access(TOPpx, R_OK);
2789         if (result == 0)
2790             RETPUSHYES;
2791         if (result < 0)
2792             RETPUSHUNDEF;
2793         RETPUSHNO;
2794     }
2795     else
2796         result = my_stat();
2797 #else
2798     result = my_stat();
2799 #endif
2800     SPAGAIN;
2801     if (result < 0)
2802         RETPUSHUNDEF;
2803     if (cando(S_IRUSR, 0, &PL_statcache))
2804         RETPUSHYES;
2805     RETPUSHNO;
2806 }
2807
2808 PP(pp_ftrwrite)
2809 {
2810     I32 result;
2811     dSP;
2812 #if defined(HAS_ACCESS) && defined(W_OK)
2813     STRLEN n_a;
2814     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2815         result = access(TOPpx, W_OK);
2816         if (result == 0)
2817             RETPUSHYES;
2818         if (result < 0)
2819             RETPUSHUNDEF;
2820         RETPUSHNO;
2821     }
2822     else
2823         result = my_stat();
2824 #else
2825     result = my_stat();
2826 #endif
2827     SPAGAIN;
2828     if (result < 0)
2829         RETPUSHUNDEF;
2830     if (cando(S_IWUSR, 0, &PL_statcache))
2831         RETPUSHYES;
2832     RETPUSHNO;
2833 }
2834
2835 PP(pp_ftrexec)
2836 {
2837     I32 result;
2838     dSP;
2839 #if defined(HAS_ACCESS) && defined(X_OK)
2840     STRLEN n_a;
2841     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2842         result = access(TOPpx, X_OK);
2843         if (result == 0)
2844             RETPUSHYES;
2845         if (result < 0)
2846             RETPUSHUNDEF;
2847         RETPUSHNO;
2848     }
2849     else
2850         result = my_stat();
2851 #else
2852     result = my_stat();
2853 #endif
2854     SPAGAIN;
2855     if (result < 0)
2856         RETPUSHUNDEF;
2857     if (cando(S_IXUSR, 0, &PL_statcache))
2858         RETPUSHYES;
2859     RETPUSHNO;
2860 }
2861
2862 PP(pp_fteread)
2863 {
2864     I32 result;
2865     dSP;
2866 #ifdef PERL_EFF_ACCESS_R_OK
2867     STRLEN n_a;
2868     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2869         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2870         if (result == 0)
2871             RETPUSHYES;
2872         if (result < 0)
2873             RETPUSHUNDEF;
2874         RETPUSHNO;
2875     }
2876     else
2877         result = my_stat();
2878 #else
2879     result = my_stat();
2880 #endif
2881     SPAGAIN;
2882     if (result < 0)
2883         RETPUSHUNDEF;
2884     if (cando(S_IRUSR, 1, &PL_statcache))
2885         RETPUSHYES;
2886     RETPUSHNO;
2887 }
2888
2889 PP(pp_ftewrite)
2890 {
2891     I32 result;
2892     dSP;
2893 #ifdef PERL_EFF_ACCESS_W_OK
2894     STRLEN n_a;
2895     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2896         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2897         if (result == 0)
2898             RETPUSHYES;
2899         if (result < 0)
2900             RETPUSHUNDEF;
2901         RETPUSHNO;
2902     }
2903     else
2904         result = my_stat();
2905 #else
2906     result = my_stat();
2907 #endif
2908     SPAGAIN;
2909     if (result < 0)
2910         RETPUSHUNDEF;
2911     if (cando(S_IWUSR, 1, &PL_statcache))
2912         RETPUSHYES;
2913     RETPUSHNO;
2914 }
2915
2916 PP(pp_fteexec)
2917 {
2918     I32 result;
2919     dSP;
2920 #ifdef PERL_EFF_ACCESS_X_OK
2921     STRLEN n_a;
2922     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2923         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2924         if (result == 0)
2925             RETPUSHYES;
2926         if (result < 0)
2927             RETPUSHUNDEF;
2928         RETPUSHNO;
2929     }
2930     else
2931         result = my_stat();
2932 #else
2933     result = my_stat();
2934 #endif
2935     SPAGAIN;
2936     if (result < 0)
2937         RETPUSHUNDEF;
2938     if (cando(S_IXUSR, 1, &PL_statcache))
2939         RETPUSHYES;
2940     RETPUSHNO;
2941 }
2942
2943 PP(pp_ftis)
2944 {
2945     I32 result = my_stat();
2946     dSP;
2947     if (result < 0)
2948         RETPUSHUNDEF;
2949     RETPUSHYES;
2950 }
2951
2952 PP(pp_fteowned)
2953 {
2954     return pp_ftrowned();
2955 }
2956
2957 PP(pp_ftrowned)
2958 {
2959     I32 result = my_stat();
2960     dSP;
2961     if (result < 0)
2962         RETPUSHUNDEF;
2963     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2964                                 PL_euid : PL_uid) )
2965         RETPUSHYES;
2966     RETPUSHNO;
2967 }
2968
2969 PP(pp_ftzero)
2970 {
2971     I32 result = my_stat();
2972     dSP;
2973     if (result < 0)
2974         RETPUSHUNDEF;
2975     if (PL_statcache.st_size == 0)
2976         RETPUSHYES;
2977     RETPUSHNO;
2978 }
2979
2980 PP(pp_ftsize)
2981 {
2982     I32 result = my_stat();
2983     dSP; dTARGET;
2984     if (result < 0)
2985         RETPUSHUNDEF;
2986 #if Off_t_size > IVSIZE
2987     PUSHn(PL_statcache.st_size);
2988 #else
2989     PUSHi(PL_statcache.st_size);
2990 #endif
2991     RETURN;
2992 }
2993
2994 PP(pp_ftmtime)
2995 {
2996     I32 result = my_stat();
2997     dSP; dTARGET;
2998     if (result < 0)
2999         RETPUSHUNDEF;
3000     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3001     RETURN;
3002 }
3003
3004 PP(pp_ftatime)
3005 {
3006     I32 result = my_stat();
3007     dSP; dTARGET;
3008     if (result < 0)
3009         RETPUSHUNDEF;
3010     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
3011     RETURN;
3012 }
3013
3014 PP(pp_ftctime)
3015 {
3016     I32 result = my_stat();
3017     dSP; dTARGET;
3018     if (result < 0)
3019         RETPUSHUNDEF;
3020     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3021     RETURN;
3022 }
3023
3024 PP(pp_ftsock)
3025 {
3026     I32 result = my_stat();
3027     dSP;
3028     if (result < 0)
3029         RETPUSHUNDEF;
3030     if (S_ISSOCK(PL_statcache.st_mode))
3031         RETPUSHYES;
3032     RETPUSHNO;
3033 }
3034
3035 PP(pp_ftchr)
3036 {
3037     I32 result = my_stat();
3038     dSP;
3039     if (result < 0)
3040         RETPUSHUNDEF;
3041     if (S_ISCHR(PL_statcache.st_mode))
3042         RETPUSHYES;
3043     RETPUSHNO;
3044 }
3045
3046 PP(pp_ftblk)
3047 {
3048     I32 result = my_stat();
3049     dSP;
3050     if (result < 0)
3051         RETPUSHUNDEF;
3052     if (S_ISBLK(PL_statcache.st_mode))
3053         RETPUSHYES;
3054     RETPUSHNO;
3055 }
3056
3057 PP(pp_ftfile)
3058 {
3059     I32 result = my_stat();
3060     dSP;
3061     if (result < 0)
3062         RETPUSHUNDEF;
3063     if (S_ISREG(PL_statcache.st_mode))
3064         RETPUSHYES;
3065     RETPUSHNO;
3066 }
3067
3068 PP(pp_ftdir)
3069 {
3070     I32 result = my_stat();
3071     dSP;
3072     if (result < 0)
3073         RETPUSHUNDEF;
3074     if (S_ISDIR(PL_statcache.st_mode))
3075         RETPUSHYES;
3076     RETPUSHNO;
3077 }
3078
3079 PP(pp_ftpipe)
3080 {
3081     I32 result = my_stat();
3082     dSP;
3083     if (result < 0)
3084         RETPUSHUNDEF;
3085     if (S_ISFIFO(PL_statcache.st_mode))
3086         RETPUSHYES;
3087     RETPUSHNO;
3088 }
3089
3090 PP(pp_ftlink)
3091 {
3092     I32 result = my_lstat();
3093     dSP;
3094     if (result < 0)
3095         RETPUSHUNDEF;
3096     if (S_ISLNK(PL_statcache.st_mode))
3097         RETPUSHYES;
3098     RETPUSHNO;
3099 }
3100
3101 PP(pp_ftsuid)
3102 {
3103     dSP;
3104 #ifdef S_ISUID
3105     I32 result = my_stat();
3106     SPAGAIN;
3107     if (result < 0)
3108         RETPUSHUNDEF;
3109     if (PL_statcache.st_mode & S_ISUID)
3110         RETPUSHYES;
3111 #endif
3112     RETPUSHNO;
3113 }
3114
3115 PP(pp_ftsgid)
3116 {
3117     dSP;
3118 #ifdef S_ISGID
3119     I32 result = my_stat();
3120     SPAGAIN;
3121     if (result < 0)
3122         RETPUSHUNDEF;
3123     if (PL_statcache.st_mode & S_ISGID)
3124         RETPUSHYES;
3125 #endif
3126     RETPUSHNO;
3127 }
3128
3129 PP(pp_ftsvtx)
3130 {
3131     dSP;
3132 #ifdef S_ISVTX
3133     I32 result = my_stat();
3134     SPAGAIN;
3135     if (result < 0)
3136         RETPUSHUNDEF;
3137     if (PL_statcache.st_mode & S_ISVTX)
3138         RETPUSHYES;
3139 #endif
3140     RETPUSHNO;
3141 }
3142
3143 PP(pp_fttty)
3144 {
3145     dSP;
3146     int fd;
3147     GV *gv;
3148     char *tmps = Nullch;
3149     STRLEN n_a;
3150
3151     if (PL_op->op_flags & OPf_REF)
3152         gv = cGVOP_gv;
3153     else if (isGV(TOPs))
3154         gv = (GV*)POPs;
3155     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3156         gv = (GV*)SvRV(POPs);
3157     else
3158         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3159
3160     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3161         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3162     else if (tmps && isDIGIT(*tmps))
3163         fd = atoi(tmps);
3164     else
3165         RETPUSHUNDEF;
3166     if (PerlLIO_isatty(fd))
3167         RETPUSHYES;
3168     RETPUSHNO;
3169 }
3170
3171 #if defined(atarist) /* this will work with atariST. Configure will
3172                         make guesses for other systems. */
3173 # define FILE_base(f) ((f)->_base)
3174 # define FILE_ptr(f) ((f)->_ptr)
3175 # define FILE_cnt(f) ((f)->_cnt)
3176 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3177 #endif
3178
3179 PP(pp_fttext)
3180 {
3181     dSP;
3182     I32 i;
3183     I32 len;
3184     I32 odd = 0;
3185     STDCHAR tbuf[512];
3186     register STDCHAR *s;
3187     register IO *io;
3188     register SV *sv;
3189     GV *gv;
3190     STRLEN n_a;
3191     PerlIO *fp;
3192
3193     if (PL_op->op_flags & OPf_REF)
3194         gv = cGVOP_gv;
3195     else if (isGV(TOPs))
3196         gv = (GV*)POPs;
3197     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3198         gv = (GV*)SvRV(POPs);
3199     else
3200         gv = Nullgv;
3201
3202     if (gv) {
3203         EXTEND(SP, 1);
3204         if (gv == PL_defgv) {
3205             if (PL_statgv)
3206                 io = GvIO(PL_statgv);
3207             else {
3208                 sv = PL_statname;
3209                 goto really_filename;
3210             }
3211         }
3212         else {
3213             PL_statgv = gv;
3214             PL_laststatval = -1;
3215             sv_setpv(PL_statname, "");
3216             io = GvIO(PL_statgv);
3217         }
3218         if (io && IoIFP(io)) {
3219             if (! PerlIO_has_base(IoIFP(io)))
3220                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3221             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3222             if (PL_laststatval < 0)
3223                 RETPUSHUNDEF;
3224             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3225                 if (PL_op->op_type == OP_FTTEXT)
3226                     RETPUSHNO;
3227                 else
3228                     RETPUSHYES;
3229             }
3230             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3231                 i = PerlIO_getc(IoIFP(io));
3232                 if (i != EOF)
3233                     (void)PerlIO_ungetc(IoIFP(io),i);
3234             }
3235             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3236                 RETPUSHYES;
3237             len = PerlIO_get_bufsiz(IoIFP(io));
3238             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3239             /* sfio can have large buffers - limit to 512 */
3240             if (len > 512)
3241                 len = 512;
3242         }
3243         else {
3244             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3245                 gv = cGVOP_gv;
3246                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3247             }
3248             SETERRNO(EBADF,RMS$_IFI);
3249             RETPUSHUNDEF;
3250         }
3251     }
3252     else {
3253         sv = POPs;
3254       really_filename:
3255         PL_statgv = Nullgv;
3256         PL_laststatval = -1;
3257         sv_setpv(PL_statname, SvPV(sv, n_a));
3258         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3259             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3260                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3261             RETPUSHUNDEF;
3262         }
3263         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3264         if (PL_laststatval < 0) {
3265             (void)PerlIO_close(fp);
3266             RETPUSHUNDEF;
3267         }
3268         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
3269         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3270         (void)PerlIO_close(fp);
3271         if (len <= 0) {
3272             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3273                 RETPUSHNO;              /* special case NFS directories */
3274             RETPUSHYES;         /* null file is anything */
3275         }
3276         s = tbuf;
3277     }
3278
3279     /* now scan s to look for textiness */
3280     /*   XXX ASCII dependent code */
3281
3282 #if defined(DOSISH) || defined(USEMYBINMODE)
3283     /* ignore trailing ^Z on short files */
3284     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3285         --len;
3286 #endif
3287
3288     for (i = 0; i < len; i++, s++) {
3289         if (!*s) {                      /* null never allowed in text */
3290             odd += len;
3291             break;
3292         }
3293 #ifdef EBCDIC
3294         else if (!(isPRINT(*s) || isSPACE(*s)))
3295             odd++;
3296 #else
3297         else if (*s & 128) {
3298 #ifdef USE_LOCALE
3299             if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3300                 continue;
3301 #endif
3302             /* utf8 characters don't count as odd */
3303             if (UTF8_IS_START(*s)) {
3304                 int ulen = UTF8SKIP(s);
3305                 if (ulen < len - i) {
3306                     int j;
3307                     for (j = 1; j < ulen; j++) {
3308                         if (!UTF8_IS_CONTINUATION(s[j]))
3309                             goto not_utf8;
3310                     }
3311                     --ulen;     /* loop does extra increment */
3312                     s += ulen;
3313                     i += ulen;
3314                     continue;
3315                 }
3316             }
3317           not_utf8:
3318             odd++;
3319         }
3320         else if (*s < 32 &&
3321           *s != '\n' && *s != '\r' && *s != '\b' &&
3322           *s != '\t' && *s != '\f' && *s != 27)
3323             odd++;
3324 #endif
3325     }
3326
3327     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3328         RETPUSHNO;
3329     else
3330         RETPUSHYES;
3331 }
3332
3333 PP(pp_ftbinary)
3334 {
3335     return pp_fttext();
3336 }
3337
3338 /* File calls. */
3339
3340 PP(pp_chdir)
3341 {
3342     dSP; dTARGET;
3343     char *tmps;
3344     SV **svp;
3345     STRLEN n_a;
3346
3347     if (MAXARG < 1)
3348         tmps = Nullch;
3349     else
3350         tmps = POPpx;
3351     if (!tmps || !*tmps) {
3352         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3353         if (svp)
3354             tmps = SvPV(*svp, n_a);
3355     }
3356     if (!tmps || !*tmps) {
3357         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3358         if (svp)
3359             tmps = SvPV(*svp, n_a);
3360     }
3361 #ifdef VMS
3362     if (!tmps || !*tmps) {
3363        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3364        if (svp)
3365            tmps = SvPV(*svp, n_a);
3366     }
3367 #endif
3368     TAINT_PROPER("chdir");
3369     PUSHi( PerlDir_chdir(tmps) >= 0 );
3370 #ifdef VMS
3371     /* Clear the DEFAULT element of ENV so we'll get the new value
3372      * in the future. */
3373     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3374 #endif
3375     RETURN;
3376 }
3377
3378 PP(pp_chown)
3379 {
3380     dSP; dMARK; dTARGET;
3381     I32 value;
3382 #ifdef HAS_CHOWN
3383     value = (I32)apply(PL_op->op_type, MARK, SP);
3384     SP = MARK;
3385     PUSHi(value);
3386     RETURN;
3387 #else
3388     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3389 #endif
3390 }
3391
3392 PP(pp_chroot)
3393 {
3394     dSP; dTARGET;
3395     char *tmps;
3396 #ifdef HAS_CHROOT
3397     STRLEN n_a;
3398     tmps = POPpx;
3399     TAINT_PROPER("chroot");
3400     PUSHi( chroot(tmps) >= 0 );
3401     RETURN;
3402 #else
3403     DIE(aTHX_ PL_no_func, "chroot");
3404 #endif
3405 }
3406
3407 PP(pp_unlink)
3408 {
3409     dSP; dMARK; dTARGET;
3410     I32 value;
3411     value = (I32)apply(PL_op->op_type, MARK, SP);
3412     SP = MARK;
3413     PUSHi(value);
3414     RETURN;
3415 }
3416
3417 PP(pp_chmod)
3418 {
3419     dSP; dMARK; dTARGET;
3420     I32 value;
3421     value = (I32)apply(PL_op->op_type, MARK, SP);
3422     SP = MARK;
3423     PUSHi(value);
3424     RETURN;
3425 }
3426
3427 PP(pp_utime)
3428 {
3429     dSP; dMARK; dTARGET;
3430     I32 value;
3431     value = (I32)apply(PL_op->op_type, MARK, SP);
3432     SP = MARK;
3433     PUSHi(value);
3434     RETURN;
3435 }
3436
3437 PP(pp_rename)
3438 {
3439     dSP; dTARGET;
3440     int anum;
3441     STRLEN n_a;
3442
3443     char *tmps2 = POPpx;
3444     char *tmps = SvPV(TOPs, n_a);
3445     TAINT_PROPER("rename");
3446 #ifdef HAS_RENAME
3447     anum = PerlLIO_rename(tmps, tmps2);
3448 #else
3449     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3450         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3451             anum = 1;
3452         else {
3453             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3454                 (void)UNLINK(tmps2);
3455             if (!(anum = link(tmps, tmps2)))
3456                 anum = UNLINK(tmps);
3457         }
3458     }
3459 #endif
3460     SETi( anum >= 0 );
3461     RETURN;
3462 }
3463
3464 PP(pp_link)
3465 {
3466     dSP; dTARGET;
3467 #ifdef HAS_LINK
3468     STRLEN n_a;
3469     char *tmps2 = POPpx;
3470     char *tmps = SvPV(TOPs, n_a);
3471     TAINT_PROPER("link");
3472     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3473 #else
3474     DIE(aTHX_ PL_no_func, "Unsupported function link");
3475 #endif
3476     RETURN;
3477 }
3478
3479 PP(pp_symlink)
3480 {
3481     dSP; dTARGET;
3482 #ifdef HAS_SYMLINK
3483     STRLEN n_a;
3484     char *tmps2 = POPpx;
3485     char *tmps = SvPV(TOPs, n_a);
3486     TAINT_PROPER("symlink");
3487     SETi( symlink(tmps, tmps2) >= 0 );
3488     RETURN;
3489 #else
3490     DIE(aTHX_ PL_no_func, "symlink");
3491 #endif
3492 }
3493
3494 PP(pp_readlink)
3495 {
3496     dSP; dTARGET;
3497 #ifdef HAS_SYMLINK
3498     char *tmps;
3499     char buf[MAXPATHLEN];
3500     int len;
3501     STRLEN n_a;
3502
3503 #ifndef INCOMPLETE_TAINTS
3504     TAINT;
3505 #endif
3506     tmps = POPpx;
3507     len = readlink(tmps, buf, sizeof buf);
3508     EXTEND(SP, 1);
3509     if (len < 0)
3510         RETPUSHUNDEF;
3511     PUSHp(buf, len);
3512     RETURN;
3513 #else
3514     EXTEND(SP, 1);
3515     RETSETUNDEF;                /* just pretend it's a normal file */
3516 #endif
3517 }
3518
3519 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3520 STATIC int
3521 S_dooneliner(pTHX_ char *cmd, char *filename)
3522 {
3523     char *save_filename = filename;
3524     char *cmdline;
3525     char *s;
3526     PerlIO *myfp;
3527     int anum = 1;
3528
3529     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3530     strcpy(cmdline, cmd);
3531     strcat(cmdline, " ");
3532     for (s = cmdline + strlen(cmdline); *filename; ) {
3533         *s++ = '\\';
3534         *s++ = *filename++;
3535     }
3536     strcpy(s, " 2>&1");
3537     myfp = PerlProc_popen(cmdline, "r");
3538     Safefree(cmdline);
3539
3540     if (myfp) {
3541         SV *tmpsv = sv_newmortal();
3542         /* Need to save/restore 'PL_rs' ?? */
3543         s = sv_gets(tmpsv, myfp, 0);
3544         (void)PerlProc_pclose(myfp);
3545         if (s != Nullch) {
3546             int e;
3547             for (e = 1;
3548 #ifdef HAS_SYS_ERRLIST
3549                  e <= sys_nerr
3550 #endif
3551                  ; e++)
3552             {
3553                 /* you don't see this */
3554                 char *errmsg =
3555 #ifdef HAS_SYS_ERRLIST
3556                     sys_errlist[e]
3557 #else
3558                     strerror(e)
3559 #endif
3560                     ;
3561                 if (!errmsg)
3562                     break;
3563                 if (instr(s, errmsg)) {
3564                     SETERRNO(e,0);
3565                     return 0;
3566                 }
3567             }
3568             SETERRNO(0,0);
3569 #ifndef EACCES
3570 #define EACCES EPERM
3571 #endif
3572             if (instr(s, "cannot make"))
3573                 SETERRNO(EEXIST,RMS$_FEX);
3574             else if (instr(s, "existing file"))
3575                 SETERRNO(EEXIST,RMS$_FEX);
3576             else if (instr(s, "ile exists"))
3577                 SETERRNO(EEXIST,RMS$_FEX);
3578             else if (instr(s, "non-exist"))
3579                 SETERRNO(ENOENT,RMS$_FNF);
3580             else if (instr(s, "does not exist"))
3581                 SETERRNO(ENOENT,RMS$_FNF);
3582             else if (instr(s, "not empty"))
3583                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3584             else if (instr(s, "cannot access"))
3585                 SETERRNO(EACCES,RMS$_PRV);
3586             else
3587                 SETERRNO(EPERM,RMS$_PRV);
3588             return 0;
3589         }
3590         else {  /* some mkdirs return no failure indication */
3591             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3592             if (PL_op->op_type == OP_RMDIR)
3593                 anum = !anum;
3594             if (anum)
3595                 SETERRNO(0,0);
3596             else
3597                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3598         }
3599         return anum;
3600     }
3601     else
3602         return 0;
3603 }
3604 #endif
3605
3606 PP(pp_mkdir)
3607 {
3608     dSP; dTARGET;
3609     int mode;
3610 #ifndef HAS_MKDIR
3611     int oldumask;
3612 #endif
3613     STRLEN len;
3614     char *tmps;
3615     bool copy = FALSE;
3616
3617     if (MAXARG > 1)
3618         mode = POPi;
3619     else
3620         mode = 0777;
3621
3622     tmps = SvPV(TOPs, len);
3623     /* Different operating and file systems take differently to
3624      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3625      * any number of trailing slashes should be allowed.
3626      * Thusly we snip them away so that even non-conforming
3627      * systems are happy. */
3628     /* We should probably do this "filtering" for all
3629      * the functions that expect (potentially) directory names:
3630      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3631      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3632     if (len > 1 && tmps[len-1] == '/') {
3633         while (tmps[len] == '/' && len > 1)
3634             len--;
3635         tmps = savepvn(tmps, len);
3636         copy = TRUE;
3637     }
3638
3639     TAINT_PROPER("mkdir");
3640 #ifdef HAS_MKDIR
3641     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3642 #else
3643     SETi( dooneliner("mkdir", tmps) );
3644     oldumask = PerlLIO_umask(0);
3645     PerlLIO_umask(oldumask);
3646     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3647 #endif
3648     if (copy)
3649         Safefree(tmps);
3650     RETURN;
3651 }
3652
3653 PP(pp_rmdir)
3654 {
3655     dSP; dTARGET;
3656     char *tmps;
3657     STRLEN n_a;
3658
3659     tmps = POPpx;
3660     TAINT_PROPER("rmdir");
3661 #ifdef HAS_RMDIR
3662     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3663 #else
3664     XPUSHi( dooneliner("rmdir", tmps) );
3665 #endif
3666     RETURN;
3667 }
3668
3669 /* Directory calls. */
3670
3671 PP(pp_open_dir)
3672 {
3673     dSP;
3674 #if defined(Direntry_t) && defined(HAS_READDIR)
3675     STRLEN n_a;
3676     char *dirname = POPpx;
3677     GV *gv = (GV*)POPs;
3678     register IO *io = GvIOn(gv);
3679
3680     if (!io)
3681         goto nope;
3682
3683     if (IoDIRP(io))
3684         PerlDir_close(IoDIRP(io));
3685     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3686         goto nope;
3687
3688     RETPUSHYES;
3689 nope:
3690     if (!errno)
3691         SETERRNO(EBADF,RMS$_DIR);
3692     RETPUSHUNDEF;
3693 #else
3694     DIE(aTHX_ PL_no_dir_func, "opendir");
3695 #endif
3696 }
3697
3698 PP(pp_readdir)
3699 {
3700     dSP;
3701 #if defined(Direntry_t) && defined(HAS_READDIR)
3702 #if !defined(I_DIRENT) && !defined(VMS)
3703     Direntry_t *readdir (DIR *);
3704 #endif
3705     register Direntry_t *dp;
3706     GV *gv = (GV*)POPs;
3707     register IO *io = GvIOn(gv);
3708     SV *sv;
3709
3710     if (!io || !IoDIRP(io))
3711         goto nope;
3712
3713     if (GIMME == G_ARRAY) {
3714         /*SUPPRESS 560*/
3715         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3716 #ifdef DIRNAMLEN
3717             sv = newSVpvn(dp->d_name, dp->d_namlen);
3718 #else
3719             sv = newSVpv(dp->d_name, 0);
3720 #endif
3721 #ifndef INCOMPLETE_TAINTS
3722             if (!(IoFLAGS(io) & IOf_UNTAINT))
3723                 SvTAINTED_on(sv);
3724 #endif
3725             XPUSHs(sv_2mortal(sv));
3726         }
3727     }
3728     else {
3729         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3730             goto nope;
3731 #ifdef DIRNAMLEN
3732         sv = newSVpvn(dp->d_name, dp->d_namlen);
3733 #else
3734         sv = newSVpv(dp->d_name, 0);
3735 #endif
3736 #ifndef INCOMPLETE_TAINTS
3737         if (!(IoFLAGS(io) & IOf_UNTAINT))
3738             SvTAINTED_on(sv);
3739 #endif
3740         XPUSHs(sv_2mortal(sv));
3741     }
3742     RETURN;
3743
3744 nope:
3745     if (!errno)
3746         SETERRNO(EBADF,RMS$_ISI);
3747     if (GIMME == G_ARRAY)
3748         RETURN;
3749     else
3750         RETPUSHUNDEF;
3751 #else
3752     DIE(aTHX_ PL_no_dir_func, "readdir");
3753 #endif
3754 }
3755
3756 PP(pp_telldir)
3757 {
3758     dSP; dTARGET;
3759 #if defined(HAS_TELLDIR) || defined(telldir)
3760  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3761  /* XXX netbsd still seemed to.
3762     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3763     --JHI 1999-Feb-02 */
3764 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3765     long telldir (DIR *);
3766 # endif
3767     GV *gv = (GV*)POPs;
3768     register IO *io = GvIOn(gv);
3769
3770     if (!io || !IoDIRP(io))
3771         goto nope;
3772
3773     PUSHi( PerlDir_tell(IoDIRP(io)) );
3774     RETURN;
3775 nope:
3776     if (!errno)
3777         SETERRNO(EBADF,RMS$_ISI);
3778     RETPUSHUNDEF;
3779 #else
3780     DIE(aTHX_ PL_no_dir_func, "telldir");
3781 #endif
3782 }
3783
3784 PP(pp_seekdir)
3785 {
3786     dSP;
3787 #if defined(HAS_SEEKDIR) || defined(seekdir)
3788     long along = POPl;
3789     GV *gv = (GV*)POPs;
3790     register IO *io = GvIOn(gv);
3791
3792     if (!io || !IoDIRP(io))
3793         goto nope;
3794
3795     (void)PerlDir_seek(IoDIRP(io), along);
3796
3797     RETPUSHYES;
3798 nope:
3799     if (!errno)
3800         SETERRNO(EBADF,RMS$_ISI);
3801     RETPUSHUNDEF;
3802 #else
3803     DIE(aTHX_ PL_no_dir_func, "seekdir");
3804 #endif
3805 }
3806
3807 PP(pp_rewinddir)
3808 {
3809     dSP;
3810 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3811     GV *gv = (GV*)POPs;
3812     register IO *io = GvIOn(gv);
3813
3814     if (!io || !IoDIRP(io))
3815         goto nope;
3816
3817     (void)PerlDir_rewind(IoDIRP(io));
3818     RETPUSHYES;
3819 nope:
3820     if (!errno)
3821         SETERRNO(EBADF,RMS$_ISI);
3822     RETPUSHUNDEF;
3823 #else
3824     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3825 #endif
3826 }
3827
3828 PP(pp_closedir)
3829 {
3830     dSP;
3831 #if defined(Direntry_t) && defined(HAS_READDIR)
3832     GV *gv = (GV*)POPs;
3833     register IO *io = GvIOn(gv);
3834
3835     if (!io || !IoDIRP(io))
3836         goto nope;
3837
3838 #ifdef VOID_CLOSEDIR
3839     PerlDir_close(IoDIRP(io));
3840 #else
3841     if (PerlDir_close(IoDIRP(io)) < 0) {
3842         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3843         goto nope;
3844     }
3845 #endif
3846     IoDIRP(io) = 0;
3847
3848     RETPUSHYES;
3849 nope:
3850     if (!errno)
3851         SETERRNO(EBADF,RMS$_IFI);
3852     RETPUSHUNDEF;
3853 #else
3854     DIE(aTHX_ PL_no_dir_func, "closedir");
3855 #endif
3856 }
3857
3858 /* Process control. */
3859
3860 PP(pp_fork)
3861 {
3862 #ifdef HAS_FORK
3863     dSP; dTARGET;
3864     Pid_t childpid;
3865     GV *tmpgv;
3866
3867     EXTEND(SP, 1);
3868     PERL_FLUSHALL_FOR_CHILD;
3869     childpid = fork();
3870     if (childpid < 0)
3871         RETSETUNDEF;
3872     if (!childpid) {
3873         /*SUPPRESS 560*/
3874         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3875             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3876         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3877     }
3878     PUSHi(childpid);
3879     RETURN;
3880 #else
3881 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3882     dSP; dTARGET;
3883     Pid_t childpid;
3884
3885     EXTEND(SP, 1);
3886     PERL_FLUSHALL_FOR_CHILD;
3887     childpid = PerlProc_fork();
3888     if (childpid == -1)
3889         RETSETUNDEF;
3890     PUSHi(childpid);
3891     RETURN;
3892 #  else
3893     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3894 #  endif
3895 #endif
3896 }
3897
3898 PP(pp_wait)
3899 {
3900 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3901     dSP; dTARGET;
3902     Pid_t childpid;
3903     int argflags;
3904
3905     childpid = wait4pid(-1, &argflags, 0);
3906 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3907     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3908     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3909 #  else
3910     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3911 #  endif
3912     XPUSHi(childpid);
3913     RETURN;
3914 #else
3915     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3916 #endif
3917 }
3918
3919 PP(pp_waitpid)
3920 {
3921 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3922     dSP; dTARGET;
3923     Pid_t childpid;
3924     int optype;
3925     int argflags;
3926
3927     optype = POPi;
3928     childpid = TOPi;
3929     childpid = wait4pid(childpid, &argflags, optype);
3930 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3931     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3932     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3933 #  else
3934     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3935 #  endif
3936     SETi(childpid);
3937     RETURN;
3938 #else
3939     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3940 #endif
3941 }
3942
3943 PP(pp_system)
3944 {
3945     dSP; dMARK; dORIGMARK; dTARGET;
3946     I32 value;
3947     Pid_t childpid;
3948     int result;
3949     int status;
3950     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3951     STRLEN n_a;
3952     I32 did_pipes = 0;
3953     int pp[2];
3954
3955     if (SP - MARK == 1) {
3956         if (PL_tainting) {
3957             char *junk = SvPV(TOPs, n_a);
3958             TAINT_ENV();
3959             TAINT_PROPER("system");
3960         }
3961     }
3962     PERL_FLUSHALL_FOR_CHILD;
3963 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3964     if (PerlProc_pipe(pp) >= 0)
3965         did_pipes = 1;
3966     while ((childpid = vfork()) == -1) {
3967         if (errno != EAGAIN) {
3968             value = -1;
3969             SP = ORIGMARK;
3970             PUSHi(value);
3971             if (did_pipes) {
3972                 PerlLIO_close(pp[0]);
3973                 PerlLIO_close(pp[1]);
3974             }
3975             RETURN;
3976         }
3977         sleep(5);
3978     }
3979     if (childpid > 0) {
3980         if (did_pipes)
3981             PerlLIO_close(pp[1]);
3982 #ifndef PERL_MICRO
3983         rsignal_save(SIGINT, SIG_IGN, &ihand);
3984         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3985 #endif
3986         do {
3987             result = wait4pid(childpid, &status, 0);
3988         } while (result == -1 && errno == EINTR);
3989 #ifndef PERL_MICRO
3990         (void)rsignal_restore(SIGINT, &ihand);
3991         (void)rsignal_restore(SIGQUIT, &qhand);
3992 #endif
3993         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3994         do_execfree();  /* free any memory child malloced on vfork */
3995         SP = ORIGMARK;
3996         if (did_pipes) {
3997             int errkid;
3998             int n = 0, n1;
3999
4000             while (n < sizeof(int)) {
4001                 n1 = PerlLIO_read(pp[0],
4002                                   (void*)(((char*)&errkid)+n),
4003                                   (sizeof(int)) - n);
4004                 if (n1 <= 0)
4005                     break;
4006                 n += n1;
4007             }
4008             PerlLIO_close(pp[0]);
4009             if (n) {                    /* Error */
4010                 if (n != sizeof(int))
4011                     DIE(aTHX_ "panic: kid popen errno read");
4012                 errno = errkid;         /* Propagate errno from kid */
4013                 STATUS_CURRENT = -1;
4014             }
4015         }
4016         PUSHi(STATUS_CURRENT);
4017         RETURN;
4018     }
4019     if (did_pipes) {
4020         PerlLIO_close(pp[0]);
4021 #if defined(HAS_FCNTL) && defined(F_SETFD)
4022         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4023 #endif
4024     }
4025     if (PL_op->op_flags & OPf_STACKED) {
4026         SV *really = *++MARK;
4027         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4028     }
4029     else if (SP - MARK != 1)
4030         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4031     else {
4032         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4033     }
4034     PerlProc__exit(-1);
4035 #else /* ! FORK or VMS or OS/2 */
4036     PL_statusvalue = 0;
4037     result = 0;
4038     if (PL_op->op_flags & OPf_STACKED) {
4039         SV *really = *++MARK;
4040         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4041     }
4042     else if (SP - MARK != 1)
4043         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4044     else {
4045         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4046     }
4047     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4048         result = 1;
4049     STATUS_NATIVE_SET(value);
4050     do_execfree();
4051     SP = ORIGMARK;
4052     PUSHi(result ? value : STATUS_CURRENT);
4053 #endif /* !FORK or VMS */
4054     RETURN;
4055 }
4056
4057 PP(pp_exec)
4058 {
4059     dSP; dMARK; dORIGMARK; dTARGET;
4060     I32 value;
4061     STRLEN n_a;
4062
4063     PERL_FLUSHALL_FOR_CHILD;
4064     if (PL_op->op_flags & OPf_STACKED) {
4065         SV *really = *++MARK;
4066         value = (I32)do_aexec(really, MARK, SP);
4067     }
4068     else if (SP - MARK != 1)
4069 #ifdef VMS
4070         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4071 #else
4072 #  ifdef __OPEN_VM
4073         {
4074            (void ) do_aspawn(Nullsv, MARK, SP);
4075            value = 0;
4076         }
4077 #  else
4078         value = (I32)do_aexec(Nullsv, MARK, SP);
4079 #  endif
4080 #endif
4081     else {
4082         if (PL_tainting) {
4083             char *junk = SvPV(*SP, n_a);
4084             TAINT_ENV();
4085             TAINT_PROPER("exec");
4086         }
4087 #ifdef VMS
4088         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4089 #else
4090 #  ifdef __OPEN_VM
4091         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4092         value = 0;
4093 #  else
4094         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4095 #  endif
4096 #endif
4097     }
4098
4099 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4100     if (value >= 0)
4101         my_exit(value);
4102 #endif
4103
4104     SP = ORIGMARK;
4105     PUSHi(value);
4106     RETURN;
4107 }
4108
4109 PP(pp_kill)
4110 {
4111     dSP; dMARK; dTARGET;
4112     I32 value;
4113 #ifdef HAS_KILL
4114     value = (I32)apply(PL_op->op_type, MARK, SP);
4115     SP = MARK;
4116     PUSHi(value);
4117     RETURN;
4118 #else
4119     DIE(aTHX_ PL_no_func, "Unsupported function kill");
4120 #endif
4121 }
4122
4123 PP(pp_getppid)
4124 {
4125 #ifdef HAS_GETPPID
4126     dSP; dTARGET;
4127     XPUSHi( getppid() );
4128     RETURN;
4129 #else
4130     DIE(aTHX_ PL_no_func, "getppid");
4131 #endif
4132 }
4133
4134 PP(pp_getpgrp)
4135 {
4136 #ifdef HAS_GETPGRP
4137     dSP; dTARGET;
4138     Pid_t pid;
4139     Pid_t pgrp;
4140
4141     if (MAXARG < 1)
4142         pid = 0;
4143     else
4144         pid = SvIVx(POPs);
4145 #ifdef BSD_GETPGRP
4146     pgrp = (I32)BSD_GETPGRP(pid);
4147 #else
4148     if (pid != 0 && pid != PerlProc_getpid())
4149         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4150     pgrp = getpgrp();
4151 #endif
4152     XPUSHi(pgrp);
4153     RETURN;
4154 #else
4155     DIE(aTHX_ PL_no_func, "getpgrp()");
4156 #endif
4157 }
4158
4159 PP(pp_setpgrp)
4160 {
4161 #ifdef HAS_SETPGRP
4162     dSP; dTARGET;
4163     Pid_t pgrp;
4164     Pid_t pid;
4165     if (MAXARG < 2) {
4166         pgrp = 0;
4167         pid = 0;
4168     }
4169     else {
4170         pgrp = POPi;
4171         pid = TOPi;
4172     }
4173
4174     TAINT_PROPER("setpgrp");
4175 #ifdef BSD_SETPGRP
4176     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4177 #else
4178     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4179         || (pid != 0 && pid != PerlProc_getpid()))
4180     {
4181         DIE(aTHX_ "setpgrp can't take arguments");
4182     }
4183     SETi( setpgrp() >= 0 );
4184 #endif /* USE_BSDPGRP */
4185     RETURN;
4186 #else
4187     DIE(aTHX_ PL_no_func, "setpgrp()");
4188 #endif
4189 }
4190
4191 PP(pp_getpriority)
4192 {
4193     dSP; dTARGET;
4194     int which;
4195     int who;
4196 #ifdef HAS_GETPRIORITY
4197     who = POPi;
4198     which = TOPi;
4199     SETi( getpriority(which, who) );
4200     RETURN;
4201 #else
4202     DIE(aTHX_ PL_no_func, "getpriority()");
4203 #endif
4204 }
4205
4206 PP(pp_setpriority)
4207 {
4208     dSP; dTARGET;
4209     int which;
4210     int who;
4211     int niceval;
4212 #ifdef HAS_SETPRIORITY
4213     niceval = POPi;
4214     who = POPi;
4215     which = TOPi;
4216     TAINT_PROPER("setpriority");
4217     SETi( setpriority(which, who, niceval) >= 0 );
4218     RETURN;
4219 #else
4220     DIE(aTHX_ PL_no_func, "setpriority()");
4221 #endif
4222 }
4223
4224 /* Time calls. */
4225
4226 PP(pp_time)
4227 {
4228     dSP; dTARGET;
4229 #ifdef BIG_TIME
4230     XPUSHn( time(Null(Time_t*)) );
4231 #else
4232     XPUSHi( time(Null(Time_t*)) );
4233 #endif
4234     RETURN;
4235 }
4236
4237 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4238    to HZ.  Probably.  For now, assume that if the system
4239    defines HZ, it does so correctly.  (Will this break
4240    on VMS?)
4241    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4242    it's supported.    --AD  9/96.
4243 */
4244
4245 #ifndef HZ
4246 #  ifdef CLK_TCK
4247 #    define HZ CLK_TCK
4248 #  else
4249 #    define HZ 60
4250 #  endif
4251 #endif
4252
4253 PP(pp_tms)
4254 {
4255     dSP;
4256
4257 #ifndef HAS_TIMES
4258     DIE(aTHX_ "times not implemented");
4259 #else
4260     EXTEND(SP, 4);
4261
4262 #ifndef VMS
4263     (void)PerlProc_times(&PL_timesbuf);
4264 #else
4265     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4266                                                    /* struct tms, though same data   */
4267                                                    /* is returned.                   */
4268 #endif
4269
4270     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4271     if (GIMME == G_ARRAY) {
4272         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4273         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4274         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4275     }
4276     RETURN;
4277 #endif /* HAS_TIMES */
4278 }
4279
4280 PP(pp_localtime)
4281 {
4282     return pp_gmtime();
4283 }
4284
4285 PP(pp_gmtime)
4286 {
4287     dSP;
4288     Time_t when;
4289     struct tm *tmbuf;
4290     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4291     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4292                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4293
4294     if (MAXARG < 1)
4295         (void)time(&when);
4296     else
4297 #ifdef BIG_TIME
4298         when = (Time_t)SvNVx(POPs);
4299 #else
4300         when = (Time_t)SvIVx(POPs);
4301 #endif
4302
4303     if (PL_op->op_type == OP_LOCALTIME)
4304         tmbuf = localtime(&when);
4305     else
4306         tmbuf = gmtime(&when);
4307
4308     EXTEND(SP, 9);
4309     EXTEND_MORTAL(9);
4310     if (GIMME != G_ARRAY) {
4311         SV *tsv;
4312         if (!tmbuf)
4313             RETPUSHUNDEF;
4314         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4315                             dayname[tmbuf->tm_wday],
4316                             monname[tmbuf->tm_mon],
4317                             tmbuf->tm_mday,
4318                             tmbuf->tm_hour,
4319                             tmbuf->tm_min,
4320                             tmbuf->tm_sec,
4321                             tmbuf->tm_year + 1900);
4322         PUSHs(sv_2mortal(tsv));
4323     }
4324     else if (tmbuf) {
4325         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4326         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4327         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4328         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4329         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4330         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4331         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4332         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4333         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4334     }
4335     RETURN;
4336 }
4337
4338 PP(pp_alarm)
4339 {
4340     dSP; dTARGET;
4341     int anum;
4342 #ifdef HAS_ALARM
4343     anum = POPi;
4344     anum = alarm((unsigned int)anum);
4345     EXTEND(SP, 1);
4346     if (anum < 0)
4347         RETPUSHUNDEF;
4348     PUSHi(anum);
4349     RETURN;
4350 #else
4351     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4352 #endif
4353 }
4354
4355 PP(pp_sleep)
4356 {
4357     dSP; dTARGET;
4358     I32 duration;
4359     Time_t lasttime;
4360     Time_t when;
4361
4362     (void)time(&lasttime);
4363     if (MAXARG < 1)
4364         PerlProc_pause();
4365     else {
4366         duration = POPi;
4367         PerlProc_sleep((unsigned int)duration);
4368     }
4369     (void)time(&when);
4370     XPUSHi(when - lasttime);
4371     RETURN;
4372 }
4373
4374 /* Shared memory. */
4375
4376 PP(pp_shmget)
4377 {
4378     return pp_semget();
4379 }
4380
4381 PP(pp_shmctl)
4382 {
4383     return pp_semctl();
4384 }
4385
4386 PP(pp_shmread)
4387 {
4388     return pp_shmwrite();
4389 }
4390
4391 PP(pp_shmwrite)
4392 {
4393 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4394     dSP; dMARK; dTARGET;
4395     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4396     SP = MARK;
4397     PUSHi(value);
4398     RETURN;
4399 #else
4400     return pp_semget();
4401 #endif
4402 }
4403
4404 /* Message passing. */
4405
4406 PP(pp_msgget)
4407 {
4408     return pp_semget();
4409 }
4410
4411 PP(pp_msgctl)
4412 {
4413     return pp_semctl();
4414 }
4415
4416 PP(pp_msgsnd)
4417 {
4418 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4419     dSP; dMARK; dTARGET;
4420     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4421     SP = MARK;
4422     PUSHi(value);
4423     RETURN;
4424 #else
4425     return pp_semget();
4426 #endif
4427 }
4428
4429 PP(pp_msgrcv)
4430 {
4431 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4432     dSP; dMARK; dTARGET;
4433     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4434     SP = MARK;
4435     PUSHi(value);
4436     RETURN;
4437 #else
4438     return pp_semget();
4439 #endif
4440 }
4441
4442 /* Semaphores. */
4443
4444 PP(pp_semget)
4445 {
4446 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4447     dSP; dMARK; dTARGET;
4448     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4449     SP = MARK;
4450     if (anum == -1)
4451         RETPUSHUNDEF;
4452     PUSHi(anum);
4453     RETURN;
4454 #else
4455     DIE(aTHX_ "System V IPC is not implemented on this machine");
4456 #endif
4457 }
4458
4459 PP(pp_semctl)
4460 {
4461 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4462     dSP; dMARK; dTARGET;
4463     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4464     SP = MARK;
4465     if (anum == -1)
4466         RETSETUNDEF;
4467     if (anum != 0) {
4468         PUSHi(anum);
4469     }
4470     else {
4471         PUSHp(zero_but_true, ZBTLEN);
4472     }
4473     RETURN;
4474 #else
4475     return pp_semget();
4476 #endif
4477 }
4478
4479 PP(pp_semop)
4480 {
4481 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4482     dSP; dMARK; dTARGET;
4483     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4484     SP = MARK;
4485     PUSHi(value);
4486     RETURN;
4487 #else
4488     return pp_semget();
4489 #endif
4490 }
4491
4492 /* Get system info. */
4493
4494 PP(pp_ghbyname)
4495 {
4496 #ifdef HAS_GETHOSTBYNAME
4497     return pp_ghostent();
4498 #else
4499     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4500 #endif
4501 }
4502
4503 PP(pp_ghbyaddr)
4504 {
4505 #ifdef HAS_GETHOSTBYADDR
4506     return pp_ghostent();
4507 #else
4508     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4509 #endif
4510 }
4511
4512 PP(pp_ghostent)
4513 {
4514     dSP;
4515 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4516     I32 which = PL_op->op_type;
4517     register char **elem;
4518     register SV *sv;
4519 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4520     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4521     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4522     struct hostent *PerlSock_gethostent(void);
4523 #endif
4524     struct hostent *hent;
4525     unsigned long len;
4526     STRLEN n_a;
4527
4528     EXTEND(SP, 10);
4529     if (which == OP_GHBYNAME)
4530 #ifdef HAS_GETHOSTBYNAME
4531         hent = PerlSock_gethostbyname(POPpbytex);
4532 #else
4533         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4534 #endif
4535     else if (which == OP_GHBYADDR) {
4536 #ifdef HAS_GETHOSTBYADDR
4537         int addrtype = POPi;
4538         SV *addrsv = POPs;
4539         STRLEN addrlen;
4540         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4541
4542         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4543 #else
4544         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4545 #endif
4546     }
4547     else
4548 #ifdef HAS_GETHOSTENT
4549         hent = PerlSock_gethostent();
4550 #else
4551         DIE(aTHX_ PL_no_sock_func, "gethostent");
4552 #endif
4553
4554 #ifdef HOST_NOT_FOUND
4555     if (!hent)
4556         STATUS_NATIVE_SET(h_errno);
4557 #endif
4558
4559     if (GIMME != G_ARRAY) {
4560         PUSHs(sv = sv_newmortal());
4561         if (hent) {
4562             if (which == OP_GHBYNAME) {
4563                 if (hent->h_addr)
4564                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4565             }
4566             else
4567                 sv_setpv(sv, (char*)hent->h_name);
4568         }
4569         RETURN;
4570     }
4571
4572     if (hent) {
4573         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4574         sv_setpv(sv, (char*)hent->h_name);
4575         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4576         for (elem = hent->h_aliases; elem && *elem; elem++) {
4577             sv_catpv(sv, *elem);
4578             if (elem[1])
4579                 sv_catpvn(sv, " ", 1);
4580         }
4581         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4582         sv_setiv(sv, (IV)hent->h_addrtype);
4583         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4584         len = hent->h_length;
4585         sv_setiv(sv, (IV)len);
4586 #ifdef h_addr
4587         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4588             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4589             sv_setpvn(sv, *elem, len);
4590         }
4591 #else
4592         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4593         if (hent->h_addr)
4594             sv_setpvn(sv, hent->h_addr, len);
4595 #endif /* h_addr */
4596     }
4597     RETURN;
4598 #else
4599     DIE(aTHX_ PL_no_sock_func, "gethostent");
4600 #endif
4601 }
4602
4603 PP(pp_gnbyname)
4604 {
4605 #ifdef HAS_GETNETBYNAME
4606     return pp_gnetent();
4607 #else
4608     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4609 #endif
4610 }
4611
4612 PP(pp_gnbyaddr)
4613 {
4614 #ifdef HAS_GETNETBYADDR
4615     return pp_gnetent();
4616 #else
4617     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4618 #endif
4619 }
4620
4621 PP(pp_gnetent)
4622 {
4623     dSP;
4624 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4625     I32 which = PL_op->op_type;
4626     register char **elem;
4627     register SV *sv;
4628 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4629     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4630     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4631     struct netent *PerlSock_getnetent(void);
4632 #endif
4633     struct netent *nent;
4634     STRLEN n_a;
4635
4636     if (which == OP_GNBYNAME)
4637 #ifdef HAS_GETNETBYNAME
4638         nent = PerlSock_getnetbyname(POPpbytex);
4639 #else
4640         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4641 #endif
4642     else if (which == OP_GNBYADDR) {
4643 #ifdef HAS_GETNETBYADDR
4644         int addrtype = POPi;
4645         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4646         nent = PerlSock_getnetbyaddr(addr, addrtype);
4647 #else
4648         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4649 #endif
4650     }
4651     else
4652 #ifdef HAS_GETNETENT
4653         nent = PerlSock_getnetent();
4654 #else
4655         DIE(aTHX_ PL_no_sock_func, "getnetent");
4656 #endif
4657
4658     EXTEND(SP, 4);
4659     if (GIMME != G_ARRAY) {
4660         PUSHs(sv = sv_newmortal());
4661         if (nent) {
4662             if (which == OP_GNBYNAME)
4663                 sv_setiv(sv, (IV)nent->n_net);
4664             else
4665                 sv_setpv(sv, nent->n_name);
4666         }
4667         RETURN;
4668     }
4669
4670     if (nent) {
4671         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4672         sv_setpv(sv, nent->n_name);
4673         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4674         for (elem = nent->n_aliases; elem && *elem; elem++) {
4675             sv_catpv(sv, *elem);
4676             if (elem[1])
4677                 sv_catpvn(sv, " ", 1);
4678         }
4679         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4680         sv_setiv(sv, (IV)nent->n_addrtype);
4681         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4682         sv_setiv(sv, (IV)nent->n_net);
4683     }
4684
4685     RETURN;
4686 #else
4687     DIE(aTHX_ PL_no_sock_func, "getnetent");
4688 #endif
4689 }
4690
4691 PP(pp_gpbyname)
4692 {
4693 #ifdef HAS_GETPROTOBYNAME
4694     return pp_gprotoent();
4695 #else
4696     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4697 #endif
4698 }
4699
4700 PP(pp_gpbynumber)
4701 {
4702 #ifdef HAS_GETPROTOBYNUMBER
4703     return pp_gprotoent();
4704 #else
4705     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4706 #endif
4707 }
4708
4709 PP(pp_gprotoent)
4710 {
4711     dSP;
4712 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4713     I32 which = PL_op->op_type;
4714     register char **elem;
4715     register SV *sv;
4716 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4717     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4718     struct protoent *PerlSock_getprotobynumber(int);
4719     struct protoent *PerlSock_getprotoent(void);
4720 #endif
4721     struct protoent *pent;
4722     STRLEN n_a;
4723
4724     if (which == OP_GPBYNAME)
4725 #ifdef HAS_GETPROTOBYNAME
4726         pent = PerlSock_getprotobyname(POPpbytex);
4727 #else
4728         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4729 #endif
4730     else if (which == OP_GPBYNUMBER)
4731 #ifdef HAS_GETPROTOBYNUMBER
4732         pent = PerlSock_getprotobynumber(POPi);
4733 #else
4734     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4735 #endif
4736     else
4737 #ifdef HAS_GETPROTOENT
4738         pent = PerlSock_getprotoent();
4739 #else
4740         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4741 #endif
4742
4743     EXTEND(SP, 3);
4744     if (GIMME != G_ARRAY) {
4745         PUSHs(sv = sv_newmortal());
4746         if (pent) {
4747             if (which == OP_GPBYNAME)
4748                 sv_setiv(sv, (IV)pent->p_proto);
4749             else
4750                 sv_setpv(sv, pent->p_name);
4751         }
4752         RETURN;
4753     }
4754
4755     if (pent) {
4756         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4757         sv_setpv(sv, pent->p_name);
4758         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4759         for (elem = pent->p_aliases; elem && *elem; elem++) {
4760             sv_catpv(sv, *elem);
4761             if (elem[1])
4762                 sv_catpvn(sv, " ", 1);
4763         }
4764         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4765         sv_setiv(sv, (IV)pent->p_proto);
4766     }
4767
4768     RETURN;
4769 #else
4770     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4771 #endif
4772 }
4773
4774 PP(pp_gsbyname)
4775 {
4776 #ifdef HAS_GETSERVBYNAME
4777     return pp_gservent();
4778 #else
4779     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4780 #endif
4781 }
4782
4783 PP(pp_gsbyport)
4784 {
4785 #ifdef HAS_GETSERVBYPORT
4786     return pp_gservent();
4787 #else
4788     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4789 #endif
4790 }
4791
4792 PP(pp_gservent)
4793 {
4794     dSP;
4795 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4796     I32 which = PL_op->op_type;
4797     register char **elem;
4798     register SV *sv;
4799 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4800     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4801     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4802     struct servent *PerlSock_getservent(void);
4803 #endif
4804     struct servent *sent;
4805     STRLEN n_a;
4806
4807     if (which == OP_GSBYNAME) {
4808 #ifdef HAS_GETSERVBYNAME
4809         char *proto = POPpbytex;
4810         char *name = POPpbytex;
4811
4812         if (proto && !*proto)
4813             proto = Nullch;
4814
4815         sent = PerlSock_getservbyname(name, proto);
4816 #else
4817         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4818 #endif
4819     }
4820     else if (which == OP_GSBYPORT) {
4821 #ifdef HAS_GETSERVBYPORT
4822         char *proto = POPpbytex;
4823         unsigned short port = POPu;
4824
4825 #ifdef HAS_HTONS
4826         port = PerlSock_htons(port);
4827 #endif
4828         sent = PerlSock_getservbyport(port, proto);
4829 #else
4830         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4831 #endif
4832     }
4833     else
4834 #ifdef HAS_GETSERVENT
4835         sent = PerlSock_getservent();
4836 #else
4837         DIE(aTHX_ PL_no_sock_func, "getservent");
4838 #endif
4839
4840     EXTEND(SP, 4);
4841     if (GIMME != G_ARRAY) {
4842         PUSHs(sv = sv_newmortal());
4843         if (sent) {
4844             if (which == OP_GSBYNAME) {
4845 #ifdef HAS_NTOHS
4846                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4847 #else
4848                 sv_setiv(sv, (IV)(sent->s_port));
4849 #endif
4850             }
4851             else
4852                 sv_setpv(sv, sent->s_name);
4853         }
4854         RETURN;
4855     }
4856
4857     if (sent) {
4858         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4859         sv_setpv(sv, sent->s_name);
4860         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4861         for (elem = sent->s_aliases; elem && *elem; elem++) {
4862             sv_catpv(sv, *elem);
4863             if (elem[1])
4864                 sv_catpvn(sv, " ", 1);
4865         }
4866         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4867 #ifdef HAS_NTOHS
4868         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4869 #else
4870         sv_setiv(sv, (IV)(sent->s_port));
4871 #endif
4872         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4873         sv_setpv(sv, sent->s_proto);
4874     }
4875
4876     RETURN;
4877 #else
4878     DIE(aTHX_ PL_no_sock_func, "getservent");
4879 #endif
4880 }
4881
4882 PP(pp_shostent)
4883 {
4884     dSP;
4885 #ifdef HAS_SETHOSTENT
4886     PerlSock_sethostent(TOPi);
4887     RETSETYES;
4888 #else
4889     DIE(aTHX_ PL_no_sock_func, "sethostent");
4890 #endif
4891 }
4892
4893 PP(pp_snetent)
4894 {
4895     dSP;
4896 #ifdef HAS_SETNETENT
4897     PerlSock_setnetent(TOPi);
4898     RETSETYES;
4899 #else
4900     DIE(aTHX_ PL_no_sock_func, "setnetent");
4901 #endif
4902 }
4903
4904 PP(pp_sprotoent)
4905 {
4906     dSP;
4907 #ifdef HAS_SETPROTOENT
4908     PerlSock_setprotoent(TOPi);
4909     RETSETYES;
4910 #else
4911     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4912 #endif
4913 }
4914
4915 PP(pp_sservent)
4916 {
4917     dSP;
4918 #ifdef HAS_SETSERVENT
4919     PerlSock_setservent(TOPi);
4920     RETSETYES;
4921 #else
4922     DIE(aTHX_ PL_no_sock_func, "setservent");
4923 #endif
4924 }
4925
4926 PP(pp_ehostent)
4927 {
4928     dSP;
4929 #ifdef HAS_ENDHOSTENT
4930     PerlSock_endhostent();
4931     EXTEND(SP,1);
4932     RETPUSHYES;
4933 #else
4934     DIE(aTHX_ PL_no_sock_func, "endhostent");
4935 #endif
4936 }
4937
4938 PP(pp_enetent)
4939 {
4940     dSP;
4941 #ifdef HAS_ENDNETENT
4942     PerlSock_endnetent();
4943     EXTEND(SP,1);
4944     RETPUSHYES;
4945 #else
4946     DIE(aTHX_ PL_no_sock_func, "endnetent");
4947 #endif
4948 }
4949
4950 PP(pp_eprotoent)
4951 {
4952     dSP;
4953 #ifdef HAS_ENDPROTOENT
4954     PerlSock_endprotoent();
4955     EXTEND(SP,1);
4956     RETPUSHYES;
4957 #else
4958     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4959 #endif
4960 }
4961
4962 PP(pp_eservent)
4963 {
4964     dSP;
4965 #ifdef HAS_ENDSERVENT
4966     PerlSock_endservent();
4967     EXTEND(SP,1);
4968     RETPUSHYES;
4969 #else
4970     DIE(aTHX_ PL_no_sock_func, "endservent");
4971 #endif
4972 }
4973
4974 PP(pp_gpwnam)
4975 {
4976 #ifdef HAS_PASSWD
4977     return pp_gpwent();
4978 #else
4979     DIE(aTHX_ PL_no_func, "getpwnam");
4980 #endif
4981 }
4982
4983 PP(pp_gpwuid)
4984 {
4985 #ifdef HAS_PASSWD
4986     return pp_gpwent();
4987 #else
4988     DIE(aTHX_ PL_no_func, "getpwuid");
4989 #endif
4990 }
4991
4992 PP(pp_gpwent)
4993 {
4994     dSP;
4995 #ifdef HAS_PASSWD
4996     I32 which = PL_op->op_type;
4997     register SV *sv;
4998     STRLEN n_a;
4999     struct passwd *pwent  = NULL;
5000     /*
5001      * We currently support only the SysV getsp* shadow password interface.
5002      * The interface is declared in <shadow.h> and often one needs to link
5003      * with -lsecurity or some such.
5004      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5005      * (and SCO?)
5006      *
5007      * AIX getpwnam() is clever enough to return the encrypted password
5008      * only if the caller (euid?) is root.
5009      *
5010      * There are at least two other shadow password APIs.  Many platforms
5011      * seem to contain more than one interface for accessing the shadow
5012      * password databases, possibly for compatibility reasons.
5013      * The getsp*() is by far he simplest one, the other two interfaces
5014      * are much more complicated, but also very similar to each other.
5015      *
5016      * <sys/types.h>
5017      * <sys/security.h>
5018      * <prot.h>
5019      * struct pr_passwd *getprpw*();
5020      * The password is in
5021      * char getprpw*(...).ufld.fd_encrypt[]
5022      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5023      *
5024      * <sys/types.h>
5025      * <sys/security.h>
5026      * <prot.h>
5027      * struct es_passwd *getespw*();
5028      * The password is in
5029      * char *(getespw*(...).ufld.fd_encrypt)
5030      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5031      *
5032      * Mention I_PROT here so that Configure probes for it.
5033      *
5034      * In HP-UX for getprpw*() the manual page claims that one should include
5035      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5036      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5037      * and pp_sys.c already includes <shadow.h> if there is such.
5038      *
5039      * Note that <sys/security.h> is already probed for, but currently
5040      * it is only included in special cases.
5041      *
5042      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5043      * be preferred interface, even though also the getprpw*() interface
5044      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5045      * One also needs to call set_auth_parameters() in main() before
5046      * doing anything else, whether one is using getespw*() or getprpw*().
5047      *
5048      * Note that accessing the shadow databases can be magnitudes
5049      * slower than accessing the standard databases.
5050      *
5051      * --jhi
5052      */
5053
5054     switch (which) {
5055     case OP_GPWNAM:
5056         pwent  = getpwnam(POPpbytex);
5057         break;
5058     case OP_GPWUID:
5059         pwent = getpwuid((Uid_t)POPi);
5060         break;
5061     case OP_GPWENT:
5062 #   ifdef HAS_GETPWENT
5063         pwent  = getpwent();
5064 #   else
5065         DIE(aTHX_ PL_no_func, "getpwent");
5066 #   endif
5067         break;
5068     }
5069
5070     EXTEND(SP, 10);
5071     if (GIMME != G_ARRAY) {
5072         PUSHs(sv = sv_newmortal());
5073         if (pwent) {
5074             if (which == OP_GPWNAM)
5075 #   if Uid_t_sign <= 0
5076                 sv_setiv(sv, (IV)pwent->pw_uid);
5077 #   else
5078                 sv_setuv(sv, (UV)pwent->pw_uid);
5079 #   endif
5080             else
5081                 sv_setpv(sv, pwent->pw_name);
5082         }
5083         RETURN;
5084     }
5085
5086     if (pwent) {
5087         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5088         sv_setpv(sv, pwent->pw_name);
5089
5090         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5091         SvPOK_off(sv);
5092         /* If we have getspnam(), we try to dig up the shadow
5093          * password.  If we are underprivileged, the shadow
5094          * interface will set the errno to EACCES or similar,
5095          * and return a null pointer.  If this happens, we will
5096          * use the dummy password (usually "*" or "x") from the
5097          * standard password database.
5098          *
5099          * In theory we could skip the shadow call completely
5100          * if euid != 0 but in practice we cannot know which
5101          * security measures are guarding the shadow databases
5102          * on a random platform.
5103          *
5104          * Resist the urge to use additional shadow interfaces.
5105          * Divert the urge to writing an extension instead.
5106          *
5107          * --jhi */
5108 #   ifdef HAS_GETSPNAM
5109         {
5110             struct spwd *spwent;
5111             int saverrno; /* Save and restore errno so that
5112                            * underprivileged attempts seem
5113                            * to have never made the unsccessful
5114                            * attempt to retrieve the shadow password. */
5115
5116             saverrno = errno;
5117             spwent = getspnam(pwent->pw_name);
5118             errno = saverrno;
5119             if (spwent && spwent->sp_pwdp)
5120                 sv_setpv(sv, spwent->sp_pwdp);
5121         }
5122 #   endif
5123 #   ifdef PWPASSWD
5124         if (!SvPOK(sv)) /* Use the standard password, then. */
5125             sv_setpv(sv, pwent->pw_passwd);
5126 #   endif
5127
5128 #   ifndef INCOMPLETE_TAINTS
5129         /* passwd is tainted because user himself can diddle with it.
5130          * admittedly not much and in a very limited way, but nevertheless. */
5131         SvTAINTED_on(sv);
5132 #   endif
5133
5134         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5135 #   if Uid_t_sign <= 0
5136         sv_setiv(sv, (IV)pwent->pw_uid);
5137 #   else
5138         sv_setuv(sv, (UV)pwent->pw_uid);
5139 #   endif
5140
5141         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5142 #   if Uid_t_sign <= 0
5143         sv_setiv(sv, (IV)pwent->pw_gid);
5144 #   else
5145         sv_setuv(sv, (UV)pwent->pw_gid);
5146 #   endif
5147         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5148          * because of the poor interface of the Perl getpw*(),
5149          * not because there's some standard/convention saying so.
5150          * A better interface would have been to return a hash,
5151          * but we are accursed by our history, alas. --jhi.  */
5152         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5153 #   ifdef PWCHANGE
5154         sv_setiv(sv, (IV)pwent->pw_change);
5155 #   else
5156 #       ifdef PWQUOTA
5157         sv_setiv(sv, (IV)pwent->pw_quota);
5158 #       else
5159 #           ifdef PWAGE
5160         sv_setpv(sv, pwent->pw_age);
5161 #           endif
5162 #       endif
5163 #   endif
5164
5165         /* pw_class and pw_comment are mutually exclusive--.
5166          * see the above note for pw_change, pw_quota, and pw_age. */
5167         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5168 #   ifdef PWCLASS
5169         sv_setpv(sv, pwent->pw_class);
5170 #   else
5171 #       ifdef PWCOMMENT
5172         sv_setpv(sv, pwent->pw_comment);
5173 #       endif
5174 #   endif
5175
5176         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5177 #   ifdef PWGECOS
5178         sv_setpv(sv, pwent->pw_gecos);
5179 #   endif
5180 #   ifndef INCOMPLETE_TAINTS
5181         /* pw_gecos is tainted because user himself can diddle with it. */
5182         SvTAINTED_on(sv);
5183 #   endif
5184
5185         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5186         sv_setpv(sv, pwent->pw_dir);
5187
5188         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5189         sv_setpv(sv, pwent->pw_shell);
5190 #   ifndef INCOMPLETE_TAINTS
5191         /* pw_shell is tainted because user himself can diddle with it. */
5192         SvTAINTED_on(sv);
5193 #   endif
5194
5195 #   ifdef PWEXPIRE
5196         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5197         sv_setiv(sv, (IV)pwent->pw_expire);
5198 #   endif
5199     }
5200     RETURN;
5201 #else
5202     DIE(aTHX_ PL_no_func, "getpwent");
5203 #endif
5204 }
5205
5206 PP(pp_spwent)
5207 {
5208     dSP;
5209 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5210     setpwent();
5211     RETPUSHYES;
5212 #else
5213     DIE(aTHX_ PL_no_func, "setpwent");
5214 #endif
5215 }
5216
5217 PP(pp_epwent)
5218 {
5219     dSP;
5220 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5221     endpwent();
5222     RETPUSHYES;
5223 #else
5224     DIE(aTHX_ PL_no_func, "endpwent");
5225 #endif
5226 }
5227
5228 PP(pp_ggrnam)
5229 {
5230 #ifdef HAS_GROUP
5231     return pp_ggrent();
5232 #else
5233     DIE(aTHX_ PL_no_func, "getgrnam");
5234 #endif
5235 }
5236
5237 PP(pp_ggrgid)
5238 {
5239 #ifdef HAS_GROUP
5240     return pp_ggrent();
5241 #else
5242     DIE(aTHX_ PL_no_func, "getgrgid");
5243 #endif
5244 }
5245
5246 PP(pp_ggrent)
5247 {
5248     dSP;
5249 #ifdef HAS_GROUP
5250     I32 which = PL_op->op_type;
5251     register char **elem;
5252     register SV *sv;
5253     struct group *grent;
5254     STRLEN n_a;
5255
5256     if (which == OP_GGRNAM)
5257         grent = (struct group *)getgrnam(POPpbytex);
5258     else if (which == OP_GGRGID)
5259         grent = (struct group *)getgrgid(POPi);
5260     else
5261 #ifdef HAS_GETGRENT
5262         grent = (struct group *)getgrent();
5263 #else
5264         DIE(aTHX_ PL_no_func, "getgrent");
5265 #endif
5266
5267     EXTEND(SP, 4);
5268     if (GIMME != G_ARRAY) {
5269         PUSHs(sv = sv_newmortal());
5270         if (grent) {
5271             if (which == OP_GGRNAM)
5272                 sv_setiv(sv, (IV)grent->gr_gid);
5273             else
5274                 sv_setpv(sv, grent->gr_name);
5275         }
5276         RETURN;
5277     }
5278
5279     if (grent) {
5280         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5281         sv_setpv(sv, grent->gr_name);
5282
5283         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5284 #ifdef GRPASSWD
5285         sv_setpv(sv, grent->gr_passwd);
5286 #endif
5287
5288         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5289         sv_setiv(sv, (IV)grent->gr_gid);
5290
5291         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5292         for (elem = grent->gr_mem; elem && *elem; elem++) {
5293             sv_catpv(sv, *elem);
5294             if (elem[1])
5295                 sv_catpvn(sv, " ", 1);
5296         }
5297     }
5298
5299     RETURN;
5300 #else
5301     DIE(aTHX_ PL_no_func, "getgrent");
5302 #endif
5303 }
5304
5305 PP(pp_sgrent)
5306 {
5307     dSP;
5308 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5309     setgrent();
5310     RETPUSHYES;
5311 #else
5312     DIE(aTHX_ PL_no_func, "setgrent");
5313 #endif
5314 }
5315
5316 PP(pp_egrent)
5317 {
5318     dSP;
5319 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5320     endgrent();
5321     RETPUSHYES;
5322 #else
5323     DIE(aTHX_ PL_no_func, "endgrent");
5324 #endif
5325 }
5326
5327 PP(pp_getlogin)
5328 {
5329     dSP; dTARGET;
5330 #ifdef HAS_GETLOGIN
5331     char *tmps;
5332     EXTEND(SP, 1);
5333     if (!(tmps = PerlProc_getlogin()))
5334         RETPUSHUNDEF;
5335     PUSHp(tmps, strlen(tmps));
5336     RETURN;
5337 #else
5338     DIE(aTHX_ PL_no_func, "getlogin");
5339 #endif
5340 }
5341
5342 /* Miscellaneous. */
5343
5344 PP(pp_syscall)
5345 {
5346 #ifdef HAS_SYSCALL
5347     dSP; dMARK; dORIGMARK; dTARGET;
5348     register I32 items = SP - MARK;
5349     unsigned long a[20];
5350     register I32 i = 0;
5351     I32 retval = -1;
5352     STRLEN n_a;
5353
5354     if (PL_tainting) {
5355         while (++MARK <= SP) {
5356             if (SvTAINTED(*MARK)) {
5357                 TAINT;
5358                 break;
5359             }
5360         }
5361         MARK = ORIGMARK;
5362         TAINT_PROPER("syscall");
5363     }
5364
5365     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5366      * or where sizeof(long) != sizeof(char*).  But such machines will
5367      * not likely have syscall implemented either, so who cares?
5368      */
5369     while (++MARK <= SP) {
5370         if (SvNIOK(*MARK) || !i)
5371             a[i++] = SvIV(*MARK);
5372         else if (*MARK == &PL_sv_undef)
5373             a[i++] = 0;
5374         else
5375             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5376         if (i > 15)
5377             break;
5378     }
5379     switch (items) {
5380     default:
5381         DIE(aTHX_ "Too many args to syscall");
5382     case 0:
5383         DIE(aTHX_ "Too few args to syscall");
5384     case 1:
5385         retval = syscall(a[0]);
5386         break;
5387     case 2:
5388         retval = syscall(a[0],a[1]);
5389         break;
5390     case 3:
5391         retval = syscall(a[0],a[1],a[2]);
5392         break;
5393     case 4:
5394         retval = syscall(a[0],a[1],a[2],a[3]);
5395         break;
5396     case 5:
5397         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5398         break;
5399     case 6:
5400         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5401         break;
5402     case 7:
5403         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5404         break;
5405     case 8:
5406         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5407         break;
5408 #ifdef atarist
5409     case 9:
5410         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5411         break;
5412     case 10:
5413         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5414         break;
5415     case 11:
5416         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5417           a[10]);
5418         break;
5419     case 12:
5420         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5421           a[10],a[11]);
5422         break;
5423     case 13:
5424         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5425           a[10],a[11],a[12]);
5426         break;
5427     case 14:
5428         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5429           a[10],a[11],a[12],a[13]);
5430         break;
5431 #endif /* atarist */
5432     }
5433     SP = ORIGMARK;
5434     PUSHi(retval);
5435     RETURN;
5436 #else
5437     DIE(aTHX_ PL_no_func, "syscall");
5438 #endif
5439 }
5440
5441 #ifdef FCNTL_EMULATE_FLOCK
5442
5443 /*  XXX Emulate flock() with fcntl().
5444     What's really needed is a good file locking module.
5445 */
5446
5447 static int
5448 fcntl_emulate_flock(int fd, int operation)
5449 {
5450     struct flock flock;
5451
5452     switch (operation & ~LOCK_NB) {
5453     case LOCK_SH:
5454         flock.l_type = F_RDLCK;
5455         break;
5456     case LOCK_EX:
5457         flock.l_type = F_WRLCK;
5458         break;
5459     case LOCK_UN:
5460         flock.l_type = F_UNLCK;
5461         break;
5462     default:
5463         errno = EINVAL;
5464         return -1;
5465     }
5466     flock.l_whence = SEEK_SET;
5467     flock.l_start = flock.l_len = (Off_t)0;
5468
5469     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5470 }
5471
5472 #endif /* FCNTL_EMULATE_FLOCK */
5473
5474 #ifdef LOCKF_EMULATE_FLOCK
5475
5476 /*  XXX Emulate flock() with lockf().  This is just to increase
5477     portability of scripts.  The calls are not completely
5478     interchangeable.  What's really needed is a good file
5479     locking module.
5480 */
5481
5482 /*  The lockf() constants might have been defined in <unistd.h>.
5483     Unfortunately, <unistd.h> causes troubles on some mixed
5484     (BSD/POSIX) systems, such as SunOS 4.1.3.
5485
5486    Further, the lockf() constants aren't POSIX, so they might not be
5487    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5488    just stick in the SVID values and be done with it.  Sigh.
5489 */
5490
5491 # ifndef F_ULOCK
5492 #  define F_ULOCK       0       /* Unlock a previously locked region */
5493 # endif
5494 # ifndef F_LOCK
5495 #  define F_LOCK        1       /* Lock a region for exclusive use */
5496 # endif
5497 # ifndef F_TLOCK
5498 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5499 # endif
5500 # ifndef F_TEST
5501 #  define F_TEST        3       /* Test a region for other processes locks */
5502 # endif
5503
5504 static int
5505 lockf_emulate_flock(int fd, int operation)
5506 {
5507     int i;
5508     int save_errno;
5509     Off_t pos;
5510
5511     /* flock locks entire file so for lockf we need to do the same      */
5512     save_errno = errno;
5513     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5514     if (pos > 0)        /* is seekable and needs to be repositioned     */
5515         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5516             pos = -1;   /* seek failed, so don't seek back afterwards   */
5517     errno = save_errno;
5518
5519     switch (operation) {
5520
5521         /* LOCK_SH - get a shared lock */
5522         case LOCK_SH:
5523         /* LOCK_EX - get an exclusive lock */
5524         case LOCK_EX:
5525             i = lockf (fd, F_LOCK, 0);
5526             break;
5527
5528         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5529         case LOCK_SH|LOCK_NB:
5530         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5531         case LOCK_EX|LOCK_NB:
5532             i = lockf (fd, F_TLOCK, 0);
5533             if (i == -1)
5534                 if ((errno == EAGAIN) || (errno == EACCES))
5535                     errno = EWOULDBLOCK;
5536             break;
5537
5538         /* LOCK_UN - unlock (non-blocking is a no-op) */
5539         case LOCK_UN:
5540         case LOCK_UN|LOCK_NB:
5541             i = lockf (fd, F_ULOCK, 0);
5542             break;
5543
5544         /* Default - can't decipher operation */
5545         default:
5546             i = -1;
5547             errno = EINVAL;
5548             break;
5549     }
5550
5551     if (pos > 0)      /* need to restore position of the handle */
5552         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5553
5554     return (i);
5555 }
5556
5557 #endif /* LOCKF_EMULATE_FLOCK */