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) && ckWARN(WARN_IO))
1638         {
1639             /* integrate with report_evil_fh()? */
1640             char *name = NULL;
1641             if (isGV(gv)) {
1642                 SV* sv = sv_newmortal();
1643                 gv_efullname4(sv, gv, Nullch, FALSE);
1644                 name = SvPV_nolen(sv);
1645             }
1646             if (name && *name)
1647                 Perl_warner(aTHX_ WARN_IO,
1648                             "Filehandle %s opened only for output", name);
1649             else
1650                 Perl_warner(aTHX_ WARN_IO,
1651                             "Filehandle opened only for output");
1652         }
1653         goto say_undef;
1654     }
1655     SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
1656     *SvEND(bufsv) = '\0';
1657     (void)SvPOK_only(bufsv);
1658     if (fp_utf8 && !IN_BYTE) {
1659         /* Look at utf8 we got back and count the characters */
1660         char *bend = buffer + count;
1661         while (buffer < bend) {
1662             STRLEN skip = UTF8SKIP(buffer);
1663             if (buffer+skip > bend) {
1664                 /* partial character - try for rest of it */
1665                 length = skip - (bend-buffer);
1666                 offset = bend - SvPVX(bufsv);
1667                 goto more_bytes;
1668             }
1669             else {
1670                 got++;
1671                 buffer += skip;
1672             }
1673         }
1674         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1675            provided amount read (count) was what was requested (length)
1676          */
1677         if (got < wanted && count == length) {
1678             length = (wanted-got);
1679             offset = bend - SvPVX(bufsv);
1680             goto more_bytes;
1681         }
1682         /* return value is character count */
1683         count = got;
1684         SvUTF8_on(bufsv);
1685     }
1686     SvSETMAGIC(bufsv);
1687     /* This should not be marked tainted if the fp is marked clean */
1688     if (!(IoFLAGS(io) & IOf_UNTAINT))
1689         SvTAINTED_on(bufsv);
1690     SP = ORIGMARK;
1691     PUSHi(count);
1692     RETURN;
1693
1694   say_undef:
1695     SP = ORIGMARK;
1696     RETPUSHUNDEF;
1697 }
1698
1699 PP(pp_syswrite)
1700 {
1701     dSP;
1702     int items = (SP - PL_stack_base) - TOPMARK;
1703     if (items == 2) {
1704         SV *sv;
1705         EXTEND(SP, 1);
1706         sv = sv_2mortal(newSViv(sv_len(*SP)));
1707         PUSHs(sv);
1708         PUTBACK;
1709     }
1710     return pp_send();
1711 }
1712
1713 PP(pp_send)
1714 {
1715     dSP; dMARK; dORIGMARK; dTARGET;
1716     GV *gv;
1717     IO *io;
1718     SV *bufsv;
1719     char *buffer;
1720     Size_t length;
1721     SSize_t retval;
1722     STRLEN blen;
1723     MAGIC *mg;
1724
1725     gv = (GV*)*++MARK;
1726     if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1727         SV *sv;
1728
1729         PUSHMARK(MARK-1);
1730         *MARK = SvTIED_obj((SV*)gv, mg);
1731         ENTER;
1732         call_method("WRITE", G_SCALAR);
1733         LEAVE;
1734         SPAGAIN;
1735         sv = POPs;
1736         SP = ORIGMARK;
1737         PUSHs(sv);
1738         RETURN;
1739     }
1740     if (!gv)
1741         goto say_undef;
1742     bufsv = *++MARK;
1743 #if Size_t_size > IVSIZE
1744     length = (Size_t)SvNVx(*++MARK);
1745 #else
1746     length = (Size_t)SvIVx(*++MARK);
1747 #endif
1748     if ((SSize_t)length < 0)
1749         DIE(aTHX_ "Negative length");
1750     SETERRNO(0,0);
1751     io = GvIO(gv);
1752     if (!io || !IoIFP(io)) {
1753         retval = -1;
1754         if (ckWARN(WARN_CLOSED))
1755             report_evil_fh(gv, io, PL_op->op_type);
1756         goto say_undef;
1757     }
1758
1759     if (PerlIO_isutf8(IoIFP(io))) {
1760         buffer = SvPVutf8(bufsv, blen);
1761     }
1762     else {
1763         if (DO_UTF8(bufsv))
1764             sv_utf8_downgrade(bufsv, FALSE);
1765         buffer = SvPV(bufsv, blen);
1766     }
1767
1768     if (PL_op->op_type == OP_SYSWRITE) {
1769         IV offset;
1770         if (DO_UTF8(bufsv)) {
1771             /* length and offset are in chars */
1772             blen   = sv_len_utf8(bufsv);
1773         }
1774         if (MARK < SP) {
1775             offset = SvIVx(*++MARK);
1776             if (offset < 0) {
1777                 if (-offset > blen)
1778                     DIE(aTHX_ "Offset outside string");
1779                 offset += blen;
1780             } else if (offset >= blen && blen > 0)
1781                 DIE(aTHX_ "Offset outside string");
1782         } else
1783             offset = 0;
1784         if (length > blen - offset)
1785             length = blen - offset;
1786         if (DO_UTF8(bufsv)) {
1787             buffer = (char*)utf8_hop((U8 *)buffer, offset);
1788             length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1789         }
1790         else {
1791             buffer = buffer+offset;
1792         }
1793 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1794         if (IoTYPE(io) == IoTYPE_SOCKET) {
1795             retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1796                                    buffer, length, 0);
1797         }
1798         else
1799 #endif
1800         {
1801             /* See the note at doio.c:do_print about filesize limits. --jhi */
1802             retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1803                                    buffer, length);
1804         }
1805     }
1806 #ifdef HAS_SOCKET
1807     else if (SP > MARK) {
1808         char *sockbuf;
1809         STRLEN mlen;
1810         sockbuf = SvPVx(*++MARK, mlen);
1811         /* length is really flags */
1812         retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1813                                  length, (struct sockaddr *)sockbuf, mlen);
1814     }
1815     else
1816         /* length is really flags */
1817         retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1818 #else
1819     else
1820         DIE(aTHX_ PL_no_sock_func, "send");
1821 #endif
1822     if (retval < 0)
1823         goto say_undef;
1824     SP = ORIGMARK;
1825 #if Size_t_size > IVSIZE
1826     PUSHn(retval);
1827 #else
1828     PUSHi(retval);
1829 #endif
1830     RETURN;
1831
1832   say_undef:
1833     SP = ORIGMARK;
1834     RETPUSHUNDEF;
1835 }
1836
1837 PP(pp_recv)
1838 {
1839     return pp_sysread();
1840 }
1841
1842 PP(pp_eof)
1843 {
1844     dSP;
1845     GV *gv;
1846     MAGIC *mg;
1847
1848     if (MAXARG == 0) {
1849         if (PL_op->op_flags & OPf_SPECIAL) {    /* eof() */
1850             IO *io;
1851             gv = PL_last_in_gv = PL_argvgv;
1852             io = GvIO(gv);
1853             if (io && !IoIFP(io)) {
1854                 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1855                     IoLINES(io) = 0;
1856                     IoFLAGS(io) &= ~IOf_START;
1857                     do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1858                     sv_setpvn(GvSV(gv), "-", 1);
1859                     SvSETMAGIC(GvSV(gv));
1860                 }
1861                 else if (!nextargv(gv))
1862                     RETPUSHYES;
1863             }
1864         }
1865         else
1866             gv = PL_last_in_gv;                 /* eof */
1867     }
1868     else
1869         gv = PL_last_in_gv = (GV*)POPs;         /* eof(FH) */
1870
1871     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1872         PUSHMARK(SP);
1873         XPUSHs(SvTIED_obj((SV*)gv, mg));
1874         PUTBACK;
1875         ENTER;
1876         call_method("EOF", G_SCALAR);
1877         LEAVE;
1878         SPAGAIN;
1879         RETURN;
1880     }
1881
1882     PUSHs(boolSV(!gv || do_eof(gv)));
1883     RETURN;
1884 }
1885
1886 PP(pp_tell)
1887 {
1888     dSP; dTARGET;
1889     GV *gv;
1890     MAGIC *mg;
1891
1892     if (MAXARG == 0)
1893         gv = PL_last_in_gv;
1894     else
1895         gv = PL_last_in_gv = (GV*)POPs;
1896
1897     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1898         PUSHMARK(SP);
1899         XPUSHs(SvTIED_obj((SV*)gv, mg));
1900         PUTBACK;
1901         ENTER;
1902         call_method("TELL", G_SCALAR);
1903         LEAVE;
1904         SPAGAIN;
1905         RETURN;
1906     }
1907
1908 #if LSEEKSIZE > IVSIZE
1909     PUSHn( do_tell(gv) );
1910 #else
1911     PUSHi( do_tell(gv) );
1912 #endif
1913     RETURN;
1914 }
1915
1916 PP(pp_seek)
1917 {
1918     return pp_sysseek();
1919 }
1920
1921 PP(pp_sysseek)
1922 {
1923     dSP;
1924     GV *gv;
1925     int whence = POPi;
1926 #if LSEEKSIZE > IVSIZE
1927     Off_t offset = (Off_t)SvNVx(POPs);
1928 #else
1929     Off_t offset = (Off_t)SvIVx(POPs);
1930 #endif
1931     MAGIC *mg;
1932
1933     gv = PL_last_in_gv = (GV*)POPs;
1934
1935     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1936         PUSHMARK(SP);
1937         XPUSHs(SvTIED_obj((SV*)gv, mg));
1938 #if LSEEKSIZE > IVSIZE
1939         XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1940 #else
1941         XPUSHs(sv_2mortal(newSViv(offset)));
1942 #endif
1943         XPUSHs(sv_2mortal(newSViv(whence)));
1944         PUTBACK;
1945         ENTER;
1946         call_method("SEEK", G_SCALAR);
1947         LEAVE;
1948         SPAGAIN;
1949         RETURN;
1950     }
1951
1952     if (PL_op->op_type == OP_SEEK)
1953         PUSHs(boolSV(do_seek(gv, offset, whence)));
1954     else {
1955         Off_t sought = do_sysseek(gv, offset, whence);
1956         if (sought < 0)
1957             PUSHs(&PL_sv_undef);
1958         else {
1959             SV* sv = sought ?
1960 #if LSEEKSIZE > IVSIZE
1961                 newSVnv((NV)sought)
1962 #else
1963                 newSViv(sought)
1964 #endif
1965                 : newSVpvn(zero_but_true, ZBTLEN);
1966             PUSHs(sv_2mortal(sv));
1967         }
1968     }
1969     RETURN;
1970 }
1971
1972 PP(pp_truncate)
1973 {
1974     dSP;
1975     /* There seems to be no consensus on the length type of truncate()
1976      * and ftruncate(), both off_t and size_t have supporters. In
1977      * general one would think that when using large files, off_t is
1978      * at least as wide as size_t, so using an off_t should be okay. */
1979     /* XXX Configure probe for the length type of *truncate() needed XXX */
1980     Off_t len;
1981     int result = 1;
1982     GV *tmpgv;
1983     STRLEN n_a;
1984
1985 #if Size_t_size > IVSIZE
1986     len = (Off_t)POPn;
1987 #else
1988     len = (Off_t)POPi;
1989 #endif
1990     /* Checking for length < 0 is problematic as the type might or
1991      * might not be signed: if it is not, clever compilers will moan. */
1992     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
1993     SETERRNO(0,0);
1994 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
1995     if (PL_op->op_flags & OPf_SPECIAL) {
1996         tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
1997     do_ftruncate:
1998         TAINT_PROPER("truncate");
1999         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
2000             result = 0;
2001         else {
2002             PerlIO_flush(IoIFP(GvIOp(tmpgv)));
2003 #ifdef HAS_TRUNCATE
2004             if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
2005 #else
2006             if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
2007 #endif
2008                 result = 0;
2009         }
2010     }
2011     else {
2012         SV *sv = POPs;
2013         char *name;
2014         STRLEN n_a;
2015
2016         if (SvTYPE(sv) == SVt_PVGV) {
2017             tmpgv = (GV*)sv;            /* *main::FRED for example */
2018             goto do_ftruncate;
2019         }
2020         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2021             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
2022             goto do_ftruncate;
2023         }
2024
2025         name = SvPV(sv, n_a);
2026         TAINT_PROPER("truncate");
2027 #ifdef HAS_TRUNCATE
2028         if (truncate(name, len) < 0)
2029             result = 0;
2030 #else
2031         {
2032             int tmpfd;
2033             if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
2034                 result = 0;
2035             else {
2036                 if (my_chsize(tmpfd, len) < 0)
2037                     result = 0;
2038                 PerlLIO_close(tmpfd);
2039             }
2040         }
2041 #endif
2042     }
2043
2044     if (result)
2045         RETPUSHYES;
2046     if (!errno)
2047         SETERRNO(EBADF,RMS$_IFI);
2048     RETPUSHUNDEF;
2049 #else
2050     DIE(aTHX_ "truncate not implemented");
2051 #endif
2052 }
2053
2054 PP(pp_fcntl)
2055 {
2056     return pp_ioctl();
2057 }
2058
2059 PP(pp_ioctl)
2060 {
2061     dSP; dTARGET;
2062     SV *argsv = POPs;
2063     unsigned int func = U_I(POPn);
2064     int optype = PL_op->op_type;
2065     char *s;
2066     IV retval;
2067     GV *gv = (GV*)POPs;
2068     IO *io = gv ? GvIOn(gv) : 0;
2069
2070     if (!io || !argsv || !IoIFP(io)) {
2071         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2072             report_evil_fh(gv, io, PL_op->op_type);
2073         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
2074         RETPUSHUNDEF;
2075     }
2076
2077     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2078         STRLEN len;
2079         STRLEN need;
2080         s = SvPV_force(argsv, len);
2081         need = IOCPARM_LEN(func);
2082         if (len < need) {
2083             s = Sv_Grow(argsv, need + 1);
2084             SvCUR_set(argsv, need);
2085         }
2086
2087         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2088     }
2089     else {
2090         retval = SvIV(argsv);
2091         s = INT2PTR(char*,retval);              /* ouch */
2092     }
2093
2094     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
2095
2096     if (optype == OP_IOCTL)
2097 #ifdef HAS_IOCTL
2098         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2099 #else
2100         DIE(aTHX_ "ioctl is not implemented");
2101 #endif
2102     else
2103 #ifdef HAS_FCNTL
2104 #if defined(OS2) && defined(__EMX__)
2105         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2106 #else
2107         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2108 #endif
2109 #else
2110         DIE(aTHX_ "fcntl is not implemented");
2111 #endif
2112
2113     if (SvPOK(argsv)) {
2114         if (s[SvCUR(argsv)] != 17)
2115             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2116                 PL_op_name[optype]);
2117         s[SvCUR(argsv)] = 0;            /* put our null back */
2118         SvSETMAGIC(argsv);              /* Assume it has changed */
2119     }
2120
2121     if (retval == -1)
2122         RETPUSHUNDEF;
2123     if (retval != 0) {
2124         PUSHi(retval);
2125     }
2126     else {
2127         PUSHp(zero_but_true, ZBTLEN);
2128     }
2129     RETURN;
2130 }
2131
2132 PP(pp_flock)
2133 {
2134     dSP; dTARGET;
2135     I32 value;
2136     int argtype;
2137     GV *gv;
2138     IO *io = NULL;
2139     PerlIO *fp;
2140
2141 #ifdef FLOCK
2142     argtype = POPi;
2143     if (MAXARG == 0)
2144         gv = PL_last_in_gv;
2145     else
2146         gv = (GV*)POPs;
2147     if (gv && (io = GvIO(gv)))
2148         fp = IoIFP(io);
2149     else {
2150         fp = Nullfp;
2151         io = NULL;
2152     }
2153     if (fp) {
2154         (void)PerlIO_flush(fp);
2155         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2156     }
2157     else {
2158         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2159             report_evil_fh(gv, io, PL_op->op_type);
2160         value = 0;
2161         SETERRNO(EBADF,RMS$_IFI);
2162     }
2163     PUSHi(value);
2164     RETURN;
2165 #else
2166     DIE(aTHX_ PL_no_func, "flock()");
2167 #endif
2168 }
2169
2170 /* Sockets. */
2171
2172 PP(pp_socket)
2173 {
2174     dSP;
2175 #ifdef HAS_SOCKET
2176     GV *gv;
2177     register IO *io;
2178     int protocol = POPi;
2179     int type = POPi;
2180     int domain = POPi;
2181     int fd;
2182
2183     gv = (GV*)POPs;
2184     io = gv ? GvIOn(gv) : NULL;
2185
2186     if (!gv || !io) {
2187         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2188             report_evil_fh(gv, io, PL_op->op_type);
2189         if (IoIFP(io))
2190             do_close(gv, FALSE);
2191         SETERRNO(EBADF,LIB$_INVARG);
2192         RETPUSHUNDEF;
2193     }
2194
2195     if (IoIFP(io))
2196         do_close(gv, FALSE);
2197
2198     TAINT_PROPER("socket");
2199     fd = PerlSock_socket(domain, type, protocol);
2200     if (fd < 0)
2201         RETPUSHUNDEF;
2202     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2203     IoOFP(io) = PerlIO_fdopen(fd, "w");
2204     IoTYPE(io) = IoTYPE_SOCKET;
2205     if (!IoIFP(io) || !IoOFP(io)) {
2206         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2207         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2208         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2209         RETPUSHUNDEF;
2210     }
2211 #if defined(HAS_FCNTL) && defined(F_SETFD)
2212     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2213 #endif
2214
2215 #ifdef EPOC
2216     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2217 #endif
2218
2219     RETPUSHYES;
2220 #else
2221     DIE(aTHX_ PL_no_sock_func, "socket");
2222 #endif
2223 }
2224
2225 PP(pp_sockpair)
2226 {
2227     dSP;
2228 #ifdef HAS_SOCKETPAIR
2229     GV *gv1;
2230     GV *gv2;
2231     register IO *io1;
2232     register IO *io2;
2233     int protocol = POPi;
2234     int type = POPi;
2235     int domain = POPi;
2236     int fd[2];
2237
2238     gv2 = (GV*)POPs;
2239     gv1 = (GV*)POPs;
2240     io1 = gv1 ? GvIOn(gv1) : NULL;
2241     io2 = gv2 ? GvIOn(gv2) : NULL;
2242     if (!gv1 || !gv2 || !io1 || !io2) {
2243         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2244             if (!gv1 || !io1)
2245                 report_evil_fh(gv1, io1, PL_op->op_type);
2246             if (!gv2 || !io2)
2247                 report_evil_fh(gv1, io2, PL_op->op_type);
2248         }
2249         if (IoIFP(io1))
2250             do_close(gv1, FALSE);
2251         if (IoIFP(io2))
2252             do_close(gv2, FALSE);
2253         RETPUSHUNDEF;
2254     }
2255
2256     if (IoIFP(io1))
2257         do_close(gv1, FALSE);
2258     if (IoIFP(io2))
2259         do_close(gv2, FALSE);
2260
2261     TAINT_PROPER("socketpair");
2262     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2263         RETPUSHUNDEF;
2264     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2265     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2266     IoTYPE(io1) = IoTYPE_SOCKET;
2267     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2268     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2269     IoTYPE(io2) = IoTYPE_SOCKET;
2270     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2271         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2272         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2273         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2274         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2275         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2276         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2277         RETPUSHUNDEF;
2278     }
2279 #if defined(HAS_FCNTL) && defined(F_SETFD)
2280     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2281     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2282 #endif
2283
2284     RETPUSHYES;
2285 #else
2286     DIE(aTHX_ PL_no_sock_func, "socketpair");
2287 #endif
2288 }
2289
2290 PP(pp_bind)
2291 {
2292     dSP;
2293 #ifdef HAS_SOCKET
2294 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2295     extern GETPRIVMODE();
2296     extern GETUSERMODE();
2297 #endif
2298     SV *addrsv = POPs;
2299     char *addr;
2300     GV *gv = (GV*)POPs;
2301     register IO *io = GvIOn(gv);
2302     STRLEN len;
2303     int bind_ok = 0;
2304 #ifdef MPE
2305     int mpeprivmode = 0;
2306 #endif
2307
2308     if (!io || !IoIFP(io))
2309         goto nuts;
2310
2311     addr = SvPV(addrsv, len);
2312     TAINT_PROPER("bind");
2313 #ifdef MPE /* Deal with MPE bind() peculiarities */
2314     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2315         /* The address *MUST* stupidly be zero. */
2316         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2317         /* PRIV mode is required to bind() to ports < 1024. */
2318         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2319             ((struct sockaddr_in *)addr)->sin_port > 0) {
2320             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2321             mpeprivmode = 1;
2322         }
2323     }
2324 #endif /* MPE */
2325     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2326                       (struct sockaddr *)addr, len) >= 0)
2327         bind_ok = 1;
2328
2329 #ifdef MPE /* Switch back to USER mode */
2330     if (mpeprivmode)
2331         GETUSERMODE();
2332 #endif /* MPE */
2333
2334     if (bind_ok)
2335         RETPUSHYES;
2336     else
2337         RETPUSHUNDEF;
2338
2339 nuts:
2340     if (ckWARN(WARN_CLOSED))
2341         report_evil_fh(gv, io, PL_op->op_type);
2342     SETERRNO(EBADF,SS$_IVCHAN);
2343     RETPUSHUNDEF;
2344 #else
2345     DIE(aTHX_ PL_no_sock_func, "bind");
2346 #endif
2347 }
2348
2349 PP(pp_connect)
2350 {
2351     dSP;
2352 #ifdef HAS_SOCKET
2353     SV *addrsv = POPs;
2354     char *addr;
2355     GV *gv = (GV*)POPs;
2356     register IO *io = GvIOn(gv);
2357     STRLEN len;
2358
2359     if (!io || !IoIFP(io))
2360         goto nuts;
2361
2362     addr = SvPV(addrsv, len);
2363     TAINT_PROPER("connect");
2364     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2365         RETPUSHYES;
2366     else
2367         RETPUSHUNDEF;
2368
2369 nuts:
2370     if (ckWARN(WARN_CLOSED))
2371         report_evil_fh(gv, io, PL_op->op_type);
2372     SETERRNO(EBADF,SS$_IVCHAN);
2373     RETPUSHUNDEF;
2374 #else
2375     DIE(aTHX_ PL_no_sock_func, "connect");
2376 #endif
2377 }
2378
2379 PP(pp_listen)
2380 {
2381     dSP;
2382 #ifdef HAS_SOCKET
2383     int backlog = POPi;
2384     GV *gv = (GV*)POPs;
2385     register IO *io = gv ? GvIOn(gv) : NULL;
2386
2387     if (!gv || !io || !IoIFP(io))
2388         goto nuts;
2389
2390     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2391         RETPUSHYES;
2392     else
2393         RETPUSHUNDEF;
2394
2395 nuts:
2396     if (ckWARN(WARN_CLOSED))
2397         report_evil_fh(gv, io, PL_op->op_type);
2398     SETERRNO(EBADF,SS$_IVCHAN);
2399     RETPUSHUNDEF;
2400 #else
2401     DIE(aTHX_ PL_no_sock_func, "listen");
2402 #endif
2403 }
2404
2405 PP(pp_accept)
2406 {
2407     dSP; dTARGET;
2408 #ifdef HAS_SOCKET
2409     GV *ngv;
2410     GV *ggv;
2411     register IO *nstio;
2412     register IO *gstio;
2413     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2414     Sock_size_t len = sizeof saddr;
2415     int fd;
2416
2417     ggv = (GV*)POPs;
2418     ngv = (GV*)POPs;
2419
2420     if (!ngv)
2421         goto badexit;
2422     if (!ggv)
2423         goto nuts;
2424
2425     gstio = GvIO(ggv);
2426     if (!gstio || !IoIFP(gstio))
2427         goto nuts;
2428
2429     nstio = GvIOn(ngv);
2430     if (IoIFP(nstio))
2431         do_close(ngv, FALSE);
2432
2433     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2434     if (fd < 0)
2435         goto badexit;
2436     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2437     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2438     IoTYPE(nstio) = IoTYPE_SOCKET;
2439     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2440         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2441         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2442         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2443         goto badexit;
2444     }
2445 #if defined(HAS_FCNTL) && defined(F_SETFD)
2446     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2447 #endif
2448
2449 #ifdef EPOC
2450     len = sizeof saddr;          /* EPOC somehow truncates info */
2451     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2452 #endif
2453
2454     PUSHp((char *)&saddr, len);
2455     RETURN;
2456
2457 nuts:
2458     if (ckWARN(WARN_CLOSED))
2459         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2460     SETERRNO(EBADF,SS$_IVCHAN);
2461
2462 badexit:
2463     RETPUSHUNDEF;
2464
2465 #else
2466     DIE(aTHX_ PL_no_sock_func, "accept");
2467 #endif
2468 }
2469
2470 PP(pp_shutdown)
2471 {
2472     dSP; dTARGET;
2473 #ifdef HAS_SOCKET
2474     int how = POPi;
2475     GV *gv = (GV*)POPs;
2476     register IO *io = GvIOn(gv);
2477
2478     if (!io || !IoIFP(io))
2479         goto nuts;
2480
2481     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2482     RETURN;
2483
2484 nuts:
2485     if (ckWARN(WARN_CLOSED))
2486         report_evil_fh(gv, io, PL_op->op_type);
2487     SETERRNO(EBADF,SS$_IVCHAN);
2488     RETPUSHUNDEF;
2489 #else
2490     DIE(aTHX_ PL_no_sock_func, "shutdown");
2491 #endif
2492 }
2493
2494 PP(pp_gsockopt)
2495 {
2496 #ifdef HAS_SOCKET
2497     return pp_ssockopt();
2498 #else
2499     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2500 #endif
2501 }
2502
2503 PP(pp_ssockopt)
2504 {
2505     dSP;
2506 #ifdef HAS_SOCKET
2507     int optype = PL_op->op_type;
2508     SV *sv;
2509     int fd;
2510     unsigned int optname;
2511     unsigned int lvl;
2512     GV *gv;
2513     register IO *io;
2514     Sock_size_t len;
2515
2516     if (optype == OP_GSOCKOPT)
2517         sv = sv_2mortal(NEWSV(22, 257));
2518     else
2519         sv = POPs;
2520     optname = (unsigned int) POPi;
2521     lvl = (unsigned int) POPi;
2522
2523     gv = (GV*)POPs;
2524     io = GvIOn(gv);
2525     if (!io || !IoIFP(io))
2526         goto nuts;
2527
2528     fd = PerlIO_fileno(IoIFP(io));
2529     switch (optype) {
2530     case OP_GSOCKOPT:
2531         SvGROW(sv, 257);
2532         (void)SvPOK_only(sv);
2533         SvCUR_set(sv,256);
2534         *SvEND(sv) ='\0';
2535         len = SvCUR(sv);
2536         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2537             goto nuts2;
2538         SvCUR_set(sv, len);
2539         *SvEND(sv) ='\0';
2540         PUSHs(sv);
2541         break;
2542     case OP_SSOCKOPT: {
2543             char *buf;
2544             int aint;
2545             if (SvPOKp(sv)) {
2546                 STRLEN l;
2547                 buf = SvPV(sv, l);
2548                 len = l;
2549             }
2550             else {
2551                 aint = (int)SvIV(sv);
2552                 buf = (char*)&aint;
2553                 len = sizeof(int);
2554             }
2555             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2556                 goto nuts2;
2557             PUSHs(&PL_sv_yes);
2558         }
2559         break;
2560     }
2561     RETURN;
2562
2563 nuts:
2564     if (ckWARN(WARN_CLOSED))
2565         report_evil_fh(gv, io, optype);
2566     SETERRNO(EBADF,SS$_IVCHAN);
2567 nuts2:
2568     RETPUSHUNDEF;
2569
2570 #else
2571     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2572 #endif
2573 }
2574
2575 PP(pp_getsockname)
2576 {
2577 #ifdef HAS_SOCKET
2578     return pp_getpeername();
2579 #else
2580     DIE(aTHX_ PL_no_sock_func, "getsockname");
2581 #endif
2582 }
2583
2584 PP(pp_getpeername)
2585 {
2586     dSP;
2587 #ifdef HAS_SOCKET
2588     int optype = PL_op->op_type;
2589     SV *sv;
2590     int fd;
2591     GV *gv = (GV*)POPs;
2592     register IO *io = GvIOn(gv);
2593     Sock_size_t len;
2594
2595     if (!io || !IoIFP(io))
2596         goto nuts;
2597
2598     sv = sv_2mortal(NEWSV(22, 257));
2599     (void)SvPOK_only(sv);
2600     len = 256;
2601     SvCUR_set(sv, len);
2602     *SvEND(sv) ='\0';
2603     fd = PerlIO_fileno(IoIFP(io));
2604     switch (optype) {
2605     case OP_GETSOCKNAME:
2606         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2607             goto nuts2;
2608         break;
2609     case OP_GETPEERNAME:
2610         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2611             goto nuts2;
2612 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2613         {
2614             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";
2615             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2616             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2617                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2618                         sizeof(u_short) + sizeof(struct in_addr))) {
2619                 goto nuts2;
2620             }
2621         }
2622 #endif
2623         break;
2624     }
2625 #ifdef BOGUS_GETNAME_RETURN
2626     /* Interactive Unix, getpeername() and getsockname()
2627       does not return valid namelen */
2628     if (len == BOGUS_GETNAME_RETURN)
2629         len = sizeof(struct sockaddr);
2630 #endif
2631     SvCUR_set(sv, len);
2632     *SvEND(sv) ='\0';
2633     PUSHs(sv);
2634     RETURN;
2635
2636 nuts:
2637     if (ckWARN(WARN_CLOSED))
2638         report_evil_fh(gv, io, optype);
2639     SETERRNO(EBADF,SS$_IVCHAN);
2640 nuts2:
2641     RETPUSHUNDEF;
2642
2643 #else
2644     DIE(aTHX_ PL_no_sock_func, "getpeername");
2645 #endif
2646 }
2647
2648 /* Stat calls. */
2649
2650 PP(pp_lstat)
2651 {
2652     return pp_stat();
2653 }
2654
2655 PP(pp_stat)
2656 {
2657     dSP;
2658     GV *gv;
2659     I32 gimme;
2660     I32 max = 13;
2661     STRLEN n_a;
2662
2663     if (PL_op->op_flags & OPf_REF) {
2664         gv = cGVOP_gv;
2665         if (PL_op->op_type == OP_LSTAT) {
2666             if (PL_laststype != OP_LSTAT)
2667                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2668             if (ckWARN(WARN_IO) && gv != PL_defgv)
2669                 Perl_warner(aTHX_ WARN_IO,
2670                         "lstat() on filehandle %s", GvENAME(gv));
2671                 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2672         }
2673
2674       do_fstat:
2675         if (gv != PL_defgv) {
2676             PL_laststype = OP_STAT;
2677             PL_statgv = gv;
2678             sv_setpv(PL_statname, "");
2679             PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2680                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2681         }
2682         if (PL_laststatval < 0) {
2683             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2684                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2685             max = 0;
2686         }
2687     }
2688     else {
2689         SV* sv = POPs;
2690         if (SvTYPE(sv) == SVt_PVGV) {
2691             gv = (GV*)sv;
2692             goto do_fstat;
2693         }
2694         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2695             gv = (GV*)SvRV(sv);
2696             goto do_fstat;
2697         }
2698         sv_setpv(PL_statname, SvPV(sv,n_a));
2699         PL_statgv = Nullgv;
2700 #ifdef HAS_LSTAT
2701         PL_laststype = PL_op->op_type;
2702         if (PL_op->op_type == OP_LSTAT)
2703             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2704         else
2705 #endif
2706             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2707         if (PL_laststatval < 0) {
2708             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2709                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2710             max = 0;
2711         }
2712     }
2713
2714     gimme = GIMME_V;
2715     if (gimme != G_ARRAY) {
2716         if (gimme != G_VOID)
2717             XPUSHs(boolSV(max));
2718         RETURN;
2719     }
2720     if (max) {
2721         EXTEND(SP, max);
2722         EXTEND_MORTAL(max);
2723         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2724         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2725         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2726         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2727 #if Uid_t_size > IVSIZE
2728         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2729 #else
2730 #   if Uid_t_sign <= 0
2731         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2732 #   else
2733         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2734 #   endif
2735 #endif
2736 #if Gid_t_size > IVSIZE
2737         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2738 #else
2739 #   if Gid_t_sign <= 0
2740         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2741 #   else
2742         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2743 #   endif
2744 #endif
2745 #ifdef USE_STAT_RDEV
2746         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2747 #else
2748         PUSHs(sv_2mortal(newSVpvn("", 0)));
2749 #endif
2750 #if Off_t_size > IVSIZE
2751         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2752 #else
2753         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2754 #endif
2755 #ifdef BIG_TIME
2756         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2757         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2758         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2759 #else
2760         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2761         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2762         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2763 #endif
2764 #ifdef USE_STAT_BLOCKS
2765         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2766         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2767 #else
2768         PUSHs(sv_2mortal(newSVpvn("", 0)));
2769         PUSHs(sv_2mortal(newSVpvn("", 0)));
2770 #endif
2771     }
2772     RETURN;
2773 }
2774
2775 PP(pp_ftrread)
2776 {
2777     I32 result;
2778     dSP;
2779 #if defined(HAS_ACCESS) && defined(R_OK)
2780     STRLEN n_a;
2781     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2782         result = access(TOPpx, R_OK);
2783         if (result == 0)
2784             RETPUSHYES;
2785         if (result < 0)
2786             RETPUSHUNDEF;
2787         RETPUSHNO;
2788     }
2789     else
2790         result = my_stat();
2791 #else
2792     result = my_stat();
2793 #endif
2794     SPAGAIN;
2795     if (result < 0)
2796         RETPUSHUNDEF;
2797     if (cando(S_IRUSR, 0, &PL_statcache))
2798         RETPUSHYES;
2799     RETPUSHNO;
2800 }
2801
2802 PP(pp_ftrwrite)
2803 {
2804     I32 result;
2805     dSP;
2806 #if defined(HAS_ACCESS) && defined(W_OK)
2807     STRLEN n_a;
2808     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2809         result = access(TOPpx, W_OK);
2810         if (result == 0)
2811             RETPUSHYES;
2812         if (result < 0)
2813             RETPUSHUNDEF;
2814         RETPUSHNO;
2815     }
2816     else
2817         result = my_stat();
2818 #else
2819     result = my_stat();
2820 #endif
2821     SPAGAIN;
2822     if (result < 0)
2823         RETPUSHUNDEF;
2824     if (cando(S_IWUSR, 0, &PL_statcache))
2825         RETPUSHYES;
2826     RETPUSHNO;
2827 }
2828
2829 PP(pp_ftrexec)
2830 {
2831     I32 result;
2832     dSP;
2833 #if defined(HAS_ACCESS) && defined(X_OK)
2834     STRLEN n_a;
2835     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2836         result = access(TOPpx, X_OK);
2837         if (result == 0)
2838             RETPUSHYES;
2839         if (result < 0)
2840             RETPUSHUNDEF;
2841         RETPUSHNO;
2842     }
2843     else
2844         result = my_stat();
2845 #else
2846     result = my_stat();
2847 #endif
2848     SPAGAIN;
2849     if (result < 0)
2850         RETPUSHUNDEF;
2851     if (cando(S_IXUSR, 0, &PL_statcache))
2852         RETPUSHYES;
2853     RETPUSHNO;
2854 }
2855
2856 PP(pp_fteread)
2857 {
2858     I32 result;
2859     dSP;
2860 #ifdef PERL_EFF_ACCESS_R_OK
2861     STRLEN n_a;
2862     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2863         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2864         if (result == 0)
2865             RETPUSHYES;
2866         if (result < 0)
2867             RETPUSHUNDEF;
2868         RETPUSHNO;
2869     }
2870     else
2871         result = my_stat();
2872 #else
2873     result = my_stat();
2874 #endif
2875     SPAGAIN;
2876     if (result < 0)
2877         RETPUSHUNDEF;
2878     if (cando(S_IRUSR, 1, &PL_statcache))
2879         RETPUSHYES;
2880     RETPUSHNO;
2881 }
2882
2883 PP(pp_ftewrite)
2884 {
2885     I32 result;
2886     dSP;
2887 #ifdef PERL_EFF_ACCESS_W_OK
2888     STRLEN n_a;
2889     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2890         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2891         if (result == 0)
2892             RETPUSHYES;
2893         if (result < 0)
2894             RETPUSHUNDEF;
2895         RETPUSHNO;
2896     }
2897     else
2898         result = my_stat();
2899 #else
2900     result = my_stat();
2901 #endif
2902     SPAGAIN;
2903     if (result < 0)
2904         RETPUSHUNDEF;
2905     if (cando(S_IWUSR, 1, &PL_statcache))
2906         RETPUSHYES;
2907     RETPUSHNO;
2908 }
2909
2910 PP(pp_fteexec)
2911 {
2912     I32 result;
2913     dSP;
2914 #ifdef PERL_EFF_ACCESS_X_OK
2915     STRLEN n_a;
2916     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2917         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2918         if (result == 0)
2919             RETPUSHYES;
2920         if (result < 0)
2921             RETPUSHUNDEF;
2922         RETPUSHNO;
2923     }
2924     else
2925         result = my_stat();
2926 #else
2927     result = my_stat();
2928 #endif
2929     SPAGAIN;
2930     if (result < 0)
2931         RETPUSHUNDEF;
2932     if (cando(S_IXUSR, 1, &PL_statcache))
2933         RETPUSHYES;
2934     RETPUSHNO;
2935 }
2936
2937 PP(pp_ftis)
2938 {
2939     I32 result = my_stat();
2940     dSP;
2941     if (result < 0)
2942         RETPUSHUNDEF;
2943     RETPUSHYES;
2944 }
2945
2946 PP(pp_fteowned)
2947 {
2948     return pp_ftrowned();
2949 }
2950
2951 PP(pp_ftrowned)
2952 {
2953     I32 result = my_stat();
2954     dSP;
2955     if (result < 0)
2956         RETPUSHUNDEF;
2957     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2958                                 PL_euid : PL_uid) )
2959         RETPUSHYES;
2960     RETPUSHNO;
2961 }
2962
2963 PP(pp_ftzero)
2964 {
2965     I32 result = my_stat();
2966     dSP;
2967     if (result < 0)
2968         RETPUSHUNDEF;
2969     if (PL_statcache.st_size == 0)
2970         RETPUSHYES;
2971     RETPUSHNO;
2972 }
2973
2974 PP(pp_ftsize)
2975 {
2976     I32 result = my_stat();
2977     dSP; dTARGET;
2978     if (result < 0)
2979         RETPUSHUNDEF;
2980 #if Off_t_size > IVSIZE
2981     PUSHn(PL_statcache.st_size);
2982 #else
2983     PUSHi(PL_statcache.st_size);
2984 #endif
2985     RETURN;
2986 }
2987
2988 PP(pp_ftmtime)
2989 {
2990     I32 result = my_stat();
2991     dSP; dTARGET;
2992     if (result < 0)
2993         RETPUSHUNDEF;
2994     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
2995     RETURN;
2996 }
2997
2998 PP(pp_ftatime)
2999 {
3000     I32 result = my_stat();
3001     dSP; dTARGET;
3002     if (result < 0)
3003         RETPUSHUNDEF;
3004     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
3005     RETURN;
3006 }
3007
3008 PP(pp_ftctime)
3009 {
3010     I32 result = my_stat();
3011     dSP; dTARGET;
3012     if (result < 0)
3013         RETPUSHUNDEF;
3014     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3015     RETURN;
3016 }
3017
3018 PP(pp_ftsock)
3019 {
3020     I32 result = my_stat();
3021     dSP;
3022     if (result < 0)
3023         RETPUSHUNDEF;
3024     if (S_ISSOCK(PL_statcache.st_mode))
3025         RETPUSHYES;
3026     RETPUSHNO;
3027 }
3028
3029 PP(pp_ftchr)
3030 {
3031     I32 result = my_stat();
3032     dSP;
3033     if (result < 0)
3034         RETPUSHUNDEF;
3035     if (S_ISCHR(PL_statcache.st_mode))
3036         RETPUSHYES;
3037     RETPUSHNO;
3038 }
3039
3040 PP(pp_ftblk)
3041 {
3042     I32 result = my_stat();
3043     dSP;
3044     if (result < 0)
3045         RETPUSHUNDEF;
3046     if (S_ISBLK(PL_statcache.st_mode))
3047         RETPUSHYES;
3048     RETPUSHNO;
3049 }
3050
3051 PP(pp_ftfile)
3052 {
3053     I32 result = my_stat();
3054     dSP;
3055     if (result < 0)
3056         RETPUSHUNDEF;
3057     if (S_ISREG(PL_statcache.st_mode))
3058         RETPUSHYES;
3059     RETPUSHNO;
3060 }
3061
3062 PP(pp_ftdir)
3063 {
3064     I32 result = my_stat();
3065     dSP;
3066     if (result < 0)
3067         RETPUSHUNDEF;
3068     if (S_ISDIR(PL_statcache.st_mode))
3069         RETPUSHYES;
3070     RETPUSHNO;
3071 }
3072
3073 PP(pp_ftpipe)
3074 {
3075     I32 result = my_stat();
3076     dSP;
3077     if (result < 0)
3078         RETPUSHUNDEF;
3079     if (S_ISFIFO(PL_statcache.st_mode))
3080         RETPUSHYES;
3081     RETPUSHNO;
3082 }
3083
3084 PP(pp_ftlink)
3085 {
3086     I32 result = my_lstat();
3087     dSP;
3088     if (result < 0)
3089         RETPUSHUNDEF;
3090     if (S_ISLNK(PL_statcache.st_mode))
3091         RETPUSHYES;
3092     RETPUSHNO;
3093 }
3094
3095 PP(pp_ftsuid)
3096 {
3097     dSP;
3098 #ifdef S_ISUID
3099     I32 result = my_stat();
3100     SPAGAIN;
3101     if (result < 0)
3102         RETPUSHUNDEF;
3103     if (PL_statcache.st_mode & S_ISUID)
3104         RETPUSHYES;
3105 #endif
3106     RETPUSHNO;
3107 }
3108
3109 PP(pp_ftsgid)
3110 {
3111     dSP;
3112 #ifdef S_ISGID
3113     I32 result = my_stat();
3114     SPAGAIN;
3115     if (result < 0)
3116         RETPUSHUNDEF;
3117     if (PL_statcache.st_mode & S_ISGID)
3118         RETPUSHYES;
3119 #endif
3120     RETPUSHNO;
3121 }
3122
3123 PP(pp_ftsvtx)
3124 {
3125     dSP;
3126 #ifdef S_ISVTX
3127     I32 result = my_stat();
3128     SPAGAIN;
3129     if (result < 0)
3130         RETPUSHUNDEF;
3131     if (PL_statcache.st_mode & S_ISVTX)
3132         RETPUSHYES;
3133 #endif
3134     RETPUSHNO;
3135 }
3136
3137 PP(pp_fttty)
3138 {
3139     dSP;
3140     int fd;
3141     GV *gv;
3142     char *tmps = Nullch;
3143     STRLEN n_a;
3144
3145     if (PL_op->op_flags & OPf_REF)
3146         gv = cGVOP_gv;
3147     else if (isGV(TOPs))
3148         gv = (GV*)POPs;
3149     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3150         gv = (GV*)SvRV(POPs);
3151     else
3152         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3153
3154     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3155         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3156     else if (tmps && isDIGIT(*tmps))
3157         fd = atoi(tmps);
3158     else
3159         RETPUSHUNDEF;
3160     if (PerlLIO_isatty(fd))
3161         RETPUSHYES;
3162     RETPUSHNO;
3163 }
3164
3165 #if defined(atarist) /* this will work with atariST. Configure will
3166                         make guesses for other systems. */
3167 # define FILE_base(f) ((f)->_base)
3168 # define FILE_ptr(f) ((f)->_ptr)
3169 # define FILE_cnt(f) ((f)->_cnt)
3170 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3171 #endif
3172
3173 PP(pp_fttext)
3174 {
3175     dSP;
3176     I32 i;
3177     I32 len;
3178     I32 odd = 0;
3179     STDCHAR tbuf[512];
3180     register STDCHAR *s;
3181     register IO *io;
3182     register SV *sv;
3183     GV *gv;
3184     STRLEN n_a;
3185     PerlIO *fp;
3186
3187     if (PL_op->op_flags & OPf_REF)
3188         gv = cGVOP_gv;
3189     else if (isGV(TOPs))
3190         gv = (GV*)POPs;
3191     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3192         gv = (GV*)SvRV(POPs);
3193     else
3194         gv = Nullgv;
3195
3196     if (gv) {
3197         EXTEND(SP, 1);
3198         if (gv == PL_defgv) {
3199             if (PL_statgv)
3200                 io = GvIO(PL_statgv);
3201             else {
3202                 sv = PL_statname;
3203                 goto really_filename;
3204             }
3205         }
3206         else {
3207             PL_statgv = gv;
3208             PL_laststatval = -1;
3209             sv_setpv(PL_statname, "");
3210             io = GvIO(PL_statgv);
3211         }
3212         if (io && IoIFP(io)) {
3213             if (! PerlIO_has_base(IoIFP(io)))
3214                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3215             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3216             if (PL_laststatval < 0)
3217                 RETPUSHUNDEF;
3218             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3219                 if (PL_op->op_type == OP_FTTEXT)
3220                     RETPUSHNO;
3221                 else
3222                     RETPUSHYES;
3223             }
3224             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3225                 i = PerlIO_getc(IoIFP(io));
3226                 if (i != EOF)
3227                     (void)PerlIO_ungetc(IoIFP(io),i);
3228             }
3229             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3230                 RETPUSHYES;
3231             len = PerlIO_get_bufsiz(IoIFP(io));
3232             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3233             /* sfio can have large buffers - limit to 512 */
3234             if (len > 512)
3235                 len = 512;
3236         }
3237         else {
3238             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3239                 gv = cGVOP_gv;
3240                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3241             }
3242             SETERRNO(EBADF,RMS$_IFI);
3243             RETPUSHUNDEF;
3244         }
3245     }
3246     else {
3247         sv = POPs;
3248       really_filename:
3249         PL_statgv = Nullgv;
3250         PL_laststatval = -1;
3251         sv_setpv(PL_statname, SvPV(sv, n_a));
3252         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3253             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3254                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3255             RETPUSHUNDEF;
3256         }
3257         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3258         if (PL_laststatval < 0) {
3259             (void)PerlIO_close(fp);
3260             RETPUSHUNDEF;
3261         }
3262         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
3263         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3264         (void)PerlIO_close(fp);
3265         if (len <= 0) {
3266             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3267                 RETPUSHNO;              /* special case NFS directories */
3268             RETPUSHYES;         /* null file is anything */
3269         }
3270         s = tbuf;
3271     }
3272
3273     /* now scan s to look for textiness */
3274     /*   XXX ASCII dependent code */
3275
3276 #if defined(DOSISH) || defined(USEMYBINMODE)
3277     /* ignore trailing ^Z on short files */
3278     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3279         --len;
3280 #endif
3281
3282     for (i = 0; i < len; i++, s++) {
3283         if (!*s) {                      /* null never allowed in text */
3284             odd += len;
3285             break;
3286         }
3287 #ifdef EBCDIC
3288         else if (!(isPRINT(*s) || isSPACE(*s)))
3289             odd++;
3290 #else
3291         else if (*s & 128) {
3292 #ifdef USE_LOCALE
3293             if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3294                 continue;
3295 #endif
3296             /* utf8 characters don't count as odd */
3297             if (UTF8_IS_START(*s)) {
3298                 int ulen = UTF8SKIP(s);
3299                 if (ulen < len - i) {
3300                     int j;
3301                     for (j = 1; j < ulen; j++) {
3302                         if (!UTF8_IS_CONTINUATION(s[j]))
3303                             goto not_utf8;
3304                     }
3305                     --ulen;     /* loop does extra increment */
3306                     s += ulen;
3307                     i += ulen;
3308                     continue;
3309                 }
3310             }
3311           not_utf8:
3312             odd++;
3313         }
3314         else if (*s < 32 &&
3315           *s != '\n' && *s != '\r' && *s != '\b' &&
3316           *s != '\t' && *s != '\f' && *s != 27)
3317             odd++;
3318 #endif
3319     }
3320
3321     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3322         RETPUSHNO;
3323     else
3324         RETPUSHYES;
3325 }
3326
3327 PP(pp_ftbinary)
3328 {
3329     return pp_fttext();
3330 }
3331
3332 /* File calls. */
3333
3334 PP(pp_chdir)
3335 {
3336     dSP; dTARGET;
3337     char *tmps;
3338     SV **svp;
3339     STRLEN n_a;
3340
3341     if (MAXARG < 1)
3342         tmps = Nullch;
3343     else
3344         tmps = POPpx;
3345     if (!tmps || !*tmps) {
3346         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3347         if (svp)
3348             tmps = SvPV(*svp, n_a);
3349     }
3350     if (!tmps || !*tmps) {
3351         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3352         if (svp)
3353             tmps = SvPV(*svp, n_a);
3354     }
3355 #ifdef VMS
3356     if (!tmps || !*tmps) {
3357        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3358        if (svp)
3359            tmps = SvPV(*svp, n_a);
3360     }
3361 #endif
3362     TAINT_PROPER("chdir");
3363     PUSHi( PerlDir_chdir(tmps) >= 0 );
3364 #ifdef VMS
3365     /* Clear the DEFAULT element of ENV so we'll get the new value
3366      * in the future. */
3367     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3368 #endif
3369     RETURN;
3370 }
3371
3372 PP(pp_chown)
3373 {
3374     dSP; dMARK; dTARGET;
3375     I32 value;
3376 #ifdef HAS_CHOWN
3377     value = (I32)apply(PL_op->op_type, MARK, SP);
3378     SP = MARK;
3379     PUSHi(value);
3380     RETURN;
3381 #else
3382     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3383 #endif
3384 }
3385
3386 PP(pp_chroot)
3387 {
3388     dSP; dTARGET;
3389     char *tmps;
3390 #ifdef HAS_CHROOT
3391     STRLEN n_a;
3392     tmps = POPpx;
3393     TAINT_PROPER("chroot");
3394     PUSHi( chroot(tmps) >= 0 );
3395     RETURN;
3396 #else
3397     DIE(aTHX_ PL_no_func, "chroot");
3398 #endif
3399 }
3400
3401 PP(pp_unlink)
3402 {
3403     dSP; dMARK; dTARGET;
3404     I32 value;
3405     value = (I32)apply(PL_op->op_type, MARK, SP);
3406     SP = MARK;
3407     PUSHi(value);
3408     RETURN;
3409 }
3410
3411 PP(pp_chmod)
3412 {
3413     dSP; dMARK; dTARGET;
3414     I32 value;
3415     value = (I32)apply(PL_op->op_type, MARK, SP);
3416     SP = MARK;
3417     PUSHi(value);
3418     RETURN;
3419 }
3420
3421 PP(pp_utime)
3422 {
3423     dSP; dMARK; dTARGET;
3424     I32 value;
3425     value = (I32)apply(PL_op->op_type, MARK, SP);
3426     SP = MARK;
3427     PUSHi(value);
3428     RETURN;
3429 }
3430
3431 PP(pp_rename)
3432 {
3433     dSP; dTARGET;
3434     int anum;
3435     STRLEN n_a;
3436
3437     char *tmps2 = POPpx;
3438     char *tmps = SvPV(TOPs, n_a);
3439     TAINT_PROPER("rename");
3440 #ifdef HAS_RENAME
3441     anum = PerlLIO_rename(tmps, tmps2);
3442 #else
3443     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3444         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3445             anum = 1;
3446         else {
3447             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3448                 (void)UNLINK(tmps2);
3449             if (!(anum = link(tmps, tmps2)))
3450                 anum = UNLINK(tmps);
3451         }
3452     }
3453 #endif
3454     SETi( anum >= 0 );
3455     RETURN;
3456 }
3457
3458 PP(pp_link)
3459 {
3460     dSP; dTARGET;
3461 #ifdef HAS_LINK
3462     STRLEN n_a;
3463     char *tmps2 = POPpx;
3464     char *tmps = SvPV(TOPs, n_a);
3465     TAINT_PROPER("link");
3466     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3467 #else
3468     DIE(aTHX_ PL_no_func, "Unsupported function link");
3469 #endif
3470     RETURN;
3471 }
3472
3473 PP(pp_symlink)
3474 {
3475     dSP; dTARGET;
3476 #ifdef HAS_SYMLINK
3477     STRLEN n_a;
3478     char *tmps2 = POPpx;
3479     char *tmps = SvPV(TOPs, n_a);
3480     TAINT_PROPER("symlink");
3481     SETi( symlink(tmps, tmps2) >= 0 );
3482     RETURN;
3483 #else
3484     DIE(aTHX_ PL_no_func, "symlink");
3485 #endif
3486 }
3487
3488 PP(pp_readlink)
3489 {
3490     dSP; dTARGET;
3491 #ifdef HAS_SYMLINK
3492     char *tmps;
3493     char buf[MAXPATHLEN];
3494     int len;
3495     STRLEN n_a;
3496
3497 #ifndef INCOMPLETE_TAINTS
3498     TAINT;
3499 #endif
3500     tmps = POPpx;
3501     len = readlink(tmps, buf, sizeof buf);
3502     EXTEND(SP, 1);
3503     if (len < 0)
3504         RETPUSHUNDEF;
3505     PUSHp(buf, len);
3506     RETURN;
3507 #else
3508     EXTEND(SP, 1);
3509     RETSETUNDEF;                /* just pretend it's a normal file */
3510 #endif
3511 }
3512
3513 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3514 STATIC int
3515 S_dooneliner(pTHX_ char *cmd, char *filename)
3516 {
3517     char *save_filename = filename;
3518     char *cmdline;
3519     char *s;
3520     PerlIO *myfp;
3521     int anum = 1;
3522
3523     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3524     strcpy(cmdline, cmd);
3525     strcat(cmdline, " ");
3526     for (s = cmdline + strlen(cmdline); *filename; ) {
3527         *s++ = '\\';
3528         *s++ = *filename++;
3529     }
3530     strcpy(s, " 2>&1");
3531     myfp = PerlProc_popen(cmdline, "r");
3532     Safefree(cmdline);
3533
3534     if (myfp) {
3535         SV *tmpsv = sv_newmortal();
3536         /* Need to save/restore 'PL_rs' ?? */
3537         s = sv_gets(tmpsv, myfp, 0);
3538         (void)PerlProc_pclose(myfp);
3539         if (s != Nullch) {
3540             int e;
3541             for (e = 1;
3542 #ifdef HAS_SYS_ERRLIST
3543                  e <= sys_nerr
3544 #endif
3545                  ; e++)
3546             {
3547                 /* you don't see this */
3548                 char *errmsg =
3549 #ifdef HAS_SYS_ERRLIST
3550                     sys_errlist[e]
3551 #else
3552                     strerror(e)
3553 #endif
3554                     ;
3555                 if (!errmsg)
3556                     break;
3557                 if (instr(s, errmsg)) {
3558                     SETERRNO(e,0);
3559                     return 0;
3560                 }
3561             }
3562             SETERRNO(0,0);
3563 #ifndef EACCES
3564 #define EACCES EPERM
3565 #endif
3566             if (instr(s, "cannot make"))
3567                 SETERRNO(EEXIST,RMS$_FEX);
3568             else if (instr(s, "existing file"))
3569                 SETERRNO(EEXIST,RMS$_FEX);
3570             else if (instr(s, "ile exists"))
3571                 SETERRNO(EEXIST,RMS$_FEX);
3572             else if (instr(s, "non-exist"))
3573                 SETERRNO(ENOENT,RMS$_FNF);
3574             else if (instr(s, "does not exist"))
3575                 SETERRNO(ENOENT,RMS$_FNF);
3576             else if (instr(s, "not empty"))
3577                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3578             else if (instr(s, "cannot access"))
3579                 SETERRNO(EACCES,RMS$_PRV);
3580             else
3581                 SETERRNO(EPERM,RMS$_PRV);
3582             return 0;
3583         }
3584         else {  /* some mkdirs return no failure indication */
3585             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3586             if (PL_op->op_type == OP_RMDIR)
3587                 anum = !anum;
3588             if (anum)
3589                 SETERRNO(0,0);
3590             else
3591                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3592         }
3593         return anum;
3594     }
3595     else
3596         return 0;
3597 }
3598 #endif
3599
3600 PP(pp_mkdir)
3601 {
3602     dSP; dTARGET;
3603     int mode;
3604 #ifndef HAS_MKDIR
3605     int oldumask;
3606 #endif
3607     STRLEN len;
3608     char *tmps;
3609     bool copy = FALSE;
3610
3611     if (MAXARG > 1)
3612         mode = POPi;
3613     else
3614         mode = 0777;
3615
3616     tmps = SvPV(TOPs, len);
3617     /* Different operating and file systems take differently to
3618      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3619      * any number of trailing slashes should be allowed.
3620      * Thusly we snip them away so that even non-conforming
3621      * systems are happy. */
3622     /* We should probably do this "filtering" for all
3623      * the functions that expect (potentially) directory names:
3624      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3625      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3626     if (len > 1 && tmps[len-1] == '/') {
3627         while (tmps[len] == '/' && len > 1)
3628             len--;
3629         tmps = savepvn(tmps, len);
3630         copy = TRUE;
3631     }
3632
3633     TAINT_PROPER("mkdir");
3634 #ifdef HAS_MKDIR
3635     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3636 #else
3637     SETi( dooneliner("mkdir", tmps) );
3638     oldumask = PerlLIO_umask(0);
3639     PerlLIO_umask(oldumask);
3640     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3641 #endif
3642     if (copy)
3643         Safefree(tmps);
3644     RETURN;
3645 }
3646
3647 PP(pp_rmdir)
3648 {
3649     dSP; dTARGET;
3650     char *tmps;
3651     STRLEN n_a;
3652
3653     tmps = POPpx;
3654     TAINT_PROPER("rmdir");
3655 #ifdef HAS_RMDIR
3656     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3657 #else
3658     XPUSHi( dooneliner("rmdir", tmps) );
3659 #endif
3660     RETURN;
3661 }
3662
3663 /* Directory calls. */
3664
3665 PP(pp_open_dir)
3666 {
3667     dSP;
3668 #if defined(Direntry_t) && defined(HAS_READDIR)
3669     STRLEN n_a;
3670     char *dirname = POPpx;
3671     GV *gv = (GV*)POPs;
3672     register IO *io = GvIOn(gv);
3673
3674     if (!io)
3675         goto nope;
3676
3677     if (IoDIRP(io))
3678         PerlDir_close(IoDIRP(io));
3679     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3680         goto nope;
3681
3682     RETPUSHYES;
3683 nope:
3684     if (!errno)
3685         SETERRNO(EBADF,RMS$_DIR);
3686     RETPUSHUNDEF;
3687 #else
3688     DIE(aTHX_ PL_no_dir_func, "opendir");
3689 #endif
3690 }
3691
3692 PP(pp_readdir)
3693 {
3694     dSP;
3695 #if defined(Direntry_t) && defined(HAS_READDIR)
3696 #ifndef I_DIRENT
3697     Direntry_t *readdir (DIR *);
3698 #endif
3699     register Direntry_t *dp;
3700     GV *gv = (GV*)POPs;
3701     register IO *io = GvIOn(gv);
3702     SV *sv;
3703
3704     if (!io || !IoDIRP(io))
3705         goto nope;
3706
3707     if (GIMME == G_ARRAY) {
3708         /*SUPPRESS 560*/
3709         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3710 #ifdef DIRNAMLEN
3711             sv = newSVpvn(dp->d_name, dp->d_namlen);
3712 #else
3713             sv = newSVpv(dp->d_name, 0);
3714 #endif
3715 #ifndef INCOMPLETE_TAINTS
3716             if (!(IoFLAGS(io) & IOf_UNTAINT))
3717                 SvTAINTED_on(sv);
3718 #endif
3719             XPUSHs(sv_2mortal(sv));
3720         }
3721     }
3722     else {
3723         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3724             goto nope;
3725 #ifdef DIRNAMLEN
3726         sv = newSVpvn(dp->d_name, dp->d_namlen);
3727 #else
3728         sv = newSVpv(dp->d_name, 0);
3729 #endif
3730 #ifndef INCOMPLETE_TAINTS
3731         if (!(IoFLAGS(io) & IOf_UNTAINT))
3732             SvTAINTED_on(sv);
3733 #endif
3734         XPUSHs(sv_2mortal(sv));
3735     }
3736     RETURN;
3737
3738 nope:
3739     if (!errno)
3740         SETERRNO(EBADF,RMS$_ISI);
3741     if (GIMME == G_ARRAY)
3742         RETURN;
3743     else
3744         RETPUSHUNDEF;
3745 #else
3746     DIE(aTHX_ PL_no_dir_func, "readdir");
3747 #endif
3748 }
3749
3750 PP(pp_telldir)
3751 {
3752     dSP; dTARGET;
3753 #if defined(HAS_TELLDIR) || defined(telldir)
3754  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3755  /* XXX netbsd still seemed to.
3756     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3757     --JHI 1999-Feb-02 */
3758 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3759     long telldir (DIR *);
3760 # endif
3761     GV *gv = (GV*)POPs;
3762     register IO *io = GvIOn(gv);
3763
3764     if (!io || !IoDIRP(io))
3765         goto nope;
3766
3767     PUSHi( PerlDir_tell(IoDIRP(io)) );
3768     RETURN;
3769 nope:
3770     if (!errno)
3771         SETERRNO(EBADF,RMS$_ISI);
3772     RETPUSHUNDEF;
3773 #else
3774     DIE(aTHX_ PL_no_dir_func, "telldir");
3775 #endif
3776 }
3777
3778 PP(pp_seekdir)
3779 {
3780     dSP;
3781 #if defined(HAS_SEEKDIR) || defined(seekdir)
3782     long along = POPl;
3783     GV *gv = (GV*)POPs;
3784     register IO *io = GvIOn(gv);
3785
3786     if (!io || !IoDIRP(io))
3787         goto nope;
3788
3789     (void)PerlDir_seek(IoDIRP(io), along);
3790
3791     RETPUSHYES;
3792 nope:
3793     if (!errno)
3794         SETERRNO(EBADF,RMS$_ISI);
3795     RETPUSHUNDEF;
3796 #else
3797     DIE(aTHX_ PL_no_dir_func, "seekdir");
3798 #endif
3799 }
3800
3801 PP(pp_rewinddir)
3802 {
3803     dSP;
3804 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3805     GV *gv = (GV*)POPs;
3806     register IO *io = GvIOn(gv);
3807
3808     if (!io || !IoDIRP(io))
3809         goto nope;
3810
3811     (void)PerlDir_rewind(IoDIRP(io));
3812     RETPUSHYES;
3813 nope:
3814     if (!errno)
3815         SETERRNO(EBADF,RMS$_ISI);
3816     RETPUSHUNDEF;
3817 #else
3818     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3819 #endif
3820 }
3821
3822 PP(pp_closedir)
3823 {
3824     dSP;
3825 #if defined(Direntry_t) && defined(HAS_READDIR)
3826     GV *gv = (GV*)POPs;
3827     register IO *io = GvIOn(gv);
3828
3829     if (!io || !IoDIRP(io))
3830         goto nope;
3831
3832 #ifdef VOID_CLOSEDIR
3833     PerlDir_close(IoDIRP(io));
3834 #else
3835     if (PerlDir_close(IoDIRP(io)) < 0) {
3836         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3837         goto nope;
3838     }
3839 #endif
3840     IoDIRP(io) = 0;
3841
3842     RETPUSHYES;
3843 nope:
3844     if (!errno)
3845         SETERRNO(EBADF,RMS$_IFI);
3846     RETPUSHUNDEF;
3847 #else
3848     DIE(aTHX_ PL_no_dir_func, "closedir");
3849 #endif
3850 }
3851
3852 /* Process control. */
3853
3854 PP(pp_fork)
3855 {
3856 #ifdef HAS_FORK
3857     dSP; dTARGET;
3858     Pid_t childpid;
3859     GV *tmpgv;
3860
3861     EXTEND(SP, 1);
3862     PERL_FLUSHALL_FOR_CHILD;
3863     childpid = fork();
3864     if (childpid < 0)
3865         RETSETUNDEF;
3866     if (!childpid) {
3867         /*SUPPRESS 560*/
3868         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3869             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3870         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3871     }
3872     PUSHi(childpid);
3873     RETURN;
3874 #else
3875 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3876     dSP; dTARGET;
3877     Pid_t childpid;
3878
3879     EXTEND(SP, 1);
3880     PERL_FLUSHALL_FOR_CHILD;
3881     childpid = PerlProc_fork();
3882     if (childpid == -1)
3883         RETSETUNDEF;
3884     PUSHi(childpid);
3885     RETURN;
3886 #  else
3887     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3888 #  endif
3889 #endif
3890 }
3891
3892 PP(pp_wait)
3893 {
3894 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3895     dSP; dTARGET;
3896     Pid_t childpid;
3897     int argflags;
3898
3899     childpid = wait4pid(-1, &argflags, 0);
3900 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3901     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3902     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3903 #  else
3904     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3905 #  endif
3906     XPUSHi(childpid);
3907     RETURN;
3908 #else
3909     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3910 #endif
3911 }
3912
3913 PP(pp_waitpid)
3914 {
3915 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3916     dSP; dTARGET;
3917     Pid_t childpid;
3918     int optype;
3919     int argflags;
3920
3921     optype = POPi;
3922     childpid = TOPi;
3923     childpid = wait4pid(childpid, &argflags, optype);
3924 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3925     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3926     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3927 #  else
3928     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3929 #  endif
3930     SETi(childpid);
3931     RETURN;
3932 #else
3933     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3934 #endif
3935 }
3936
3937 PP(pp_system)
3938 {
3939     dSP; dMARK; dORIGMARK; dTARGET;
3940     I32 value;
3941     Pid_t childpid;
3942     int result;
3943     int status;
3944     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3945     STRLEN n_a;
3946     I32 did_pipes = 0;
3947     int pp[2];
3948
3949     if (SP - MARK == 1) {
3950         if (PL_tainting) {
3951             char *junk = SvPV(TOPs, n_a);
3952             TAINT_ENV();
3953             TAINT_PROPER("system");
3954         }
3955     }
3956     PERL_FLUSHALL_FOR_CHILD;
3957 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3958     if (PerlProc_pipe(pp) >= 0)
3959         did_pipes = 1;
3960     while ((childpid = vfork()) == -1) {
3961         if (errno != EAGAIN) {
3962             value = -1;
3963             SP = ORIGMARK;
3964             PUSHi(value);
3965             if (did_pipes) {
3966                 PerlLIO_close(pp[0]);
3967                 PerlLIO_close(pp[1]);
3968             }
3969             RETURN;
3970         }
3971         sleep(5);
3972     }
3973     if (childpid > 0) {
3974         if (did_pipes)
3975             PerlLIO_close(pp[1]);
3976 #ifndef PERL_MICRO
3977         rsignal_save(SIGINT, SIG_IGN, &ihand);
3978         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3979 #endif
3980         do {
3981             result = wait4pid(childpid, &status, 0);
3982         } while (result == -1 && errno == EINTR);
3983 #ifndef PERL_MICRO
3984         (void)rsignal_restore(SIGINT, &ihand);
3985         (void)rsignal_restore(SIGQUIT, &qhand);
3986 #endif
3987         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3988         do_execfree();  /* free any memory child malloced on vfork */
3989         SP = ORIGMARK;
3990         if (did_pipes) {
3991             int errkid;
3992             int n = 0, n1;
3993
3994             while (n < sizeof(int)) {
3995                 n1 = PerlLIO_read(pp[0],
3996                                   (void*)(((char*)&errkid)+n),
3997                                   (sizeof(int)) - n);
3998                 if (n1 <= 0)
3999                     break;
4000                 n += n1;
4001             }
4002             PerlLIO_close(pp[0]);
4003             if (n) {                    /* Error */
4004                 if (n != sizeof(int))
4005                     DIE(aTHX_ "panic: kid popen errno read");
4006                 errno = errkid;         /* Propagate errno from kid */
4007                 STATUS_CURRENT = -1;
4008             }
4009         }
4010         PUSHi(STATUS_CURRENT);
4011         RETURN;
4012     }
4013     if (did_pipes) {
4014         PerlLIO_close(pp[0]);
4015 #if defined(HAS_FCNTL) && defined(F_SETFD)
4016         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4017 #endif
4018     }
4019     if (PL_op->op_flags & OPf_STACKED) {
4020         SV *really = *++MARK;
4021         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4022     }
4023     else if (SP - MARK != 1)
4024         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4025     else {
4026         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4027     }
4028     PerlProc__exit(-1);
4029 #else /* ! FORK or VMS or OS/2 */
4030     PL_statusvalue = 0;
4031     result = 0;
4032     if (PL_op->op_flags & OPf_STACKED) {
4033         SV *really = *++MARK;
4034         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4035     }
4036     else if (SP - MARK != 1)
4037         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4038     else {
4039         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4040     }
4041     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4042         result = 1;
4043     STATUS_NATIVE_SET(value);
4044     do_execfree();
4045     SP = ORIGMARK;
4046     PUSHi(result ? value : STATUS_CURRENT);
4047 #endif /* !FORK or VMS */
4048     RETURN;
4049 }
4050
4051 PP(pp_exec)
4052 {
4053     dSP; dMARK; dORIGMARK; dTARGET;
4054     I32 value;
4055     STRLEN n_a;
4056
4057     PERL_FLUSHALL_FOR_CHILD;
4058     if (PL_op->op_flags & OPf_STACKED) {
4059         SV *really = *++MARK;
4060         value = (I32)do_aexec(really, MARK, SP);
4061     }
4062     else if (SP - MARK != 1)
4063 #ifdef VMS
4064         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4065 #else
4066 #  ifdef __OPEN_VM
4067         {
4068            (void ) do_aspawn(Nullsv, MARK, SP);
4069            value = 0;
4070         }
4071 #  else
4072         value = (I32)do_aexec(Nullsv, MARK, SP);
4073 #  endif
4074 #endif
4075     else {
4076         if (PL_tainting) {
4077             char *junk = SvPV(*SP, n_a);
4078             TAINT_ENV();
4079             TAINT_PROPER("exec");
4080         }
4081 #ifdef VMS
4082         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4083 #else
4084 #  ifdef __OPEN_VM
4085         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4086         value = 0;
4087 #  else
4088         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4089 #  endif
4090 #endif
4091     }
4092
4093 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4094     if (value >= 0)
4095         my_exit(value);
4096 #endif
4097
4098     SP = ORIGMARK;
4099     PUSHi(value);
4100     RETURN;
4101 }
4102
4103 PP(pp_kill)
4104 {
4105     dSP; dMARK; dTARGET;
4106     I32 value;
4107 #ifdef HAS_KILL
4108     value = (I32)apply(PL_op->op_type, MARK, SP);
4109     SP = MARK;
4110     PUSHi(value);
4111     RETURN;
4112 #else
4113     DIE(aTHX_ PL_no_func, "Unsupported function kill");
4114 #endif
4115 }
4116
4117 PP(pp_getppid)
4118 {
4119 #ifdef HAS_GETPPID
4120     dSP; dTARGET;
4121     XPUSHi( getppid() );
4122     RETURN;
4123 #else
4124     DIE(aTHX_ PL_no_func, "getppid");
4125 #endif
4126 }
4127
4128 PP(pp_getpgrp)
4129 {
4130 #ifdef HAS_GETPGRP
4131     dSP; dTARGET;
4132     Pid_t pid;
4133     Pid_t pgrp;
4134
4135     if (MAXARG < 1)
4136         pid = 0;
4137     else
4138         pid = SvIVx(POPs);
4139 #ifdef BSD_GETPGRP
4140     pgrp = (I32)BSD_GETPGRP(pid);
4141 #else
4142     if (pid != 0 && pid != PerlProc_getpid())
4143         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4144     pgrp = getpgrp();
4145 #endif
4146     XPUSHi(pgrp);
4147     RETURN;
4148 #else
4149     DIE(aTHX_ PL_no_func, "getpgrp()");
4150 #endif
4151 }
4152
4153 PP(pp_setpgrp)
4154 {
4155 #ifdef HAS_SETPGRP
4156     dSP; dTARGET;
4157     Pid_t pgrp;
4158     Pid_t pid;
4159     if (MAXARG < 2) {
4160         pgrp = 0;
4161         pid = 0;
4162     }
4163     else {
4164         pgrp = POPi;
4165         pid = TOPi;
4166     }
4167
4168     TAINT_PROPER("setpgrp");
4169 #ifdef BSD_SETPGRP
4170     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4171 #else
4172     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4173         || (pid != 0 && pid != PerlProc_getpid()))
4174     {
4175         DIE(aTHX_ "setpgrp can't take arguments");
4176     }
4177     SETi( setpgrp() >= 0 );
4178 #endif /* USE_BSDPGRP */
4179     RETURN;
4180 #else
4181     DIE(aTHX_ PL_no_func, "setpgrp()");
4182 #endif
4183 }
4184
4185 PP(pp_getpriority)
4186 {
4187     dSP; dTARGET;
4188     int which;
4189     int who;
4190 #ifdef HAS_GETPRIORITY
4191     who = POPi;
4192     which = TOPi;
4193     SETi( getpriority(which, who) );
4194     RETURN;
4195 #else
4196     DIE(aTHX_ PL_no_func, "getpriority()");
4197 #endif
4198 }
4199
4200 PP(pp_setpriority)
4201 {
4202     dSP; dTARGET;
4203     int which;
4204     int who;
4205     int niceval;
4206 #ifdef HAS_SETPRIORITY
4207     niceval = POPi;
4208     who = POPi;
4209     which = TOPi;
4210     TAINT_PROPER("setpriority");
4211     SETi( setpriority(which, who, niceval) >= 0 );
4212     RETURN;
4213 #else
4214     DIE(aTHX_ PL_no_func, "setpriority()");
4215 #endif
4216 }
4217
4218 /* Time calls. */
4219
4220 PP(pp_time)
4221 {
4222     dSP; dTARGET;
4223 #ifdef BIG_TIME
4224     XPUSHn( time(Null(Time_t*)) );
4225 #else
4226     XPUSHi( time(Null(Time_t*)) );
4227 #endif
4228     RETURN;
4229 }
4230
4231 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4232    to HZ.  Probably.  For now, assume that if the system
4233    defines HZ, it does so correctly.  (Will this break
4234    on VMS?)
4235    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4236    it's supported.    --AD  9/96.
4237 */
4238
4239 #ifndef HZ
4240 #  ifdef CLK_TCK
4241 #    define HZ CLK_TCK
4242 #  else
4243 #    define HZ 60
4244 #  endif
4245 #endif
4246
4247 PP(pp_tms)
4248 {
4249     dSP;
4250
4251 #ifndef HAS_TIMES
4252     DIE(aTHX_ "times not implemented");
4253 #else
4254     EXTEND(SP, 4);
4255
4256 #ifndef VMS
4257     (void)PerlProc_times(&PL_timesbuf);
4258 #else
4259     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4260                                                    /* struct tms, though same data   */
4261                                                    /* is returned.                   */
4262 #endif
4263
4264     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4265     if (GIMME == G_ARRAY) {
4266         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4267         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4268         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4269     }
4270     RETURN;
4271 #endif /* HAS_TIMES */
4272 }
4273
4274 PP(pp_localtime)
4275 {
4276     return pp_gmtime();
4277 }
4278
4279 PP(pp_gmtime)
4280 {
4281     dSP;
4282     Time_t when;
4283     struct tm *tmbuf;
4284     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4285     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4286                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4287
4288     if (MAXARG < 1)
4289         (void)time(&when);
4290     else
4291 #ifdef BIG_TIME
4292         when = (Time_t)SvNVx(POPs);
4293 #else
4294         when = (Time_t)SvIVx(POPs);
4295 #endif
4296
4297     if (PL_op->op_type == OP_LOCALTIME)
4298         tmbuf = localtime(&when);
4299     else
4300         tmbuf = gmtime(&when);
4301
4302     EXTEND(SP, 9);
4303     EXTEND_MORTAL(9);
4304     if (GIMME != G_ARRAY) {
4305         SV *tsv;
4306         if (!tmbuf)
4307             RETPUSHUNDEF;
4308         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4309                             dayname[tmbuf->tm_wday],
4310                             monname[tmbuf->tm_mon],
4311                             tmbuf->tm_mday,
4312                             tmbuf->tm_hour,
4313                             tmbuf->tm_min,
4314                             tmbuf->tm_sec,
4315                             tmbuf->tm_year + 1900);
4316         PUSHs(sv_2mortal(tsv));
4317     }
4318     else if (tmbuf) {
4319         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4320         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4321         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4322         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4323         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4324         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4325         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4326         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4327         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4328     }
4329     RETURN;
4330 }
4331
4332 PP(pp_alarm)
4333 {
4334     dSP; dTARGET;
4335     int anum;
4336 #ifdef HAS_ALARM
4337     anum = POPi;
4338     anum = alarm((unsigned int)anum);
4339     EXTEND(SP, 1);
4340     if (anum < 0)
4341         RETPUSHUNDEF;
4342     PUSHi(anum);
4343     RETURN;
4344 #else
4345     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4346 #endif
4347 }
4348
4349 PP(pp_sleep)
4350 {
4351     dSP; dTARGET;
4352     I32 duration;
4353     Time_t lasttime;
4354     Time_t when;
4355
4356     (void)time(&lasttime);
4357     if (MAXARG < 1)
4358         PerlProc_pause();
4359     else {
4360         duration = POPi;
4361         PerlProc_sleep((unsigned int)duration);
4362     }
4363     (void)time(&when);
4364     XPUSHi(when - lasttime);
4365     RETURN;
4366 }
4367
4368 /* Shared memory. */
4369
4370 PP(pp_shmget)
4371 {
4372     return pp_semget();
4373 }
4374
4375 PP(pp_shmctl)
4376 {
4377     return pp_semctl();
4378 }
4379
4380 PP(pp_shmread)
4381 {
4382     return pp_shmwrite();
4383 }
4384
4385 PP(pp_shmwrite)
4386 {
4387 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4388     dSP; dMARK; dTARGET;
4389     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4390     SP = MARK;
4391     PUSHi(value);
4392     RETURN;
4393 #else
4394     return pp_semget();
4395 #endif
4396 }
4397
4398 /* Message passing. */
4399
4400 PP(pp_msgget)
4401 {
4402     return pp_semget();
4403 }
4404
4405 PP(pp_msgctl)
4406 {
4407     return pp_semctl();
4408 }
4409
4410 PP(pp_msgsnd)
4411 {
4412 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4413     dSP; dMARK; dTARGET;
4414     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4415     SP = MARK;
4416     PUSHi(value);
4417     RETURN;
4418 #else
4419     return pp_semget();
4420 #endif
4421 }
4422
4423 PP(pp_msgrcv)
4424 {
4425 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4426     dSP; dMARK; dTARGET;
4427     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4428     SP = MARK;
4429     PUSHi(value);
4430     RETURN;
4431 #else
4432     return pp_semget();
4433 #endif
4434 }
4435
4436 /* Semaphores. */
4437
4438 PP(pp_semget)
4439 {
4440 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4441     dSP; dMARK; dTARGET;
4442     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4443     SP = MARK;
4444     if (anum == -1)
4445         RETPUSHUNDEF;
4446     PUSHi(anum);
4447     RETURN;
4448 #else
4449     DIE(aTHX_ "System V IPC is not implemented on this machine");
4450 #endif
4451 }
4452
4453 PP(pp_semctl)
4454 {
4455 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4456     dSP; dMARK; dTARGET;
4457     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4458     SP = MARK;
4459     if (anum == -1)
4460         RETSETUNDEF;
4461     if (anum != 0) {
4462         PUSHi(anum);
4463     }
4464     else {
4465         PUSHp(zero_but_true, ZBTLEN);
4466     }
4467     RETURN;
4468 #else
4469     return pp_semget();
4470 #endif
4471 }
4472
4473 PP(pp_semop)
4474 {
4475 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4476     dSP; dMARK; dTARGET;
4477     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4478     SP = MARK;
4479     PUSHi(value);
4480     RETURN;
4481 #else
4482     return pp_semget();
4483 #endif
4484 }
4485
4486 /* Get system info. */
4487
4488 PP(pp_ghbyname)
4489 {
4490 #ifdef HAS_GETHOSTBYNAME
4491     return pp_ghostent();
4492 #else
4493     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4494 #endif
4495 }
4496
4497 PP(pp_ghbyaddr)
4498 {
4499 #ifdef HAS_GETHOSTBYADDR
4500     return pp_ghostent();
4501 #else
4502     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4503 #endif
4504 }
4505
4506 PP(pp_ghostent)
4507 {
4508     dSP;
4509 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4510     I32 which = PL_op->op_type;
4511     register char **elem;
4512     register SV *sv;
4513 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4514     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4515     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4516     struct hostent *PerlSock_gethostent(void);
4517 #endif
4518     struct hostent *hent;
4519     unsigned long len;
4520     STRLEN n_a;
4521
4522     EXTEND(SP, 10);
4523     if (which == OP_GHBYNAME)
4524 #ifdef HAS_GETHOSTBYNAME
4525         hent = PerlSock_gethostbyname(POPpbytex);
4526 #else
4527         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4528 #endif
4529     else if (which == OP_GHBYADDR) {
4530 #ifdef HAS_GETHOSTBYADDR
4531         int addrtype = POPi;
4532         SV *addrsv = POPs;
4533         STRLEN addrlen;
4534         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4535
4536         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4537 #else
4538         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4539 #endif
4540     }
4541     else
4542 #ifdef HAS_GETHOSTENT
4543         hent = PerlSock_gethostent();
4544 #else
4545         DIE(aTHX_ PL_no_sock_func, "gethostent");
4546 #endif
4547
4548 #ifdef HOST_NOT_FOUND
4549     if (!hent)
4550         STATUS_NATIVE_SET(h_errno);
4551 #endif
4552
4553     if (GIMME != G_ARRAY) {
4554         PUSHs(sv = sv_newmortal());
4555         if (hent) {
4556             if (which == OP_GHBYNAME) {
4557                 if (hent->h_addr)
4558                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4559             }
4560             else
4561                 sv_setpv(sv, (char*)hent->h_name);
4562         }
4563         RETURN;
4564     }
4565
4566     if (hent) {
4567         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4568         sv_setpv(sv, (char*)hent->h_name);
4569         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4570         for (elem = hent->h_aliases; elem && *elem; elem++) {
4571             sv_catpv(sv, *elem);
4572             if (elem[1])
4573                 sv_catpvn(sv, " ", 1);
4574         }
4575         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4576         sv_setiv(sv, (IV)hent->h_addrtype);
4577         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4578         len = hent->h_length;
4579         sv_setiv(sv, (IV)len);
4580 #ifdef h_addr
4581         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4582             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4583             sv_setpvn(sv, *elem, len);
4584         }
4585 #else
4586         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4587         if (hent->h_addr)
4588             sv_setpvn(sv, hent->h_addr, len);
4589 #endif /* h_addr */
4590     }
4591     RETURN;
4592 #else
4593     DIE(aTHX_ PL_no_sock_func, "gethostent");
4594 #endif
4595 }
4596
4597 PP(pp_gnbyname)
4598 {
4599 #ifdef HAS_GETNETBYNAME
4600     return pp_gnetent();
4601 #else
4602     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4603 #endif
4604 }
4605
4606 PP(pp_gnbyaddr)
4607 {
4608 #ifdef HAS_GETNETBYADDR
4609     return pp_gnetent();
4610 #else
4611     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4612 #endif
4613 }
4614
4615 PP(pp_gnetent)
4616 {
4617     dSP;
4618 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4619     I32 which = PL_op->op_type;
4620     register char **elem;
4621     register SV *sv;
4622 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4623     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4624     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4625     struct netent *PerlSock_getnetent(void);
4626 #endif
4627     struct netent *nent;
4628     STRLEN n_a;
4629
4630     if (which == OP_GNBYNAME)
4631 #ifdef HAS_GETNETBYNAME
4632         nent = PerlSock_getnetbyname(POPpbytex);
4633 #else
4634         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4635 #endif
4636     else if (which == OP_GNBYADDR) {
4637 #ifdef HAS_GETNETBYADDR
4638         int addrtype = POPi;
4639         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4640         nent = PerlSock_getnetbyaddr(addr, addrtype);
4641 #else
4642         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4643 #endif
4644     }
4645     else
4646 #ifdef HAS_GETNETENT
4647         nent = PerlSock_getnetent();
4648 #else
4649         DIE(aTHX_ PL_no_sock_func, "getnetent");
4650 #endif
4651
4652     EXTEND(SP, 4);
4653     if (GIMME != G_ARRAY) {
4654         PUSHs(sv = sv_newmortal());
4655         if (nent) {
4656             if (which == OP_GNBYNAME)
4657                 sv_setiv(sv, (IV)nent->n_net);
4658             else
4659                 sv_setpv(sv, nent->n_name);
4660         }
4661         RETURN;
4662     }
4663
4664     if (nent) {
4665         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4666         sv_setpv(sv, nent->n_name);
4667         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4668         for (elem = nent->n_aliases; elem && *elem; elem++) {
4669             sv_catpv(sv, *elem);
4670             if (elem[1])
4671                 sv_catpvn(sv, " ", 1);
4672         }
4673         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4674         sv_setiv(sv, (IV)nent->n_addrtype);
4675         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4676         sv_setiv(sv, (IV)nent->n_net);
4677     }
4678
4679     RETURN;
4680 #else
4681     DIE(aTHX_ PL_no_sock_func, "getnetent");
4682 #endif
4683 }
4684
4685 PP(pp_gpbyname)
4686 {
4687 #ifdef HAS_GETPROTOBYNAME
4688     return pp_gprotoent();
4689 #else
4690     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4691 #endif
4692 }
4693
4694 PP(pp_gpbynumber)
4695 {
4696 #ifdef HAS_GETPROTOBYNUMBER
4697     return pp_gprotoent();
4698 #else
4699     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4700 #endif
4701 }
4702
4703 PP(pp_gprotoent)
4704 {
4705     dSP;
4706 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4707     I32 which = PL_op->op_type;
4708     register char **elem;
4709     register SV *sv;
4710 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4711     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4712     struct protoent *PerlSock_getprotobynumber(int);
4713     struct protoent *PerlSock_getprotoent(void);
4714 #endif
4715     struct protoent *pent;
4716     STRLEN n_a;
4717
4718     if (which == OP_GPBYNAME)
4719 #ifdef HAS_GETPROTOBYNAME
4720         pent = PerlSock_getprotobyname(POPpbytex);
4721 #else
4722         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4723 #endif
4724     else if (which == OP_GPBYNUMBER)
4725 #ifdef HAS_GETPROTOBYNUMBER
4726         pent = PerlSock_getprotobynumber(POPi);
4727 #else
4728     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4729 #endif
4730     else
4731 #ifdef HAS_GETPROTOENT
4732         pent = PerlSock_getprotoent();
4733 #else
4734         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4735 #endif
4736
4737     EXTEND(SP, 3);
4738     if (GIMME != G_ARRAY) {
4739         PUSHs(sv = sv_newmortal());
4740         if (pent) {
4741             if (which == OP_GPBYNAME)
4742                 sv_setiv(sv, (IV)pent->p_proto);
4743             else
4744                 sv_setpv(sv, pent->p_name);
4745         }
4746         RETURN;
4747     }
4748
4749     if (pent) {
4750         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4751         sv_setpv(sv, pent->p_name);
4752         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4753         for (elem = pent->p_aliases; elem && *elem; elem++) {
4754             sv_catpv(sv, *elem);
4755             if (elem[1])
4756                 sv_catpvn(sv, " ", 1);
4757         }
4758         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4759         sv_setiv(sv, (IV)pent->p_proto);
4760     }
4761
4762     RETURN;
4763 #else
4764     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4765 #endif
4766 }
4767
4768 PP(pp_gsbyname)
4769 {
4770 #ifdef HAS_GETSERVBYNAME
4771     return pp_gservent();
4772 #else
4773     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4774 #endif
4775 }
4776
4777 PP(pp_gsbyport)
4778 {
4779 #ifdef HAS_GETSERVBYPORT
4780     return pp_gservent();
4781 #else
4782     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4783 #endif
4784 }
4785
4786 PP(pp_gservent)
4787 {
4788     dSP;
4789 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4790     I32 which = PL_op->op_type;
4791     register char **elem;
4792     register SV *sv;
4793 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4794     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4795     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4796     struct servent *PerlSock_getservent(void);
4797 #endif
4798     struct servent *sent;
4799     STRLEN n_a;
4800
4801     if (which == OP_GSBYNAME) {
4802 #ifdef HAS_GETSERVBYNAME
4803         char *proto = POPpbytex;
4804         char *name = POPpbytex;
4805
4806         if (proto && !*proto)
4807             proto = Nullch;
4808
4809         sent = PerlSock_getservbyname(name, proto);
4810 #else
4811         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4812 #endif
4813     }
4814     else if (which == OP_GSBYPORT) {
4815 #ifdef HAS_GETSERVBYPORT
4816         char *proto = POPpbytex;
4817         unsigned short port = POPu;
4818
4819 #ifdef HAS_HTONS
4820         port = PerlSock_htons(port);
4821 #endif
4822         sent = PerlSock_getservbyport(port, proto);
4823 #else
4824         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4825 #endif
4826     }
4827     else
4828 #ifdef HAS_GETSERVENT
4829         sent = PerlSock_getservent();
4830 #else
4831         DIE(aTHX_ PL_no_sock_func, "getservent");
4832 #endif
4833
4834     EXTEND(SP, 4);
4835     if (GIMME != G_ARRAY) {
4836         PUSHs(sv = sv_newmortal());
4837         if (sent) {
4838             if (which == OP_GSBYNAME) {
4839 #ifdef HAS_NTOHS
4840                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4841 #else
4842                 sv_setiv(sv, (IV)(sent->s_port));
4843 #endif
4844             }
4845             else
4846                 sv_setpv(sv, sent->s_name);
4847         }
4848         RETURN;
4849     }
4850
4851     if (sent) {
4852         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4853         sv_setpv(sv, sent->s_name);
4854         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4855         for (elem = sent->s_aliases; elem && *elem; elem++) {
4856             sv_catpv(sv, *elem);
4857             if (elem[1])
4858                 sv_catpvn(sv, " ", 1);
4859         }
4860         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4861 #ifdef HAS_NTOHS
4862         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4863 #else
4864         sv_setiv(sv, (IV)(sent->s_port));
4865 #endif
4866         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4867         sv_setpv(sv, sent->s_proto);
4868     }
4869
4870     RETURN;
4871 #else
4872     DIE(aTHX_ PL_no_sock_func, "getservent");
4873 #endif
4874 }
4875
4876 PP(pp_shostent)
4877 {
4878     dSP;
4879 #ifdef HAS_SETHOSTENT
4880     PerlSock_sethostent(TOPi);
4881     RETSETYES;
4882 #else
4883     DIE(aTHX_ PL_no_sock_func, "sethostent");
4884 #endif
4885 }
4886
4887 PP(pp_snetent)
4888 {
4889     dSP;
4890 #ifdef HAS_SETNETENT
4891     PerlSock_setnetent(TOPi);
4892     RETSETYES;
4893 #else
4894     DIE(aTHX_ PL_no_sock_func, "setnetent");
4895 #endif
4896 }
4897
4898 PP(pp_sprotoent)
4899 {
4900     dSP;
4901 #ifdef HAS_SETPROTOENT
4902     PerlSock_setprotoent(TOPi);
4903     RETSETYES;
4904 #else
4905     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4906 #endif
4907 }
4908
4909 PP(pp_sservent)
4910 {
4911     dSP;
4912 #ifdef HAS_SETSERVENT
4913     PerlSock_setservent(TOPi);
4914     RETSETYES;
4915 #else
4916     DIE(aTHX_ PL_no_sock_func, "setservent");
4917 #endif
4918 }
4919
4920 PP(pp_ehostent)
4921 {
4922     dSP;
4923 #ifdef HAS_ENDHOSTENT
4924     PerlSock_endhostent();
4925     EXTEND(SP,1);
4926     RETPUSHYES;
4927 #else
4928     DIE(aTHX_ PL_no_sock_func, "endhostent");
4929 #endif
4930 }
4931
4932 PP(pp_enetent)
4933 {
4934     dSP;
4935 #ifdef HAS_ENDNETENT
4936     PerlSock_endnetent();
4937     EXTEND(SP,1);
4938     RETPUSHYES;
4939 #else
4940     DIE(aTHX_ PL_no_sock_func, "endnetent");
4941 #endif
4942 }
4943
4944 PP(pp_eprotoent)
4945 {
4946     dSP;
4947 #ifdef HAS_ENDPROTOENT
4948     PerlSock_endprotoent();
4949     EXTEND(SP,1);
4950     RETPUSHYES;
4951 #else
4952     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4953 #endif
4954 }
4955
4956 PP(pp_eservent)
4957 {
4958     dSP;
4959 #ifdef HAS_ENDSERVENT
4960     PerlSock_endservent();
4961     EXTEND(SP,1);
4962     RETPUSHYES;
4963 #else
4964     DIE(aTHX_ PL_no_sock_func, "endservent");
4965 #endif
4966 }
4967
4968 PP(pp_gpwnam)
4969 {
4970 #ifdef HAS_PASSWD
4971     return pp_gpwent();
4972 #else
4973     DIE(aTHX_ PL_no_func, "getpwnam");
4974 #endif
4975 }
4976
4977 PP(pp_gpwuid)
4978 {
4979 #ifdef HAS_PASSWD
4980     return pp_gpwent();
4981 #else
4982     DIE(aTHX_ PL_no_func, "getpwuid");
4983 #endif
4984 }
4985
4986 PP(pp_gpwent)
4987 {
4988     dSP;
4989 #ifdef HAS_PASSWD
4990     I32 which = PL_op->op_type;
4991     register SV *sv;
4992     STRLEN n_a;
4993     struct passwd *pwent  = NULL;
4994     /*
4995      * We currently support only the SysV getsp* shadow password interface.
4996      * The interface is declared in <shadow.h> and often one needs to link
4997      * with -lsecurity or some such.
4998      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4999      * (and SCO?)
5000      *
5001      * AIX getpwnam() is clever enough to return the encrypted password
5002      * only if the caller (euid?) is root.
5003      *
5004      * There are at least two other shadow password APIs.  Many platforms
5005      * seem to contain more than one interface for accessing the shadow
5006      * password databases, possibly for compatibility reasons.
5007      * The getsp*() is by far he simplest one, the other two interfaces
5008      * are much more complicated, but also very similar to each other.
5009      *
5010      * <sys/types.h>
5011      * <sys/security.h>
5012      * <prot.h>
5013      * struct pr_passwd *getprpw*();
5014      * The password is in
5015      * char getprpw*(...).ufld.fd_encrypt[]
5016      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5017      *
5018      * <sys/types.h>
5019      * <sys/security.h>
5020      * <prot.h>
5021      * struct es_passwd *getespw*();
5022      * The password is in
5023      * char *(getespw*(...).ufld.fd_encrypt)
5024      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5025      *
5026      * Mention I_PROT here so that Configure probes for it.
5027      *
5028      * In HP-UX for getprpw*() the manual page claims that one should include
5029      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5030      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5031      * and pp_sys.c already includes <shadow.h> if there is such.
5032      *
5033      * Note that <sys/security.h> is already probed for, but currently
5034      * it is only included in special cases.
5035      *
5036      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5037      * be preferred interface, even though also the getprpw*() interface
5038      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5039      * One also needs to call set_auth_parameters() in main() before
5040      * doing anything else, whether one is using getespw*() or getprpw*().
5041      *
5042      * Note that accessing the shadow databases can be magnitudes
5043      * slower than accessing the standard databases.
5044      *
5045      * --jhi
5046      */
5047
5048     switch (which) {
5049     case OP_GPWNAM:
5050         pwent  = getpwnam(POPpbytex);
5051         break;
5052     case OP_GPWUID:
5053         pwent = getpwuid((Uid_t)POPi);
5054         break;
5055     case OP_GPWENT:
5056 #   ifdef HAS_GETPWENT
5057         pwent  = getpwent();
5058 #   else
5059         DIE(aTHX_ PL_no_func, "getpwent");
5060 #   endif
5061         break;
5062     }
5063
5064     EXTEND(SP, 10);
5065     if (GIMME != G_ARRAY) {
5066         PUSHs(sv = sv_newmortal());
5067         if (pwent) {
5068             if (which == OP_GPWNAM)
5069 #   if Uid_t_sign <= 0
5070                 sv_setiv(sv, (IV)pwent->pw_uid);
5071 #   else
5072                 sv_setuv(sv, (UV)pwent->pw_uid);
5073 #   endif
5074             else
5075                 sv_setpv(sv, pwent->pw_name);
5076         }
5077         RETURN;
5078     }
5079
5080     if (pwent) {
5081         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5082         sv_setpv(sv, pwent->pw_name);
5083
5084         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5085         SvPOK_off(sv);
5086         /* If we have getspnam(), we try to dig up the shadow
5087          * password.  If we are underprivileged, the shadow
5088          * interface will set the errno to EACCES or similar,
5089          * and return a null pointer.  If this happens, we will
5090          * use the dummy password (usually "*" or "x") from the
5091          * standard password database.
5092          *
5093          * In theory we could skip the shadow call completely
5094          * if euid != 0 but in practice we cannot know which
5095          * security measures are guarding the shadow databases
5096          * on a random platform.
5097          *
5098          * Resist the urge to use additional shadow interfaces.
5099          * Divert the urge to writing an extension instead.
5100          *
5101          * --jhi */
5102 #   ifdef HAS_GETSPNAM
5103         {
5104             struct spwd *spwent;
5105             int saverrno; /* Save and restore errno so that
5106                            * underprivileged attempts seem
5107                            * to have never made the unsccessful
5108                            * attempt to retrieve the shadow password. */
5109
5110             saverrno = errno;
5111             spwent = getspnam(pwent->pw_name);
5112             errno = saverrno;
5113             if (spwent && spwent->sp_pwdp)
5114                 sv_setpv(sv, spwent->sp_pwdp);
5115         }
5116 #   endif
5117 #   ifdef PWPASSWD
5118         if (!SvPOK(sv)) /* Use the standard password, then. */
5119             sv_setpv(sv, pwent->pw_passwd);
5120 #   endif
5121
5122 #   ifndef INCOMPLETE_TAINTS
5123         /* passwd is tainted because user himself can diddle with it.
5124          * admittedly not much and in a very limited way, but nevertheless. */
5125         SvTAINTED_on(sv);
5126 #   endif
5127
5128         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5129 #   if Uid_t_sign <= 0
5130         sv_setiv(sv, (IV)pwent->pw_uid);
5131 #   else
5132         sv_setuv(sv, (UV)pwent->pw_uid);
5133 #   endif
5134
5135         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5136 #   if Uid_t_sign <= 0
5137         sv_setiv(sv, (IV)pwent->pw_gid);
5138 #   else
5139         sv_setuv(sv, (UV)pwent->pw_gid);
5140 #   endif
5141         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5142          * because of the poor interface of the Perl getpw*(),
5143          * not because there's some standard/convention saying so.
5144          * A better interface would have been to return a hash,
5145          * but we are accursed by our history, alas. --jhi.  */
5146         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5147 #   ifdef PWCHANGE
5148         sv_setiv(sv, (IV)pwent->pw_change);
5149 #   else
5150 #       ifdef PWQUOTA
5151         sv_setiv(sv, (IV)pwent->pw_quota);
5152 #       else
5153 #           ifdef PWAGE
5154         sv_setpv(sv, pwent->pw_age);
5155 #           endif
5156 #       endif
5157 #   endif
5158
5159         /* pw_class and pw_comment are mutually exclusive--.
5160          * see the above note for pw_change, pw_quota, and pw_age. */
5161         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5162 #   ifdef PWCLASS
5163         sv_setpv(sv, pwent->pw_class);
5164 #   else
5165 #       ifdef PWCOMMENT
5166         sv_setpv(sv, pwent->pw_comment);
5167 #       endif
5168 #   endif
5169
5170         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5171 #   ifdef PWGECOS
5172         sv_setpv(sv, pwent->pw_gecos);
5173 #   endif
5174 #   ifndef INCOMPLETE_TAINTS
5175         /* pw_gecos is tainted because user himself can diddle with it. */
5176         SvTAINTED_on(sv);
5177 #   endif
5178
5179         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5180         sv_setpv(sv, pwent->pw_dir);
5181
5182         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5183         sv_setpv(sv, pwent->pw_shell);
5184 #   ifndef INCOMPLETE_TAINTS
5185         /* pw_shell is tainted because user himself can diddle with it. */
5186         SvTAINTED_on(sv);
5187 #   endif
5188
5189 #   ifdef PWEXPIRE
5190         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5191         sv_setiv(sv, (IV)pwent->pw_expire);
5192 #   endif
5193     }
5194     RETURN;
5195 #else
5196     DIE(aTHX_ PL_no_func, "getpwent");
5197 #endif
5198 }
5199
5200 PP(pp_spwent)
5201 {
5202     dSP;
5203 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5204     setpwent();
5205     RETPUSHYES;
5206 #else
5207     DIE(aTHX_ PL_no_func, "setpwent");
5208 #endif
5209 }
5210
5211 PP(pp_epwent)
5212 {
5213     dSP;
5214 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5215     endpwent();
5216     RETPUSHYES;
5217 #else
5218     DIE(aTHX_ PL_no_func, "endpwent");
5219 #endif
5220 }
5221
5222 PP(pp_ggrnam)
5223 {
5224 #ifdef HAS_GROUP
5225     return pp_ggrent();
5226 #else
5227     DIE(aTHX_ PL_no_func, "getgrnam");
5228 #endif
5229 }
5230
5231 PP(pp_ggrgid)
5232 {
5233 #ifdef HAS_GROUP
5234     return pp_ggrent();
5235 #else
5236     DIE(aTHX_ PL_no_func, "getgrgid");
5237 #endif
5238 }
5239
5240 PP(pp_ggrent)
5241 {
5242     dSP;
5243 #ifdef HAS_GROUP
5244     I32 which = PL_op->op_type;
5245     register char **elem;
5246     register SV *sv;
5247     struct group *grent;
5248     STRLEN n_a;
5249
5250     if (which == OP_GGRNAM)
5251         grent = (struct group *)getgrnam(POPpbytex);
5252     else if (which == OP_GGRGID)
5253         grent = (struct group *)getgrgid(POPi);
5254     else
5255 #ifdef HAS_GETGRENT
5256         grent = (struct group *)getgrent();
5257 #else
5258         DIE(aTHX_ PL_no_func, "getgrent");
5259 #endif
5260
5261     EXTEND(SP, 4);
5262     if (GIMME != G_ARRAY) {
5263         PUSHs(sv = sv_newmortal());
5264         if (grent) {
5265             if (which == OP_GGRNAM)
5266                 sv_setiv(sv, (IV)grent->gr_gid);
5267             else
5268                 sv_setpv(sv, grent->gr_name);
5269         }
5270         RETURN;
5271     }
5272
5273     if (grent) {
5274         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5275         sv_setpv(sv, grent->gr_name);
5276
5277         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5278 #ifdef GRPASSWD
5279         sv_setpv(sv, grent->gr_passwd);
5280 #endif
5281
5282         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5283         sv_setiv(sv, (IV)grent->gr_gid);
5284
5285         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5286         for (elem = grent->gr_mem; elem && *elem; elem++) {
5287             sv_catpv(sv, *elem);
5288             if (elem[1])
5289                 sv_catpvn(sv, " ", 1);
5290         }
5291     }
5292
5293     RETURN;
5294 #else
5295     DIE(aTHX_ PL_no_func, "getgrent");
5296 #endif
5297 }
5298
5299 PP(pp_sgrent)
5300 {
5301     dSP;
5302 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5303     setgrent();
5304     RETPUSHYES;
5305 #else
5306     DIE(aTHX_ PL_no_func, "setgrent");
5307 #endif
5308 }
5309
5310 PP(pp_egrent)
5311 {
5312     dSP;
5313 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5314     endgrent();
5315     RETPUSHYES;
5316 #else
5317     DIE(aTHX_ PL_no_func, "endgrent");
5318 #endif
5319 }
5320
5321 PP(pp_getlogin)
5322 {
5323     dSP; dTARGET;
5324 #ifdef HAS_GETLOGIN
5325     char *tmps;
5326     EXTEND(SP, 1);
5327     if (!(tmps = PerlProc_getlogin()))
5328         RETPUSHUNDEF;
5329     PUSHp(tmps, strlen(tmps));
5330     RETURN;
5331 #else
5332     DIE(aTHX_ PL_no_func, "getlogin");
5333 #endif
5334 }
5335
5336 /* Miscellaneous. */
5337
5338 PP(pp_syscall)
5339 {
5340 #ifdef HAS_SYSCALL
5341     dSP; dMARK; dORIGMARK; dTARGET;
5342     register I32 items = SP - MARK;
5343     unsigned long a[20];
5344     register I32 i = 0;
5345     I32 retval = -1;
5346     STRLEN n_a;
5347
5348     if (PL_tainting) {
5349         while (++MARK <= SP) {
5350             if (SvTAINTED(*MARK)) {
5351                 TAINT;
5352                 break;
5353             }
5354         }
5355         MARK = ORIGMARK;
5356         TAINT_PROPER("syscall");
5357     }
5358
5359     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5360      * or where sizeof(long) != sizeof(char*).  But such machines will
5361      * not likely have syscall implemented either, so who cares?
5362      */
5363     while (++MARK <= SP) {
5364         if (SvNIOK(*MARK) || !i)
5365             a[i++] = SvIV(*MARK);
5366         else if (*MARK == &PL_sv_undef)
5367             a[i++] = 0;
5368         else
5369             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5370         if (i > 15)
5371             break;
5372     }
5373     switch (items) {
5374     default:
5375         DIE(aTHX_ "Too many args to syscall");
5376     case 0:
5377         DIE(aTHX_ "Too few args to syscall");
5378     case 1:
5379         retval = syscall(a[0]);
5380         break;
5381     case 2:
5382         retval = syscall(a[0],a[1]);
5383         break;
5384     case 3:
5385         retval = syscall(a[0],a[1],a[2]);
5386         break;
5387     case 4:
5388         retval = syscall(a[0],a[1],a[2],a[3]);
5389         break;
5390     case 5:
5391         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5392         break;
5393     case 6:
5394         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5395         break;
5396     case 7:
5397         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5398         break;
5399     case 8:
5400         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5401         break;
5402 #ifdef atarist
5403     case 9:
5404         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5405         break;
5406     case 10:
5407         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5408         break;
5409     case 11:
5410         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5411           a[10]);
5412         break;
5413     case 12:
5414         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5415           a[10],a[11]);
5416         break;
5417     case 13:
5418         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5419           a[10],a[11],a[12]);
5420         break;
5421     case 14:
5422         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5423           a[10],a[11],a[12],a[13]);
5424         break;
5425 #endif /* atarist */
5426     }
5427     SP = ORIGMARK;
5428     PUSHi(retval);
5429     RETURN;
5430 #else
5431     DIE(aTHX_ PL_no_func, "syscall");
5432 #endif
5433 }
5434
5435 #ifdef FCNTL_EMULATE_FLOCK
5436
5437 /*  XXX Emulate flock() with fcntl().
5438     What's really needed is a good file locking module.
5439 */
5440
5441 static int
5442 fcntl_emulate_flock(int fd, int operation)
5443 {
5444     struct flock flock;
5445
5446     switch (operation & ~LOCK_NB) {
5447     case LOCK_SH:
5448         flock.l_type = F_RDLCK;
5449         break;
5450     case LOCK_EX:
5451         flock.l_type = F_WRLCK;
5452         break;
5453     case LOCK_UN:
5454         flock.l_type = F_UNLCK;
5455         break;
5456     default:
5457         errno = EINVAL;
5458         return -1;
5459     }
5460     flock.l_whence = SEEK_SET;
5461     flock.l_start = flock.l_len = (Off_t)0;
5462
5463     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5464 }
5465
5466 #endif /* FCNTL_EMULATE_FLOCK */
5467
5468 #ifdef LOCKF_EMULATE_FLOCK
5469
5470 /*  XXX Emulate flock() with lockf().  This is just to increase
5471     portability of scripts.  The calls are not completely
5472     interchangeable.  What's really needed is a good file
5473     locking module.
5474 */
5475
5476 /*  The lockf() constants might have been defined in <unistd.h>.
5477     Unfortunately, <unistd.h> causes troubles on some mixed
5478     (BSD/POSIX) systems, such as SunOS 4.1.3.
5479
5480    Further, the lockf() constants aren't POSIX, so they might not be
5481    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5482    just stick in the SVID values and be done with it.  Sigh.
5483 */
5484
5485 # ifndef F_ULOCK
5486 #  define F_ULOCK       0       /* Unlock a previously locked region */
5487 # endif
5488 # ifndef F_LOCK
5489 #  define F_LOCK        1       /* Lock a region for exclusive use */
5490 # endif
5491 # ifndef F_TLOCK
5492 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5493 # endif
5494 # ifndef F_TEST
5495 #  define F_TEST        3       /* Test a region for other processes locks */
5496 # endif
5497
5498 static int
5499 lockf_emulate_flock(int fd, int operation)
5500 {
5501     int i;
5502     int save_errno;
5503     Off_t pos;
5504
5505     /* flock locks entire file so for lockf we need to do the same      */
5506     save_errno = errno;
5507     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5508     if (pos > 0)        /* is seekable and needs to be repositioned     */
5509         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5510             pos = -1;   /* seek failed, so don't seek back afterwards   */
5511     errno = save_errno;
5512
5513     switch (operation) {
5514
5515         /* LOCK_SH - get a shared lock */
5516         case LOCK_SH:
5517         /* LOCK_EX - get an exclusive lock */
5518         case LOCK_EX:
5519             i = lockf (fd, F_LOCK, 0);
5520             break;
5521
5522         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5523         case LOCK_SH|LOCK_NB:
5524         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5525         case LOCK_EX|LOCK_NB:
5526             i = lockf (fd, F_TLOCK, 0);
5527             if (i == -1)
5528                 if ((errno == EAGAIN) || (errno == EACCES))
5529                     errno = EWOULDBLOCK;
5530             break;
5531
5532         /* LOCK_UN - unlock (non-blocking is a no-op) */
5533         case LOCK_UN:
5534         case LOCK_UN|LOCK_NB:
5535             i = lockf (fd, F_ULOCK, 0);
5536             break;
5537
5538         /* Default - can't decipher operation */
5539         default:
5540             i = -1;
5541             errno = EINVAL;
5542             break;
5543     }
5544
5545     if (pos > 0)      /* need to restore position of the handle */
5546         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5547
5548     return (i);
5549 }
5550
5551 #endif /* LOCKF_EMULATE_FLOCK */