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