pp_sys.c

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