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