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     {
1773         count = PerlIO_read(IoIFP(io), buffer, length);
1774         /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1775         if (count == 0 && PerlIO_error(IoIFP(io)))
1776             count = -1;
1777     }
1778     if (count < 0) {
1779         if (IoTYPE(io) == IoTYPE_WRONLY)
1780             report_wrongway_fh(gv, '>');
1781         goto say_undef;
1782     }
1783     SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1784     *SvEND(read_target) = '\0';
1785     (void)SvPOK_only(read_target);
1786     if (fp_utf8 && !IN_BYTES) {
1787         /* Look at utf8 we got back and count the characters */
1788         const char *bend = buffer + count;
1789         while (buffer < bend) {
1790             if (charstart) {
1791                 skip = UTF8SKIP(buffer);
1792                 charskip = 0;
1793             }
1794             if (buffer - charskip + skip > bend) {
1795                 /* partial character - try for rest of it */
1796                 length = skip - (bend-buffer);
1797                 offset = bend - SvPVX_const(bufsv);
1798                 charstart = FALSE;
1799                 charskip += count;
1800                 goto more_bytes;
1801             }
1802             else {
1803                 got++;
1804                 buffer += skip;
1805                 charstart = TRUE;
1806                 charskip  = 0;
1807             }
1808         }
1809         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1810            provided amount read (count) was what was requested (length)
1811          */
1812         if (got < wanted && count == length) {
1813             length = wanted - got;
1814             offset = bend - SvPVX_const(bufsv);
1815             goto more_bytes;
1816         }
1817         /* return value is character count */
1818         count = got;
1819         SvUTF8_on(bufsv);
1820     }
1821     else if (buffer_utf8) {
1822         /* Let svcatsv upgrade the bytes we read in to utf8.
1823            The buffer is a mortal so will be freed soon.  */
1824         sv_catsv_nomg(bufsv, read_target);
1825     }
1826     SvSETMAGIC(bufsv);
1827     /* This should not be marked tainted if the fp is marked clean */
1828     if (!(IoFLAGS(io) & IOf_UNTAINT))
1829         SvTAINTED_on(bufsv);
1830     SP = ORIGMARK;
1831     PUSHi(count);
1832     RETURN;
1833
1834   say_undef:
1835     SP = ORIGMARK;
1836     RETPUSHUNDEF;
1837 }
1838
1839 PP(pp_syswrite)
1840 {
1841     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1842     SV *bufsv;
1843     const char *buffer;
1844     SSize_t retval;
1845     STRLEN blen;
1846     STRLEN orig_blen_bytes;
1847     const int op_type = PL_op->op_type;
1848     bool doing_utf8;
1849     U8 *tmpbuf = NULL;
1850     GV *const gv = MUTABLE_GV(*++MARK);
1851     IO *const io = GvIO(gv);
1852
1853     if (op_type == OP_SYSWRITE && io) {
1854         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1855         if (mg) {
1856             if (MARK == SP - 1) {
1857                 SV *sv = *SP;
1858                 mXPUSHi(sv_len(sv));
1859                 PUTBACK;
1860             }
1861
1862             return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1863                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1864                                     sp - mark);
1865         }
1866     }
1867     if (!gv)
1868         goto say_undef;
1869
1870     bufsv = *++MARK;
1871
1872     SETERRNO(0,0);
1873     if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1874         retval = -1;
1875         if (io && IoIFP(io))
1876             report_wrongway_fh(gv, '<');
1877         else
1878             report_evil_fh(gv);
1879         SETERRNO(EBADF,RMS_IFI);
1880         goto say_undef;
1881     }
1882
1883     /* Do this first to trigger any overloading.  */
1884     buffer = SvPV_const(bufsv, blen);
1885     orig_blen_bytes = blen;
1886     doing_utf8 = DO_UTF8(bufsv);
1887
1888     if (PerlIO_isutf8(IoIFP(io))) {
1889         if (!SvUTF8(bufsv)) {
1890             /* We don't modify the original scalar.  */
1891             tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1892             buffer = (char *) tmpbuf;
1893             doing_utf8 = TRUE;
1894         }
1895     }
1896     else if (doing_utf8) {
1897         STRLEN tmplen = blen;
1898         U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1899         if (!doing_utf8) {
1900             tmpbuf = result;
1901             buffer = (char *) tmpbuf;
1902             blen = tmplen;
1903         }
1904         else {
1905             assert((char *)result == buffer);
1906             Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1907         }
1908     }
1909
1910 #ifdef HAS_SOCKET
1911     if (op_type == OP_SEND) {
1912         const int flags = SvIVx(*++MARK);
1913         if (SP > MARK) {
1914             STRLEN mlen;
1915             char * const sockbuf = SvPVx(*++MARK, mlen);
1916             retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1917                                      flags, (struct sockaddr *)sockbuf, mlen);
1918         }
1919         else {
1920             retval
1921                 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1922         }
1923     }
1924     else
1925 #endif
1926     {
1927         Size_t length = 0; /* This length is in characters.  */
1928         STRLEN blen_chars;
1929         IV offset;
1930
1931         if (doing_utf8) {
1932             if (tmpbuf) {
1933                 /* The SV is bytes, and we've had to upgrade it.  */
1934                 blen_chars = orig_blen_bytes;
1935             } else {
1936                 /* The SV really is UTF-8.  */
1937                 /* Don't call sv_len_utf8 on a magical or overloaded
1938                    scalar, as we might get back a different result.  */
1939                 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1940             }
1941         } else {
1942             blen_chars = blen;
1943         }
1944
1945         if (MARK >= SP) {
1946             length = blen_chars;
1947         } else {
1948 #if Size_t_size > IVSIZE
1949             length = (Size_t)SvNVx(*++MARK);
1950 #else
1951             length = (Size_t)SvIVx(*++MARK);
1952 #endif
1953             if ((SSize_t)length < 0) {
1954                 Safefree(tmpbuf);
1955                 DIE(aTHX_ "Negative length");
1956             }
1957         }
1958
1959         if (MARK < SP) {
1960             offset = SvIVx(*++MARK);
1961             if (offset < 0) {
1962                 if (-offset > (IV)blen_chars) {
1963                     Safefree(tmpbuf);
1964                     DIE(aTHX_ "Offset outside string");
1965                 }
1966                 offset += blen_chars;
1967             } else if (offset > (IV)blen_chars) {
1968                 Safefree(tmpbuf);
1969                 DIE(aTHX_ "Offset outside string");
1970             }
1971         } else
1972             offset = 0;
1973         if (length > blen_chars - offset)
1974             length = blen_chars - offset;
1975         if (doing_utf8) {
1976             /* Here we convert length from characters to bytes.  */
1977             if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1978                 /* Either we had to convert the SV, or the SV is magical, or
1979                    the SV has overloading, in which case we can't or mustn't
1980                    or mustn't call it again.  */
1981
1982                 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1983                 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1984             } else {
1985                 /* It's a real UTF-8 SV, and it's not going to change under
1986                    us.  Take advantage of any cache.  */
1987                 I32 start = offset;
1988                 I32 len_I32 = length;
1989
1990                 /* Convert the start and end character positions to bytes.
1991                    Remember that the second argument to sv_pos_u2b is relative
1992                    to the first.  */
1993                 sv_pos_u2b(bufsv, &start, &len_I32);
1994
1995                 buffer += start;
1996                 length = len_I32;
1997             }
1998         }
1999         else {
2000             buffer = buffer+offset;
2001         }
2002 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2003         if (IoTYPE(io) == IoTYPE_SOCKET) {
2004             retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2005                                    buffer, length, 0);
2006         }
2007         else
2008 #endif
2009         {
2010             /* See the note at doio.c:do_print about filesize limits. --jhi */
2011             retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2012                                    buffer, length);
2013         }
2014     }
2015
2016     if (retval < 0)
2017         goto say_undef;
2018     SP = ORIGMARK;
2019     if (doing_utf8)
2020         retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2021
2022     Safefree(tmpbuf);
2023 #if Size_t_size > IVSIZE
2024     PUSHn(retval);
2025 #else
2026     PUSHi(retval);
2027 #endif
2028     RETURN;
2029
2030   say_undef:
2031     Safefree(tmpbuf);
2032     SP = ORIGMARK;
2033     RETPUSHUNDEF;
2034 }
2035
2036 PP(pp_eof)
2037 {
2038     dVAR; dSP;
2039     GV *gv;
2040     IO *io;
2041     const MAGIC *mg;
2042     /*
2043      * in Perl 5.12 and later, the additional parameter is a bitmask:
2044      * 0 = eof
2045      * 1 = eof(FH)
2046      * 2 = eof()  <- ARGV magic
2047      *
2048      * I'll rely on the compiler's trace flow analysis to decide whether to
2049      * actually assign this out here, or punt it into the only block where it is
2050      * used. Doing it out here is DRY on the condition logic.
2051      */
2052     unsigned int which;
2053
2054     if (MAXARG) {
2055         gv = PL_last_in_gv = MUTABLE_GV(POPs);  /* eof(FH) */
2056         which = 1;
2057     }
2058     else {
2059         EXTEND(SP, 1);
2060
2061         if (PL_op->op_flags & OPf_SPECIAL) {
2062             gv = PL_last_in_gv = GvEGVx(PL_argvgv);     /* eof() - ARGV magic */
2063             which = 2;
2064         }
2065         else {
2066             gv = PL_last_in_gv;                 /* eof */
2067             which = 0;
2068         }
2069     }
2070
2071     if (!gv)
2072         RETPUSHNO;
2073
2074     if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2075         return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2076     }
2077
2078     if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) {   /* eof() */
2079         if (io && !IoIFP(io)) {
2080             if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2081                 IoLINES(io) = 0;
2082                 IoFLAGS(io) &= ~IOf_START;
2083                 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2084                 if (GvSV(gv))
2085                     sv_setpvs(GvSV(gv), "-");
2086                 else
2087                     GvSV(gv) = newSVpvs("-");
2088                 SvSETMAGIC(GvSV(gv));
2089             }
2090             else if (!nextargv(gv))
2091                 RETPUSHYES;
2092         }
2093     }
2094
2095     PUSHs(boolSV(do_eof(gv)));
2096     RETURN;
2097 }
2098
2099 PP(pp_tell)
2100 {
2101     dVAR; dSP; dTARGET;
2102     GV *gv;
2103     IO *io;
2104
2105     if (MAXARG != 0 && (TOPs || POPs))
2106         PL_last_in_gv = MUTABLE_GV(POPs);
2107     else
2108         EXTEND(SP, 1);
2109     gv = PL_last_in_gv;
2110
2111     io = GvIO(gv);
2112     if (io) {
2113         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2114         if (mg) {
2115             return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2116         }
2117     }
2118     else if (!gv) {
2119         if (!errno)
2120             SETERRNO(EBADF,RMS_IFI);
2121         PUSHi(-1);
2122         RETURN;
2123     }
2124
2125 #if LSEEKSIZE > IVSIZE
2126     PUSHn( do_tell(gv) );
2127 #else
2128     PUSHi( do_tell(gv) );
2129 #endif
2130     RETURN;
2131 }
2132
2133 PP(pp_sysseek)
2134 {
2135     dVAR; dSP;
2136     const int whence = POPi;
2137 #if LSEEKSIZE > IVSIZE
2138     const Off_t offset = (Off_t)SvNVx(POPs);
2139 #else
2140     const Off_t offset = (Off_t)SvIVx(POPs);
2141 #endif
2142
2143     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2144     IO *const io = GvIO(gv);
2145
2146     if (io) {
2147         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2148         if (mg) {
2149 #if LSEEKSIZE > IVSIZE
2150             SV *const offset_sv = newSVnv((NV) offset);
2151 #else
2152             SV *const offset_sv = newSViv(offset);
2153 #endif
2154
2155             return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2156                                 newSViv(whence));
2157         }
2158     }
2159
2160     if (PL_op->op_type == OP_SEEK)
2161         PUSHs(boolSV(do_seek(gv, offset, whence)));
2162     else {
2163         const Off_t sought = do_sysseek(gv, offset, whence);
2164         if (sought < 0)
2165             PUSHs(&PL_sv_undef);
2166         else {
2167             SV* const sv = sought ?
2168 #if LSEEKSIZE > IVSIZE
2169                 newSVnv((NV)sought)
2170 #else
2171                 newSViv(sought)
2172 #endif
2173                 : newSVpvn(zero_but_true, ZBTLEN);
2174             mPUSHs(sv);
2175         }
2176     }
2177     RETURN;
2178 }
2179
2180 PP(pp_truncate)
2181 {
2182     dVAR;
2183     dSP;
2184     /* There seems to be no consensus on the length type of truncate()
2185      * and ftruncate(), both off_t and size_t have supporters. In
2186      * general one would think that when using large files, off_t is
2187      * at least as wide as size_t, so using an off_t should be okay. */
2188     /* XXX Configure probe for the length type of *truncate() needed XXX */
2189     Off_t len;
2190
2191 #if Off_t_size > IVSIZE
2192     len = (Off_t)POPn;
2193 #else
2194     len = (Off_t)POPi;
2195 #endif
2196     /* Checking for length < 0 is problematic as the type might or
2197      * might not be signed: if it is not, clever compilers will moan. */
2198     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2199     SETERRNO(0,0);
2200     {
2201         SV * const sv = POPs;
2202         int result = 1;
2203         GV *tmpgv;
2204         IO *io;
2205
2206         if (PL_op->op_flags & OPf_SPECIAL
2207                        ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2208                        : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2209             io = GvIO(tmpgv);
2210             if (!io)
2211                 result = 0;
2212             else {
2213                 PerlIO *fp;
2214             do_ftruncate_io:
2215                 TAINT_PROPER("truncate");
2216                 if (!(fp = IoIFP(io))) {
2217                     result = 0;
2218                 }
2219                 else {
2220                     PerlIO_flush(fp);
2221 #ifdef HAS_TRUNCATE
2222                     if (ftruncate(PerlIO_fileno(fp), len) < 0)
2223 #else
2224                     if (my_chsize(PerlIO_fileno(fp), len) < 0)
2225 #endif
2226                         result = 0;
2227                 }
2228             }
2229         }
2230         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2231                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2232                 goto do_ftruncate_io;
2233         }
2234         else {
2235             const char * const name = SvPV_nomg_const_nolen(sv);
2236             TAINT_PROPER("truncate");
2237 #ifdef HAS_TRUNCATE
2238             if (truncate(name, len) < 0)
2239                 result = 0;
2240 #else
2241             {
2242                 const int tmpfd = PerlLIO_open(name, O_RDWR);
2243
2244                 if (tmpfd < 0)
2245                     result = 0;
2246                 else {
2247                     if (my_chsize(tmpfd, len) < 0)
2248                         result = 0;
2249                     PerlLIO_close(tmpfd);
2250                 }
2251             }
2252 #endif
2253         }
2254
2255         if (result)
2256             RETPUSHYES;
2257         if (!errno)
2258             SETERRNO(EBADF,RMS_IFI);
2259         RETPUSHUNDEF;
2260     }
2261 }
2262
2263 PP(pp_ioctl)
2264 {
2265     dVAR; dSP; dTARGET;
2266     SV * const argsv = POPs;
2267     const unsigned int func = POPu;
2268     const int optype = PL_op->op_type;
2269     GV * const gv = MUTABLE_GV(POPs);
2270     IO * const io = gv ? GvIOn(gv) : NULL;
2271     char *s;
2272     IV retval;
2273
2274     if (!io || !argsv || !IoIFP(io)) {
2275         report_evil_fh(gv);
2276         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2277         RETPUSHUNDEF;
2278     }
2279
2280     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2281         STRLEN len;
2282         STRLEN need;
2283         s = SvPV_force(argsv, len);
2284         need = IOCPARM_LEN(func);
2285         if (len < need) {
2286             s = Sv_Grow(argsv, need + 1);
2287             SvCUR_set(argsv, need);
2288         }
2289
2290         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2291     }
2292     else {
2293         retval = SvIV(argsv);
2294         s = INT2PTR(char*,retval);              /* ouch */
2295     }
2296
2297     TAINT_PROPER(PL_op_desc[optype]);
2298
2299     if (optype == OP_IOCTL)
2300 #ifdef HAS_IOCTL
2301         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2302 #else
2303         DIE(aTHX_ "ioctl is not implemented");
2304 #endif
2305     else
2306 #ifndef HAS_FCNTL
2307       DIE(aTHX_ "fcntl is not implemented");
2308 #else
2309 #if defined(OS2) && defined(__EMX__)
2310         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2311 #else
2312         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2313 #endif
2314 #endif
2315
2316 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2317     if (SvPOK(argsv)) {
2318         if (s[SvCUR(argsv)] != 17)
2319             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2320                 OP_NAME(PL_op));
2321         s[SvCUR(argsv)] = 0;            /* put our null back */
2322         SvSETMAGIC(argsv);              /* Assume it has changed */
2323     }
2324
2325     if (retval == -1)
2326         RETPUSHUNDEF;
2327     if (retval != 0) {
2328         PUSHi(retval);
2329     }
2330     else {
2331         PUSHp(zero_but_true, ZBTLEN);
2332     }
2333 #endif
2334     RETURN;
2335 }
2336
2337 PP(pp_flock)
2338 {
2339 #ifdef FLOCK
2340     dVAR; dSP; dTARGET;
2341     I32 value;
2342     const int argtype = POPi;
2343     GV * const gv = MUTABLE_GV(POPs);
2344     IO *const io = GvIO(gv);
2345     PerlIO *const fp = io ? IoIFP(io) : NULL;
2346
2347     /* XXX Looks to me like io is always NULL at this point */
2348     if (fp) {
2349         (void)PerlIO_flush(fp);
2350         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2351     }
2352     else {
2353         report_evil_fh(gv);
2354         value = 0;
2355         SETERRNO(EBADF,RMS_IFI);
2356     }
2357     PUSHi(value);
2358     RETURN;
2359 #else
2360     DIE(aTHX_ PL_no_func, "flock()");
2361 #endif
2362 }
2363
2364 /* Sockets. */
2365
2366 #ifdef HAS_SOCKET
2367
2368 PP(pp_socket)
2369 {
2370     dVAR; dSP;
2371     const int protocol = POPi;
2372     const int type = POPi;
2373     const int domain = POPi;
2374     GV * const gv = MUTABLE_GV(POPs);
2375     IO * const io = gv ? GvIOn(gv) : NULL;
2376     int fd;
2377
2378     if (!io) {
2379         report_evil_fh(gv);
2380         if (io && IoIFP(io))
2381             do_close(gv, FALSE);
2382         SETERRNO(EBADF,LIB_INVARG);
2383         RETPUSHUNDEF;
2384     }
2385
2386     if (IoIFP(io))
2387         do_close(gv, FALSE);
2388
2389     TAINT_PROPER("socket");
2390     fd = PerlSock_socket(domain, type, protocol);
2391     if (fd < 0)
2392         RETPUSHUNDEF;
2393     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2394     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2395     IoTYPE(io) = IoTYPE_SOCKET;
2396     if (!IoIFP(io) || !IoOFP(io)) {
2397         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2398         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2399         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2400         RETPUSHUNDEF;
2401     }
2402 #if defined(HAS_FCNTL) && defined(F_SETFD)
2403     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2404 #endif
2405
2406     RETPUSHYES;
2407 }
2408 #endif
2409
2410 PP(pp_sockpair)
2411 {
2412 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2413     dVAR; dSP;
2414     const int protocol = POPi;
2415     const int type = POPi;
2416     const int domain = POPi;
2417     GV * const gv2 = MUTABLE_GV(POPs);
2418     GV * const gv1 = MUTABLE_GV(POPs);
2419     IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2420     IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2421     int fd[2];
2422
2423     if (!io1)
2424         report_evil_fh(gv1);
2425     if (!io2)
2426         report_evil_fh(gv2);
2427
2428     if (io1 && IoIFP(io1))
2429         do_close(gv1, FALSE);
2430     if (io2 && IoIFP(io2))
2431         do_close(gv2, FALSE);
2432
2433     if (!io1 || !io2)
2434         RETPUSHUNDEF;
2435
2436     TAINT_PROPER("socketpair");
2437     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2438         RETPUSHUNDEF;
2439     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2440     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2441     IoTYPE(io1) = IoTYPE_SOCKET;
2442     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2443     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2444     IoTYPE(io2) = IoTYPE_SOCKET;
2445     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2446         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2447         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2448         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2449         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2450         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2451         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2452         RETPUSHUNDEF;
2453     }
2454 #if defined(HAS_FCNTL) && defined(F_SETFD)
2455     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2456     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2457 #endif
2458
2459     RETPUSHYES;
2460 #else
2461     DIE(aTHX_ PL_no_sock_func, "socketpair");
2462 #endif
2463 }
2464
2465 #ifdef HAS_SOCKET
2466
2467 PP(pp_bind)
2468 {
2469     dVAR; dSP;
2470     SV * const addrsv = POPs;
2471     /* OK, so on what platform does bind modify addr?  */
2472     const char *addr;
2473     GV * const gv = MUTABLE_GV(POPs);
2474     IO * const io = GvIOn(gv);
2475     STRLEN len;
2476     const int op_type = PL_op->op_type;
2477
2478     if (!io || !IoIFP(io))
2479         goto nuts;
2480
2481     addr = SvPV_const(addrsv, len);
2482     TAINT_PROPER(PL_op_desc[op_type]);
2483     if ((op_type == OP_BIND
2484          ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2485          : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2486         >= 0)
2487         RETPUSHYES;
2488     else
2489         RETPUSHUNDEF;
2490
2491 nuts:
2492     report_evil_fh(gv);
2493     SETERRNO(EBADF,SS_IVCHAN);
2494     RETPUSHUNDEF;
2495 }
2496
2497 PP(pp_listen)
2498 {
2499     dVAR; dSP;
2500     const int backlog = POPi;
2501     GV * const gv = MUTABLE_GV(POPs);
2502     IO * const io = gv ? GvIOn(gv) : NULL;
2503
2504     if (!io || !IoIFP(io))
2505         goto nuts;
2506
2507     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2508         RETPUSHYES;
2509     else
2510         RETPUSHUNDEF;
2511
2512 nuts:
2513     report_evil_fh(gv);
2514     SETERRNO(EBADF,SS_IVCHAN);
2515     RETPUSHUNDEF;
2516 }
2517
2518 PP(pp_accept)
2519 {
2520     dVAR; dSP; dTARGET;
2521     IO *nstio;
2522     IO *gstio;
2523     char namebuf[MAXPATHLEN];
2524 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2525     Sock_size_t len = sizeof (struct sockaddr_in);
2526 #else
2527     Sock_size_t len = sizeof namebuf;
2528 #endif
2529     GV * const ggv = MUTABLE_GV(POPs);
2530     GV * const ngv = MUTABLE_GV(POPs);
2531     int fd;
2532
2533     if (!ngv)
2534         goto badexit;
2535     if (!ggv)
2536         goto nuts;
2537
2538     gstio = GvIO(ggv);
2539     if (!gstio || !IoIFP(gstio))
2540         goto nuts;
2541
2542     nstio = GvIOn(ngv);
2543     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2544 #if defined(OEMVS)
2545     if (len == 0) {
2546         /* Some platforms indicate zero length when an AF_UNIX client is
2547          * not bound. Simulate a non-zero-length sockaddr structure in
2548          * this case. */
2549         namebuf[0] = 0;        /* sun_len */
2550         namebuf[1] = AF_UNIX;  /* sun_family */
2551         len = 2;
2552     }
2553 #endif
2554
2555     if (fd < 0)
2556         goto badexit;
2557     if (IoIFP(nstio))
2558         do_close(ngv, FALSE);
2559     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2560     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2561     IoTYPE(nstio) = IoTYPE_SOCKET;
2562     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2563         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2564         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2565         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2566         goto badexit;
2567     }
2568 #if defined(HAS_FCNTL) && defined(F_SETFD)
2569     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2570 #endif
2571
2572 #ifdef __SCO_VERSION__
2573     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2574 #endif
2575
2576     PUSHp(namebuf, len);
2577     RETURN;
2578
2579 nuts:
2580     report_evil_fh(ggv);
2581     SETERRNO(EBADF,SS_IVCHAN);
2582
2583 badexit:
2584     RETPUSHUNDEF;
2585
2586 }
2587
2588 PP(pp_shutdown)
2589 {
2590     dVAR; dSP; dTARGET;
2591     const int how = POPi;
2592     GV * const gv = MUTABLE_GV(POPs);
2593     IO * const io = GvIOn(gv);
2594
2595     if (!io || !IoIFP(io))
2596         goto nuts;
2597
2598     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2599     RETURN;
2600
2601 nuts:
2602     report_evil_fh(gv);
2603     SETERRNO(EBADF,SS_IVCHAN);
2604     RETPUSHUNDEF;
2605 }
2606
2607 PP(pp_ssockopt)
2608 {
2609     dVAR; dSP;
2610     const int optype = PL_op->op_type;
2611     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2612     const unsigned int optname = (unsigned int) POPi;
2613     const unsigned int lvl = (unsigned int) POPi;
2614     GV * const gv = MUTABLE_GV(POPs);
2615     IO * const io = GvIOn(gv);
2616     int fd;
2617     Sock_size_t len;
2618
2619     if (!io || !IoIFP(io))
2620         goto nuts;
2621
2622     fd = PerlIO_fileno(IoIFP(io));
2623     switch (optype) {
2624     case OP_GSOCKOPT:
2625         SvGROW(sv, 257);
2626         (void)SvPOK_only(sv);
2627         SvCUR_set(sv,256);
2628         *SvEND(sv) ='\0';
2629         len = SvCUR(sv);
2630         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2631             goto nuts2;
2632         SvCUR_set(sv, len);
2633         *SvEND(sv) ='\0';
2634         PUSHs(sv);
2635         break;
2636     case OP_SSOCKOPT: {
2637 #if defined(__SYMBIAN32__)
2638 # define SETSOCKOPT_OPTION_VALUE_T void *
2639 #else
2640 # define SETSOCKOPT_OPTION_VALUE_T const char *
2641 #endif
2642         /* XXX TODO: We need to have a proper type (a Configure probe,
2643          * etc.) for what the C headers think of the third argument of
2644          * setsockopt(), the option_value read-only buffer: is it
2645          * a "char *", or a "void *", const or not.  Some compilers
2646          * don't take kindly to e.g. assuming that "char *" implicitly
2647          * promotes to a "void *", or to explicitly promoting/demoting
2648          * consts to non/vice versa.  The "const void *" is the SUS
2649          * definition, but that does not fly everywhere for the above
2650          * reasons. */
2651             SETSOCKOPT_OPTION_VALUE_T buf;
2652             int aint;
2653             if (SvPOKp(sv)) {
2654                 STRLEN l;
2655                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2656                 len = l;
2657             }
2658             else {
2659                 aint = (int)SvIV(sv);
2660                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2661                 len = sizeof(int);
2662             }
2663             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2664                 goto nuts2;
2665             PUSHs(&PL_sv_yes);
2666         }
2667         break;
2668     }
2669     RETURN;
2670
2671 nuts:
2672     report_evil_fh(gv);
2673     SETERRNO(EBADF,SS_IVCHAN);
2674 nuts2:
2675     RETPUSHUNDEF;
2676
2677 }
2678
2679 PP(pp_getpeername)
2680 {
2681     dVAR; dSP;
2682     const int optype = PL_op->op_type;
2683     GV * const gv = MUTABLE_GV(POPs);
2684     IO * const io = GvIOn(gv);
2685     Sock_size_t len;
2686     SV *sv;
2687     int fd;
2688
2689     if (!io || !IoIFP(io))
2690         goto nuts;
2691
2692     sv = sv_2mortal(newSV(257));
2693     (void)SvPOK_only(sv);
2694     len = 256;
2695     SvCUR_set(sv, len);
2696     *SvEND(sv) ='\0';
2697     fd = PerlIO_fileno(IoIFP(io));
2698     switch (optype) {
2699     case OP_GETSOCKNAME:
2700         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2701             goto nuts2;
2702         break;
2703     case OP_GETPEERNAME:
2704         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2705             goto nuts2;
2706 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2707         {
2708             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";
2709             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2710             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2711                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2712                         sizeof(u_short) + sizeof(struct in_addr))) {
2713                 goto nuts2;
2714             }
2715         }
2716 #endif
2717         break;
2718     }
2719 #ifdef BOGUS_GETNAME_RETURN
2720     /* Interactive Unix, getpeername() and getsockname()
2721       does not return valid namelen */
2722     if (len == BOGUS_GETNAME_RETURN)
2723         len = sizeof(struct sockaddr);
2724 #endif
2725     SvCUR_set(sv, len);
2726     *SvEND(sv) ='\0';
2727     PUSHs(sv);
2728     RETURN;
2729
2730 nuts:
2731     report_evil_fh(gv);
2732     SETERRNO(EBADF,SS_IVCHAN);
2733 nuts2:
2734     RETPUSHUNDEF;
2735 }
2736
2737 #endif
2738
2739 /* Stat calls. */
2740
2741 PP(pp_stat)
2742 {
2743     dVAR;
2744     dSP;
2745     GV *gv = NULL;
2746     IO *io = NULL;
2747     I32 gimme;
2748     I32 max = 13;
2749     SV* sv;
2750
2751     if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2752                                   : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2753         if (PL_op->op_type == OP_LSTAT) {
2754             if (gv != PL_defgv) {
2755             do_fstat_warning_check:
2756                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2757                                "lstat() on filehandle%s%"SVf,
2758                                 gv ? " " : "",
2759                                 SVfARG(gv
2760                                         ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2761                                         : &PL_sv_no));
2762             } else if (PL_laststype != OP_LSTAT)
2763                 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2764                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2765         }
2766
2767         if (gv != PL_defgv) {
2768             bool havefp;
2769           do_fstat_have_io:
2770             havefp = FALSE;
2771             PL_laststype = OP_STAT;
2772             PL_statgv = gv ? gv : (GV *)io;
2773             sv_setpvs(PL_statname, "");
2774             if(gv) {
2775                 io = GvIO(gv);
2776             }
2777             if (io) {
2778                     if (IoIFP(io)) {
2779                         PL_laststatval =
2780                             PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2781                         havefp = TRUE;
2782                     } else if (IoDIRP(io)) {
2783                         PL_laststatval =
2784                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2785                         havefp = TRUE;
2786                     } else {
2787                         PL_laststatval = -1;
2788                     }
2789             }
2790             else PL_laststatval = -1;
2791             if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2792         }
2793
2794         if (PL_laststatval < 0) {
2795             max = 0;
2796         }
2797     }
2798     else {
2799         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2800             io = MUTABLE_IO(SvRV(sv));
2801             if (PL_op->op_type == OP_LSTAT)
2802                 goto do_fstat_warning_check;
2803             goto do_fstat_have_io;
2804         }
2805
2806         SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2807         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2808         PL_statgv = NULL;
2809         PL_laststype = PL_op->op_type;
2810         if (PL_op->op_type == OP_LSTAT)
2811             PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2812         else
2813             PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2814         if (PL_laststatval < 0) {
2815             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2816                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2817             max = 0;
2818         }
2819     }
2820
2821     gimme = GIMME_V;
2822     if (gimme != G_ARRAY) {
2823         if (gimme != G_VOID)
2824             XPUSHs(boolSV(max));
2825         RETURN;
2826     }
2827     if (max) {
2828         EXTEND(SP, max);
2829         EXTEND_MORTAL(max);
2830         mPUSHi(PL_statcache.st_dev);
2831 #if ST_INO_SIZE > IVSIZE
2832         mPUSHn(PL_statcache.st_ino);
2833 #else
2834 #   if ST_INO_SIGN <= 0
2835         mPUSHi(PL_statcache.st_ino);
2836 #   else
2837         mPUSHu(PL_statcache.st_ino);
2838 #   endif
2839 #endif
2840         mPUSHu(PL_statcache.st_mode);
2841         mPUSHu(PL_statcache.st_nlink);
2842
2843         sv_setuid(PUSHmortal, PL_statcache.st_uid);
2844         sv_setgid(PUSHmortal, PL_statcache.st_gid);
2845
2846 #ifdef USE_STAT_RDEV
2847         mPUSHi(PL_statcache.st_rdev);
2848 #else
2849         PUSHs(newSVpvs_flags("", SVs_TEMP));
2850 #endif
2851 #if Off_t_size > IVSIZE
2852         mPUSHn(PL_statcache.st_size);
2853 #else
2854         mPUSHi(PL_statcache.st_size);
2855 #endif
2856 #ifdef BIG_TIME
2857         mPUSHn(PL_statcache.st_atime);
2858         mPUSHn(PL_statcache.st_mtime);
2859         mPUSHn(PL_statcache.st_ctime);
2860 #else
2861         mPUSHi(PL_statcache.st_atime);
2862         mPUSHi(PL_statcache.st_mtime);
2863         mPUSHi(PL_statcache.st_ctime);
2864 #endif
2865 #ifdef USE_STAT_BLOCKS
2866         mPUSHu(PL_statcache.st_blksize);
2867         mPUSHu(PL_statcache.st_blocks);
2868 #else
2869         PUSHs(newSVpvs_flags("", SVs_TEMP));
2870         PUSHs(newSVpvs_flags("", SVs_TEMP));
2871 #endif
2872     }
2873     RETURN;
2874 }
2875
2876 /* All filetest ops avoid manipulating the perl stack pointer in their main
2877    bodies (since commit d2c4d2d1e22d3125), and return using either
2878    S_ft_return_false() or S_ft_return_true().  These two helper functions are
2879    the only two which manipulate the perl stack.  To ensure that no stack
2880    manipulation macros are used, the filetest ops avoid defining a local copy
2881    of the stack pointer with dSP.  */
2882
2883 /* If the next filetest is stacked up with this one
2884    (PL_op->op_private & OPpFT_STACKING), we leave
2885    the original argument on the stack for success,
2886    and skip the stacked operators on failure.
2887    The next few macros/functions take care of this.
2888 */
2889
2890 static OP *
2891 S_ft_return_false(pTHX_ SV *ret) {
2892     OP *next = NORMAL;
2893     dSP;
2894
2895     if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2896     else                           SETs(ret);
2897     PUTBACK;
2898
2899     if (PL_op->op_private & OPpFT_STACKING) {
2900         while (OP_IS_FILETEST(next->op_type)
2901                && next->op_private & OPpFT_STACKED)
2902             next = next->op_next;
2903     }
2904     return next;
2905 }
2906
2907 PERL_STATIC_INLINE OP *
2908 S_ft_return_true(pTHX_ SV *ret) {
2909     dSP;
2910     if (PL_op->op_flags & OPf_REF)
2911         XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2912     else if (!(PL_op->op_private & OPpFT_STACKING))
2913         SETs(ret);
2914     PUTBACK;
2915     return NORMAL;
2916 }
2917
2918 #define FT_RETURNNO     return S_ft_return_false(aTHX_ &PL_sv_no)
2919 #define FT_RETURNUNDEF  return S_ft_return_false(aTHX_ &PL_sv_undef)
2920 #define FT_RETURNYES    return S_ft_return_true(aTHX_ &PL_sv_yes)
2921
2922 #define tryAMAGICftest_MG(chr) STMT_START { \
2923         if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2924                 && PL_op->op_flags & OPf_KIDS) {     \
2925             OP *next = S_try_amagic_ftest(aTHX_ chr);   \
2926             if (next) return next;                        \
2927         }                                                  \
2928     } STMT_END
2929
2930 STATIC OP *
2931 S_try_amagic_ftest(pTHX_ char chr) {
2932     dVAR;
2933     SV *const arg = *PL_stack_sp;
2934
2935     assert(chr != '?');
2936     if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2937
2938     if (SvAMAGIC(arg))
2939     {
2940         const char tmpchr = chr;
2941         SV * const tmpsv = amagic_call(arg,
2942                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2943                                 ftest_amg, AMGf_unary);
2944
2945         if (!tmpsv)
2946             return NULL;
2947
2948         return SvTRUE(tmpsv)
2949             ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2950     }
2951     return NULL;
2952 }
2953
2954
2955 PP(pp_ftrread)
2956 {
2957     dVAR;
2958     I32 result;
2959     /* Not const, because things tweak this below. Not bool, because there's
2960        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2961 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2962     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2963     /* Giving some sort of initial value silences compilers.  */
2964 #  ifdef R_OK
2965     int access_mode = R_OK;
2966 #  else
2967     int access_mode = 0;
2968 #  endif
2969 #else
2970     /* access_mode is never used, but leaving use_access in makes the
2971        conditional compiling below much clearer.  */
2972     I32 use_access = 0;
2973 #endif
2974     Mode_t stat_mode = S_IRUSR;
2975
2976     bool effective = FALSE;
2977     char opchar = '?';
2978
2979     switch (PL_op->op_type) {
2980     case OP_FTRREAD:    opchar = 'R'; break;
2981     case OP_FTRWRITE:   opchar = 'W'; break;
2982     case OP_FTREXEC:    opchar = 'X'; break;
2983     case OP_FTEREAD:    opchar = 'r'; break;
2984     case OP_FTEWRITE:   opchar = 'w'; break;
2985     case OP_FTEEXEC:    opchar = 'x'; break;
2986     }
2987     tryAMAGICftest_MG(opchar);
2988
2989     switch (PL_op->op_type) {
2990     case OP_FTRREAD:
2991 #if !(defined(HAS_ACCESS) && defined(R_OK))
2992         use_access = 0;
2993 #endif
2994         break;
2995
2996     case OP_FTRWRITE:
2997 #if defined(HAS_ACCESS) && defined(W_OK)
2998         access_mode = W_OK;
2999 #else
3000         use_access = 0;
3001 #endif
3002         stat_mode = S_IWUSR;
3003         break;
3004
3005     case OP_FTREXEC:
3006 #if defined(HAS_ACCESS) && defined(X_OK)
3007         access_mode = X_OK;
3008 #else
3009         use_access = 0;
3010 #endif
3011         stat_mode = S_IXUSR;
3012         break;
3013
3014     case OP_FTEWRITE:
3015 #ifdef PERL_EFF_ACCESS
3016         access_mode = W_OK;
3017 #endif
3018         stat_mode = S_IWUSR;
3019         /* fall through */
3020
3021     case OP_FTEREAD:
3022 #ifndef PERL_EFF_ACCESS
3023         use_access = 0;
3024 #endif
3025         effective = TRUE;
3026         break;
3027
3028     case OP_FTEEXEC:
3029 #ifdef PERL_EFF_ACCESS
3030         access_mode = X_OK;
3031 #else
3032         use_access = 0;
3033 #endif
3034         stat_mode = S_IXUSR;
3035         effective = TRUE;
3036         break;
3037     }
3038
3039     if (use_access) {
3040 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3041         const char *name = SvPV_nolen(*PL_stack_sp);
3042         if (effective) {
3043 #  ifdef PERL_EFF_ACCESS
3044             result = PERL_EFF_ACCESS(name, access_mode);
3045 #  else
3046             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3047                 OP_NAME(PL_op));
3048 #  endif
3049         }
3050         else {
3051 #  ifdef HAS_ACCESS
3052             result = access(name, access_mode);
3053 #  else
3054             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3055 #  endif
3056         }
3057         if (result == 0)
3058             FT_RETURNYES;
3059         if (result < 0)
3060             FT_RETURNUNDEF;
3061         FT_RETURNNO;
3062 #endif
3063     }
3064
3065     result = my_stat_flags(0);
3066     if (result < 0)
3067         FT_RETURNUNDEF;
3068     if (cando(stat_mode, effective, &PL_statcache))
3069         FT_RETURNYES;
3070     FT_RETURNNO;
3071 }
3072
3073 PP(pp_ftis)
3074 {
3075     dVAR;
3076     I32 result;
3077     const int op_type = PL_op->op_type;
3078     char opchar = '?';
3079
3080     switch (op_type) {
3081     case OP_FTIS:       opchar = 'e'; break;
3082     case OP_FTSIZE:     opchar = 's'; break;
3083     case OP_FTMTIME:    opchar = 'M'; break;
3084     case OP_FTCTIME:    opchar = 'C'; break;
3085     case OP_FTATIME:    opchar = 'A'; break;
3086     }
3087     tryAMAGICftest_MG(opchar);
3088
3089     result = my_stat_flags(0);
3090     if (result < 0)
3091         FT_RETURNUNDEF;
3092     if (op_type == OP_FTIS)
3093         FT_RETURNYES;
3094     {
3095         /* You can't dTARGET inside OP_FTIS, because you'll get
3096            "panic: pad_sv po" - the op is not flagged to have a target.  */
3097         dTARGET;
3098         switch (op_type) {
3099         case OP_FTSIZE:
3100 #if Off_t_size > IVSIZE
3101             sv_setnv(TARG, (NV)PL_statcache.st_size);
3102 #else
3103             sv_setiv(TARG, (IV)PL_statcache.st_size);
3104 #endif
3105             break;
3106         case OP_FTMTIME:
3107             sv_setnv(TARG,
3108                     ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3109             break;
3110         case OP_FTATIME:
3111             sv_setnv(TARG,
3112                     ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3113             break;
3114         case OP_FTCTIME:
3115             sv_setnv(TARG,
3116                     ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3117             break;
3118         }
3119         SvSETMAGIC(TARG);
3120         return SvTRUE_nomg(TARG)
3121             ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3122     }
3123 }
3124
3125 PP(pp_ftrowned)
3126 {
3127     dVAR;
3128     I32 result;
3129     char opchar = '?';
3130
3131     switch (PL_op->op_type) {
3132     case OP_FTROWNED:   opchar = 'O'; break;
3133     case OP_FTEOWNED:   opchar = 'o'; break;
3134     case OP_FTZERO:     opchar = 'z'; break;
3135     case OP_FTSOCK:     opchar = 'S'; break;
3136     case OP_FTCHR:      opchar = 'c'; break;
3137     case OP_FTBLK:      opchar = 'b'; break;
3138     case OP_FTFILE:     opchar = 'f'; break;
3139     case OP_FTDIR:      opchar = 'd'; break;
3140     case OP_FTPIPE:     opchar = 'p'; break;
3141     case OP_FTSUID:     opchar = 'u'; break;
3142     case OP_FTSGID:     opchar = 'g'; break;
3143     case OP_FTSVTX:     opchar = 'k'; break;
3144     }
3145     tryAMAGICftest_MG(opchar);
3146
3147     /* I believe that all these three are likely to be defined on most every
3148        system these days.  */
3149 #ifndef S_ISUID
3150     if(PL_op->op_type == OP_FTSUID) {
3151         FT_RETURNNO;
3152     }
3153 #endif
3154 #ifndef S_ISGID
3155     if(PL_op->op_type == OP_FTSGID) {
3156         FT_RETURNNO;
3157     }
3158 #endif
3159 #ifndef S_ISVTX
3160     if(PL_op->op_type == OP_FTSVTX) {
3161         FT_RETURNNO;
3162     }
3163 #endif
3164
3165     result = my_stat_flags(0);
3166     if (result < 0)
3167         FT_RETURNUNDEF;
3168     switch (PL_op->op_type) {
3169     case OP_FTROWNED:
3170         if (PL_statcache.st_uid == PerlProc_getuid())
3171             FT_RETURNYES;
3172         break;
3173     case OP_FTEOWNED:
3174         if (PL_statcache.st_uid == PerlProc_geteuid())
3175             FT_RETURNYES;
3176         break;
3177     case OP_FTZERO:
3178         if (PL_statcache.st_size == 0)
3179             FT_RETURNYES;
3180         break;
3181     case OP_FTSOCK:
3182         if (S_ISSOCK(PL_statcache.st_mode))
3183             FT_RETURNYES;
3184         break;
3185     case OP_FTCHR:
3186         if (S_ISCHR(PL_statcache.st_mode))
3187             FT_RETURNYES;
3188         break;
3189     case OP_FTBLK:
3190         if (S_ISBLK(PL_statcache.st_mode))
3191             FT_RETURNYES;
3192         break;
3193     case OP_FTFILE:
3194         if (S_ISREG(PL_statcache.st_mode))
3195             FT_RETURNYES;
3196         break;
3197     case OP_FTDIR:
3198         if (S_ISDIR(PL_statcache.st_mode))
3199             FT_RETURNYES;
3200         break;
3201     case OP_FTPIPE:
3202         if (S_ISFIFO(PL_statcache.st_mode))
3203             FT_RETURNYES;
3204         break;
3205 #ifdef S_ISUID
3206     case OP_FTSUID:
3207         if (PL_statcache.st_mode & S_ISUID)
3208             FT_RETURNYES;
3209         break;
3210 #endif
3211 #ifdef S_ISGID
3212     case OP_FTSGID:
3213         if (PL_statcache.st_mode & S_ISGID)
3214             FT_RETURNYES;
3215         break;
3216 #endif
3217 #ifdef S_ISVTX
3218     case OP_FTSVTX:
3219         if (PL_statcache.st_mode & S_ISVTX)
3220             FT_RETURNYES;
3221         break;
3222 #endif
3223     }
3224     FT_RETURNNO;
3225 }
3226
3227 PP(pp_ftlink)
3228 {
3229     dVAR;
3230     I32 result;
3231
3232     tryAMAGICftest_MG('l');
3233     result = my_lstat_flags(0);
3234
3235     if (result < 0)
3236         FT_RETURNUNDEF;
3237     if (S_ISLNK(PL_statcache.st_mode))
3238         FT_RETURNYES;
3239     FT_RETURNNO;
3240 }
3241
3242 PP(pp_fttty)
3243 {
3244     dVAR;
3245     int fd;
3246     GV *gv;
3247     char *name = NULL;
3248     STRLEN namelen;
3249
3250     tryAMAGICftest_MG('t');
3251
3252     if (PL_op->op_flags & OPf_REF)
3253         gv = cGVOP_gv;
3254     else {
3255       SV *tmpsv = *PL_stack_sp;
3256       if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3257         name = SvPV_nomg(tmpsv, namelen);
3258         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3259       }
3260     }
3261
3262     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3263         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3264     else if (name && isDIGIT(*name))
3265             fd = atoi(name);
3266     else
3267         FT_RETURNUNDEF;
3268     if (PerlLIO_isatty(fd))
3269         FT_RETURNYES;
3270     FT_RETURNNO;
3271 }
3272
3273 PP(pp_fttext)
3274 {
3275     dVAR;
3276     I32 i;
3277     SSize_t len;
3278     I32 odd = 0;
3279     STDCHAR tbuf[512];
3280     STDCHAR *s;
3281     IO *io;
3282     SV *sv = NULL;
3283     GV *gv;
3284     PerlIO *fp;
3285
3286     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3287
3288     if (PL_op->op_flags & OPf_REF)
3289         gv = cGVOP_gv;
3290     else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3291              == OPpFT_STACKED)
3292         gv = PL_defgv;
3293     else {
3294         sv = *PL_stack_sp;
3295         gv = MAYBE_DEREF_GV_nomg(sv);
3296     }
3297
3298     if (gv) {
3299         if (gv == PL_defgv) {
3300             if (PL_statgv)
3301                 io = SvTYPE(PL_statgv) == SVt_PVIO
3302                     ? (IO *)PL_statgv
3303                     : GvIO(PL_statgv);
3304             else {
3305                 goto really_filename;
3306             }
3307         }
3308         else {
3309             PL_statgv = gv;
3310             sv_setpvs(PL_statname, "");
3311             io = GvIO(PL_statgv);
3312         }
3313         PL_laststatval = -1;
3314         PL_laststype = OP_STAT;
3315         if (io && IoIFP(io)) {
3316             if (! PerlIO_has_base(IoIFP(io)))
3317                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3318             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3319             if (PL_laststatval < 0)
3320                 FT_RETURNUNDEF;
3321             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3322                 if (PL_op->op_type == OP_FTTEXT)
3323                     FT_RETURNNO;
3324                 else
3325                     FT_RETURNYES;
3326             }
3327             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3328                 i = PerlIO_getc(IoIFP(io));
3329                 if (i != EOF)
3330                     (void)PerlIO_ungetc(IoIFP(io),i);
3331             }
3332             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3333                 FT_RETURNYES;
3334             len = PerlIO_get_bufsiz(IoIFP(io));
3335             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3336             /* sfio can have large buffers - limit to 512 */
3337             if (len > 512)
3338                 len = 512;
3339         }
3340         else {
3341             SETERRNO(EBADF,RMS_IFI);
3342             report_evil_fh(gv);
3343             SETERRNO(EBADF,RMS_IFI);
3344             FT_RETURNUNDEF;
3345         }
3346     }
3347     else {
3348         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3349       really_filename:
3350         PL_statgv = NULL;
3351         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3352             if (!gv) {
3353                 PL_laststatval = -1;
3354                 PL_laststype = OP_STAT;
3355             }
3356             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3357                                                '\n'))
3358                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3359             FT_RETURNUNDEF;
3360         }
3361         PL_laststype = OP_STAT;
3362         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3363         if (PL_laststatval < 0) {
3364             (void)PerlIO_close(fp);
3365             FT_RETURNUNDEF;
3366         }
3367         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3368         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3369         (void)PerlIO_close(fp);
3370         if (len <= 0) {
3371             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3372                 FT_RETURNNO;            /* special case NFS directories */
3373             FT_RETURNYES;               /* null file is anything */
3374         }
3375         s = tbuf;
3376     }
3377
3378     /* now scan s to look for textiness */
3379     /*   XXX ASCII dependent code */
3380
3381 #if defined(DOSISH) || defined(USEMYBINMODE)
3382     /* ignore trailing ^Z on short files */
3383     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3384         --len;
3385 #endif
3386
3387     for (i = 0; i < len; i++, s++) {
3388         if (!*s) {                      /* null never allowed in text */
3389             odd += len;
3390             break;
3391         }
3392 #ifdef EBCDIC
3393         else if (!(isPRINT(*s) || isSPACE(*s)))
3394             odd++;
3395 #else
3396         else if (*s & 128) {
3397 #ifdef USE_LOCALE
3398             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3399                 continue;
3400 #endif
3401             /* utf8 characters don't count as odd */
3402             if (UTF8_IS_START(*s)) {
3403                 int ulen = UTF8SKIP(s);
3404                 if (ulen < len - i) {
3405                     int j;
3406                     for (j = 1; j < ulen; j++) {
3407                         if (!UTF8_IS_CONTINUATION(s[j]))
3408                             goto not_utf8;
3409                     }
3410                     --ulen;     /* loop does extra increment */
3411                     s += ulen;
3412                     i += ulen;
3413                     continue;
3414                 }
3415             }
3416           not_utf8:
3417             odd++;
3418         }
3419         else if (*s < 32 &&
3420           *s != '\n' && *s != '\r' && *s != '\b' &&
3421           *s != '\t' && *s != '\f' && *s != 27)
3422             odd++;
3423 #endif
3424     }
3425
3426     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3427         FT_RETURNNO;
3428     else
3429         FT_RETURNYES;
3430 }
3431
3432 /* File calls. */
3433
3434 PP(pp_chdir)
3435 {
3436     dVAR; dSP; dTARGET;
3437     const char *tmps = NULL;
3438     GV *gv = NULL;
3439
3440     if( MAXARG == 1 ) {
3441         SV * const sv = POPs;
3442         if (PL_op->op_flags & OPf_SPECIAL) {
3443             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3444         }
3445         else if (!(gv = MAYBE_DEREF_GV(sv)))
3446                 tmps = SvPV_nomg_const_nolen(sv);
3447     }
3448
3449     if( !gv && (!tmps || !*tmps) ) {
3450         HV * const table = GvHVn(PL_envgv);
3451         SV **svp;
3452
3453         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3454              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3455 #ifdef VMS
3456              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3457 #endif
3458            )
3459         {
3460             if( MAXARG == 1 )
3461                 deprecate("chdir('') or chdir(undef) as chdir()");
3462             tmps = SvPV_nolen_const(*svp);
3463         }
3464         else {
3465             PUSHi(0);
3466             TAINT_PROPER("chdir");
3467             RETURN;
3468         }
3469     }
3470
3471     TAINT_PROPER("chdir");
3472     if (gv) {
3473 #ifdef HAS_FCHDIR
3474         IO* const io = GvIO(gv);
3475         if (io) {
3476             if (IoDIRP(io)) {
3477                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3478             } else if (IoIFP(io)) {
3479                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3480             }
3481             else {
3482                 report_evil_fh(gv);
3483                 SETERRNO(EBADF, RMS_IFI);
3484                 PUSHi(0);
3485             }
3486         }
3487         else {
3488             report_evil_fh(gv);
3489             SETERRNO(EBADF,RMS_IFI);
3490             PUSHi(0);
3491         }
3492 #else
3493         DIE(aTHX_ PL_no_func, "fchdir");
3494 #endif
3495     }
3496     else
3497         PUSHi( PerlDir_chdir(tmps) >= 0 );
3498 #ifdef VMS
3499     /* Clear the DEFAULT element of ENV so we'll get the new value
3500      * in the future. */
3501     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3502 #endif
3503     RETURN;
3504 }
3505
3506 PP(pp_chown)
3507 {
3508     dVAR; dSP; dMARK; dTARGET;
3509     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3510
3511     SP = MARK;
3512     XPUSHi(value);
3513     RETURN;
3514 }
3515
3516 PP(pp_chroot)
3517 {
3518 #ifdef HAS_CHROOT
3519     dVAR; dSP; dTARGET;
3520     char * const tmps = POPpx;
3521     TAINT_PROPER("chroot");
3522     PUSHi( chroot(tmps) >= 0 );
3523     RETURN;
3524 #else
3525     DIE(aTHX_ PL_no_func, "chroot");
3526 #endif
3527 }
3528
3529 PP(pp_rename)
3530 {
3531     dVAR; dSP; dTARGET;
3532     int anum;
3533     const char * const tmps2 = POPpconstx;
3534     const char * const tmps = SvPV_nolen_const(TOPs);
3535     TAINT_PROPER("rename");
3536 #ifdef HAS_RENAME
3537     anum = PerlLIO_rename(tmps, tmps2);
3538 #else
3539     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3540         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3541             anum = 1;
3542         else {
3543             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3544                 (void)UNLINK(tmps2);
3545             if (!(anum = link(tmps, tmps2)))
3546                 anum = UNLINK(tmps);
3547         }
3548     }
3549 #endif
3550     SETi( anum >= 0 );
3551     RETURN;
3552 }
3553
3554 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3555 PP(pp_link)
3556 {
3557     dVAR; dSP; dTARGET;
3558     const int op_type = PL_op->op_type;
3559     int result;
3560
3561 #  ifndef HAS_LINK
3562     if (op_type == OP_LINK)
3563         DIE(aTHX_ PL_no_func, "link");
3564 #  endif
3565 #  ifndef HAS_SYMLINK
3566     if (op_type == OP_SYMLINK)
3567         DIE(aTHX_ PL_no_func, "symlink");
3568 #  endif
3569
3570     {
3571         const char * const tmps2 = POPpconstx;
3572         const char * const tmps = SvPV_nolen_const(TOPs);
3573         TAINT_PROPER(PL_op_desc[op_type]);
3574         result =
3575 #  if defined(HAS_LINK)
3576 #    if defined(HAS_SYMLINK)
3577             /* Both present - need to choose which.  */
3578             (op_type == OP_LINK) ?
3579             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3580 #    else
3581     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3582         PerlLIO_link(tmps, tmps2);
3583 #    endif
3584 #  else
3585 #    if defined(HAS_SYMLINK)
3586     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3587         symlink(tmps, tmps2);
3588 #    endif
3589 #  endif
3590     }
3591
3592     SETi( result >= 0 );
3593     RETURN;
3594 }
3595 #else
3596 PP(pp_link)
3597 {
3598     /* Have neither.  */
3599     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3600 }
3601 #endif
3602
3603 PP(pp_readlink)
3604 {
3605     dVAR;
3606     dSP;
3607 #ifdef HAS_SYMLINK
3608     dTARGET;
3609     const char *tmps;
3610     char buf[MAXPATHLEN];
3611     int len;
3612
3613     TAINT;
3614     tmps = POPpconstx;
3615     len = readlink(tmps, buf, sizeof(buf) - 1);
3616     if (len < 0)
3617         RETPUSHUNDEF;
3618     PUSHp(buf, len);
3619     RETURN;
3620 #else
3621     EXTEND(SP, 1);
3622     RETSETUNDEF;                /* just pretend it's a normal file */
3623 #endif
3624 }
3625
3626 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3627 STATIC int
3628 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3629 {
3630     char * const save_filename = filename;
3631     char *cmdline;
3632     char *s;
3633     PerlIO *myfp;
3634     int anum = 1;
3635     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3636
3637     PERL_ARGS_ASSERT_DOONELINER;
3638
3639     Newx(cmdline, size, char);
3640     my_strlcpy(cmdline, cmd, size);
3641     my_strlcat(cmdline, " ", size);
3642     for (s = cmdline + strlen(cmdline); *filename; ) {
3643         *s++ = '\\';
3644         *s++ = *filename++;
3645     }
3646     if (s - cmdline < size)
3647         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3648     myfp = PerlProc_popen(cmdline, "r");
3649     Safefree(cmdline);
3650
3651     if (myfp) {
3652         SV * const tmpsv = sv_newmortal();
3653         /* Need to save/restore 'PL_rs' ?? */
3654         s = sv_gets(tmpsv, myfp, 0);
3655         (void)PerlProc_pclose(myfp);
3656         if (s != NULL) {
3657             int e;
3658             for (e = 1;
3659 #ifdef HAS_SYS_ERRLIST
3660                  e <= sys_nerr
3661 #endif
3662                  ; e++)
3663             {
3664                 /* you don't see this */
3665                 const char * const errmsg = Strerror(e) ;
3666                 if (!errmsg)
3667                     break;
3668                 if (instr(s, errmsg)) {
3669                     SETERRNO(e,0);
3670                     return 0;
3671                 }
3672             }
3673             SETERRNO(0,0);
3674 #ifndef EACCES
3675 #define EACCES EPERM
3676 #endif
3677             if (instr(s, "cannot make"))
3678                 SETERRNO(EEXIST,RMS_FEX);
3679             else if (instr(s, "existing file"))
3680                 SETERRNO(EEXIST,RMS_FEX);
3681             else if (instr(s, "ile exists"))
3682                 SETERRNO(EEXIST,RMS_FEX);
3683             else if (instr(s, "non-exist"))
3684                 SETERRNO(ENOENT,RMS_FNF);
3685             else if (instr(s, "does not exist"))
3686                 SETERRNO(ENOENT,RMS_FNF);
3687             else if (instr(s, "not empty"))
3688                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3689             else if (instr(s, "cannot access"))
3690                 SETERRNO(EACCES,RMS_PRV);
3691             else
3692                 SETERRNO(EPERM,RMS_PRV);
3693             return 0;
3694         }
3695         else {  /* some mkdirs return no failure indication */
3696             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3697             if (PL_op->op_type == OP_RMDIR)
3698                 anum = !anum;
3699             if (anum)
3700                 SETERRNO(0,0);
3701             else
3702                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3703         }
3704         return anum;
3705     }
3706     else
3707         return 0;
3708 }
3709 #endif
3710
3711 /* This macro removes trailing slashes from a directory name.
3712  * Different operating and file systems take differently to
3713  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3714  * any number of trailing slashes should be allowed.
3715  * Thusly we snip them away so that even non-conforming
3716  * systems are happy.
3717  * We should probably do this "filtering" for all
3718  * the functions that expect (potentially) directory names:
3719  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3720  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3721
3722 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3723     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3724         do { \
3725             (len)--; \
3726         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3727         (tmps) = savepvn((tmps), (len)); \
3728         (copy) = TRUE; \
3729     }
3730
3731 PP(pp_mkdir)
3732 {
3733     dVAR; dSP; dTARGET;
3734     STRLEN len;
3735     const char *tmps;
3736     bool copy = FALSE;
3737     const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3738
3739     TRIMSLASHES(tmps,len,copy);
3740
3741     TAINT_PROPER("mkdir");
3742 #ifdef HAS_MKDIR
3743     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3744 #else
3745     {
3746     int oldumask;
3747     SETi( dooneliner("mkdir", tmps) );
3748     oldumask = PerlLIO_umask(0);
3749     PerlLIO_umask(oldumask);
3750     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3751     }
3752 #endif
3753     if (copy)
3754         Safefree(tmps);
3755     RETURN;
3756 }
3757
3758 PP(pp_rmdir)
3759 {
3760     dVAR; dSP; dTARGET;
3761     STRLEN len;
3762     const char *tmps;
3763     bool copy = FALSE;
3764
3765     TRIMSLASHES(tmps,len,copy);
3766     TAINT_PROPER("rmdir");
3767 #ifdef HAS_RMDIR
3768     SETi( PerlDir_rmdir(tmps) >= 0 );
3769 #else
3770     SETi( dooneliner("rmdir", tmps) );
3771 #endif
3772     if (copy)
3773         Safefree(tmps);
3774     RETURN;
3775 }
3776
3777 /* Directory calls. */
3778
3779 PP(pp_open_dir)
3780 {
3781 #if defined(Direntry_t) && defined(HAS_READDIR)
3782     dVAR; dSP;
3783     const char * const dirname = POPpconstx;
3784     GV * const gv = MUTABLE_GV(POPs);
3785     IO * const io = GvIOn(gv);
3786
3787     if (!io)
3788         goto nope;
3789
3790     if ((IoIFP(io) || IoOFP(io)))
3791         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3792                          "Opening filehandle %"HEKf" also as a directory",
3793                              HEKfARG(GvENAME_HEK(gv)) );
3794     if (IoDIRP(io))
3795         PerlDir_close(IoDIRP(io));
3796     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3797         goto nope;
3798
3799     RETPUSHYES;
3800 nope:
3801     if (!errno)
3802         SETERRNO(EBADF,RMS_DIR);
3803     RETPUSHUNDEF;
3804 #else
3805     DIE(aTHX_ PL_no_dir_func, "opendir");
3806 #endif
3807 }
3808
3809 PP(pp_readdir)
3810 {
3811 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3812     DIE(aTHX_ PL_no_dir_func, "readdir");
3813 #else
3814 #if !defined(I_DIRENT) && !defined(VMS)
3815     Direntry_t *readdir (DIR *);
3816 #endif
3817     dVAR;
3818     dSP;
3819
3820     SV *sv;
3821     const I32 gimme = GIMME;
3822     GV * const gv = MUTABLE_GV(POPs);
3823     const Direntry_t *dp;
3824     IO * const io = GvIOn(gv);
3825
3826     if (!io || !IoDIRP(io)) {
3827         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3828                        "readdir() attempted on invalid dirhandle %"HEKf,
3829                             HEKfARG(GvENAME_HEK(gv)));
3830         goto nope;
3831     }
3832
3833     do {
3834         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3835         if (!dp)
3836             break;
3837 #ifdef DIRNAMLEN
3838         sv = newSVpvn(dp->d_name, dp->d_namlen);
3839 #else
3840         sv = newSVpv(dp->d_name, 0);
3841 #endif
3842         if (!(IoFLAGS(io) & IOf_UNTAINT))
3843             SvTAINTED_on(sv);
3844         mXPUSHs(sv);
3845     } while (gimme == G_ARRAY);
3846
3847     if (!dp && gimme != G_ARRAY)
3848         goto nope;
3849
3850     RETURN;
3851
3852 nope:
3853     if (!errno)
3854         SETERRNO(EBADF,RMS_ISI);
3855     if (GIMME == G_ARRAY)
3856         RETURN;
3857     else
3858         RETPUSHUNDEF;
3859 #endif
3860 }
3861
3862 PP(pp_telldir)
3863 {
3864 #if defined(HAS_TELLDIR) || defined(telldir)
3865     dVAR; dSP; dTARGET;
3866  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3867  /* XXX netbsd still seemed to.
3868     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3869     --JHI 1999-Feb-02 */
3870 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3871     long telldir (DIR *);
3872 # endif
3873     GV * const gv = MUTABLE_GV(POPs);
3874     IO * const io = GvIOn(gv);
3875
3876     if (!io || !IoDIRP(io)) {
3877         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3878                        "telldir() attempted on invalid dirhandle %"HEKf,
3879                             HEKfARG(GvENAME_HEK(gv)));
3880         goto nope;
3881     }
3882
3883     PUSHi( PerlDir_tell(IoDIRP(io)) );
3884     RETURN;
3885 nope:
3886     if (!errno)
3887         SETERRNO(EBADF,RMS_ISI);
3888     RETPUSHUNDEF;
3889 #else
3890     DIE(aTHX_ PL_no_dir_func, "telldir");
3891 #endif
3892 }
3893
3894 PP(pp_seekdir)
3895 {
3896 #if defined(HAS_SEEKDIR) || defined(seekdir)
3897     dVAR; dSP;
3898     const long along = POPl;
3899     GV * const gv = MUTABLE_GV(POPs);
3900     IO * const io = GvIOn(gv);
3901
3902     if (!io || !IoDIRP(io)) {
3903         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3904                        "seekdir() attempted on invalid dirhandle %"HEKf,
3905                                 HEKfARG(GvENAME_HEK(gv)));
3906         goto nope;
3907     }
3908     (void)PerlDir_seek(IoDIRP(io), along);
3909
3910     RETPUSHYES;
3911 nope:
3912     if (!errno)
3913         SETERRNO(EBADF,RMS_ISI);
3914     RETPUSHUNDEF;
3915 #else
3916     DIE(aTHX_ PL_no_dir_func, "seekdir");
3917 #endif
3918 }
3919
3920 PP(pp_rewinddir)
3921 {
3922 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3923     dVAR; dSP;
3924     GV * const gv = MUTABLE_GV(POPs);
3925     IO * const io = GvIOn(gv);
3926
3927     if (!io || !IoDIRP(io)) {
3928         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3929                        "rewinddir() attempted on invalid dirhandle %"HEKf,
3930                                 HEKfARG(GvENAME_HEK(gv)));
3931         goto nope;
3932     }
3933     (void)PerlDir_rewind(IoDIRP(io));
3934     RETPUSHYES;
3935 nope:
3936     if (!errno)
3937         SETERRNO(EBADF,RMS_ISI);
3938     RETPUSHUNDEF;
3939 #else
3940     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3941 #endif
3942 }
3943
3944 PP(pp_closedir)
3945 {
3946 #if defined(Direntry_t) && defined(HAS_READDIR)
3947     dVAR; dSP;
3948     GV * const gv = MUTABLE_GV(POPs);
3949     IO * const io = GvIOn(gv);
3950
3951     if (!io || !IoDIRP(io)) {
3952         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3953                        "closedir() attempted on invalid dirhandle %"HEKf,
3954                                 HEKfARG(GvENAME_HEK(gv)));
3955         goto nope;
3956     }
3957 #ifdef VOID_CLOSEDIR
3958     PerlDir_close(IoDIRP(io));
3959 #else
3960     if (PerlDir_close(IoDIRP(io)) < 0) {
3961         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3962         goto nope;
3963     }
3964 #endif
3965     IoDIRP(io) = 0;
3966
3967     RETPUSHYES;
3968 nope:
3969     if (!errno)
3970         SETERRNO(EBADF,RMS_IFI);
3971     RETPUSHUNDEF;
3972 #else
3973     DIE(aTHX_ PL_no_dir_func, "closedir");
3974 #endif
3975 }
3976
3977 /* Process control. */
3978
3979 PP(pp_fork)
3980 {
3981 #ifdef HAS_FORK
3982     dVAR; dSP; dTARGET;
3983     Pid_t childpid;
3984 #ifdef HAS_SIGPROCMASK
3985     sigset_t oldmask, newmask;
3986 #endif
3987
3988     EXTEND(SP, 1);
3989     PERL_FLUSHALL_FOR_CHILD;
3990 #ifdef HAS_SIGPROCMASK
3991     sigfillset(&newmask);
3992     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
3993 #endif
3994     childpid = PerlProc_fork();
3995     if (childpid == 0) {
3996         int sig;
3997         PL_sig_pending = 0;
3998         if (PL_psig_pend)
3999             for (sig = 1; sig < SIG_SIZE; sig++)
4000                 PL_psig_pend[sig] = 0;
4001     }
4002 #ifdef HAS_SIGPROCMASK
4003     {
4004         dSAVE_ERRNO;
4005         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4006         RESTORE_ERRNO;
4007     }
4008 #endif
4009     if (childpid < 0)
4010         RETPUSHUNDEF;
4011     if (!childpid) {
4012 #ifdef PERL_USES_PL_PIDSTATUS
4013         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4014 #endif
4015     }
4016     PUSHi(childpid);
4017     RETURN;
4018 #else
4019 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4020     dSP; dTARGET;
4021     Pid_t childpid;
4022
4023     EXTEND(SP, 1);
4024     PERL_FLUSHALL_FOR_CHILD;
4025     childpid = PerlProc_fork();
4026     if (childpid == -1)
4027         RETPUSHUNDEF;
4028     PUSHi(childpid);
4029     RETURN;
4030 #  else
4031     DIE(aTHX_ PL_no_func, "fork");
4032 #  endif
4033 #endif
4034 }
4035
4036 PP(pp_wait)
4037 {
4038 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4039     dVAR; dSP; dTARGET;
4040     Pid_t childpid;
4041     int argflags;
4042
4043     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4044         childpid = wait4pid(-1, &argflags, 0);
4045     else {
4046         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4047                errno == EINTR) {
4048           PERL_ASYNC_CHECK();
4049         }
4050     }
4051 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4052     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4053     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4054 #  else
4055     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4056 #  endif
4057     XPUSHi(childpid);
4058     RETURN;
4059 #else
4060     DIE(aTHX_ PL_no_func, "wait");
4061 #endif
4062 }
4063
4064 PP(pp_waitpid)
4065 {
4066 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4067     dVAR; dSP; dTARGET;
4068     const int optype = POPi;
4069     const Pid_t pid = TOPi;
4070     Pid_t result;
4071     int argflags;
4072
4073     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4074         result = wait4pid(pid, &argflags, optype);
4075     else {
4076         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4077                errno == EINTR) {
4078           PERL_ASYNC_CHECK();
4079         }
4080     }
4081 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4082     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4083     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4084 #  else
4085     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4086 #  endif
4087     SETi(result);
4088     RETURN;
4089 #else
4090     DIE(aTHX_ PL_no_func, "waitpid");
4091 #endif
4092 }
4093
4094 PP(pp_system)
4095 {
4096     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4097 #if defined(__LIBCATAMOUNT__)
4098     PL_statusvalue = -1;
4099     SP = ORIGMARK;
4100     XPUSHi(-1);
4101 #else
4102     I32 value;
4103     int result;
4104
4105     if (TAINTING_get) {
4106         TAINT_ENV();
4107         while (++MARK <= SP) {
4108             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4109             if (TAINT_get)
4110                 break;
4111         }
4112         MARK = ORIGMARK;
4113         TAINT_PROPER("system");
4114     }
4115     PERL_FLUSHALL_FOR_CHILD;
4116 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4117     {
4118         Pid_t childpid;
4119         int pp[2];
4120         I32 did_pipes = 0;
4121 #ifdef HAS_SIGPROCMASK
4122         sigset_t newset, oldset;
4123 #endif
4124
4125         if (PerlProc_pipe(pp) >= 0)
4126             did_pipes = 1;
4127 #ifdef HAS_SIGPROCMASK
4128         sigemptyset(&newset);
4129         sigaddset(&newset, SIGCHLD);
4130         sigprocmask(SIG_BLOCK, &newset, &oldset);
4131 #endif
4132         while ((childpid = PerlProc_fork()) == -1) {
4133             if (errno != EAGAIN) {
4134                 value = -1;
4135                 SP = ORIGMARK;
4136                 XPUSHi(value);
4137                 if (did_pipes) {
4138                     PerlLIO_close(pp[0]);
4139                     PerlLIO_close(pp[1]);
4140                 }
4141 #ifdef HAS_SIGPROCMASK
4142                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4143 #endif
4144                 RETURN;
4145             }
4146             sleep(5);
4147         }
4148         if (childpid > 0) {
4149             Sigsave_t ihand,qhand; /* place to save signals during system() */
4150             int status;
4151
4152             if (did_pipes)
4153                 PerlLIO_close(pp[1]);
4154 #ifndef PERL_MICRO
4155             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4156             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4157 #endif
4158             do {
4159                 result = wait4pid(childpid, &status, 0);
4160             } while (result == -1 && errno == EINTR);
4161 #ifndef PERL_MICRO
4162 #ifdef HAS_SIGPROCMASK
4163             sigprocmask(SIG_SETMASK, &oldset, NULL);
4164 #endif
4165             (void)rsignal_restore(SIGINT, &ihand);
4166             (void)rsignal_restore(SIGQUIT, &qhand);
4167 #endif
4168             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4169             do_execfree();      /* free any memory child malloced on fork */
4170             SP = ORIGMARK;
4171             if (did_pipes) {
4172                 int errkid;
4173                 unsigned n = 0;
4174                 SSize_t n1;
4175
4176                 while (n < sizeof(int)) {
4177                     n1 = PerlLIO_read(pp[0],
4178                                       (void*)(((char*)&errkid)+n),
4179                                       (sizeof(int)) - n);
4180                     if (n1 <= 0)
4181                         break;
4182                     n += n1;
4183                 }
4184                 PerlLIO_close(pp[0]);
4185                 if (n) {                        /* Error */
4186                     if (n != sizeof(int))
4187                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4188                     errno = errkid;             /* Propagate errno from kid */
4189                     STATUS_NATIVE_CHILD_SET(-1);
4190                 }
4191             }
4192             XPUSHi(STATUS_CURRENT);
4193             RETURN;
4194         }
4195 #ifdef HAS_SIGPROCMASK
4196         sigprocmask(SIG_SETMASK, &oldset, NULL);
4197 #endif
4198         if (did_pipes) {
4199             PerlLIO_close(pp[0]);
4200 #if defined(HAS_FCNTL) && defined(F_SETFD)
4201             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4202 #endif
4203         }
4204         if (PL_op->op_flags & OPf_STACKED) {
4205             SV * const really = *++MARK;
4206             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4207         }
4208         else if (SP - MARK != 1)
4209             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4210         else {
4211             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4212         }
4213         PerlProc__exit(-1);
4214     }
4215 #else /* ! FORK or VMS or OS/2 */
4216     PL_statusvalue = 0;
4217     result = 0;
4218     if (PL_op->op_flags & OPf_STACKED) {
4219         SV * const really = *++MARK;
4220 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4221         value = (I32)do_aspawn(really, MARK, SP);
4222 #  else
4223         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4224 #  endif
4225     }
4226     else if (SP - MARK != 1) {
4227 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4228         value = (I32)do_aspawn(NULL, MARK, SP);
4229 #  else
4230         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4231 #  endif
4232     }
4233     else {
4234         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4235     }
4236     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4237         result = 1;
4238     STATUS_NATIVE_CHILD_SET(value);
4239     do_execfree();
4240     SP = ORIGMARK;
4241     XPUSHi(result ? value : STATUS_CURRENT);
4242 #endif /* !FORK or VMS or OS/2 */
4243 #endif
4244     RETURN;
4245 }
4246
4247 PP(pp_exec)
4248 {
4249     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4250     I32 value;
4251
4252     if (TAINTING_get) {
4253         TAINT_ENV();
4254         while (++MARK <= SP) {
4255             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4256             if (TAINT_get)
4257                 break;
4258         }
4259         MARK = ORIGMARK;
4260         TAINT_PROPER("exec");
4261     }
4262     PERL_FLUSHALL_FOR_CHILD;
4263     if (PL_op->op_flags & OPf_STACKED) {
4264         SV * const really = *++MARK;
4265         value = (I32)do_aexec(really, MARK, SP);
4266     }
4267     else if (SP - MARK != 1)
4268 #ifdef VMS
4269         value = (I32)vms_do_aexec(NULL, MARK, SP);
4270 #else
4271         value = (I32)do_aexec(NULL, MARK, SP);
4272 #endif
4273     else {
4274 #ifdef VMS
4275         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4276 #else
4277         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4278 #endif
4279     }
4280
4281     SP = ORIGMARK;
4282     XPUSHi(value);
4283     RETURN;
4284 }
4285
4286 PP(pp_getppid)
4287 {
4288 #ifdef HAS_GETPPID
4289     dVAR; dSP; dTARGET;
4290     XPUSHi( getppid() );
4291     RETURN;
4292 #else
4293     DIE(aTHX_ PL_no_func, "getppid");
4294 #endif
4295 }
4296
4297 PP(pp_getpgrp)
4298 {
4299 #ifdef HAS_GETPGRP
4300     dVAR; dSP; dTARGET;
4301     Pid_t pgrp;
4302     const Pid_t pid =
4303         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4304
4305 #ifdef BSD_GETPGRP
4306     pgrp = (I32)BSD_GETPGRP(pid);
4307 #else
4308     if (pid != 0 && pid != PerlProc_getpid())
4309         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4310     pgrp = getpgrp();
4311 #endif
4312     XPUSHi(pgrp);
4313     RETURN;
4314 #else
4315     DIE(aTHX_ PL_no_func, "getpgrp()");
4316 #endif
4317 }
4318
4319 PP(pp_setpgrp)
4320 {
4321 #ifdef HAS_SETPGRP
4322     dVAR; dSP; dTARGET;
4323     Pid_t pgrp;
4324     Pid_t pid;
4325     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4326     if (MAXARG > 0) pid = TOPs && TOPi;
4327     else {
4328         pid = 0;
4329         XPUSHi(-1);
4330     }
4331
4332     TAINT_PROPER("setpgrp");
4333 #ifdef BSD_SETPGRP
4334     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4335 #else
4336     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4337         || (pid != 0 && pid != PerlProc_getpid()))
4338     {
4339         DIE(aTHX_ "setpgrp can't take arguments");
4340     }
4341     SETi( setpgrp() >= 0 );
4342 #endif /* USE_BSDPGRP */
4343     RETURN;
4344 #else
4345     DIE(aTHX_ PL_no_func, "setpgrp()");
4346 #endif
4347 }
4348
4349 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4350 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4351 #else
4352 #  define PRIORITY_WHICH_T(which) which
4353 #endif
4354
4355 PP(pp_getpriority)
4356 {
4357 #ifdef HAS_GETPRIORITY
4358     dVAR; dSP; dTARGET;
4359     const int who = POPi;
4360     const int which = TOPi;
4361     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4362     RETURN;
4363 #else
4364     DIE(aTHX_ PL_no_func, "getpriority()");
4365 #endif
4366 }
4367
4368 PP(pp_setpriority)
4369 {
4370 #ifdef HAS_SETPRIORITY
4371     dVAR; dSP; dTARGET;
4372     const int niceval = POPi;
4373     const int who = POPi;
4374     const int which = TOPi;
4375     TAINT_PROPER("setpriority");
4376     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4377     RETURN;
4378 #else
4379     DIE(aTHX_ PL_no_func, "setpriority()");
4380 #endif
4381 }
4382
4383 #undef PRIORITY_WHICH_T
4384
4385 /* Time calls. */
4386
4387 PP(pp_time)
4388 {
4389     dVAR; dSP; dTARGET;
4390 #ifdef BIG_TIME
4391     XPUSHn( time(NULL) );
4392 #else
4393     XPUSHi( time(NULL) );
4394 #endif
4395     RETURN;
4396 }
4397
4398 PP(pp_tms)
4399 {
4400 #ifdef HAS_TIMES
4401     dVAR;
4402     dSP;
4403     EXTEND(SP, 4);
4404 #ifndef VMS
4405     (void)PerlProc_times(&PL_timesbuf);
4406 #else
4407     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4408                                                    /* struct tms, though same data   */
4409                                                    /* is returned.                   */
4410 #endif
4411
4412     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4413     if (GIMME == G_ARRAY) {
4414         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4415         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4416         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4417     }
4418     RETURN;
4419 #else
4420 #   ifdef PERL_MICRO
4421     dSP;
4422     mPUSHn(0.0);
4423     EXTEND(SP, 4);
4424     if (GIMME == G_ARRAY) {
4425          mPUSHn(0.0);
4426          mPUSHn(0.0);
4427          mPUSHn(0.0);
4428     }
4429     RETURN;
4430 #   else
4431     DIE(aTHX_ "times not implemented");
4432 #   endif
4433 #endif /* HAS_TIMES */
4434 }
4435
4436 /* The 32 bit int year limits the times we can represent to these
4437    boundaries with a few days wiggle room to account for time zone
4438    offsets
4439 */
4440 /* Sat Jan  3 00:00:00 -2147481748 */
4441 #define TIME_LOWER_BOUND -67768100567755200.0
4442 /* Sun Dec 29 12:00:00  2147483647 */
4443 #define TIME_UPPER_BOUND  67767976233316800.0
4444
4445 PP(pp_gmtime)
4446 {
4447     dVAR;
4448     dSP;
4449     Time64_T when;
4450     struct TM tmbuf;
4451     struct TM *err;
4452     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4453     static const char * const dayname[] =
4454         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4455     static const char * const monname[] =
4456         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4457          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4458
4459     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4460         time_t now;
4461         (void)time(&now);
4462         when = (Time64_T)now;
4463     }
4464     else {
4465         NV input = Perl_floor(POPn);
4466         when = (Time64_T)input;
4467         if (when != input) {
4468             /* diag_listed_as: gmtime(%f) too large */
4469             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4470                            "%s(%.0" NVff ") too large", opname, input);
4471         }
4472     }
4473
4474     if ( TIME_LOWER_BOUND > when ) {
4475         /* diag_listed_as: gmtime(%f) too small */
4476         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4477                        "%s(%.0" NVff ") too small", opname, when);
4478         err = NULL;
4479     }
4480     else if( when > TIME_UPPER_BOUND ) {
4481         /* diag_listed_as: gmtime(%f) too small */
4482         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4483                        "%s(%.0" NVff ") too large", opname, when);
4484         err = NULL;
4485     }
4486     else {
4487         if (PL_op->op_type == OP_LOCALTIME)
4488             err = S_localtime64_r(&when, &tmbuf);
4489         else
4490             err = S_gmtime64_r(&when, &tmbuf);
4491     }
4492
4493     if (err == NULL) {
4494         /* XXX %lld broken for quads */
4495         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4496                        "%s(%.0" NVff ") failed", opname, when);
4497     }
4498
4499     if (GIMME != G_ARRAY) {     /* scalar context */
4500         SV *tsv;
4501         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4502         double year = (double)tmbuf.tm_year + 1900;
4503
4504         EXTEND(SP, 1);
4505         EXTEND_MORTAL(1);
4506         if (err == NULL)
4507             RETPUSHUNDEF;
4508
4509         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4510                             dayname[tmbuf.tm_wday],
4511                             monname[tmbuf.tm_mon],
4512                             tmbuf.tm_mday,
4513                             tmbuf.tm_hour,
4514                             tmbuf.tm_min,
4515                             tmbuf.tm_sec,
4516                             year);
4517         mPUSHs(tsv);
4518     }
4519     else {                      /* list context */
4520         if ( err == NULL )
4521             RETURN;
4522
4523         EXTEND(SP, 9);
4524         EXTEND_MORTAL(9);
4525         mPUSHi(tmbuf.tm_sec);
4526         mPUSHi(tmbuf.tm_min);
4527         mPUSHi(tmbuf.tm_hour);
4528         mPUSHi(tmbuf.tm_mday);
4529         mPUSHi(tmbuf.tm_mon);
4530         mPUSHn(tmbuf.tm_year);
4531         mPUSHi(tmbuf.tm_wday);
4532         mPUSHi(tmbuf.tm_yday);
4533         mPUSHi(tmbuf.tm_isdst);
4534     }
4535     RETURN;
4536 }
4537
4538 PP(pp_alarm)
4539 {
4540 #ifdef HAS_ALARM
4541     dVAR; dSP; dTARGET;
4542     int anum;
4543     anum = POPi;
4544     anum = alarm((unsigned int)anum);
4545     if (anum < 0)
4546         RETPUSHUNDEF;
4547     PUSHi(anum);
4548     RETURN;
4549 #else
4550     DIE(aTHX_ PL_no_func, "alarm");
4551 #endif
4552 }
4553
4554 PP(pp_sleep)
4555 {
4556     dVAR; dSP; dTARGET;
4557     I32 duration;
4558     Time_t lasttime;
4559     Time_t when;
4560
4561     (void)time(&lasttime);
4562     if (MAXARG < 1 || (!TOPs && !POPs))
4563         PerlProc_pause();
4564     else {
4565         duration = POPi;
4566         PerlProc_sleep((unsigned int)duration);
4567     }
4568     (void)time(&when);
4569     XPUSHi(when - lasttime);
4570     RETURN;
4571 }
4572
4573 /* Shared memory. */
4574 /* Merged with some message passing. */
4575
4576 PP(pp_shmwrite)
4577 {
4578 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4579     dVAR; dSP; dMARK; dTARGET;
4580     const int op_type = PL_op->op_type;
4581     I32 value;
4582
4583     switch (op_type) {
4584     case OP_MSGSND:
4585         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4586         break;
4587     case OP_MSGRCV:
4588         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4589         break;
4590     case OP_SEMOP:
4591         value = (I32)(do_semop(MARK, SP) >= 0);
4592         break;
4593     default:
4594         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4595         break;
4596     }
4597
4598     SP = MARK;
4599     PUSHi(value);
4600     RETURN;
4601 #else
4602     return Perl_pp_semget(aTHX);
4603 #endif
4604 }
4605
4606 /* Semaphores. */
4607
4608 PP(pp_semget)
4609 {
4610 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4611     dVAR; dSP; dMARK; dTARGET;
4612     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4613     SP = MARK;
4614     if (anum == -1)
4615         RETPUSHUNDEF;
4616     PUSHi(anum);
4617     RETURN;
4618 #else
4619     DIE(aTHX_ "System V IPC is not implemented on this machine");
4620 #endif
4621 }
4622
4623 PP(pp_semctl)
4624 {
4625 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4626     dVAR; dSP; dMARK; dTARGET;
4627     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4628     SP = MARK;
4629     if (anum == -1)
4630         RETSETUNDEF;
4631     if (anum != 0) {
4632         PUSHi(anum);
4633     }
4634     else {
4635         PUSHp(zero_but_true, ZBTLEN);
4636     }
4637     RETURN;
4638 #else
4639     return Perl_pp_semget(aTHX);
4640 #endif
4641 }
4642
4643 /* I can't const this further without getting warnings about the types of
4644    various arrays passed in from structures.  */
4645 static SV *
4646 S_space_join_names_mortal(pTHX_ char *const *array)
4647 {
4648     SV *target;
4649
4650     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4651
4652     if (array && *array) {
4653         target = newSVpvs_flags("", SVs_TEMP);
4654         while (1) {
4655             sv_catpv(target, *array);
4656             if (!*++array)
4657                 break;
4658             sv_catpvs(target, " ");
4659         }
4660     } else {
4661         target = sv_mortalcopy(&PL_sv_no);
4662     }
4663     return target;
4664 }
4665
4666 /* Get system info. */
4667
4668 PP(pp_ghostent)
4669 {
4670 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4671     dVAR; dSP;
4672     I32 which = PL_op->op_type;
4673     char **elem;
4674     SV *sv;
4675 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4676     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4677     struct hostent *gethostbyname(Netdb_name_t);
4678     struct hostent *gethostent(void);
4679 #endif
4680     struct hostent *hent = NULL;
4681     unsigned long len;
4682
4683     EXTEND(SP, 10);
4684     if (which == OP_GHBYNAME) {
4685 #ifdef HAS_GETHOSTBYNAME
4686         const char* const name = POPpbytex;
4687         hent = PerlSock_gethostbyname(name);
4688 #else
4689         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4690 #endif
4691     }
4692     else if (which == OP_GHBYADDR) {
4693 #ifdef HAS_GETHOSTBYADDR
4694         const int addrtype = POPi;
4695         SV * const addrsv = POPs;
4696         STRLEN addrlen;
4697         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4698
4699         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4700 #else
4701         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4702 #endif
4703     }
4704     else
4705 #ifdef HAS_GETHOSTENT
4706         hent = PerlSock_gethostent();
4707 #else
4708         DIE(aTHX_ PL_no_sock_func, "gethostent");
4709 #endif
4710
4711 #ifdef HOST_NOT_FOUND
4712         if (!hent) {
4713 #ifdef USE_REENTRANT_API
4714 #   ifdef USE_GETHOSTENT_ERRNO
4715             h_errno = PL_reentrant_buffer->_gethostent_errno;
4716 #   endif
4717 #endif
4718             STATUS_UNIX_SET(h_errno);
4719         }
4720 #endif
4721
4722     if (GIMME != G_ARRAY) {
4723         PUSHs(sv = sv_newmortal());
4724         if (hent) {
4725             if (which == OP_GHBYNAME) {
4726                 if (hent->h_addr)
4727                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4728             }
4729             else
4730                 sv_setpv(sv, (char*)hent->h_name);
4731         }
4732         RETURN;
4733     }
4734
4735     if (hent) {
4736         mPUSHs(newSVpv((char*)hent->h_name, 0));
4737         PUSHs(space_join_names_mortal(hent->h_aliases));
4738         mPUSHi(hent->h_addrtype);
4739         len = hent->h_length;
4740         mPUSHi(len);
4741 #ifdef h_addr
4742         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4743             mXPUSHp(*elem, len);
4744         }
4745 #else
4746         if (hent->h_addr)
4747             mPUSHp(hent->h_addr, len);
4748         else
4749             PUSHs(sv_mortalcopy(&PL_sv_no));
4750 #endif /* h_addr */
4751     }
4752     RETURN;
4753 #else
4754     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4755 #endif
4756 }
4757
4758 PP(pp_gnetent)
4759 {
4760 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4761     dVAR; dSP;
4762     I32 which = PL_op->op_type;
4763     SV *sv;
4764 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4765     struct netent *getnetbyaddr(Netdb_net_t, int);
4766     struct netent *getnetbyname(Netdb_name_t);
4767     struct netent *getnetent(void);
4768 #endif
4769     struct netent *nent;
4770
4771     if (which == OP_GNBYNAME){
4772 #ifdef HAS_GETNETBYNAME
4773         const char * const name = POPpbytex;
4774         nent = PerlSock_getnetbyname(name);
4775 #else
4776         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4777 #endif
4778     }
4779     else if (which == OP_GNBYADDR) {
4780 #ifdef HAS_GETNETBYADDR
4781         const int addrtype = POPi;
4782         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4783         nent = PerlSock_getnetbyaddr(addr, addrtype);
4784 #else
4785         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4786 #endif
4787     }
4788     else
4789 #ifdef HAS_GETNETENT
4790         nent = PerlSock_getnetent();
4791 #else
4792         DIE(aTHX_ PL_no_sock_func, "getnetent");
4793 #endif
4794
4795 #ifdef HOST_NOT_FOUND
4796         if (!nent) {
4797 #ifdef USE_REENTRANT_API
4798 #   ifdef USE_GETNETENT_ERRNO
4799              h_errno = PL_reentrant_buffer->_getnetent_errno;
4800 #   endif
4801 #endif
4802             STATUS_UNIX_SET(h_errno);
4803         }
4804 #endif
4805
4806     EXTEND(SP, 4);
4807     if (GIMME != G_ARRAY) {
4808         PUSHs(sv = sv_newmortal());
4809         if (nent) {
4810             if (which == OP_GNBYNAME)
4811                 sv_setiv(sv, (IV)nent->n_net);
4812             else
4813                 sv_setpv(sv, nent->n_name);
4814         }
4815         RETURN;
4816     }
4817
4818     if (nent) {
4819         mPUSHs(newSVpv(nent->n_name, 0));
4820         PUSHs(space_join_names_mortal(nent->n_aliases));
4821         mPUSHi(nent->n_addrtype);
4822         mPUSHi(nent->n_net);
4823     }
4824
4825     RETURN;
4826 #else
4827     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4828 #endif
4829 }
4830
4831 PP(pp_gprotoent)
4832 {
4833 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4834     dVAR; dSP;
4835     I32 which = PL_op->op_type;
4836     SV *sv;
4837 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4838     struct protoent *getprotobyname(Netdb_name_t);
4839     struct protoent *getprotobynumber(int);
4840     struct protoent *getprotoent(void);
4841 #endif
4842     struct protoent *pent;
4843
4844     if (which == OP_GPBYNAME) {
4845 #ifdef HAS_GETPROTOBYNAME
4846         const char* const name = POPpbytex;
4847         pent = PerlSock_getprotobyname(name);
4848 #else
4849         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4850 #endif
4851     }
4852     else if (which == OP_GPBYNUMBER) {
4853 #ifdef HAS_GETPROTOBYNUMBER
4854         const int number = POPi;
4855         pent = PerlSock_getprotobynumber(number);
4856 #else
4857         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4858 #endif
4859     }
4860     else
4861 #ifdef HAS_GETPROTOENT
4862         pent = PerlSock_getprotoent();
4863 #else
4864         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4865 #endif
4866
4867     EXTEND(SP, 3);
4868     if (GIMME != G_ARRAY) {
4869         PUSHs(sv = sv_newmortal());
4870         if (pent) {
4871             if (which == OP_GPBYNAME)
4872                 sv_setiv(sv, (IV)pent->p_proto);
4873             else
4874                 sv_setpv(sv, pent->p_name);
4875         }
4876         RETURN;
4877     }
4878
4879     if (pent) {
4880         mPUSHs(newSVpv(pent->p_name, 0));
4881         PUSHs(space_join_names_mortal(pent->p_aliases));
4882         mPUSHi(pent->p_proto);
4883     }
4884
4885     RETURN;
4886 #else
4887     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4888 #endif
4889 }
4890
4891 PP(pp_gservent)
4892 {
4893 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4894     dVAR; dSP;
4895     I32 which = PL_op->op_type;
4896     SV *sv;
4897 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4898     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4899     struct servent *getservbyport(int, Netdb_name_t);
4900     struct servent *getservent(void);
4901 #endif
4902     struct servent *sent;
4903
4904     if (which == OP_GSBYNAME) {
4905 #ifdef HAS_GETSERVBYNAME
4906         const char * const proto = POPpbytex;
4907         const char * const name = POPpbytex;
4908         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4909 #else
4910         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4911 #endif
4912     }
4913     else if (which == OP_GSBYPORT) {
4914 #ifdef HAS_GETSERVBYPORT
4915         const char * const proto = POPpbytex;
4916         unsigned short port = (unsigned short)POPu;
4917         port = PerlSock_htons(port);
4918         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4919 #else
4920         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4921 #endif
4922     }
4923     else
4924 #ifdef HAS_GETSERVENT
4925         sent = PerlSock_getservent();
4926 #else
4927         DIE(aTHX_ PL_no_sock_func, "getservent");
4928 #endif
4929
4930     EXTEND(SP, 4);
4931     if (GIMME != G_ARRAY) {
4932         PUSHs(sv = sv_newmortal());
4933         if (sent) {
4934             if (which == OP_GSBYNAME) {
4935                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4936             }
4937             else
4938                 sv_setpv(sv, sent->s_name);
4939         }
4940         RETURN;
4941     }
4942
4943     if (sent) {
4944         mPUSHs(newSVpv(sent->s_name, 0));
4945         PUSHs(space_join_names_mortal(sent->s_aliases));
4946         mPUSHi(PerlSock_ntohs(sent->s_port));
4947         mPUSHs(newSVpv(sent->s_proto, 0));
4948     }
4949
4950     RETURN;
4951 #else
4952     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4953 #endif
4954 }
4955
4956 PP(pp_shostent)
4957 {
4958     dVAR; dSP;
4959     const int stayopen = TOPi;
4960     switch(PL_op->op_type) {
4961     case OP_SHOSTENT:
4962 #ifdef HAS_SETHOSTENT
4963         PerlSock_sethostent(stayopen);
4964 #else
4965         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4966 #endif
4967         break;
4968 #ifdef HAS_SETNETENT
4969     case OP_SNETENT:
4970         PerlSock_setnetent(stayopen);
4971 #else
4972         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4973 #endif
4974         break;
4975     case OP_SPROTOENT:
4976 #ifdef HAS_SETPROTOENT
4977         PerlSock_setprotoent(stayopen);
4978 #else
4979         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4980 #endif
4981         break;
4982     case OP_SSERVENT:
4983 #ifdef HAS_SETSERVENT
4984         PerlSock_setservent(stayopen);
4985 #else
4986         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4987 #endif
4988         break;
4989     }
4990     RETSETYES;
4991 }
4992
4993 PP(pp_ehostent)
4994 {
4995     dVAR; dSP;
4996     switch(PL_op->op_type) {
4997     case OP_EHOSTENT:
4998 #ifdef HAS_ENDHOSTENT
4999         PerlSock_endhostent();
5000 #else
5001         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5002 #endif
5003         break;
5004     case OP_ENETENT:
5005 #ifdef HAS_ENDNETENT
5006         PerlSock_endnetent();
5007 #else
5008         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5009 #endif
5010         break;
5011     case OP_EPROTOENT:
5012 #ifdef HAS_ENDPROTOENT
5013         PerlSock_endprotoent();
5014 #else
5015         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5016 #endif
5017         break;
5018     case OP_ESERVENT:
5019 #ifdef HAS_ENDSERVENT
5020         PerlSock_endservent();
5021 #else
5022         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5023 #endif
5024         break;
5025     case OP_SGRENT:
5026 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5027         setgrent();
5028 #else
5029         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5030 #endif
5031         break;
5032     case OP_EGRENT:
5033 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5034         endgrent();
5035 #else
5036         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5037 #endif
5038         break;
5039     case OP_SPWENT:
5040 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5041         setpwent();
5042 #else
5043         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5044 #endif
5045         break;
5046     case OP_EPWENT:
5047 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5048