pp_sys.c

   1 /*    pp_sys.c
   2  *
   3  *    Copyright (c) 1991-2003, 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     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3967         childpid = wait4pid(-1, &argflags, 0);
3968     else {
3969         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
3970                errno == EINTR) {
3971           PERL_ASYNC_CHECK();
3972         }
3973     }
3974 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3975     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3976     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3977 #  else
3978     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3979 #  endif
3980     XPUSHi(childpid);
3981     RETURN;
3982 #else
3983     DIE(aTHX_ PL_no_func, "wait");
3984 #endif
3985 }
3986
3987 PP(pp_waitpid)
3988 {
3989 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3990     dSP; dTARGET;
3991     Pid_t childpid;
3992     int optype;
3993     int argflags;
3994
3995     optype = POPi;
3996     childpid = TOPi;
3997     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3998         childpid = wait4pid(childpid, &argflags, optype);
3999     else {
4000         while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 &&
4001                errno == EINTR) {
4002           PERL_ASYNC_CHECK();
4003         }
4004     }
4005 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4006     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4007     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
4008 #  else
4009     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
4010 #  endif
4011     SETi(childpid);
4012     RETURN;
4013 #else
4014     DIE(aTHX_ PL_no_func, "waitpid");
4015 #endif
4016 }
4017
4018 PP(pp_system)
4019 {
4020     dSP; dMARK; dORIGMARK; dTARGET;
4021     I32 value;
4022     STRLEN n_a;
4023     int result;
4024     I32 did_pipes = 0;
4025
4026     if (PL_tainting) {
4027         TAINT_ENV();
4028         while (++MARK <= SP) {
4029             (void)SvPV_nolen(*MARK);      /* stringify for taint check */
4030             if (PL_tainted)
4031                 break;
4032         }
4033         MARK = ORIGMARK;
4034         TAINT_PROPER("system");
4035     }
4036     PERL_FLUSHALL_FOR_CHILD;
4037 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4038     {
4039         Pid_t childpid;
4040         int pp[2];
4041
4042         if (PerlProc_pipe(pp) >= 0)
4043             did_pipes = 1;
4044         while ((childpid = PerlProc_fork()) == -1) {
4045             if (errno != EAGAIN) {
4046                 value = -1;
4047                 SP = ORIGMARK;
4048                 PUSHi(value);
4049                 if (did_pipes) {
4050                     PerlLIO_close(pp[0]);
4051                     PerlLIO_close(pp[1]);
4052                 }
4053                 RETURN;
4054             }
4055             sleep(5);
4056         }
4057         if (childpid > 0) {
4058             Sigsave_t ihand,qhand; /* place to save signals during system() */
4059             int status;
4060
4061             if (did_pipes)
4062                 PerlLIO_close(pp[1]);
4063 #ifndef PERL_MICRO
4064             rsignal_save(SIGINT, SIG_IGN, &ihand);
4065             rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4066 #endif
4067             do {
4068                 result = wait4pid(childpid, &status, 0);
4069             } while (result == -1 && errno == EINTR);
4070 #ifndef PERL_MICRO
4071             (void)rsignal_restore(SIGINT, &ihand);
4072             (void)rsignal_restore(SIGQUIT, &qhand);
4073 #endif
4074             STATUS_NATIVE_SET(result == -1 ? -1 : status);
4075             do_execfree();      /* free any memory child malloced on fork */
4076             SP = ORIGMARK;
4077             if (did_pipes) {
4078                 int errkid;
4079                 int n = 0, n1;
4080
4081                 while (n < sizeof(int)) {
4082                     n1 = PerlLIO_read(pp[0],
4083                                       (void*)(((char*)&errkid)+n),
4084                                       (sizeof(int)) - n);
4085                     if (n1 <= 0)
4086                         break;
4087                     n += n1;
4088                 }
4089                 PerlLIO_close(pp[0]);
4090                 if (n) {                        /* Error */
4091                     if (n != sizeof(int))
4092                         DIE(aTHX_ "panic: kid popen errno read");
4093                     errno = errkid;             /* Propagate errno from kid */
4094                     STATUS_CURRENT = -1;
4095                 }
4096             }
4097             PUSHi(STATUS_CURRENT);
4098             RETURN;
4099         }
4100         if (did_pipes) {
4101             PerlLIO_close(pp[0]);
4102 #if defined(HAS_FCNTL) && defined(F_SETFD)
4103             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4104 #endif
4105         }
4106         if (PL_op->op_flags & OPf_STACKED) {
4107             SV *really = *++MARK;
4108             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4109         }
4110         else if (SP - MARK != 1)
4111             value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4112         else {
4113             value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4114         }
4115         PerlProc__exit(-1);
4116     }
4117 #else /* ! FORK or VMS or OS/2 */
4118     PL_statusvalue = 0;
4119     result = 0;
4120     if (PL_op->op_flags & OPf_STACKED) {
4121         SV *really = *++MARK;
4122 #  ifdef WIN32
4123         value = (I32)do_aspawn(really, MARK, SP);
4124 #  else
4125         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4126 #  endif
4127     }
4128     else if (SP - MARK != 1) {
4129 #  ifdef WIN32
4130         value = (I32)do_aspawn(Nullsv, MARK, SP);
4131 #  else
4132         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4133 #  endif
4134     }
4135     else {
4136         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4137     }
4138     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4139         result = 1;
4140     STATUS_NATIVE_SET(value);
4141     do_execfree();
4142     SP = ORIGMARK;
4143     PUSHi(result ? value : STATUS_CURRENT);
4144 #endif /* !FORK or VMS */
4145     RETURN;
4146 }
4147
4148 PP(pp_exec)
4149 {
4150     dSP; dMARK; dORIGMARK; dTARGET;
4151     I32 value;
4152     STRLEN n_a;
4153
4154     if (PL_tainting) {
4155         TAINT_ENV();
4156         while (++MARK <= SP) {
4157             (void)SvPV_nolen(*MARK);      /* stringify for taint check */
4158             if (PL_tainted)
4159                 break;
4160         }
4161         MARK = ORIGMARK;
4162         TAINT_PROPER("exec");
4163     }
4164     PERL_FLUSHALL_FOR_CHILD;
4165     if (PL_op->op_flags & OPf_STACKED) {
4166         SV *really = *++MARK;
4167         value = (I32)do_aexec(really, MARK, SP);
4168     }
4169     else if (SP - MARK != 1)
4170 #ifdef VMS
4171         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4172 #else
4173 #  ifdef __OPEN_VM
4174         {
4175            (void ) do_aspawn(Nullsv, MARK, SP);
4176            value = 0;
4177         }
4178 #  else
4179         value = (I32)do_aexec(Nullsv, MARK, SP);
4180 #  endif
4181 #endif
4182     else {
4183 #ifdef VMS
4184         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4185 #else
4186 #  ifdef __OPEN_VM
4187         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4188         value = 0;
4189 #  else
4190         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4191 #  endif
4192 #endif
4193     }
4194
4195     SP = ORIGMARK;
4196     PUSHi(value);
4197     RETURN;
4198 }
4199
4200 PP(pp_kill)
4201 {
4202 #ifdef HAS_KILL
4203     dSP; dMARK; dTARGET;
4204     I32 value;
4205     value = (I32)apply(PL_op->op_type, MARK, SP);
4206     SP = MARK;
4207     PUSHi(value);
4208     RETURN;
4209 #else
4210     DIE(aTHX_ PL_no_func, "kill");
4211 #endif
4212 }
4213
4214 PP(pp_getppid)
4215 {
4216 #ifdef HAS_GETPPID
4217     dSP; dTARGET;
4218 #   ifdef THREADS_HAVE_PIDS
4219     XPUSHi( PL_ppid );
4220 #   else
4221     XPUSHi( getppid() );
4222 #   endif
4223     RETURN;
4224 #else
4225     DIE(aTHX_ PL_no_func, "getppid");
4226 #endif
4227 }
4228
4229 PP(pp_getpgrp)
4230 {
4231 #ifdef HAS_GETPGRP
4232     dSP; dTARGET;
4233     Pid_t pid;
4234     Pid_t pgrp;
4235
4236     if (MAXARG < 1)
4237         pid = 0;
4238     else
4239         pid = SvIVx(POPs);
4240 #ifdef BSD_GETPGRP
4241     pgrp = (I32)BSD_GETPGRP(pid);
4242 #else
4243     if (pid != 0 && pid != PerlProc_getpid())
4244         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4245     pgrp = getpgrp();
4246 #endif
4247     XPUSHi(pgrp);
4248     RETURN;
4249 #else
4250     DIE(aTHX_ PL_no_func, "getpgrp()");
4251 #endif
4252 }
4253
4254 PP(pp_setpgrp)
4255 {
4256 #ifdef HAS_SETPGRP
4257     dSP; dTARGET;
4258     Pid_t pgrp;
4259     Pid_t pid;
4260     if (MAXARG < 2) {
4261         pgrp = 0;
4262         pid = 0;
4263     }
4264     else {
4265         pgrp = POPi;
4266         pid = TOPi;
4267     }
4268
4269     TAINT_PROPER("setpgrp");
4270 #ifdef BSD_SETPGRP
4271     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4272 #else
4273     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4274         || (pid != 0 && pid != PerlProc_getpid()))
4275     {
4276         DIE(aTHX_ "setpgrp can't take arguments");
4277     }
4278     SETi( setpgrp() >= 0 );
4279 #endif /* USE_BSDPGRP */
4280     RETURN;
4281 #else
4282     DIE(aTHX_ PL_no_func, "setpgrp()");
4283 #endif
4284 }
4285
4286 PP(pp_getpriority)
4287 {
4288 #ifdef HAS_GETPRIORITY
4289     dSP; dTARGET;
4290     int who = POPi;
4291     int which = TOPi;
4292     SETi( getpriority(which, who) );
4293     RETURN;
4294 #else
4295     DIE(aTHX_ PL_no_func, "getpriority()");
4296 #endif
4297 }
4298
4299 PP(pp_setpriority)
4300 {
4301 #ifdef HAS_SETPRIORITY
4302     dSP; dTARGET;
4303     int niceval = POPi;
4304     int who = POPi;
4305     int which = TOPi;
4306     TAINT_PROPER("setpriority");
4307     SETi( setpriority(which, who, niceval) >= 0 );
4308     RETURN;
4309 #else
4310     DIE(aTHX_ PL_no_func, "setpriority()");
4311 #endif
4312 }
4313
4314 /* Time calls. */
4315
4316 PP(pp_time)
4317 {
4318     dSP; dTARGET;
4319 #ifdef BIG_TIME
4320     XPUSHn( time(Null(Time_t*)) );
4321 #else
4322     XPUSHi( time(Null(Time_t*)) );
4323 #endif
4324     RETURN;
4325 }
4326
4327 PP(pp_tms)
4328 {
4329 #ifdef HAS_TIMES
4330     dSP;
4331     EXTEND(SP, 4);
4332 #ifndef VMS
4333     (void)PerlProc_times(&PL_timesbuf);
4334 #else
4335     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4336                                                    /* struct tms, though same data   */
4337                                                    /* is returned.                   */
4338 #endif
4339
4340     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4341     if (GIMME == G_ARRAY) {
4342         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4343         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4344         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4345     }
4346     RETURN;
4347 #else
4348     DIE(aTHX_ "times not implemented");
4349 #endif /* HAS_TIMES */
4350 }
4351
4352 PP(pp_localtime)
4353 {
4354     return pp_gmtime();
4355 }
4356
4357 PP(pp_gmtime)
4358 {
4359     dSP;
4360     Time_t when;
4361     struct tm *tmbuf;
4362     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4363     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4364                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4365
4366     if (MAXARG < 1)
4367         (void)time(&when);
4368     else
4369 #ifdef BIG_TIME
4370         when = (Time_t)SvNVx(POPs);
4371 #else
4372         when = (Time_t)SvIVx(POPs);
4373 #endif
4374
4375     if (PL_op->op_type == OP_LOCALTIME)
4376         tmbuf = localtime(&when);
4377     else
4378         tmbuf = gmtime(&when);
4379
4380     if (GIMME != G_ARRAY) {
4381         SV *tsv;
4382         EXTEND(SP, 1);
4383         EXTEND_MORTAL(1);
4384         if (!tmbuf)
4385             RETPUSHUNDEF;
4386         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4387                             dayname[tmbuf->tm_wday],
4388                             monname[tmbuf->tm_mon],
4389                             tmbuf->tm_mday,
4390                             tmbuf->tm_hour,
4391                             tmbuf->tm_min,
4392                             tmbuf->tm_sec,
4393                             tmbuf->tm_year + 1900);
4394         PUSHs(sv_2mortal(tsv));
4395     }
4396     else if (tmbuf) {
4397         EXTEND(SP, 9);
4398         EXTEND_MORTAL(9);
4399         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4400         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4401         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4402         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4403         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4404         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4405         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4406         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4407         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4408     }
4409     RETURN;
4410 }
4411
4412 PP(pp_alarm)
4413 {
4414 #ifdef HAS_ALARM
4415     dSP; dTARGET;
4416     int anum;
4417     anum = POPi;
4418     anum = alarm((unsigned int)anum);
4419     EXTEND(SP, 1);
4420     if (anum < 0)
4421         RETPUSHUNDEF;
4422     PUSHi(anum);
4423     RETURN;
4424 #else
4425     DIE(aTHX_ PL_no_func, "alarm");
4426 #endif
4427 }
4428
4429 PP(pp_sleep)
4430 {
4431     dSP; dTARGET;
4432     I32 duration;
4433     Time_t lasttime;
4434     Time_t when;
4435
4436     (void)time(&lasttime);
4437     if (MAXARG < 1)
4438         PerlProc_pause();
4439     else {
4440         duration = POPi;
4441         PerlProc_sleep((unsigned int)duration);
4442     }
4443     (void)time(&when);
4444     XPUSHi(when - lasttime);
4445     RETURN;
4446 }
4447
4448 /* Shared memory. */
4449
4450 PP(pp_shmget)
4451 {
4452     return pp_semget();
4453 }
4454
4455 PP(pp_shmctl)
4456 {
4457     return pp_semctl();
4458 }
4459
4460 PP(pp_shmread)
4461 {
4462     return pp_shmwrite();
4463 }
4464
4465 PP(pp_shmwrite)
4466 {
4467 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4468     dSP; dMARK; dTARGET;
4469     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4470     SP = MARK;
4471     PUSHi(value);
4472     RETURN;
4473 #else
4474     return pp_semget();
4475 #endif
4476 }
4477
4478 /* Message passing. */
4479
4480 PP(pp_msgget)
4481 {
4482     return pp_semget();
4483 }
4484
4485 PP(pp_msgctl)
4486 {
4487     return pp_semctl();
4488 }
4489
4490 PP(pp_msgsnd)
4491 {
4492 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4493     dSP; dMARK; dTARGET;
4494     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4495     SP = MARK;
4496     PUSHi(value);
4497     RETURN;
4498 #else
4499     return pp_semget();
4500 #endif
4501 }
4502
4503 PP(pp_msgrcv)
4504 {
4505 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4506     dSP; dMARK; dTARGET;
4507     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4508     SP = MARK;
4509     PUSHi(value);
4510     RETURN;
4511 #else
4512     return pp_semget();
4513 #endif
4514 }
4515
4516 /* Semaphores. */
4517
4518 PP(pp_semget)
4519 {
4520 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4521     dSP; dMARK; dTARGET;
4522     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4523     SP = MARK;
4524     if (anum == -1)
4525         RETPUSHUNDEF;
4526     PUSHi(anum);
4527     RETURN;
4528 #else
4529     DIE(aTHX_ "System V IPC is not implemented on this machine");
4530 #endif
4531 }
4532
4533 PP(pp_semctl)
4534 {
4535 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4536     dSP; dMARK; dTARGET;
4537     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4538     SP = MARK;
4539     if (anum == -1)
4540         RETSETUNDEF;
4541     if (anum != 0) {
4542         PUSHi(anum);
4543     }
4544     else {
4545         PUSHp(zero_but_true, ZBTLEN);
4546     }
4547     RETURN;
4548 #else
4549     return pp_semget();
4550 #endif
4551 }
4552
4553 PP(pp_semop)
4554 {
4555 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4556     dSP; dMARK; dTARGET;
4557     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4558     SP = MARK;
4559     PUSHi(value);
4560     RETURN;
4561 #else
4562     return pp_semget();
4563 #endif
4564 }
4565
4566 /* Get system info. */
4567
4568 PP(pp_ghbyname)
4569 {
4570 #ifdef HAS_GETHOSTBYNAME
4571     return pp_ghostent();
4572 #else
4573     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4574 #endif
4575 }
4576
4577 PP(pp_ghbyaddr)
4578 {
4579 #ifdef HAS_GETHOSTBYADDR
4580     return pp_ghostent();
4581 #else
4582     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4583 #endif
4584 }
4585
4586 PP(pp_ghostent)
4587 {
4588 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4589     dSP;
4590     I32 which = PL_op->op_type;
4591     register char **elem;
4592     register SV *sv;
4593 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4594     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4595     struct hostent *gethostbyname(Netdb_name_t);
4596     struct hostent *gethostent(void);
4597 #endif
4598     struct hostent *hent;
4599     unsigned long len;
4600     STRLEN n_a;
4601
4602     EXTEND(SP, 10);
4603     if (which == OP_GHBYNAME) {
4604 #ifdef HAS_GETHOSTBYNAME
4605         char* name = POPpbytex;
4606         hent = PerlSock_gethostbyname(name);
4607 #else
4608         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4609 #endif
4610     }
4611     else if (which == OP_GHBYADDR) {
4612 #ifdef HAS_GETHOSTBYADDR
4613         int addrtype = POPi;
4614         SV *addrsv = POPs;
4615         STRLEN addrlen;
4616         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4617
4618         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4619 #else
4620         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4621 #endif
4622     }
4623     else
4624 #ifdef HAS_GETHOSTENT
4625         hent = PerlSock_gethostent();
4626 #else
4627         DIE(aTHX_ PL_no_sock_func, "gethostent");
4628 #endif
4629
4630 #ifdef HOST_NOT_FOUND
4631         if (!hent) {
4632 #ifdef USE_REENTRANT_API
4633 #   ifdef USE_GETHOSTENT_ERRNO
4634             h_errno = PL_reentrant_buffer->_gethostent_errno;
4635 #   endif
4636 #endif
4637             STATUS_NATIVE_SET(h_errno);
4638         }
4639 #endif
4640
4641     if (GIMME != G_ARRAY) {
4642         PUSHs(sv = sv_newmortal());
4643         if (hent) {
4644             if (which == OP_GHBYNAME) {
4645                 if (hent->h_addr)
4646                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4647             }
4648             else
4649                 sv_setpv(sv, (char*)hent->h_name);
4650         }
4651         RETURN;
4652     }
4653
4654     if (hent) {
4655         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4656         sv_setpv(sv, (char*)hent->h_name);
4657         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4658         for (elem = hent->h_aliases; elem && *elem; elem++) {
4659             sv_catpv(sv, *elem);
4660             if (elem[1])
4661                 sv_catpvn(sv, " ", 1);
4662         }
4663         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4664         sv_setiv(sv, (IV)hent->h_addrtype);
4665         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4666         len = hent->h_length;
4667         sv_setiv(sv, (IV)len);
4668 #ifdef h_addr
4669         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4670             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4671             sv_setpvn(sv, *elem, len);
4672         }
4673 #else
4674         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4675         if (hent->h_addr)
4676             sv_setpvn(sv, hent->h_addr, len);
4677 #endif /* h_addr */
4678     }
4679     RETURN;
4680 #else
4681     DIE(aTHX_ PL_no_sock_func, "gethostent");
4682 #endif
4683 }
4684
4685 PP(pp_gnbyname)
4686 {
4687 #ifdef HAS_GETNETBYNAME
4688     return pp_gnetent();
4689 #else
4690     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4691 #endif
4692 }
4693
4694 PP(pp_gnbyaddr)
4695 {
4696 #ifdef HAS_GETNETBYADDR
4697     return pp_gnetent();
4698 #else
4699     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4700 #endif
4701 }
4702
4703 PP(pp_gnetent)
4704 {
4705 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4706     dSP;
4707     I32 which = PL_op->op_type;
4708     register char **elem;
4709     register SV *sv;
4710 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4711     struct netent *getnetbyaddr(Netdb_net_t, int);
4712     struct netent *getnetbyname(Netdb_name_t);
4713     struct netent *getnetent(void);
4714 #endif
4715     struct netent *nent;
4716     STRLEN n_a;
4717
4718     if (which == OP_GNBYNAME){
4719 #ifdef HAS_GETNETBYNAME
4720         char *name = POPpbytex;
4721         nent = PerlSock_getnetbyname(name);
4722 #else
4723         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4724 #endif
4725     }
4726     else if (which == OP_GNBYADDR) {
4727 #ifdef HAS_GETNETBYADDR
4728         int addrtype = POPi;
4729         Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4730         nent = PerlSock_getnetbyaddr(addr, addrtype);
4731 #else
4732         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4733 #endif
4734     }
4735     else
4736 #ifdef HAS_GETNETENT
4737         nent = PerlSock_getnetent();
4738 #else
4739         DIE(aTHX_ PL_no_sock_func, "getnetent");
4740 #endif
4741
4742 #ifdef HOST_NOT_FOUND
4743         if (!nent) {
4744 #ifdef USE_REENTRANT_API
4745 #   ifdef USE_GETNETENT_ERRNO
4746              h_errno = PL_reentrant_buffer->_getnetent_errno;
4747 #   endif
4748 #endif
4749             STATUS_NATIVE_SET(h_errno);
4750         }
4751 #endif
4752
4753     EXTEND(SP, 4);
4754     if (GIMME != G_ARRAY) {
4755         PUSHs(sv = sv_newmortal());
4756         if (nent) {
4757             if (which == OP_GNBYNAME)
4758                 sv_setiv(sv, (IV)nent->n_net);
4759             else
4760                 sv_setpv(sv, nent->n_name);
4761         }
4762         RETURN;
4763     }
4764
4765     if (nent) {
4766         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4767         sv_setpv(sv, nent->n_name);
4768         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4769         for (elem = nent->n_aliases; elem && *elem; elem++) {
4770             sv_catpv(sv, *elem);
4771             if (elem[1])
4772                 sv_catpvn(sv, " ", 1);
4773         }
4774         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4775         sv_setiv(sv, (IV)nent->n_addrtype);
4776         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4777         sv_setiv(sv, (IV)nent->n_net);
4778     }
4779
4780     RETURN;
4781 #else
4782     DIE(aTHX_ PL_no_sock_func, "getnetent");
4783 #endif
4784 }
4785
4786 PP(pp_gpbyname)
4787 {
4788 #ifdef HAS_GETPROTOBYNAME
4789     return pp_gprotoent();
4790 #else
4791     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4792 #endif
4793 }
4794
4795 PP(pp_gpbynumber)
4796 {
4797 #ifdef HAS_GETPROTOBYNUMBER
4798     return pp_gprotoent();
4799 #else
4800     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4801 #endif
4802 }
4803
4804 PP(pp_gprotoent)
4805 {
4806 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4807     dSP;
4808     I32 which = PL_op->op_type;
4809     register char **elem;
4810     register SV *sv;
4811 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4812     struct protoent *getprotobyname(Netdb_name_t);
4813     struct protoent *getprotobynumber(int);
4814     struct protoent *getprotoent(void);
4815 #endif
4816     struct protoent *pent;
4817     STRLEN n_a;
4818
4819     if (which == OP_GPBYNAME) {
4820 #ifdef HAS_GETPROTOBYNAME
4821         char* name = POPpbytex;
4822         pent = PerlSock_getprotobyname(name);
4823 #else
4824         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4825 #endif
4826     }
4827     else if (which == OP_GPBYNUMBER) {
4828 #ifdef HAS_GETPROTOBYNUMBER
4829         int number = POPi;
4830         pent = PerlSock_getprotobynumber(number);
4831 #else
4832         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4833 #endif
4834     }
4835     else
4836 #ifdef HAS_GETPROTOENT
4837         pent = PerlSock_getprotoent();
4838 #else
4839         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4840 #endif
4841
4842     EXTEND(SP, 3);
4843     if (GIMME != G_ARRAY) {
4844         PUSHs(sv = sv_newmortal());
4845         if (pent) {
4846             if (which == OP_GPBYNAME)
4847                 sv_setiv(sv, (IV)pent->p_proto);
4848             else
4849                 sv_setpv(sv, pent->p_name);
4850         }
4851         RETURN;
4852     }
4853
4854     if (pent) {
4855         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4856         sv_setpv(sv, pent->p_name);
4857         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4858         for (elem = pent->p_aliases; elem && *elem; elem++) {
4859             sv_catpv(sv, *elem);
4860             if (elem[1])
4861                 sv_catpvn(sv, " ", 1);
4862         }
4863         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4864         sv_setiv(sv, (IV)pent->p_proto);
4865     }
4866
4867     RETURN;
4868 #else
4869     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4870 #endif
4871 }
4872
4873 PP(pp_gsbyname)
4874 {
4875 #ifdef HAS_GETSERVBYNAME
4876     return pp_gservent();
4877 #else
4878     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4879 #endif
4880 }
4881
4882 PP(pp_gsbyport)
4883 {
4884 #ifdef HAS_GETSERVBYPORT
4885     return pp_gservent();
4886 #else
4887     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4888 #endif
4889 }
4890
4891 PP(pp_gservent)
4892 {
4893 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4894     dSP;
4895     I32 which = PL_op->op_type;
4896     register char **elem;
4897     register SV *sv;
4898 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4899     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4900     struct servent *getservbyport(int, Netdb_name_t);
4901     struct servent *getservent(void);
4902 #endif
4903     struct servent *sent;
4904     STRLEN n_a;
4905
4906     if (which == OP_GSBYNAME) {
4907 #ifdef HAS_GETSERVBYNAME
4908         char *proto = POPpbytex;
4909         char *name = POPpbytex;
4910
4911         if (proto && !*proto)
4912             proto = Nullch;
4913
4914         sent = PerlSock_getservbyname(name, proto);
4915 #else
4916         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4917 #endif
4918     }
4919     else if (which == OP_GSBYPORT) {
4920 #ifdef HAS_GETSERVBYPORT
4921         char *proto = POPpbytex;
4922         unsigned short port = (unsigned short)POPu;
4923
4924         if (proto && !*proto)
4925             proto = Nullch;
4926
4927 #ifdef HAS_HTONS
4928         port = PerlSock_htons(port);
4929 #endif
4930         sent = PerlSock_getservbyport(port, proto);
4931 #else
4932         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4933 #endif
4934     }
4935     else
4936 #ifdef HAS_GETSERVENT
4937         sent = PerlSock_getservent();
4938 #else
4939         DIE(aTHX_ PL_no_sock_func, "getservent");
4940 #endif
4941
4942     EXTEND(SP, 4);
4943     if (GIMME != G_ARRAY) {
4944         PUSHs(sv = sv_newmortal());
4945         if (sent) {
4946             if (which == OP_GSBYNAME) {
4947 #ifdef HAS_NTOHS
4948                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4949 #else
4950                 sv_setiv(sv, (IV)(sent->s_port));
4951 #endif
4952             }
4953             else
4954                 sv_setpv(sv, sent->s_name);
4955         }
4956         RETURN;
4957     }
4958
4959     if (sent) {
4960         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4961         sv_setpv(sv, sent->s_name);
4962         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4963         for (elem = sent->s_aliases; elem && *elem; elem++) {
4964             sv_catpv(sv, *elem);
4965             if (elem[1])
4966                 sv_catpvn(sv, " ", 1);
4967         }
4968         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4969 #ifdef HAS_NTOHS
4970         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4971 #else
4972         sv_setiv(sv, (IV)(sent->s_port));
4973 #endif
4974         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4975         sv_setpv(sv, sent->s_proto);
4976     }
4977
4978     RETURN;
4979 #else
4980     DIE(aTHX_ PL_no_sock_func, "getservent");
4981 #endif
4982 }
4983
4984 PP(pp_shostent)
4985 {
4986 #ifdef HAS_SETHOSTENT
4987     dSP;
4988     PerlSock_sethostent(TOPi);
4989     RETSETYES;
4990 #else
4991     DIE(aTHX_ PL_no_sock_func, "sethostent");
4992 #endif
4993 }
4994
4995 PP(pp_snetent)
4996 {
4997 #ifdef HAS_SETNETENT
4998     dSP;
4999     PerlSock_setnetent(TOPi);
5000     RETSETYES;
5001 #else
5002     DIE(aTHX_ PL_no_sock_func, "setnetent");
5003 #endif
5004 }
5005
5006 PP(pp_sprotoent)
5007 {
5008 #ifdef HAS_SETPROTOENT
5009     dSP;
5010     PerlSock_setprotoent(TOPi);
5011     RETSETYES;
5012 #else
5013     DIE(aTHX_ PL_no_sock_func, "setprotoent");
5014 #endif
5015 }
5016
5017 PP(pp_sservent)
5018 {
5019 #ifdef HAS_SETSERVENT
5020     dSP;
5021     PerlSock_setservent(TOPi);
5022     RETSETYES;
5023 #else
5024     DIE(aTHX_ PL_no_sock_func, "setservent");
5025 #endif
5026 }
5027
5028 PP(pp_ehostent)
5029 {
5030 #ifdef HAS_ENDHOSTENT
5031     dSP;
5032     PerlSock_endhostent();
5033     EXTEND(SP,1);
5034     RETPUSHYES;
5035 #else
5036     DIE(aTHX_ PL_no_sock_func, "endhostent");
5037 #endif
5038 }
5039
5040 PP(pp_enetent)
5041 {
5042 #ifdef HAS_ENDNETENT
5043     dSP;
5044     PerlSock_endnetent();
5045     EXTEND(SP,1);
5046     RETPUSHYES;
5047 #else
5048     DIE(aTHX_ PL_no_sock_func, "endnetent");
5049 #endif
5050 }
5051
5052 PP(pp_eprotoent)
5053 {
5054 #ifdef HAS_ENDPROTOENT
5055     dSP;
5056     PerlSock_endprotoent();
5057     EXTEND(SP,1);
5058     RETPUSHYES;
5059 #else
5060     DIE(aTHX_ PL_no_sock_func, "endprotoent");
5061 #endif
5062 }
5063
5064 PP(pp_eservent)
5065 {
5066 #ifdef HAS_ENDSERVENT
5067     dSP;
5068     PerlSock_endservent();
5069     EXTEND(SP,1);
5070     RETPUSHYES;
5071 #else
5072     DIE(aTHX_ PL_no_sock_func, "endservent");
5073 #endif
5074 }
5075
5076 PP(pp_gpwnam)
5077 {
5078 #ifdef HAS_PASSWD
5079     return pp_gpwent();
5080 #else
5081     DIE(aTHX_ PL_no_func, "getpwnam");
5082 #endif
5083 }
5084
5085 PP(pp_gpwuid)
5086 {
5087 #ifdef HAS_PASSWD
5088     return pp_gpwent();
5089 #else
5090     DIE(aTHX_ PL_no_func, "getpwuid");
5091 #endif
5092 }
5093
5094 PP(pp_gpwent)
5095 {
5096 #ifdef HAS_PASSWD
5097     dSP;
5098     I32 which = PL_op->op_type;
5099     register SV *sv;
5100     STRLEN n_a;
5101     struct passwd *pwent  = NULL;
5102     /*
5103      * We currently support only the SysV getsp* shadow password interface.
5104      * The interface is declared in <shadow.h> and often one needs to link
5105      * with -lsecurity or some such.
5106      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5107      * (and SCO?)
5108      *
5109      * AIX getpwnam() is clever enough to return the encrypted password
5110      * only if the caller (euid?) is root.
5111      *
5112      * There are at least two other shadow password APIs.  Many platforms
5113      * seem to contain more than one interface for accessing the shadow
5114      * password databases, possibly for compatibility reasons.
5115      * The getsp*() is by far he simplest one, the other two interfaces
5116      * are much more complicated, but also very similar to each other.
5117      *
5118      * <sys/types.h>
5119      * <sys/security.h>
5120      * <prot.h>
5121      * struct pr_passwd *getprpw*();
5122      * The password is in
5123      * char getprpw*(...).ufld.fd_encrypt[]
5124      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5125      *
5126      * <sys/types.h>
5127      * <sys/security.h>
5128      * <prot.h>
5129      * struct es_passwd *getespw*();
5130      * The password is in
5131      * char *(getespw*(...).ufld.fd_encrypt)
5132      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5133      *
5134      * Mention I_PROT here so that Configure probes for it.
5135      *
5136      * In HP-UX for getprpw*() the manual page claims that one should include
5137      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5138      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5139      * and pp_sys.c already includes <shadow.h> if there is such.
5140      *
5141      * Note that <sys/security.h> is already probed for, but currently
5142      * it is only included in special cases.
5143      *
5144      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5145      * be preferred interface, even though also the getprpw*() interface
5146      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5147      * One also needs to call set_auth_parameters() in main() before
5148      * doing anything else, whether one is using getespw*() or getprpw*().
5149      *
5150      * Note that accessing the shadow databases can be magnitudes
5151      * slower than accessing the standard databases.
5152      *
5153      * --jhi
5154      */
5155
5156     switch (which) {
5157     case OP_GPWNAM:
5158       {
5159         char* name = POPpbytex;
5160         pwent  = getpwnam(name);
5161       }
5162       break;
5163     case OP_GPWUID:
5164       {
5165         Uid_t uid = POPi;
5166         pwent = getpwuid(uid);
5167       }
5168         break;
5169     case OP_GPWENT:
5170 #   ifdef HAS_GETPWENT
5171         pwent  = getpwent();
5172 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5173         if (pwent) pwent = getpwnam(pwent->pw_name);
5174 #endif
5175 #   else
5176         DIE(aTHX_ PL_no_func, "getpwent");
5177 #   endif
5178         break;
5179     }
5180
5181     EXTEND(SP, 10);
5182     if (GIMME != G_ARRAY) {
5183         PUSHs(sv = sv_newmortal());
5184         if (pwent) {
5185             if (which == OP_GPWNAM)
5186 #   if Uid_t_sign <= 0
5187                 sv_setiv(sv, (IV)pwent->pw_uid);
5188 #   else
5189                 sv_setuv(sv, (UV)pwent->pw_uid);
5190 #   endif
5191             else
5192                 sv_setpv(sv, pwent->pw_name);
5193         }
5194         RETURN;
5195     }
5196
5197     if (pwent) {
5198         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5199         sv_setpv(sv, pwent->pw_name);
5200
5201         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5202         SvPOK_off(sv);
5203         /* If we have getspnam(), we try to dig up the shadow
5204          * password.  If we are underprivileged, the shadow
5205          * interface will set the errno to EACCES or similar,
5206          * and return a null pointer.  If this happens, we will
5207          * use the dummy password (usually "*" or "x") from the
5208          * standard password database.
5209          *
5210          * In theory we could skip the shadow call completely
5211          * if euid != 0 but in practice we cannot know which
5212          * security measures are guarding the shadow databases
5213          * on a random platform.
5214          *
5215          * Resist the urge to use additional shadow interfaces.
5216          * Divert the urge to writing an extension instead.
5217          *
5218          * --jhi */
5219 #   ifdef HAS_GETSPNAM
5220         {
5221             struct spwd *spwent;
5222             int saverrno; /* Save and restore errno so that
5223                            * underprivileged attempts seem
5224                            * to have never made the unsccessful
5225                            * attempt to retrieve the shadow password. */
5226
5227             saverrno = errno;
5228             spwent = getspnam(pwent->pw_name);
5229             errno = saverrno;
5230             if (spwent && spwent->sp_pwdp)
5231                 sv_setpv(sv, spwent->sp_pwdp);
5232         }
5233 #   endif
5234 #   ifdef PWPASSWD
5235         if (!SvPOK(sv)) /* Use the standard password, then. */
5236             sv_setpv(sv, pwent->pw_passwd);
5237 #   endif
5238
5239 #   ifndef INCOMPLETE_TAINTS
5240         /* passwd is tainted because user himself can diddle with it.
5241          * admittedly not much and in a very limited way, but nevertheless. */
5242         SvTAINTED_on(sv);
5243 #   endif
5244
5245         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5246 #   if Uid_t_sign <= 0
5247         sv_setiv(sv, (IV)pwent->pw_uid);
5248 #   else
5249         sv_setuv(sv, (UV)pwent->pw_uid);
5250 #   endif
5251
5252         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5253 #   if Uid_t_sign <= 0
5254         sv_setiv(sv, (IV)pwent->pw_gid);
5255 #   else
5256         sv_setuv(sv, (UV)pwent->pw_gid);
5257 #   endif
5258         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5259          * because of the poor interface of the Perl getpw*(),
5260          * not because there's some standard/convention saying so.
5261          * A better interface would have been to return a hash,
5262          * but we are accursed by our history, alas. --jhi.  */
5263         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5264 #   ifdef PWCHANGE
5265         sv_setiv(sv, (IV)pwent->pw_change);
5266 #   else
5267 #       ifdef PWQUOTA
5268         sv_setiv(sv, (IV)pwent->pw_quota);
5269 #       else
5270 #           ifdef PWAGE
5271         sv_setpv(sv, pwent->pw_age);
5272 #           endif
5273 #       endif
5274 #   endif
5275
5276         /* pw_class and pw_comment are mutually exclusive--.
5277          * see the above note for pw_change, pw_quota, and pw_age. */
5278         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5279 #   ifdef PWCLASS
5280         sv_setpv(sv, pwent->pw_class);
5281 #   else
5282 #       ifdef PWCOMMENT
5283         sv_setpv(sv, pwent->pw_comment);
5284 #       endif
5285 #   endif
5286
5287         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5288 #   ifdef PWGECOS
5289         sv_setpv(sv, pwent->pw_gecos);
5290 #   endif
5291 #   ifndef INCOMPLETE_TAINTS
5292         /* pw_gecos is tainted because user himself can diddle with it. */
5293         SvTAINTED_on(sv);
5294 #   endif
5295
5296         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5297         sv_setpv(sv, pwent->pw_dir);
5298
5299         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5300         sv_setpv(sv, pwent->pw_shell);
5301 #   ifndef INCOMPLETE_TAINTS
5302         /* pw_shell is tainted because user himself can diddle with it. */
5303         SvTAINTED_on(sv);
5304 #   endif
5305
5306 #   ifdef PWEXPIRE
5307         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5308         sv_setiv(sv, (IV)pwent->pw_expire);
5309 #   endif
5310     }
5311     RETURN;
5312 #else
5313     DIE(aTHX_ PL_no_func, "getpwent");
5314 #endif
5315 }
5316
5317 PP(pp_spwent)
5318 {
5319 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5320     dSP;
5321     setpwent();
5322     RETPUSHYES;
5323 #else
5324     DIE(aTHX_ PL_no_func, "setpwent");
5325 #endif
5326 }
5327
5328 PP(pp_epwent)
5329 {
5330 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5331     dSP;
5332     endpwent();
5333     RETPUSHYES;
5334 #else
5335     DIE(aTHX_ PL_no_func, "endpwent");
5336 #endif
5337 }
5338
5339 PP(pp_ggrnam)
5340 {
5341 #ifdef HAS_GROUP
5342     return pp_ggrent();
5343 #else
5344     DIE(aTHX_ PL_no_func, "getgrnam");
5345 #endif
5346 }
5347
5348 PP(pp_ggrgid)
5349 {
5350 #ifdef HAS_GROUP
5351     return pp_ggrent();
5352 #else
5353     DIE(aTHX_ PL_no_func, "getgrgid");
5354 #endif
5355 }
5356
5357 PP(pp_ggrent)
5358 {
5359 #ifdef HAS_GROUP
5360     dSP;
5361     I32 which = PL_op->op_type;
5362     register char **elem;
5363     register SV *sv;
5364     struct group *grent;
5365     STRLEN n_a;
5366
5367     if (which == OP_GGRNAM) {
5368         char* name = POPpbytex;
5369         grent = (struct group *)getgrnam(name);
5370     }
5371     else if (which == OP_GGRGID) {
5372         Gid_t gid = POPi;
5373         grent = (struct group *)getgrgid(gid);
5374     }
5375     else
5376 #ifdef HAS_GETGRENT
5377         grent = (struct group *)getgrent();
5378 #else
5379         DIE(aTHX_ PL_no_func, "getgrent");
5380 #endif
5381
5382     EXTEND(SP, 4);
5383     if (GIMME != G_ARRAY) {
5384         PUSHs(sv = sv_newmortal());
5385         if (grent) {
5386             if (which == OP_GGRNAM)
5387                 sv_setiv(sv, (IV)grent->gr_gid);
5388             else
5389                 sv_setpv(sv, grent->gr_name);
5390         }
5391         RETURN;
5392     }
5393
5394     if (grent) {
5395         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5396         sv_setpv(sv, grent->gr_name);
5397
5398         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5399 #ifdef GRPASSWD
5400         sv_setpv(sv, grent->gr_passwd);
5401 #endif
5402
5403         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5404         sv_setiv(sv, (IV)grent->gr_gid);
5405
5406 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5407         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5408         /* In UNICOS/mk (_CRAYMPP) the multithreading
5409          * versions (getgrnam_r, getgrgid_r)
5410          * seem to return an illegal pointer
5411          * as the group members list, gr_mem.
5412          * getgrent() doesn't even have a _r version
5413          * but the gr_mem is poisonous anyway.
5414          * So yes, you cannot get the list of group
5415          * members if building multithreaded in UNICOS/mk. */
5416         for (elem = grent->gr_mem; elem && *elem; elem++) {
5417             sv_catpv(sv, *elem);
5418             if (elem[1])
5419                 sv_catpvn(sv, " ", 1);
5420         }
5421 #endif
5422     }
5423
5424     RETURN;
5425 #else
5426     DIE(aTHX_ PL_no_func, "getgrent");
5427 #endif
5428 }
5429
5430 PP(pp_sgrent)
5431 {
5432 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5433     dSP;
5434     setgrent();
5435     RETPUSHYES;
5436 #else
5437     DIE(aTHX_ PL_no_func, "setgrent");
5438 #endif
5439 }
5440
5441 PP(pp_egrent)
5442 {
5443 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5444     dSP;
5445     endgrent();
5446     RETPUSHYES;
5447 #else
5448     DIE(aTHX_ PL_no_func, "endgrent");
5449 #endif
5450 }
5451
5452 PP(pp_getlogin)
5453 {
5454 #ifdef HAS_GETLOGIN
5455     dSP; dTARGET;
5456     char *tmps;
5457     EXTEND(SP, 1);
5458     if (!(tmps = PerlProc_getlogin()))
5459         RETPUSHUNDEF;
5460     PUSHp(tmps, strlen(tmps));
5461     RETURN;
5462 #else
5463     DIE(aTHX_ PL_no_func, "getlogin");
5464 #endif
5465 }
5466
5467 /* Miscellaneous. */
5468
5469 PP(pp_syscall)
5470 {
5471 #ifdef HAS_SYSCALL
5472     dSP; dMARK; dORIGMARK; dTARGET;
5473     register I32 items = SP - MARK;
5474     unsigned long a[20];
5475     register I32 i = 0;
5476     I32 retval = -1;
5477     STRLEN n_a;
5478
5479     if (PL_tainting) {
5480         while (++MARK <= SP) {
5481             if (SvTAINTED(*MARK)) {
5482                 TAINT;
5483                 break;
5484             }
5485         }
5486         MARK = ORIGMARK;
5487         TAINT_PROPER("syscall");
5488     }
5489
5490     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5491      * or where sizeof(long) != sizeof(char*).  But such machines will
5492      * not likely have syscall implemented either, so who cares?
5493      */
5494     while (++MARK <= SP) {
5495         if (SvNIOK(*MARK) || !i)
5496             a[i++] = SvIV(*MARK);
5497         else if (*MARK == &PL_sv_undef)
5498             a[i++] = 0;
5499         else
5500             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5501         if (i > 15)
5502             break;
5503     }
5504     switch (items) {
5505     default:
5506         DIE(aTHX_ "Too many args to syscall");
5507     case 0:
5508         DIE(aTHX_ "Too few args to syscall");
5509     case 1:
5510         retval = syscall(a[0]);
5511         break;
5512     case 2:
5513         retval = syscall(a[0],a[1]);
5514         break;
5515     case 3:
5516         retval = syscall(a[0],a[1],a[2]);
5517         break;
5518     case 4:
5519         retval = syscall(a[0],a[1],a[2],a[3]);
5520         break;
5521     case 5:
5522         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5523         break;
5524     case 6:
5525         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5526         break;
5527     case 7:
5528         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5529         break;
5530     case 8:
5531         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5532         break;
5533 #ifdef atarist
5534     case 9:
5535         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5536         break;
5537     case 10:
5538         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5539         break;
5540     case 11:
5541         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5542           a[10]);
5543         break;
5544     case 12:
5545         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5546           a[10],a[11]);
5547         break;
5548     case 13:
5549         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5550           a[10],a[11],a[12]);
5551         break;
5552     case 14:
5553         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5554           a[10],a[11],a[12],a[13]);
5555         break;
5556 #endif /* atarist */
5557     }
5558     SP = ORIGMARK;
5559     PUSHi(retval);
5560     RETURN;
5561 #else
5562     DIE(aTHX_ PL_no_func, "syscall");
5563 #endif
5564 }
5565
5566 #ifdef FCNTL_EMULATE_FLOCK
5567
5568 /*  XXX Emulate flock() with fcntl().
5569     What's really needed is a good file locking module.
5570 */
5571
5572 static int
5573 fcntl_emulate_flock(int fd, int operation)
5574 {
5575     struct flock flock;
5576
5577     switch (operation & ~LOCK_NB) {
5578     case LOCK_SH:
5579         flock.l_type = F_RDLCK;
5580         break;
5581     case LOCK_EX:
5582         flock.l_type = F_WRLCK;
5583         break;
5584     case LOCK_UN:
5585         flock.l_type = F_UNLCK;
5586         break;
5587     default:
5588         errno = EINVAL;
5589         return -1;
5590     }
5591     flock.l_whence = SEEK_SET;
5592     flock.l_start = flock.l_len = (Off_t)0;
5593
5594     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5595 }
5596
5597 #endif /* FCNTL_EMULATE_FLOCK */
5598
5599 #ifdef LOCKF_EMULATE_FLOCK
5600
5601 /*  XXX Emulate flock() with lockf().  This is just to increase
5602     portability of scripts.  The calls are not completely
5603     interchangeable.  What's really needed is a good file
5604     locking module.
5605 */
5606
5607 /*  The lockf() constants might have been defined in <unistd.h>.
5608     Unfortunately, <unistd.h> causes troubles on some mixed
5609     (BSD/POSIX) systems, such as SunOS 4.1.3.
5610
5611    Further, the lockf() constants aren't POSIX, so they might not be
5612    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5613    just stick in the SVID values and be done with it.  Sigh.
5614 */
5615
5616 # ifndef F_ULOCK
5617 #  define F_ULOCK       0       /* Unlock a previously locked region */
5618 # endif
5619 # ifndef F_LOCK
5620 #  define F_LOCK        1       /* Lock a region for exclusive use */
5621 # endif
5622 # ifndef F_TLOCK
5623 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5624 # endif
5625 # ifndef F_TEST
5626 #  define F_TEST        3       /* Test a region for other processes locks */
5627 # endif
5628
5629 static int
5630 lockf_emulate_flock(int fd, int operation)
5631 {
5632     int i;
5633     int save_errno;
5634     Off_t pos;
5635
5636     /* flock locks entire file so for lockf we need to do the same      */
5637     save_errno = errno;
5638     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5639     if (pos > 0)        /* is seekable and needs to be repositioned     */
5640         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5641             pos = -1;   /* seek failed, so don't seek back afterwards   */
5642     errno = save_errno;
5643
5644     switch (operation) {
5645
5646         /* LOCK_SH - get a shared lock */
5647         case LOCK_SH:
5648         /* LOCK_EX - get an exclusive lock */
5649         case LOCK_EX:
5650             i = lockf (fd, F_LOCK, 0);
5651             break;
5652
5653         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5654         case LOCK_SH|LOCK_NB:
5655         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5656         case LOCK_EX|LOCK_NB:
5657             i = lockf (fd, F_TLOCK, 0);
5658             if (i == -1)
5659                 if ((errno == EAGAIN) || (errno == EACCES))
5660                     errno = EWOULDBLOCK;
5661             break;
5662
5663         /* LOCK_UN - unlock (non-blocking is a no-op) */
5664         case LOCK_UN:
5665         case LOCK_UN|LOCK_NB:
5666             i = lockf (fd, F_ULOCK, 0);
5667             break;
5668
5669         /* Default - can't decipher operation */
5670         default:
5671             i = -1;
5672             errno = EINVAL;
5673             break;
5674     }
5675
5676     if (pos > 0)      /* need to restore position of the handle */
5677         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5678
5679     return (i);
5680 }
5681
5682 #endif /* LOCKF_EMULATE_FLOCK */