pp_sys.c

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