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