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