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