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