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