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