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