pp_sys.c

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