pp_sys.c

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