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 U8 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             SvPVCLEAR(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_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle",
 633                              HEKfARG(GvENAME_HEK(gv)));
 634
 635         mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 636         if (mg) {
 637             /* Method's args are same as ours ... */
 638             /* ... except handle is replaced by the object */
 639             return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
 640                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
 641                                     sp - mark);
 642         }
 643     }
 644
 645     if (MARK < SP) {
 646         sv = *++MARK;
 647     }
 648     else {
 649         sv = GvSVn(gv);
 650     }
 651
 652     tmps = SvPV_const(sv, len);
 653     ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
 654     SP = ORIGMARK;
 655     if (ok)
 656         PUSHi( (I32)PL_forkprocess );
 657     else if (PL_forkprocess == 0)               /* we are a new child */
 658         PUSHi(0);
 659     else
 660         RETPUSHUNDEF;
 661     RETURN;
 662 }
 663
 664 PP(pp_close)
 665 {
 666     dSP;
 667     GV * const gv =
 668         MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
 669
 670     if (MAXARG == 0)
 671         EXTEND(SP, 1);
 672
 673     if (gv) {
 674         IO * const io = GvIO(gv);
 675         if (io) {
 676             const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 677             if (mg) {
 678                 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
 679             }
 680         }
 681     }
 682     PUSHs(boolSV(do_close(gv, TRUE)));
 683     RETURN;
 684 }
 685
 686 PP(pp_pipe_op)
 687 {
 688 #ifdef HAS_PIPE
 689     dSP;
 690     IO *rstio;
 691     IO *wstio;
 692     int fd[2];
 693
 694     GV * const wgv = MUTABLE_GV(POPs);
 695     GV * const rgv = MUTABLE_GV(POPs);
 696
 697     rstio = GvIOn(rgv);
 698     if (IoIFP(rstio))
 699         do_close(rgv, FALSE);
 700
 701     wstio = GvIOn(wgv);
 702     if (IoIFP(wstio))
 703         do_close(wgv, FALSE);
 704
 705     if (PerlProc_pipe(fd) < 0)
 706         goto badexit;
 707
 708     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE);
 709     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE);
 710     IoOFP(rstio) = IoIFP(rstio);
 711     IoIFP(wstio) = IoOFP(wstio);
 712     IoTYPE(rstio) = IoTYPE_RDONLY;
 713     IoTYPE(wstio) = IoTYPE_WRONLY;
 714
 715     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 716         if (IoIFP(rstio))
 717             PerlIO_close(IoIFP(rstio));
 718         else
 719             PerlLIO_close(fd[0]);
 720         if (IoOFP(wstio))
 721             PerlIO_close(IoOFP(wstio));
 722         else
 723             PerlLIO_close(fd[1]);
 724         goto badexit;
 725     }
 726 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
 727     /* ensure close-on-exec */
 728     if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
 729         (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
 730         goto badexit;
 731 #endif
 732     RETPUSHYES;
 733
 734   badexit:
 735     RETPUSHUNDEF;
 736 #else
 737     DIE(aTHX_ PL_no_func, "pipe");
 738 #endif
 739 }
 740
 741 PP(pp_fileno)
 742 {
 743     dSP; dTARGET;
 744     GV *gv;
 745     IO *io;
 746     PerlIO *fp;
 747     const MAGIC *mg;
 748
 749     if (MAXARG < 1)
 750         RETPUSHUNDEF;
 751     gv = MUTABLE_GV(POPs);
 752     io = GvIO(gv);
 753
 754     if (io
 755         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 756     {
 757         return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
 758     }
 759
 760     if (io && IoDIRP(io)) {
 761 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
 762         PUSHi(my_dirfd(IoDIRP(io)));
 763         RETURN;
 764 #elif defined(ENOTSUP)
 765         errno = ENOTSUP;        /* Operation not supported */
 766         RETPUSHUNDEF;
 767 #elif defined(EOPNOTSUPP)
 768         errno = EOPNOTSUPP;     /* Operation not supported on socket */
 769         RETPUSHUNDEF;
 770 #else
 771         errno = EINVAL;         /* Invalid argument */
 772         RETPUSHUNDEF;
 773 #endif
 774     }
 775
 776     if (!io || !(fp = IoIFP(io))) {
 777         /* Can't do this because people seem to do things like
 778            defined(fileno($foo)) to check whether $foo is a valid fh.
 779
 780            report_evil_fh(gv);
 781             */
 782         RETPUSHUNDEF;
 783     }
 784
 785     PUSHi(PerlIO_fileno(fp));
 786     RETURN;
 787 }
 788
 789 PP(pp_umask)
 790 {
 791     dSP;
 792 #ifdef HAS_UMASK
 793     dTARGET;
 794     Mode_t anum;
 795
 796     if (MAXARG < 1 || (!TOPs && !POPs)) {
 797         anum = PerlLIO_umask(022);
 798         /* setting it to 022 between the two calls to umask avoids
 799          * to have a window where the umask is set to 0 -- meaning
 800          * that another thread could create world-writeable files. */
 801         if (anum != 022)
 802             (void)PerlLIO_umask(anum);
 803     }
 804     else
 805         anum = PerlLIO_umask(POPi);
 806     TAINT_PROPER("umask");
 807     XPUSHi(anum);
 808 #else
 809     /* Only DIE if trying to restrict permissions on "user" (self).
 810      * Otherwise it's harmless and more useful to just return undef
 811      * since 'group' and 'other' concepts probably don't exist here. */
 812     if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
 813         DIE(aTHX_ "umask not implemented");
 814     XPUSHs(&PL_sv_undef);
 815 #endif
 816     RETURN;
 817 }
 818
 819 PP(pp_binmode)
 820 {
 821     dSP;
 822     GV *gv;
 823     IO *io;
 824     PerlIO *fp;
 825     SV *discp = NULL;
 826
 827     if (MAXARG < 1)
 828         RETPUSHUNDEF;
 829     if (MAXARG > 1) {
 830         discp = POPs;
 831     }
 832
 833     gv = MUTABLE_GV(POPs);
 834     io = GvIO(gv);
 835
 836     if (io) {
 837         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 838         if (mg) {
 839             /* This takes advantage of the implementation of the varargs
 840                function, which I don't think that the optimiser will be able to
 841                figure out. Although, as it's a static function, in theory it
 842                could.  */
 843             return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
 844                                     G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
 845                                     discp ? 1 : 0, discp);
 846         }
 847     }
 848
 849     if (!io || !(fp = IoIFP(io))) {
 850         report_evil_fh(gv);
 851         SETERRNO(EBADF,RMS_IFI);
 852         RETPUSHUNDEF;
 853     }
 854
 855     PUTBACK;
 856     {
 857         STRLEN len = 0;
 858         const char *d = NULL;
 859         int mode;
 860         if (discp)
 861             d = SvPV_const(discp, len);
 862         mode = mode_from_discipline(d, len);
 863         if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
 864             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
 865                 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
 866                     SPAGAIN;
 867                     RETPUSHUNDEF;
 868                 }
 869             }
 870             SPAGAIN;
 871             RETPUSHYES;
 872         }
 873         else {
 874             SPAGAIN;
 875             RETPUSHUNDEF;
 876         }
 877     }
 878 }
 879
 880 PP(pp_tie)
 881 {
 882     dSP; dMARK;
 883     HV* stash;
 884     GV *gv = NULL;
 885     SV *sv;
 886     const I32 markoff = MARK - PL_stack_base;
 887     const char *methname;
 888     int how = PERL_MAGIC_tied;
 889     U32 items;
 890     SV *varsv = *++MARK;
 891
 892     switch(SvTYPE(varsv)) {
 893         case SVt_PVHV:
 894         {
 895             HE *entry;
 896             methname = "TIEHASH";
 897             if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
 898                 HvLAZYDEL_off(varsv);
 899                 hv_free_ent((HV *)varsv, entry);
 900             }
 901             HvEITER_set(MUTABLE_HV(varsv), 0);
 902             break;
 903         }
 904         case SVt_PVAV:
 905             methname = "TIEARRAY";
 906             if (!AvREAL(varsv)) {
 907                 if (!AvREIFY(varsv))
 908                     Perl_croak(aTHX_ "Cannot tie unreifiable array");
 909                 av_clear((AV *)varsv);
 910                 AvREIFY_off(varsv);
 911                 AvREAL_on(varsv);
 912             }
 913             break;
 914         case SVt_PVGV:
 915         case SVt_PVLV:
 916             if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
 917                 methname = "TIEHANDLE";
 918                 how = PERL_MAGIC_tiedscalar;
 919                 /* For tied filehandles, we apply tiedscalar magic to the IO
 920                    slot of the GP rather than the GV itself. AMS 20010812 */
 921                 if (!GvIOp(varsv))
 922                     GvIOp(varsv) = newIO();
 923                 varsv = MUTABLE_SV(GvIOp(varsv));
 924                 break;
 925             }
 926             if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
 927                 vivify_defelem(varsv);
 928                 varsv = LvTARG(varsv);
 929             }
 930             /* FALLTHROUGH */
 931         default:
 932             methname = "TIESCALAR";
 933             how = PERL_MAGIC_tiedscalar;
 934             break;
 935     }
 936     items = SP - MARK++;
 937     if (sv_isobject(*MARK)) { /* Calls GET magic. */
 938         ENTER_with_name("call_TIE");
 939         PUSHSTACKi(PERLSI_MAGIC);
 940         PUSHMARK(SP);
 941         EXTEND(SP,(I32)items);
 942         while (items--)
 943             PUSHs(*MARK++);
 944         PUTBACK;
 945         call_method(methname, G_SCALAR);
 946     }
 947     else {
 948         /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
 949          * will attempt to invoke IO::File::TIEARRAY, with (best case) the
 950          * wrong error message, and worse case, supreme action at a distance.
 951          * (Sorry obfuscation writers. You're not going to be given this one.)
 952          */
 953        stash = gv_stashsv(*MARK, 0);
 954        if (!stash) {
 955            if (SvROK(*MARK))
 956                DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
 957                    methname, SVfARG(*MARK));
 958            else if (isGV(*MARK)) {
 959                /* If the glob doesn't name an existing package, using
 960                 * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
 961                 * generate the name for the error message explicitly. */
 962                SV *stashname = sv_2mortal(newSV(0));
 963                gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
 964                DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
 965                    methname, SVfARG(stashname));
 966            }
 967            else {
 968                SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
 969                              : SvCUR(*MARK)  ? *MARK
 970                              :                 sv_2mortal(newSVpvs("main"));
 971                DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
 972                    " (perhaps you forgot to load \"%" SVf "\"?)",
 973                    methname, SVfARG(stashname), SVfARG(stashname));
 974            }
 975        }
 976        else if (!(gv = gv_fetchmethod(stash, methname))) {
 977            /* The effective name can only be NULL for stashes that have
 978             * been deleted from the symbol table, which this one can't
 979             * be, since we just looked it up by name.
 980             */
 981            DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
 982                methname, HvENAME_HEK_NN(stash));
 983        }
 984         ENTER_with_name("call_TIE");
 985         PUSHSTACKi(PERLSI_MAGIC);
 986         PUSHMARK(SP);
 987         EXTEND(SP,(I32)items);
 988         while (items--)
 989             PUSHs(*MARK++);
 990         PUTBACK;
 991         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
 992     }
 993     SPAGAIN;
 994
 995     sv = TOPs;
 996     POPSTACK;
 997     if (sv_isobject(sv)) {
 998         sv_unmagic(varsv, how);
 999         /* Croak if a self-tie on an aggregate is attempted. */
1000         if (varsv == SvRV(sv) &&
1001             (SvTYPE(varsv) == SVt_PVAV ||
1002              SvTYPE(varsv) == SVt_PVHV))
1003             Perl_croak(aTHX_
1004                        "Self-ties of arrays and hashes are not supported");
1005         sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
1006     }
1007     LEAVE_with_name("call_TIE");
1008     SP = PL_stack_base + markoff;
1009     PUSHs(sv);
1010     RETURN;
1011 }
1012
1013
1014 /* also used for: pp_dbmclose() */
1015
1016 PP(pp_untie)
1017 {
1018     dSP;
1019     MAGIC *mg;
1020     SV *sv = POPs;
1021     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1022                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1023
1024     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1025         RETPUSHYES;
1026
1027     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1028         !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1029
1030     if ((mg = SvTIED_mg(sv, how))) {
1031         SV * const obj = SvRV(SvTIED_obj(sv, mg));
1032         if (obj) {
1033             GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1034             CV *cv;
1035             if (gv && isGV(gv) && (cv = GvCV(gv))) {
1036                PUSHMARK(SP);
1037                PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1038                mXPUSHi(SvREFCNT(obj) - 1);
1039                PUTBACK;
1040                ENTER_with_name("call_UNTIE");
1041                call_sv(MUTABLE_SV(cv), G_VOID);
1042                LEAVE_with_name("call_UNTIE");
1043                SPAGAIN;
1044             }
1045             else if (mg && SvREFCNT(obj) > 1) {
1046                 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1047                                "untie attempted while %" UVuf " inner references still exist",
1048                                (UV)SvREFCNT(obj) - 1 ) ;
1049             }
1050         }
1051     }
1052     sv_unmagic(sv, how) ;
1053     RETPUSHYES;
1054 }
1055
1056 PP(pp_tied)
1057 {
1058     dSP;
1059     const MAGIC *mg;
1060     dTOPss;
1061     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1062                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1063
1064     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1065         goto ret_undef;
1066
1067     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1068         !(sv = defelem_target(sv, NULL))) goto ret_undef;
1069
1070     if ((mg = SvTIED_mg(sv, how))) {
1071         SETs(SvTIED_obj(sv, mg));
1072         return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1073     }
1074     ret_undef:
1075     SETs(&PL_sv_undef);
1076     return NORMAL;
1077 }
1078
1079 PP(pp_dbmopen)
1080 {
1081     dSP;
1082     dPOPPOPssrl;
1083     HV* stash;
1084     GV *gv = NULL;
1085
1086     HV * const hv = MUTABLE_HV(POPs);
1087     SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1088     stash = gv_stashsv(sv, 0);
1089     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1090         PUTBACK;
1091         require_pv("AnyDBM_File.pm");
1092         SPAGAIN;
1093         if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1094             DIE(aTHX_ "No dbm on this machine");
1095     }
1096
1097     ENTER;
1098     PUSHMARK(SP);
1099
1100     EXTEND(SP, 5);
1101     PUSHs(sv);
1102     PUSHs(left);
1103     if (SvIV(right))
1104         mPUSHu(O_RDWR|O_CREAT);
1105     else
1106     {
1107         mPUSHu(O_RDWR);
1108         if (!SvOK(right)) right = &PL_sv_no;
1109     }
1110     PUSHs(right);
1111     PUTBACK;
1112     call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1113     SPAGAIN;
1114
1115     if (!sv_isobject(TOPs)) {
1116         SP--;
1117         PUSHMARK(SP);
1118         PUSHs(sv);
1119         PUSHs(left);
1120         mPUSHu(O_RDONLY);
1121         PUSHs(right);
1122         PUTBACK;
1123         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1124         SPAGAIN;
1125         if (sv_isobject(TOPs))
1126             goto retie;
1127     }
1128     else {
1129         retie:
1130         sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1131         sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1132     }
1133     LEAVE;
1134     RETURN;
1135 }
1136
1137 PP(pp_sselect)
1138 {
1139 #ifdef HAS_SELECT
1140     dSP; dTARGET;
1141     I32 i;
1142     I32 j;
1143     char *s;
1144     SV *sv;
1145     NV value;
1146     I32 maxlen = 0;
1147     I32 nfound;
1148     struct timeval timebuf;
1149     struct timeval *tbuf = &timebuf;
1150     I32 growsize;
1151     char *fd_sets[4];
1152 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1153         I32 masksize;
1154         I32 offset;
1155         I32 k;
1156
1157 #   if BYTEORDER & 0xf0000
1158 #       define ORDERBYTE (0x88888888 - BYTEORDER)
1159 #   else
1160 #       define ORDERBYTE (0x4444 - BYTEORDER)
1161 #   endif
1162
1163 #endif
1164
1165     SP -= 4;
1166     for (i = 1; i <= 3; i++) {
1167         SV * const sv = SP[i];
1168         SvGETMAGIC(sv);
1169         if (!SvOK(sv))
1170             continue;
1171         if (SvREADONLY(sv)) {
1172             if (!(SvPOK(sv) && SvCUR(sv) == 0))
1173                 Perl_croak_no_modify();
1174         }
1175         else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1176         if (!SvPOK(sv)) {
1177             if (!SvPOKp(sv))
1178                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1179                                     "Non-string passed as bitmask");
1180             SvPV_force_nomg_nolen(sv);  /* force string conversion */
1181         }
1182         j = SvCUR(sv);
1183         if (maxlen < j)
1184             maxlen = j;
1185     }
1186
1187 /* little endians can use vecs directly */
1188 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1189 #  ifdef NFDBITS
1190
1191 #    ifndef NBBY
1192 #     define NBBY 8
1193 #    endif
1194
1195     masksize = NFDBITS / NBBY;
1196 #  else
1197     masksize = sizeof(long);    /* documented int, everyone seems to use long */
1198 #  endif
1199     Zero(&fd_sets[0], 4, char*);
1200 #endif
1201
1202 #  if SELECT_MIN_BITS == 1
1203     growsize = sizeof(fd_set);
1204 #  else
1205 #   if defined(__GLIBC__) && defined(__FD_SETSIZE)
1206 #      undef SELECT_MIN_BITS
1207 #      define SELECT_MIN_BITS __FD_SETSIZE
1208 #   endif
1209     /* If SELECT_MIN_BITS is greater than one we most probably will want
1210      * to align the sizes with SELECT_MIN_BITS/8 because for example
1211      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1212      * UNIX, Solaris, Darwin) the smallest quantum select() operates
1213      * on (sets/tests/clears bits) is 32 bits.  */
1214     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1215 #  endif
1216
1217     sv = SP[4];
1218     SvGETMAGIC(sv);
1219     if (SvOK(sv)) {
1220         value = SvNV_nomg(sv);
1221         if (value < 0.0)
1222             value = 0.0;
1223         timebuf.tv_sec = (long)value;
1224         value -= (NV)timebuf.tv_sec;
1225         timebuf.tv_usec = (long)(value * 1000000.0);
1226     }
1227     else
1228         tbuf = NULL;
1229
1230     for (i = 1; i <= 3; i++) {
1231         sv = SP[i];
1232         if (!SvOK(sv) || SvCUR(sv) == 0) {
1233             fd_sets[i] = 0;
1234             continue;
1235         }
1236         assert(SvPOK(sv));
1237         j = SvLEN(sv);
1238         if (j < growsize) {
1239             Sv_Grow(sv, growsize);
1240         }
1241         j = SvCUR(sv);
1242         s = SvPVX(sv) + j;
1243         while (++j <= growsize) {
1244             *s++ = '\0';
1245         }
1246
1247 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1248         s = SvPVX(sv);
1249         Newx(fd_sets[i], growsize, char);
1250         for (offset = 0; offset < growsize; offset += masksize) {
1251             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1252                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1253         }
1254 #else
1255         fd_sets[i] = SvPVX(sv);
1256 #endif
1257     }
1258
1259 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1260     /* Can't make just the (void*) conditional because that would be
1261      * cpp #if within cpp macro, and not all compilers like that. */
1262     nfound = PerlSock_select(
1263         maxlen * 8,
1264         (Select_fd_set_t) fd_sets[1],
1265         (Select_fd_set_t) fd_sets[2],
1266         (Select_fd_set_t) fd_sets[3],
1267         (void*) tbuf); /* Workaround for compiler bug. */
1268 #else
1269     nfound = PerlSock_select(
1270         maxlen * 8,
1271         (Select_fd_set_t) fd_sets[1],
1272         (Select_fd_set_t) fd_sets[2],
1273         (Select_fd_set_t) fd_sets[3],
1274         tbuf);
1275 #endif
1276     for (i = 1; i <= 3; i++) {
1277         if (fd_sets[i]) {
1278             sv = SP[i];
1279 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1280             s = SvPVX(sv);
1281             for (offset = 0; offset < growsize; offset += masksize) {
1282                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1283                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1284             }
1285             Safefree(fd_sets[i]);
1286 #endif
1287             SvSETMAGIC(sv);
1288         }
1289     }
1290
1291     PUSHi(nfound);
1292     if (GIMME_V == G_ARRAY && tbuf) {
1293         value = (NV)(timebuf.tv_sec) +
1294                 (NV)(timebuf.tv_usec) / 1000000.0;
1295         mPUSHn(value);
1296     }
1297     RETURN;
1298 #else
1299     DIE(aTHX_ "select not implemented");
1300 #endif
1301 }
1302
1303 /*
1304
1305 =head1 GV Functions
1306
1307 =for apidoc setdefout
1308
1309 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1310 typeglob.  As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1311 count of the passed in typeglob is increased by one, and the reference count
1312 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1313
1314 =cut
1315 */
1316
1317 void
1318 Perl_setdefout(pTHX_ GV *gv)
1319 {
1320     GV *oldgv = PL_defoutgv;
1321
1322     PERL_ARGS_ASSERT_SETDEFOUT;
1323
1324     SvREFCNT_inc_simple_void_NN(gv);
1325     PL_defoutgv = gv;
1326     SvREFCNT_dec(oldgv);
1327 }
1328
1329 PP(pp_select)
1330 {
1331     dSP; dTARGET;
1332     HV *hv;
1333     GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1334     GV * egv = GvEGVx(PL_defoutgv);
1335     GV * const *gvp;
1336
1337     if (!egv)
1338         egv = PL_defoutgv;
1339     hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1340     gvp = hv && HvENAME(hv)
1341                 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1342                 : NULL;
1343     if (gvp && *gvp == egv) {
1344             gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1345             XPUSHTARG;
1346     }
1347     else {
1348             mXPUSHs(newRV(MUTABLE_SV(egv)));
1349     }
1350
1351     if (newdefout) {
1352         if (!GvIO(newdefout))
1353             gv_IOadd(newdefout);
1354         setdefout(newdefout);
1355     }
1356
1357     RETURN;
1358 }
1359
1360 PP(pp_getc)
1361 {
1362     dSP; dTARGET;
1363     GV * const gv =
1364         MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1365     IO *const io = GvIO(gv);
1366
1367     if (MAXARG == 0)
1368         EXTEND(SP, 1);
1369
1370     if (io) {
1371         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1372         if (mg) {
1373             const U8 gimme = GIMME_V;
1374             Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1375             if (gimme == G_SCALAR) {
1376                 SPAGAIN;
1377                 SvSetMagicSV_nosteal(TARG, TOPs);
1378             }
1379             return NORMAL;
1380         }
1381     }
1382     if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1383         if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1384             report_evil_fh(gv);
1385         SETERRNO(EBADF,RMS_IFI);
1386         RETPUSHUNDEF;
1387     }
1388     TAINT;
1389     sv_setpvs(TARG, " ");
1390     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1391     if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1392         /* Find out how many bytes the char needs */
1393         Size_t len = UTF8SKIP(SvPVX_const(TARG));
1394         if (len > 1) {
1395             SvGROW(TARG,len+1);
1396             len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1397             SvCUR_set(TARG,1+len);
1398         }
1399         SvUTF8_on(TARG);
1400     }
1401     else SvUTF8_off(TARG);
1402     PUSHTARG;
1403     RETURN;
1404 }
1405
1406 STATIC OP *
1407 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1408 {
1409     PERL_CONTEXT *cx;
1410     const U8 gimme = GIMME_V;
1411
1412     PERL_ARGS_ASSERT_DOFORM;
1413
1414     if (CvCLONE(cv))
1415         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1416
1417     cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
1418     cx_pushformat(cx, cv, retop, gv);
1419     if (CvDEPTH(cv) >= 2)
1420         pad_push(CvPADLIST(cv), CvDEPTH(cv));
1421     PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1422
1423     setdefout(gv);          /* locally select filehandle so $% et al work */
1424     return CvSTART(cv);
1425 }
1426
1427 PP(pp_enterwrite)
1428 {
1429     dSP;
1430     GV *gv;
1431     IO *io;
1432     GV *fgv;
1433     CV *cv = NULL;
1434
1435     if (MAXARG == 0) {
1436         EXTEND(SP, 1);
1437         gv = PL_defoutgv;
1438     }
1439     else {
1440         gv = MUTABLE_GV(POPs);
1441         if (!gv)
1442             gv = PL_defoutgv;
1443     }
1444     io = GvIO(gv);
1445     if (!io) {
1446         RETPUSHNO;
1447     }
1448     if (IoFMT_GV(io))
1449         fgv = IoFMT_GV(io);
1450     else
1451         fgv = gv;
1452
1453     assert(fgv);
1454
1455     cv = GvFORM(fgv);
1456     if (!cv) {
1457         SV * const tmpsv = sv_newmortal();
1458         gv_efullname4(tmpsv, fgv, NULL, FALSE);
1459         DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
1460     }
1461     IoFLAGS(io) &= ~IOf_DIDTOP;
1462     RETURNOP(doform(cv,gv,PL_op->op_next));
1463 }
1464
1465 PP(pp_leavewrite)
1466 {
1467     dSP;
1468     GV * const gv = CX_CUR()->blk_format.gv;
1469     IO * const io = GvIOp(gv);
1470     PerlIO *ofp;
1471     PerlIO *fp;
1472     PERL_CONTEXT *cx;
1473     OP *retop;
1474     bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1475
1476     if (is_return || !io || !(ofp = IoOFP(io)))
1477         goto forget_top;
1478
1479     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1480           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1481
1482     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1483         PL_formtarget != PL_toptarget)
1484     {
1485         GV *fgv;
1486         CV *cv;
1487         if (!IoTOP_GV(io)) {
1488             GV *topgv;
1489
1490             if (!IoTOP_NAME(io)) {
1491                 SV *topname;
1492                 if (!IoFMT_NAME(io))
1493                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1494                 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
1495                                         HEKfARG(GvNAME_HEK(gv))));
1496                 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1497                 if ((topgv && GvFORM(topgv)) ||
1498                   !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1499                     IoTOP_NAME(io) = savesvpv(topname);
1500                 else
1501                     IoTOP_NAME(io) = savepvs("top");
1502             }
1503             topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1504             if (!topgv || !GvFORM(topgv)) {
1505                 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1506                 goto forget_top;
1507             }
1508             IoTOP_GV(io) = topgv;
1509         }
1510         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1511             I32 lines = IoLINES_LEFT(io);
1512             const char *s = SvPVX_const(PL_formtarget);
1513             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1514                 goto forget_top;
1515             while (lines-- > 0) {
1516                 s = strchr(s, '\n');
1517                 if (!s)
1518                     break;
1519                 s++;
1520             }
1521             if (s) {
1522                 const STRLEN save = SvCUR(PL_formtarget);
1523                 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1524                 do_print(PL_formtarget, ofp);
1525                 SvCUR_set(PL_formtarget, save);
1526                 sv_chop(PL_formtarget, s);
1527                 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1528             }
1529         }
1530         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1531             do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1532         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1533         IoPAGE(io)++;
1534         PL_formtarget = PL_toptarget;
1535         IoFLAGS(io) |= IOf_DIDTOP;
1536         fgv = IoTOP_GV(io);
1537         assert(fgv); /* IoTOP_GV(io) should have been set above */
1538         cv = GvFORM(fgv);
1539         if (!cv) {
1540             SV * const sv = sv_newmortal();
1541             gv_efullname4(sv, fgv, NULL, FALSE);
1542             DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
1543         }
1544         return doform(cv, gv, PL_op);
1545     }
1546
1547   forget_top:
1548     cx = CX_CUR();
1549     assert(CxTYPE(cx) == CXt_FORMAT);
1550     SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
1551     CX_LEAVE_SCOPE(cx);
1552     cx_popformat(cx);
1553     cx_popblock(cx);
1554     retop = cx->blk_sub.retop;
1555     CX_POP(cx);
1556
1557     if (is_return)
1558         /* XXX the semantics of doing 'return' in a format aren't documented.
1559          * Currently we ignore any args to 'return' and just return
1560          * a single undef in both scalar and list contexts
1561          */
1562         PUSHs(&PL_sv_undef);
1563     else if (!io || !(fp = IoOFP(io))) {
1564         if (io && IoIFP(io))
1565             report_wrongway_fh(gv, '<');
1566         else
1567             report_evil_fh(gv);
1568         PUSHs(&PL_sv_no);
1569     }
1570     else {
1571         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1572             Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1573         }
1574         if (!do_print(PL_formtarget, fp))
1575             PUSHs(&PL_sv_no);
1576         else {
1577             FmLINES(PL_formtarget) = 0;
1578             SvCUR_set(PL_formtarget, 0);
1579             *SvEND(PL_formtarget) = '\0';
1580             if (IoFLAGS(io) & IOf_FLUSH)
1581                 (void)PerlIO_flush(fp);
1582             PUSHs(&PL_sv_yes);
1583         }
1584     }
1585     PL_formtarget = PL_bodytarget;
1586     RETURNOP(retop);
1587 }
1588
1589 PP(pp_prtf)
1590 {
1591     dSP; dMARK; dORIGMARK;
1592     PerlIO *fp;
1593
1594     GV * const gv
1595         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1596     IO *const io = GvIO(gv);
1597
1598     /* Treat empty list as "" */
1599     if (MARK == SP) XPUSHs(&PL_sv_no);
1600
1601     if (io) {
1602         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1603         if (mg) {
1604             if (MARK == ORIGMARK) {
1605                 MEXTEND(SP, 1);
1606                 ++MARK;
1607                 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1608                 ++SP;
1609             }
1610             return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1611                                     mg,
1612                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1613                                     sp - mark);
1614         }
1615     }
1616
1617     if (!io) {
1618         report_evil_fh(gv);
1619         SETERRNO(EBADF,RMS_IFI);
1620         goto just_say_no;
1621     }
1622     else if (!(fp = IoOFP(io))) {
1623         if (IoIFP(io))
1624             report_wrongway_fh(gv, '<');
1625         else if (ckWARN(WARN_CLOSED))
1626             report_evil_fh(gv);
1627         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1628         goto just_say_no;
1629     }
1630     else {
1631         SV *sv = sv_newmortal();
1632         do_sprintf(sv, SP - MARK, MARK + 1);
1633         if (!do_print(sv, fp))
1634             goto just_say_no;
1635
1636         if (IoFLAGS(io) & IOf_FLUSH)
1637             if (PerlIO_flush(fp) == EOF)
1638                 goto just_say_no;
1639     }
1640     SP = ORIGMARK;
1641     PUSHs(&PL_sv_yes);
1642     RETURN;
1643
1644   just_say_no:
1645     SP = ORIGMARK;
1646     PUSHs(&PL_sv_undef);
1647     RETURN;
1648 }
1649
1650 PP(pp_sysopen)
1651 {
1652     dSP;
1653     const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1654     const int mode = POPi;
1655     SV * const sv = POPs;
1656     GV * const gv = MUTABLE_GV(POPs);
1657     STRLEN len;
1658
1659     /* Need TIEHANDLE method ? */
1660     const char * const tmps = SvPV_const(sv, len);
1661     if (do_open_raw(gv, tmps, len, mode, perm, NULL)) {
1662         IoLINES(GvIOp(gv)) = 0;
1663         PUSHs(&PL_sv_yes);
1664     }
1665     else {
1666         PUSHs(&PL_sv_undef);
1667     }
1668     RETURN;
1669 }
1670
1671
1672 /* also used for: pp_read() and pp_recv() (where supported) */
1673
1674 PP(pp_sysread)
1675 {
1676     dSP; dMARK; dORIGMARK; dTARGET;
1677     SSize_t offset;
1678     IO *io;
1679     char *buffer;
1680     STRLEN orig_size;
1681     SSize_t length;
1682     SSize_t count;
1683     SV *bufsv;
1684     STRLEN blen;
1685     int fp_utf8;
1686     int buffer_utf8;
1687     SV *read_target;
1688     Size_t got = 0;
1689     Size_t wanted;
1690     bool charstart = FALSE;
1691     STRLEN charskip = 0;
1692     STRLEN skip = 0;
1693     GV * const gv = MUTABLE_GV(*++MARK);
1694     int fd;
1695
1696     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1697         && gv && (io = GvIO(gv)) )
1698     {
1699         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1700         if (mg) {
1701             return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1702                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1703                                     sp - mark);
1704         }
1705     }
1706
1707     if (!gv)
1708         goto say_undef;
1709     bufsv = *++MARK;
1710     if (! SvOK(bufsv))
1711         SvPVCLEAR(bufsv);
1712     length = SvIVx(*++MARK);
1713     if (length < 0)
1714         DIE(aTHX_ "Negative length");
1715     SETERRNO(0,0);
1716     if (MARK < SP)
1717         offset = SvIVx(*++MARK);
1718     else
1719         offset = 0;
1720     io = GvIO(gv);
1721     if (!io || !IoIFP(io)) {
1722         report_evil_fh(gv);
1723         SETERRNO(EBADF,RMS_IFI);
1724         goto say_undef;
1725     }
1726
1727     /* Note that fd can here validly be -1, don't check it yet. */
1728     fd = PerlIO_fileno(IoIFP(io));
1729
1730     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1731         if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1732             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1733                              "%s() is deprecated on :utf8 handles. "
1734                              "This will be a fatal error in Perl 5.30",
1735                              OP_DESC(PL_op));
1736         }
1737         buffer = SvPVutf8_force(bufsv, blen);
1738         /* UTF-8 may not have been set if they are all low bytes */
1739         SvUTF8_on(bufsv);
1740         buffer_utf8 = 0;
1741     }
1742     else {
1743         buffer = SvPV_force(bufsv, blen);
1744         buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1745     }
1746     if (DO_UTF8(bufsv)) {
1747         blen = sv_len_utf8_nomg(bufsv);
1748     }
1749
1750     charstart = TRUE;
1751     charskip  = 0;
1752     skip = 0;
1753     wanted = length;
1754
1755 #ifdef HAS_SOCKET
1756     if (PL_op->op_type == OP_RECV) {
1757         Sock_size_t bufsize;
1758         char namebuf[MAXPATHLEN];
1759         if (fd < 0) {
1760             SETERRNO(EBADF,SS_IVCHAN);
1761             RETPUSHUNDEF;
1762         }
1763 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1764         bufsize = sizeof (struct sockaddr_in);
1765 #else
1766         bufsize = sizeof namebuf;
1767 #endif
1768 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1769         if (bufsize >= 256)
1770             bufsize = 255;
1771 #endif
1772         buffer = SvGROW(bufsv, (STRLEN)(length+1));
1773         /* 'offset' means 'flags' here */
1774         count = PerlSock_recvfrom(fd, buffer, length, offset,
1775                                   (struct sockaddr *)namebuf, &bufsize);
1776         if (count < 0)
1777             RETPUSHUNDEF;
1778         /* MSG_TRUNC can give oversized count; quietly lose it */
1779         if (count > length)
1780             count = length;
1781         SvCUR_set(bufsv, count);
1782         *SvEND(bufsv) = '\0';
1783         (void)SvPOK_only(bufsv);
1784         if (fp_utf8)
1785             SvUTF8_on(bufsv);
1786         SvSETMAGIC(bufsv);
1787         /* This should not be marked tainted if the fp is marked clean */
1788         if (!(IoFLAGS(io) & IOf_UNTAINT))
1789             SvTAINTED_on(bufsv);
1790         SP = ORIGMARK;
1791 #if defined(__CYGWIN__)
1792         /* recvfrom() on cygwin doesn't set bufsize at all for
1793            connected sockets, leaving us with trash in the returned
1794            name, so use the same test as the Win32 code to check if it
1795            wasn't set, and set it [perl #118843] */
1796         if (bufsize == sizeof namebuf)
1797             bufsize = 0;
1798 #endif
1799         sv_setpvn(TARG, namebuf, bufsize);
1800         PUSHs(TARG);
1801         RETURN;
1802     }
1803 #endif
1804     if (offset < 0) {
1805         if (-offset > (SSize_t)blen)
1806             DIE(aTHX_ "Offset outside string");
1807         offset += blen;
1808     }
1809     if (DO_UTF8(bufsv)) {
1810         /* convert offset-as-chars to offset-as-bytes */
1811         if (offset >= (SSize_t)blen)
1812             offset += SvCUR(bufsv) - blen;
1813         else
1814             offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1815     }
1816
1817  more_bytes:
1818     /* Reestablish the fd in case it shifted from underneath us. */
1819     fd = PerlIO_fileno(IoIFP(io));
1820
1821     orig_size = SvCUR(bufsv);
1822     /* Allocating length + offset + 1 isn't perfect in the case of reading
1823        bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1824        unduly.
1825        (should be 2 * length + offset + 1, or possibly something longer if
1826        IN_ENCODING Is true) */
1827     buffer  = SvGROW(bufsv, (STRLEN)(length+offset+1));
1828     if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1829         Zero(buffer+orig_size, offset-orig_size, char);
1830     }
1831     buffer = buffer + offset;
1832     if (!buffer_utf8) {
1833         read_target = bufsv;
1834     } else {
1835         /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1836            concatenate it to the current buffer.  */
1837
1838         /* Truncate the existing buffer to the start of where we will be
1839            reading to:  */
1840         SvCUR_set(bufsv, offset);
1841
1842         read_target = sv_newmortal();
1843         SvUPGRADE(read_target, SVt_PV);
1844         buffer = SvGROW(read_target, (STRLEN)(length + 1));
1845     }
1846
1847     if (PL_op->op_type == OP_SYSREAD) {
1848 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1849         if (IoTYPE(io) == IoTYPE_SOCKET) {
1850             if (fd < 0) {
1851                 SETERRNO(EBADF,SS_IVCHAN);
1852                 count = -1;
1853             }
1854             else
1855                 count = PerlSock_recv(fd, buffer, length, 0);
1856         }
1857         else
1858 #endif
1859         {
1860             if (fd < 0) {
1861                 SETERRNO(EBADF,RMS_IFI);
1862                 count = -1;
1863             }
1864             else
1865                 count = PerlLIO_read(fd, buffer, length);
1866         }
1867     }
1868     else
1869     {
1870         count = PerlIO_read(IoIFP(io), buffer, length);
1871         /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1872         if (count == 0 && PerlIO_error(IoIFP(io)))
1873             count = -1;
1874     }
1875     if (count < 0) {
1876         if (IoTYPE(io) == IoTYPE_WRONLY)
1877             report_wrongway_fh(gv, '>');
1878         goto say_undef;
1879     }
1880     SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1881     *SvEND(read_target) = '\0';
1882     (void)SvPOK_only(read_target);
1883     if (fp_utf8 && !IN_BYTES) {
1884         /* Look at utf8 we got back and count the characters */
1885         const char *bend = buffer + count;
1886         while (buffer < bend) {
1887             if (charstart) {
1888                 skip = UTF8SKIP(buffer);
1889                 charskip = 0;
1890             }
1891             if (buffer - charskip + skip > bend) {
1892                 /* partial character - try for rest of it */
1893                 length = skip - (bend-buffer);
1894                 offset = bend - SvPVX_const(bufsv);
1895                 charstart = FALSE;
1896                 charskip += count;
1897                 goto more_bytes;
1898             }
1899             else {
1900                 got++;
1901                 buffer += skip;
1902                 charstart = TRUE;
1903                 charskip  = 0;
1904             }
1905         }
1906         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1907            provided amount read (count) was what was requested (length)
1908          */
1909         if (got < wanted && count == length) {
1910             length = wanted - got;
1911             offset = bend - SvPVX_const(bufsv);
1912             goto more_bytes;
1913         }
1914         /* return value is character count */
1915         count = got;
1916         SvUTF8_on(bufsv);
1917     }
1918     else if (buffer_utf8) {
1919         /* Let svcatsv upgrade the bytes we read in to utf8.
1920            The buffer is a mortal so will be freed soon.  */
1921         sv_catsv_nomg(bufsv, read_target);
1922     }
1923     SvSETMAGIC(bufsv);
1924     /* This should not be marked tainted if the fp is marked clean */
1925     if (!(IoFLAGS(io) & IOf_UNTAINT))
1926         SvTAINTED_on(bufsv);
1927     SP = ORIGMARK;
1928     PUSHi(count);
1929     RETURN;
1930
1931   say_undef:
1932     SP = ORIGMARK;
1933     RETPUSHUNDEF;
1934 }
1935
1936
1937 /* also used for: pp_send() where defined */
1938
1939 PP(pp_syswrite)
1940 {
1941     dSP; dMARK; dORIGMARK; dTARGET;
1942     SV *bufsv;
1943     const char *buffer;
1944     SSize_t retval;
1945     STRLEN blen;
1946     STRLEN orig_blen_bytes;
1947     const int op_type = PL_op->op_type;
1948     bool doing_utf8;
1949     U8 *tmpbuf = NULL;
1950     GV *const gv = MUTABLE_GV(*++MARK);
1951     IO *const io = GvIO(gv);
1952     int fd;
1953
1954     if (op_type == OP_SYSWRITE && io) {
1955         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1956         if (mg) {
1957             if (MARK == SP - 1) {
1958                 SV *sv = *SP;
1959                 mXPUSHi(sv_len(sv));
1960                 PUTBACK;
1961             }
1962
1963             return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1964                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1965                                     sp - mark);
1966         }
1967     }
1968     if (!gv)
1969         goto say_undef;
1970
1971     bufsv = *++MARK;
1972
1973     SETERRNO(0,0);
1974     if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1975         retval = -1;
1976         if (io && IoIFP(io))
1977             report_wrongway_fh(gv, '<');
1978         else
1979             report_evil_fh(gv);
1980         SETERRNO(EBADF,RMS_IFI);
1981         goto say_undef;
1982     }
1983     fd = PerlIO_fileno(IoIFP(io));
1984     if (fd < 0) {
1985         SETERRNO(EBADF,SS_IVCHAN);
1986         retval = -1;
1987         goto say_undef;
1988     }
1989
1990     /* Do this first to trigger any overloading.  */
1991     buffer = SvPV_const(bufsv, blen);
1992     orig_blen_bytes = blen;
1993     doing_utf8 = DO_UTF8(bufsv);
1994
1995     if (PerlIO_isutf8(IoIFP(io))) {
1996         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1997                          "%s() is deprecated on :utf8 handles. "
1998                          "This will be a fatal error in Perl 5.30",
1999                          OP_DESC(PL_op));
2000         if (!SvUTF8(bufsv)) {
2001             /* We don't modify the original scalar.  */
2002             tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
2003             buffer = (char *) tmpbuf;
2004             doing_utf8 = TRUE;
2005         }
2006     }
2007     else if (doing_utf8) {
2008         STRLEN tmplen = blen;
2009         U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
2010         if (!doing_utf8) {
2011             tmpbuf = result;
2012             buffer = (char *) tmpbuf;
2013             blen = tmplen;
2014         }
2015         else {
2016             assert((char *)result == buffer);
2017             Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
2018         }
2019     }
2020
2021 #ifdef HAS_SOCKET
2022     if (op_type == OP_SEND) {
2023         const int flags = SvIVx(*++MARK);
2024         if (SP > MARK) {
2025             STRLEN mlen;
2026             char * const sockbuf = SvPVx(*++MARK, mlen);
2027             retval = PerlSock_sendto(fd, buffer, blen,
2028                                      flags, (struct sockaddr *)sockbuf, mlen);
2029         }
2030         else {
2031             retval = PerlSock_send(fd, buffer, blen, flags);
2032         }
2033     }
2034     else
2035 #endif
2036     {
2037         Size_t length = 0; /* This length is in characters.  */
2038         STRLEN blen_chars;
2039         IV offset;
2040
2041         if (doing_utf8) {
2042             if (tmpbuf) {
2043                 /* The SV is bytes, and we've had to upgrade it.  */
2044                 blen_chars = orig_blen_bytes;
2045             } else {
2046                 /* The SV really is UTF-8.  */
2047                 /* Don't call sv_len_utf8 on a magical or overloaded
2048                    scalar, as we might get back a different result.  */
2049                 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2050             }
2051         } else {
2052             blen_chars = blen;
2053         }
2054
2055         if (MARK >= SP) {
2056             length = blen_chars;
2057         } else {
2058 #if Size_t_size > IVSIZE
2059             length = (Size_t)SvNVx(*++MARK);
2060 #else
2061             length = (Size_t)SvIVx(*++MARK);
2062 #endif
2063             if ((SSize_t)length < 0) {
2064                 Safefree(tmpbuf);
2065                 DIE(aTHX_ "Negative length");
2066             }
2067         }
2068
2069         if (MARK < SP) {
2070             offset = SvIVx(*++MARK);
2071             if (offset < 0) {
2072                 if (-offset > (IV)blen_chars) {
2073                     Safefree(tmpbuf);
2074                     DIE(aTHX_ "Offset outside string");
2075                 }
2076                 offset += blen_chars;
2077             } else if (offset > (IV)blen_chars) {
2078                 Safefree(tmpbuf);
2079                 DIE(aTHX_ "Offset outside string");
2080             }
2081         } else
2082             offset = 0;
2083         if (length > blen_chars - offset)
2084             length = blen_chars - offset;
2085         if (doing_utf8) {
2086             /* Here we convert length from characters to bytes.  */
2087             if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2088                 /* Either we had to convert the SV, or the SV is magical, or
2089                    the SV has overloading, in which case we can't or mustn't
2090                    or mustn't call it again.  */
2091
2092                 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2093                 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2094             } else {
2095                 /* It's a real UTF-8 SV, and it's not going to change under
2096                    us.  Take advantage of any cache.  */
2097                 I32 start = offset;
2098                 I32 len_I32 = length;
2099
2100                 /* Convert the start and end character positions to bytes.
2101                    Remember that the second argument to sv_pos_u2b is relative
2102                    to the first.  */
2103                 sv_pos_u2b(bufsv, &start, &len_I32);
2104
2105                 buffer += start;
2106                 length = len_I32;
2107             }
2108         }
2109         else {
2110             buffer = buffer+offset;
2111         }
2112 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2113         if (IoTYPE(io) == IoTYPE_SOCKET) {
2114             retval = PerlSock_send(fd, buffer, length, 0);
2115         }
2116         else
2117 #endif
2118         {
2119             /* See the note at doio.c:do_print about filesize limits. --jhi */
2120             retval = PerlLIO_write(fd, buffer, length);
2121         }
2122     }
2123
2124     if (retval < 0)
2125         goto say_undef;
2126     SP = ORIGMARK;
2127     if (doing_utf8)
2128         retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2129
2130     Safefree(tmpbuf);
2131 #if Size_t_size > IVSIZE
2132     PUSHn(retval);
2133 #else
2134     PUSHi(retval);
2135 #endif
2136     RETURN;
2137
2138   say_undef:
2139     Safefree(tmpbuf);
2140     SP = ORIGMARK;
2141     RETPUSHUNDEF;
2142 }
2143
2144 PP(pp_eof)
2145 {
2146     dSP;
2147     GV *gv;
2148     IO *io;
2149     const MAGIC *mg;
2150     /*
2151      * in Perl 5.12 and later, the additional parameter is a bitmask:
2152      * 0 = eof
2153      * 1 = eof(FH)
2154      * 2 = eof()  <- ARGV magic
2155      *
2156      * I'll rely on the compiler's trace flow analysis to decide whether to
2157      * actually assign this out here, or punt it into the only block where it is
2158      * used. Doing it out here is DRY on the condition logic.
2159      */
2160     unsigned int which;
2161
2162     if (MAXARG) {
2163         gv = PL_last_in_gv = MUTABLE_GV(POPs);  /* eof(FH) */
2164         which = 1;
2165     }
2166     else {
2167         EXTEND(SP, 1);
2168
2169         if (PL_op->op_flags & OPf_SPECIAL) {
2170             gv = PL_last_in_gv = GvEGVx(PL_argvgv);     /* eof() - ARGV magic */
2171             which = 2;
2172         }
2173         else {
2174             gv = PL_last_in_gv;                 /* eof */
2175             which = 0;
2176         }
2177     }
2178
2179     if (!gv)
2180         RETPUSHNO;
2181
2182     if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2183         return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2184     }
2185
2186     if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) {   /* eof() */
2187         if (io && !IoIFP(io)) {
2188             if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2189                 SV ** svp;
2190                 IoLINES(io) = 0;
2191                 IoFLAGS(io) &= ~IOf_START;
2192                 do_open6(gv, "-", 1, NULL, NULL, 0);
2193                 svp = &GvSV(gv);
2194                 if (*svp) {
2195                     SV * sv = *svp;
2196                     sv_setpvs(sv, "-");
2197                     SvSETMAGIC(sv);
2198                 }
2199                 else
2200                     *svp = newSVpvs("-");
2201             }
2202             else if (!nextargv(gv, FALSE))
2203                 RETPUSHYES;
2204         }
2205     }
2206
2207     PUSHs(boolSV(do_eof(gv)));
2208     RETURN;
2209 }
2210
2211 PP(pp_tell)
2212 {
2213     dSP; dTARGET;
2214     GV *gv;
2215     IO *io;
2216
2217     if (MAXARG != 0 && (TOPs || POPs))
2218         PL_last_in_gv = MUTABLE_GV(POPs);
2219     else
2220         EXTEND(SP, 1);
2221     gv = PL_last_in_gv;
2222
2223     io = GvIO(gv);
2224     if (io) {
2225         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2226         if (mg) {
2227             return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2228         }
2229     }
2230     else if (!gv) {
2231         if (!errno)
2232             SETERRNO(EBADF,RMS_IFI);
2233         PUSHi(-1);
2234         RETURN;
2235     }
2236
2237 #if LSEEKSIZE > IVSIZE
2238     PUSHn( do_tell(gv) );
2239 #else
2240     PUSHi( do_tell(gv) );
2241 #endif
2242     RETURN;
2243 }
2244
2245
2246 /* also used for: pp_seek() */
2247
2248 PP(pp_sysseek)
2249 {
2250     dSP;
2251     const int whence = POPi;
2252 #if LSEEKSIZE > IVSIZE
2253     const Off_t offset = (Off_t)SvNVx(POPs);
2254 #else
2255     const Off_t offset = (Off_t)SvIVx(POPs);
2256 #endif
2257
2258     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2259     IO *const io = GvIO(gv);
2260
2261     if (io) {
2262         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2263         if (mg) {
2264 #if LSEEKSIZE > IVSIZE
2265             SV *const offset_sv = newSVnv((NV) offset);
2266 #else
2267             SV *const offset_sv = newSViv(offset);
2268 #endif
2269
2270             return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2271                                 newSViv(whence));
2272         }
2273     }
2274
2275     if (PL_op->op_type == OP_SEEK)
2276         PUSHs(boolSV(do_seek(gv, offset, whence)));
2277     else {
2278         const Off_t sought = do_sysseek(gv, offset, whence);
2279         if (sought < 0)
2280             PUSHs(&PL_sv_undef);
2281         else {
2282             SV* const sv = sought ?
2283 #if LSEEKSIZE > IVSIZE
2284                 newSVnv((NV)sought)
2285 #else
2286                 newSViv(sought)
2287 #endif
2288                 : newSVpvn(zero_but_true, ZBTLEN);
2289             mPUSHs(sv);
2290         }
2291     }
2292     RETURN;
2293 }
2294
2295 PP(pp_truncate)
2296 {
2297     dSP;
2298     /* There seems to be no consensus on the length type of truncate()
2299      * and ftruncate(), both off_t and size_t have supporters. In
2300      * general one would think that when using large files, off_t is
2301      * at least as wide as size_t, so using an off_t should be okay. */
2302     /* XXX Configure probe for the length type of *truncate() needed XXX */
2303     Off_t len;
2304
2305 #if Off_t_size > IVSIZE
2306     len = (Off_t)POPn;
2307 #else
2308     len = (Off_t)POPi;
2309 #endif
2310     /* Checking for length < 0 is problematic as the type might or
2311      * might not be signed: if it is not, clever compilers will moan. */
2312     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2313     SETERRNO(0,0);
2314     {
2315         SV * const sv = POPs;
2316         int result = 1;
2317         GV *tmpgv;
2318         IO *io;
2319
2320         if (PL_op->op_flags & OPf_SPECIAL
2321                        ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2322                        : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2323             io = GvIO(tmpgv);
2324             if (!io)
2325                 result = 0;
2326             else {
2327                 PerlIO *fp;
2328             do_ftruncate_io:
2329                 TAINT_PROPER("truncate");
2330                 if (!(fp = IoIFP(io))) {
2331                     result = 0;
2332                 }
2333                 else {
2334                     int fd = PerlIO_fileno(fp);
2335                     if (fd < 0) {
2336                         SETERRNO(EBADF,RMS_IFI);
2337                         result = 0;
2338                     } else {
2339                         if (len < 0) {
2340                             SETERRNO(EINVAL, LIB_INVARG);
2341                             result = 0;
2342                         } else {
2343                            PerlIO_flush(fp);
2344 #ifdef HAS_TRUNCATE
2345                            if (ftruncate(fd, len) < 0)
2346 #else
2347                            if (my_chsize(fd, len) < 0)
2348 #endif
2349                                result = 0;
2350                         }
2351                     }
2352                 }
2353             }
2354         }
2355         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2356                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2357                 goto do_ftruncate_io;
2358         }
2359         else {
2360             const char * const name = SvPV_nomg_const_nolen(sv);
2361             TAINT_PROPER("truncate");
2362 #ifdef HAS_TRUNCATE
2363             if (truncate(name, len) < 0)
2364                 result = 0;
2365 #else
2366             {
2367                 int mode = O_RDWR;
2368                 int tmpfd;
2369
2370 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2371                 mode |= O_LARGEFILE;    /* Transparently largefiley. */
2372 #endif
2373 #ifdef O_BINARY
2374                 /* On open(), the Win32 CRT tries to seek around text
2375                  * files using 32-bit offsets, which causes the open()
2376                  * to fail on large files, so open in binary mode.
2377                  */
2378                 mode |= O_BINARY;
2379 #endif
2380                 tmpfd = PerlLIO_open(name, mode);
2381
2382                 if (tmpfd < 0) {
2383                     result = 0;
2384                 } else {
2385                     if (my_chsize(tmpfd, len) < 0)
2386                         result = 0;
2387                     PerlLIO_close(tmpfd);
2388                 }
2389             }
2390 #endif
2391         }
2392
2393         if (result)
2394             RETPUSHYES;
2395         if (!errno)
2396             SETERRNO(EBADF,RMS_IFI);
2397         RETPUSHUNDEF;
2398     }
2399 }
2400
2401
2402 /* also used for: pp_fcntl() */
2403
2404 PP(pp_ioctl)
2405 {
2406     dSP; dTARGET;
2407     SV * const argsv = POPs;
2408     const unsigned int func = POPu;
2409     int optype;
2410     GV * const gv = MUTABLE_GV(POPs);
2411     IO * const io = GvIOn(gv);
2412     char *s;
2413     IV retval;
2414
2415     if (!IoIFP(io)) {
2416         report_evil_fh(gv);
2417         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2418         RETPUSHUNDEF;
2419     }
2420
2421     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2422         STRLEN len;
2423         STRLEN need;
2424         s = SvPV_force(argsv, len);
2425         need = IOCPARM_LEN(func);
2426         if (len < need) {
2427             s = Sv_Grow(argsv, need + 1);
2428             SvCUR_set(argsv, need);
2429         }
2430
2431         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2432     }
2433     else {
2434         retval = SvIV(argsv);
2435         s = INT2PTR(char*,retval);              /* ouch */
2436     }
2437
2438     optype = PL_op->op_type;
2439     TAINT_PROPER(PL_op_desc[optype]);
2440
2441     if (optype == OP_IOCTL)
2442 #ifdef HAS_IOCTL
2443         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2444 #else
2445         DIE(aTHX_ "ioctl is not implemented");
2446 #endif
2447     else
2448 #ifndef HAS_FCNTL
2449       DIE(aTHX_ "fcntl is not implemented");
2450 #else
2451 #if defined(OS2) && defined(__EMX__)
2452         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2453 #else
2454         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2455 #endif
2456 #endif
2457
2458 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2459     if (SvPOK(argsv)) {
2460         if (s[SvCUR(argsv)] != 17)
2461             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2462                 OP_NAME(PL_op));
2463         s[SvCUR(argsv)] = 0;            /* put our null back */
2464         SvSETMAGIC(argsv);              /* Assume it has changed */
2465     }
2466
2467     if (retval == -1)
2468         RETPUSHUNDEF;
2469     if (retval != 0) {
2470         PUSHi(retval);
2471     }
2472     else {
2473         PUSHp(zero_but_true, ZBTLEN);
2474     }
2475 #endif
2476     RETURN;
2477 }
2478
2479 PP(pp_flock)
2480 {
2481 #ifdef FLOCK
2482     dSP; dTARGET;
2483     I32 value;
2484     const int argtype = POPi;
2485     GV * const gv = MUTABLE_GV(POPs);
2486     IO *const io = GvIO(gv);
2487     PerlIO *const fp = io ? IoIFP(io) : NULL;
2488
2489     /* XXX Looks to me like io is always NULL at this point */
2490     if (fp) {
2491         (void)PerlIO_flush(fp);
2492         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2493     }
2494     else {
2495         report_evil_fh(gv);
2496         value = 0;
2497         SETERRNO(EBADF,RMS_IFI);
2498     }
2499     PUSHi(value);
2500     RETURN;
2501 #else
2502     DIE(aTHX_ PL_no_func, "flock");
2503 #endif
2504 }
2505
2506 /* Sockets. */
2507
2508 #ifdef HAS_SOCKET
2509
2510 PP(pp_socket)
2511 {
2512     dSP;
2513     const int protocol = POPi;
2514     const int type = POPi;
2515     const int domain = POPi;
2516     GV * const gv = MUTABLE_GV(POPs);
2517     IO * const io = GvIOn(gv);
2518     int fd;
2519
2520     if (IoIFP(io))
2521         do_close(gv, FALSE);
2522
2523     TAINT_PROPER("socket");
2524     fd = PerlSock_socket(domain, type, protocol);
2525     if (fd < 0) {
2526         RETPUSHUNDEF;
2527     }
2528     IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2529     IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2530     IoTYPE(io) = IoTYPE_SOCKET;
2531     if (!IoIFP(io) || !IoOFP(io)) {
2532         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2533         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2534         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2535         RETPUSHUNDEF;
2536     }
2537 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2538     /* ensure close-on-exec */
2539     if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2540         RETPUSHUNDEF;
2541 #endif
2542
2543     RETPUSHYES;
2544 }
2545 #endif
2546
2547 PP(pp_sockpair)
2548 {
2549 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2550     dSP;
2551     int fd[2];
2552     const int protocol = POPi;
2553     const int type = POPi;
2554     const int domain = POPi;
2555
2556     GV * const gv2 = MUTABLE_GV(POPs);
2557     IO * const io2 = GvIOn(gv2);
2558     GV * const gv1 = MUTABLE_GV(POPs);
2559     IO * const io1 = GvIOn(gv1);
2560
2561     if (IoIFP(io1))
2562         do_close(gv1, FALSE);
2563     if (IoIFP(io2))
2564         do_close(gv2, FALSE);
2565
2566     TAINT_PROPER("socketpair");
2567     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2568         RETPUSHUNDEF;
2569     IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
2570     IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
2571     IoTYPE(io1) = IoTYPE_SOCKET;
2572     IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
2573     IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
2574     IoTYPE(io2) = IoTYPE_SOCKET;
2575     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2576         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2577         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2578         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2579         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2580         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2581         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2582         RETPUSHUNDEF;
2583     }
2584 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2585     /* ensure close-on-exec */
2586     if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
2587         (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
2588         RETPUSHUNDEF;
2589 #endif
2590
2591     RETPUSHYES;
2592 #else
2593     DIE(aTHX_ PL_no_sock_func, "socketpair");
2594 #endif
2595 }
2596
2597 #ifdef HAS_SOCKET
2598
2599 /* also used for: pp_connect() */
2600
2601 PP(pp_bind)
2602 {
2603     dSP;
2604     SV * const addrsv = POPs;
2605     /* OK, so on what platform does bind modify addr?  */
2606     const char *addr;
2607     GV * const gv = MUTABLE_GV(POPs);
2608     IO * const io = GvIOn(gv);
2609     STRLEN len;
2610     int op_type;
2611     int fd;
2612
2613     if (!IoIFP(io))
2614         goto nuts;
2615     fd = PerlIO_fileno(IoIFP(io));
2616     if (fd < 0)
2617         goto nuts;
2618
2619     addr = SvPV_const(addrsv, len);
2620     op_type = PL_op->op_type;
2621     TAINT_PROPER(PL_op_desc[op_type]);
2622     if ((op_type == OP_BIND
2623          ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2624          : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2625         >= 0)
2626         RETPUSHYES;
2627     else
2628         RETPUSHUNDEF;
2629
2630   nuts:
2631     report_evil_fh(gv);
2632     SETERRNO(EBADF,SS_IVCHAN);
2633     RETPUSHUNDEF;
2634 }
2635
2636 PP(pp_listen)
2637 {
2638     dSP;
2639     const int backlog = POPi;
2640     GV * const gv = MUTABLE_GV(POPs);
2641     IO * const io = GvIOn(gv);
2642
2643     if (!IoIFP(io))
2644         goto nuts;
2645
2646     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2647         RETPUSHYES;
2648     else
2649         RETPUSHUNDEF;
2650
2651   nuts:
2652     report_evil_fh(gv);
2653     SETERRNO(EBADF,SS_IVCHAN);
2654     RETPUSHUNDEF;
2655 }
2656
2657 PP(pp_accept)
2658 {
2659     dSP; dTARGET;
2660     IO *nstio;
2661     char namebuf[MAXPATHLEN];
2662 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2663     Sock_size_t len = sizeof (struct sockaddr_in);
2664 #else
2665     Sock_size_t len = sizeof namebuf;
2666 #endif
2667     GV * const ggv = MUTABLE_GV(POPs);
2668     GV * const ngv = MUTABLE_GV(POPs);
2669     int fd;
2670
2671     IO * const gstio = GvIO(ggv);
2672     if (!gstio || !IoIFP(gstio))
2673         goto nuts;
2674
2675     nstio = GvIOn(ngv);
2676     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2677 #if defined(OEMVS)
2678     if (len == 0) {
2679         /* Some platforms indicate zero length when an AF_UNIX client is
2680          * not bound. Simulate a non-zero-length sockaddr structure in
2681          * this case. */
2682         namebuf[0] = 0;        /* sun_len */
2683         namebuf[1] = AF_UNIX;  /* sun_family */
2684         len = 2;
2685     }
2686 #endif
2687
2688     if (fd < 0)
2689         goto badexit;
2690     if (IoIFP(nstio))
2691         do_close(ngv, FALSE);
2692     IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
2693     IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2694     IoTYPE(nstio) = IoTYPE_SOCKET;
2695     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2696         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2697         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2698         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2699         goto badexit;
2700     }
2701 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2702     /* ensure close-on-exec */
2703     if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2704         goto badexit;
2705 #endif
2706
2707 #ifdef __SCO_VERSION__
2708     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2709 #endif
2710
2711     PUSHp(namebuf, len);
2712     RETURN;
2713
2714   nuts:
2715     report_evil_fh(ggv);
2716     SETERRNO(EBADF,SS_IVCHAN);
2717
2718   badexit:
2719     RETPUSHUNDEF;
2720
2721 }
2722
2723 PP(pp_shutdown)
2724 {
2725     dSP; dTARGET;
2726     const int how = POPi;
2727     GV * const gv = MUTABLE_GV(POPs);
2728     IO * const io = GvIOn(gv);
2729
2730     if (!IoIFP(io))
2731         goto nuts;
2732
2733     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2734     RETURN;
2735
2736   nuts:
2737     report_evil_fh(gv);
2738     SETERRNO(EBADF,SS_IVCHAN);
2739     RETPUSHUNDEF;
2740 }
2741
2742
2743 /* also used for: pp_gsockopt() */
2744
2745 PP(pp_ssockopt)
2746 {
2747     dSP;
2748     const int optype = PL_op->op_type;
2749     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2750     const unsigned int optname = (unsigned int) POPi;
2751     const unsigned int lvl = (unsigned int) POPi;
2752     GV * const gv = MUTABLE_GV(POPs);
2753     IO * const io = GvIOn(gv);
2754     int fd;
2755     Sock_size_t len;
2756
2757     if (!IoIFP(io))
2758         goto nuts;
2759
2760     fd = PerlIO_fileno(IoIFP(io));
2761     if (fd < 0)
2762         goto nuts;
2763     switch (optype) {
2764     case OP_GSOCKOPT:
2765         SvGROW(sv, 257);
2766         (void)SvPOK_only(sv);
2767         SvCUR_set(sv,256);
2768         *SvEND(sv) ='\0';
2769         len = SvCUR(sv);
2770         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2771             goto nuts2;
2772 #if defined(_AIX)
2773         /* XXX Configure test: does getsockopt set the length properly? */
2774         if (len == 256)
2775             len = sizeof(int);
2776 #endif
2777         SvCUR_set(sv, len);
2778         *SvEND(sv) ='\0';
2779         PUSHs(sv);
2780         break;
2781     case OP_SSOCKOPT: {
2782 #if defined(__SYMBIAN32__)
2783 # define SETSOCKOPT_OPTION_VALUE_T void *
2784 #else
2785 # define SETSOCKOPT_OPTION_VALUE_T const char *
2786 #endif
2787         /* XXX TODO: We need to have a proper type (a Configure probe,
2788          * etc.) for what the C headers think of the third argument of
2789          * setsockopt(), the option_value read-only buffer: is it
2790          * a "char *", or a "void *", const or not.  Some compilers
2791          * don't take kindly to e.g. assuming that "char *" implicitly
2792          * promotes to a "void *", or to explicitly promoting/demoting
2793          * consts to non/vice versa.  The "const void *" is the SUS
2794          * definition, but that does not fly everywhere for the above
2795          * reasons. */
2796             SETSOCKOPT_OPTION_VALUE_T buf;
2797             int aint;
2798             if (SvPOKp(sv)) {
2799                 STRLEN l;
2800                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2801                 len = l;
2802             }
2803             else {
2804                 aint = (int)SvIV(sv);
2805                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2806                 len = sizeof(int);
2807             }
2808             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2809                 goto nuts2;
2810             PUSHs(&PL_sv_yes);
2811         }
2812         break;
2813     }
2814     RETURN;
2815
2816   nuts:
2817     report_evil_fh(gv);
2818     SETERRNO(EBADF,SS_IVCHAN);
2819   nuts2:
2820     RETPUSHUNDEF;
2821
2822 }
2823
2824
2825 /* also used for: pp_getsockname() */
2826
2827 PP(pp_getpeername)
2828 {
2829     dSP;
2830     const int optype = PL_op->op_type;
2831     GV * const gv = MUTABLE_GV(POPs);
2832     IO * const io = GvIOn(gv);
2833     Sock_size_t len;
2834     SV *sv;
2835     int fd;
2836
2837     if (!IoIFP(io))
2838         goto nuts;
2839
2840     sv = sv_2mortal(newSV(257));
2841     (void)SvPOK_only(sv);
2842     len = 256;
2843     SvCUR_set(sv, len);
2844     *SvEND(sv) ='\0';
2845     fd = PerlIO_fileno(IoIFP(io));
2846     if (fd < 0)
2847         goto nuts;
2848     switch (optype) {
2849     case OP_GETSOCKNAME:
2850         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2851             goto nuts2;
2852         break;
2853     case OP_GETPEERNAME:
2854         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2855             goto nuts2;
2856 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2857         {
2858             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";
2859             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2860             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2861                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2862                         sizeof(u_short) + sizeof(struct in_addr))) {
2863                 goto nuts2;
2864             }
2865         }
2866 #endif
2867         break;
2868     }
2869 #ifdef BOGUS_GETNAME_RETURN
2870     /* Interactive Unix, getpeername() and getsockname()
2871       does not return valid namelen */
2872     if (len == BOGUS_GETNAME_RETURN)
2873         len = sizeof(struct sockaddr);
2874 #endif
2875     SvCUR_set(sv, len);
2876     *SvEND(sv) ='\0';
2877     PUSHs(sv);
2878     RETURN;
2879
2880   nuts:
2881     report_evil_fh(gv);
2882     SETERRNO(EBADF,SS_IVCHAN);
2883   nuts2:
2884     RETPUSHUNDEF;
2885 }
2886
2887 #endif
2888
2889 /* Stat calls. */
2890
2891 /* also used for: pp_lstat() */
2892
2893 PP(pp_stat)
2894 {
2895     dSP;
2896     GV *gv = NULL;
2897     IO *io = NULL;
2898     U8 gimme;
2899     I32 max = 13;
2900     SV* sv;
2901
2902     if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2903                                   : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2904         if (PL_op->op_type == OP_LSTAT) {
2905             if (gv != PL_defgv) {
2906             do_fstat_warning_check:
2907                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2908                                "lstat() on filehandle%s%" SVf,
2909                                 gv ? " " : "",
2910                                 SVfARG(gv
2911                                         ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2912                                         : &PL_sv_no));
2913             } else if (PL_laststype != OP_LSTAT)
2914                 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2915                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2916         }
2917
2918         if (gv != PL_defgv) {
2919             bool havefp;
2920           do_fstat_have_io:
2921             havefp = FALSE;
2922             PL_laststype = OP_STAT;
2923             PL_statgv = gv ? gv : (GV *)io;
2924             SvPVCLEAR(PL_statname);
2925             if(gv) {
2926                 io = GvIO(gv);
2927             }
2928             if (io) {
2929                     if (IoIFP(io)) {
2930                         int fd = PerlIO_fileno(IoIFP(io));
2931                         if (fd < 0) {
2932                             PL_laststatval = -1;
2933                             SETERRNO(EBADF,RMS_IFI);
2934                         } else {
2935                             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2936                             havefp = TRUE;
2937                         }
2938                     } else if (IoDIRP(io)) {
2939                         PL_laststatval =
2940                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2941                         havefp = TRUE;
2942                     } else {
2943                         PL_laststatval = -1;
2944                     }
2945             }
2946             else PL_laststatval = -1;
2947             if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2948         }
2949
2950         if (PL_laststatval < 0) {
2951             max = 0;
2952         }
2953     }
2954     else {
2955         const char *file;
2956         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2957             io = MUTABLE_IO(SvRV(sv));
2958             if (PL_op->op_type == OP_LSTAT)
2959                 goto do_fstat_warning_check;
2960             goto do_fstat_have_io;
2961         }
2962
2963         SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2964         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2965         PL_statgv = NULL;
2966         PL_laststype = PL_op->op_type;
2967         file = SvPV_nolen_const(PL_statname);
2968         if (PL_op->op_type == OP_LSTAT)
2969             PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2970         else
2971             PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2972         if (PL_laststatval < 0) {
2973             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2974                 /* PL_warn_nl is constant */
2975                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2976                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2977                 GCC_DIAG_RESTORE;
2978             }
2979             max = 0;
2980         }
2981     }
2982
2983     gimme = GIMME_V;
2984     if (gimme != G_ARRAY) {
2985         if (gimme != G_VOID)
2986             XPUSHs(boolSV(max));
2987         RETURN;
2988     }
2989     if (max) {
2990         EXTEND(SP, max);
2991         EXTEND_MORTAL(max);
2992         mPUSHi(PL_statcache.st_dev);
2993 #if ST_INO_SIZE > IVSIZE
2994         mPUSHn(PL_statcache.st_ino);
2995 #else
2996 #   if ST_INO_SIGN <= 0
2997         mPUSHi(PL_statcache.st_ino);
2998 #   else
2999         mPUSHu(PL_statcache.st_ino);
3000 #   endif
3001 #endif
3002         mPUSHu(PL_statcache.st_mode);
3003         mPUSHu(PL_statcache.st_nlink);
3004
3005         sv_setuid(PUSHmortal, PL_statcache.st_uid);
3006         sv_setgid(PUSHmortal, PL_statcache.st_gid);
3007
3008 #ifdef USE_STAT_RDEV
3009         mPUSHi(PL_statcache.st_rdev);
3010 #else
3011         PUSHs(newSVpvs_flags("", SVs_TEMP));
3012 #endif
3013 #if Off_t_size > IVSIZE
3014         mPUSHn(PL_statcache.st_size);
3015 #else
3016         mPUSHi(PL_statcache.st_size);
3017 #endif
3018 #ifdef BIG_TIME
3019         mPUSHn(PL_statcache.st_atime);
3020         mPUSHn(PL_statcache.st_mtime);
3021         mPUSHn(PL_statcache.st_ctime);
3022 #else
3023         mPUSHi(PL_statcache.st_atime);
3024         mPUSHi(PL_statcache.st_mtime);
3025         mPUSHi(PL_statcache.st_ctime);
3026 #endif
3027 #ifdef USE_STAT_BLOCKS
3028         mPUSHu(PL_statcache.st_blksize);
3029         mPUSHu(PL_statcache.st_blocks);
3030 #else
3031         PUSHs(newSVpvs_flags("", SVs_TEMP));
3032         PUSHs(newSVpvs_flags("", SVs_TEMP));
3033 #endif
3034     }
3035     RETURN;
3036 }
3037
3038 /* All filetest ops avoid manipulating the perl stack pointer in their main
3039    bodies (since commit d2c4d2d1e22d3125), and return using either
3040    S_ft_return_false() or S_ft_return_true().  These two helper functions are
3041    the only two which manipulate the perl stack.  To ensure that no stack
3042    manipulation macros are used, the filetest ops avoid defining a local copy
3043    of the stack pointer with dSP.  */
3044
3045 /* If the next filetest is stacked up with this one
3046    (PL_op->op_private & OPpFT_STACKING), we leave
3047    the original argument on the stack for success,
3048    and skip the stacked operators on failure.
3049    The next few macros/functions take care of this.
3050 */
3051
3052 static OP *
3053 S_ft_return_false(pTHX_ SV *ret) {
3054     OP *next = NORMAL;
3055     dSP;
3056
3057     if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3058     else                           SETs(ret);
3059     PUTBACK;
3060
3061     if (PL_op->op_private & OPpFT_STACKING) {
3062         while (OP_IS_FILETEST(next->op_type)
3063                && next->op_private & OPpFT_STACKED)
3064             next = next->op_next;
3065     }
3066     return next;
3067 }
3068
3069 PERL_STATIC_INLINE OP *
3070 S_ft_return_true(pTHX_ SV *ret) {
3071     dSP;
3072     if (PL_op->op_flags & OPf_REF)
3073         XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3074     else if (!(PL_op->op_private & OPpFT_STACKING))
3075         SETs(ret);
3076     PUTBACK;
3077     return NORMAL;
3078 }
3079
3080 #define FT_RETURNNO     return S_ft_return_false(aTHX_ &PL_sv_no)
3081 #define FT_RETURNUNDEF  return S_ft_return_false(aTHX_ &PL_sv_undef)
3082 #define FT_RETURNYES    return S_ft_return_true(aTHX_ &PL_sv_yes)
3083
3084 #define tryAMAGICftest_MG(chr) STMT_START { \
3085         if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3086                 && PL_op->op_flags & OPf_KIDS) {     \
3087             OP *next = S_try_amagic_ftest(aTHX_ chr);   \
3088             if (next) return next;                        \
3089         }                                                  \
3090     } STMT_END
3091
3092 STATIC OP *
3093 S_try_amagic_ftest(pTHX_ char chr) {
3094     SV *const arg = *PL_stack_sp;
3095
3096     assert(chr != '?');
3097     if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3098
3099     if (SvAMAGIC(arg))
3100     {
3101         const char tmpchr = chr;
3102         SV * const tmpsv = amagic_call(arg,
3103                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3104                                 ftest_amg, AMGf_unary);
3105
3106         if (!tmpsv)
3107             return NULL;
3108
3109         return SvTRUE(tmpsv)
3110             ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3111     }
3112     return NULL;
3113 }
3114
3115
3116 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3117  *                pp_ftrwrite() */
3118
3119 PP(pp_ftrread)
3120 {
3121     I32 result;
3122     /* Not const, because things tweak this below. Not bool, because there's
3123        no guarantee that OPpFT_ACCESS is <= CHAR_MAX  */
3124 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3125     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3126     /* Giving some sort of initial value silences compilers.  */
3127 #  ifdef R_OK
3128     int access_mode = R_OK;
3129 #  else
3130     int access_mode = 0;
3131 #  endif
3132 #else
3133     /* access_mode is never used, but leaving use_access in makes the
3134        conditional compiling below much clearer.  */
3135     I32 use_access = 0;
3136 #endif
3137     Mode_t stat_mode = S_IRUSR;
3138
3139     bool effective = FALSE;
3140     char opchar = '?';
3141
3142     switch (PL_op->op_type) {
3143     case OP_FTRREAD:    opchar = 'R'; break;
3144     case OP_FTRWRITE:   opchar = 'W'; break;
3145     case OP_FTREXEC:    opchar = 'X'; break;
3146     case OP_FTEREAD:    opchar = 'r'; break;
3147     case OP_FTEWRITE:   opchar = 'w'; break;
3148     case OP_FTEEXEC:    opchar = 'x'; break;
3149     }
3150     tryAMAGICftest_MG(opchar);
3151
3152     switch (PL_op->op_type) {
3153     case OP_FTRREAD:
3154 #if !(defined(HAS_ACCESS) && defined(R_OK))
3155         use_access = 0;
3156 #endif
3157         break;
3158
3159     case OP_FTRWRITE:
3160 #if defined(HAS_ACCESS) && defined(W_OK)
3161         access_mode = W_OK;
3162 #else
3163         use_access = 0;
3164 #endif
3165         stat_mode = S_IWUSR;
3166         break;
3167
3168     case OP_FTREXEC:
3169 #if defined(HAS_ACCESS) && defined(X_OK)
3170         access_mode = X_OK;
3171 #else
3172         use_access = 0;
3173 #endif
3174         stat_mode = S_IXUSR;
3175         break;
3176
3177     case OP_FTEWRITE:
3178 #ifdef PERL_EFF_ACCESS
3179         access_mode = W_OK;
3180 #endif
3181         stat_mode = S_IWUSR;
3182         /* FALLTHROUGH */
3183
3184     case OP_FTEREAD:
3185 #ifndef PERL_EFF_ACCESS
3186         use_access = 0;
3187 #endif
3188         effective = TRUE;
3189         break;
3190
3191     case OP_FTEEXEC:
3192 #ifdef PERL_EFF_ACCESS
3193         access_mode = X_OK;
3194 #else
3195         use_access = 0;
3196 #endif
3197         stat_mode = S_IXUSR;
3198         effective = TRUE;
3199         break;
3200     }
3201
3202     if (use_access) {
3203 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3204         const char *name = SvPV_nolen(*PL_stack_sp);
3205         if (effective) {
3206 #  ifdef PERL_EFF_ACCESS
3207             result = PERL_EFF_ACCESS(name, access_mode);
3208 #  else
3209             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3210                 OP_NAME(PL_op));
3211 #  endif
3212         }
3213         else {
3214 #  ifdef HAS_ACCESS
3215             result = access(name, access_mode);
3216 #  else
3217             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3218 #  endif
3219         }
3220         if (result == 0)
3221             FT_RETURNYES;
3222         if (result < 0)
3223             FT_RETURNUNDEF;
3224         FT_RETURNNO;
3225 #endif
3226     }
3227
3228     result = my_stat_flags(0);
3229     if (result < 0)
3230         FT_RETURNUNDEF;
3231     if (cando(stat_mode, effective, &PL_statcache))
3232         FT_RETURNYES;
3233     FT_RETURNNO;
3234 }
3235
3236
3237 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3238
3239 PP(pp_ftis)
3240 {
3241     I32 result;
3242     const int op_type = PL_op->op_type;
3243     char opchar = '?';
3244
3245     switch (op_type) {
3246     case OP_FTIS:       opchar = 'e'; break;
3247     case OP_FTSIZE:     opchar = 's'; break;
3248     case OP_FTMTIME:    opchar = 'M'; break;
3249     case OP_FTCTIME:    opchar = 'C'; break;
3250     case OP_FTATIME:    opchar = 'A'; break;
3251     }
3252     tryAMAGICftest_MG(opchar);
3253
3254     result = my_stat_flags(0);
3255     if (result < 0)
3256         FT_RETURNUNDEF;
3257     if (op_type == OP_FTIS)
3258         FT_RETURNYES;
3259     {
3260         /* You can't dTARGET inside OP_FTIS, because you'll get
3261            "panic: pad_sv po" - the op is not flagged to have a target.  */
3262         dTARGET;
3263         switch (op_type) {
3264         case OP_FTSIZE:
3265 #if Off_t_size > IVSIZE
3266             sv_setnv(TARG, (NV)PL_statcache.st_size);
3267 #else
3268             sv_setiv(TARG, (IV)PL_statcache.st_size);
3269 #endif
3270             break;
3271         case OP_FTMTIME:
3272             sv_setnv(TARG,
3273                     ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3274             break;
3275         case OP_FTATIME:
3276             sv_setnv(TARG,
3277                     ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3278             break;
3279         case OP_FTCTIME:
3280             sv_setnv(TARG,
3281                     ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3282             break;
3283         }
3284         SvSETMAGIC(TARG);
3285         return SvTRUE_nomg(TARG)
3286             ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3287     }
3288 }
3289
3290
3291 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3292  *                pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3293  *                pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3294
3295 PP(pp_ftrowned)
3296 {
3297     I32 result;
3298     char opchar = '?';
3299
3300     switch (PL_op->op_type) {
3301     case OP_FTROWNED:   opchar = 'O'; break;
3302     case OP_FTEOWNED:   opchar = 'o'; break;
3303     case OP_FTZERO:     opchar = 'z'; break;
3304     case OP_FTSOCK:     opchar = 'S'; break;
3305     case OP_FTCHR:      opchar = 'c'; break;
3306     case OP_FTBLK:      opchar = 'b'; break;
3307     case OP_FTFILE:     opchar = 'f'; break;
3308     case OP_FTDIR:      opchar = 'd'; break;
3309     case OP_FTPIPE:     opchar = 'p'; break;
3310     case OP_FTSUID:     opchar = 'u'; break;
3311     case OP_FTSGID:     opchar = 'g'; break;
3312     case OP_FTSVTX:     opchar = 'k'; break;
3313     }
3314     tryAMAGICftest_MG(opchar);
3315
3316     /* I believe that all these three are likely to be defined on most every
3317        system these days.  */
3318 #ifndef S_ISUID
3319     if(PL_op->op_type == OP_FTSUID) {
3320         FT_RETURNNO;
3321     }
3322 #endif
3323 #ifndef S_ISGID
3324     if(PL_op->op_type == OP_FTSGID) {
3325         FT_RETURNNO;
3326     }
3327 #endif
3328 #ifndef S_ISVTX
3329     if(PL_op->op_type == OP_FTSVTX) {
3330         FT_RETURNNO;
3331     }
3332 #endif
3333
3334     result = my_stat_flags(0);
3335     if (result < 0)
3336         FT_RETURNUNDEF;
3337     switch (PL_op->op_type) {
3338     case OP_FTROWNED:
3339         if (PL_statcache.st_uid == PerlProc_getuid())
3340             FT_RETURNYES;
3341         break;
3342     case OP_FTEOWNED:
3343         if (PL_statcache.st_uid == PerlProc_geteuid())
3344             FT_RETURNYES;
3345         break;
3346     case OP_FTZERO:
3347         if (PL_statcache.st_size == 0)
3348             FT_RETURNYES;
3349         break;
3350     case OP_FTSOCK:
3351         if (S_ISSOCK(PL_statcache.st_mode))
3352             FT_RETURNYES;
3353         break;
3354     case OP_FTCHR:
3355         if (S_ISCHR(PL_statcache.st_mode))
3356             FT_RETURNYES;
3357         break;
3358     case OP_FTBLK:
3359         if (S_ISBLK(PL_statcache.st_mode))
3360             FT_RETURNYES;
3361         break;
3362     case OP_FTFILE:
3363         if (S_ISREG(PL_statcache.st_mode))
3364             FT_RETURNYES;
3365         break;
3366     case OP_FTDIR:
3367         if (S_ISDIR(PL_statcache.st_mode))
3368             FT_RETURNYES;
3369         break;
3370     case OP_FTPIPE:
3371         if (S_ISFIFO(PL_statcache.st_mode))
3372             FT_RETURNYES;
3373         break;
3374 #ifdef S_ISUID
3375     case OP_FTSUID:
3376         if (PL_statcache.st_mode & S_ISUID)
3377             FT_RETURNYES;
3378         break;
3379 #endif
3380 #ifdef S_ISGID
3381     case OP_FTSGID:
3382         if (PL_statcache.st_mode & S_ISGID)
3383             FT_RETURNYES;
3384         break;
3385 #endif
3386 #ifdef S_ISVTX
3387     case OP_FTSVTX:
3388         if (PL_statcache.st_mode & S_ISVTX)
3389             FT_RETURNYES;
3390         break;
3391 #endif
3392     }
3393     FT_RETURNNO;
3394 }
3395
3396 PP(pp_ftlink)
3397 {
3398     I32 result;
3399
3400     tryAMAGICftest_MG('l');
3401     result = my_lstat_flags(0);
3402
3403     if (result < 0)
3404         FT_RETURNUNDEF;
3405     if (S_ISLNK(PL_statcache.st_mode))
3406         FT_RETURNYES;
3407     FT_RETURNNO;
3408 }
3409
3410 PP(pp_fttty)
3411 {
3412     int fd;
3413     GV *gv;
3414     char *name = NULL;
3415     STRLEN namelen;
3416     UV uv;
3417
3418     tryAMAGICftest_MG('t');
3419
3420     if (PL_op->op_flags & OPf_REF)
3421         gv = cGVOP_gv;
3422     else {
3423       SV *tmpsv = *PL_stack_sp;
3424       if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3425         name = SvPV_nomg(tmpsv, namelen);
3426         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3427       }
3428     }
3429
3430     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3431         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3432     else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3433         fd = (int)uv;
3434     else
3435         FT_RETURNUNDEF;
3436     if (fd < 0) {
3437         SETERRNO(EBADF,RMS_IFI);
3438         FT_RETURNUNDEF;
3439     }
3440     if (PerlLIO_isatty(fd))
3441         FT_RETURNYES;
3442     FT_RETURNNO;
3443 }
3444
3445
3446 /* also used for: pp_ftbinary() */
3447
3448 PP(pp_fttext)
3449 {
3450     I32 i;
3451     SSize_t len;
3452     I32 odd = 0;
3453     STDCHAR tbuf[512];
3454     STDCHAR *s;
3455     IO *io;
3456     SV *sv = NULL;
3457     GV *gv;
3458     PerlIO *fp;
3459
3460     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3461
3462     if (PL_op->op_flags & OPf_REF)
3463         gv = cGVOP_gv;
3464     else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3465              == OPpFT_STACKED)
3466         gv = PL_defgv;
3467     else {
3468         sv = *PL_stack_sp;
3469         gv = MAYBE_DEREF_GV_nomg(sv);
3470     }
3471
3472     if (gv) {
3473         if (gv == PL_defgv) {
3474             if (PL_statgv)
3475                 io = SvTYPE(PL_statgv) == SVt_PVIO
3476                     ? (IO *)PL_statgv
3477                     : GvIO(PL_statgv);
3478             else {
3479                 goto really_filename;
3480             }
3481         }
3482         else {
3483             PL_statgv = gv;
3484             SvPVCLEAR(PL_statname);
3485             io = GvIO(PL_statgv);
3486         }
3487         PL_laststatval = -1;
3488         PL_laststype = OP_STAT;
3489         if (io && IoIFP(io)) {
3490             int fd;
3491             if (! PerlIO_has_base(IoIFP(io)))
3492                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3493             fd = PerlIO_fileno(IoIFP(io));
3494             if (fd < 0) {
3495                 SETERRNO(EBADF,RMS_IFI);
3496                 FT_RETURNUNDEF;
3497             }
3498             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3499             if (PL_laststatval < 0)
3500                 FT_RETURNUNDEF;
3501             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3502                 if (PL_op->op_type == OP_FTTEXT)
3503                     FT_RETURNNO;
3504                 else
3505                     FT_RETURNYES;
3506             }
3507             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3508                 i = PerlIO_getc(IoIFP(io));
3509                 if (i != EOF)
3510                     (void)PerlIO_ungetc(IoIFP(io),i);
3511                 else
3512                     /* null file is anything */
3513                     FT_RETURNYES;
3514             }
3515             len = PerlIO_get_bufsiz(IoIFP(io));
3516             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3517             /* sfio can have large buffers - limit to 512 */
3518             if (len > 512)
3519                 len = 512;
3520         }
3521         else {
3522             SETERRNO(EBADF,RMS_IFI);
3523             report_evil_fh(gv);
3524             SETERRNO(EBADF,RMS_IFI);
3525             FT_RETURNUNDEF;
3526         }
3527     }
3528     else {
3529         const char *file;
3530         int fd;
3531
3532         assert(sv);
3533         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3534       really_filename:
3535         file = SvPVX_const(PL_statname);
3536         PL_statgv = NULL;
3537         if (!(fp = PerlIO_open(file, "r"))) {
3538             if (!gv) {
3539                 PL_laststatval = -1;
3540                 PL_laststype = OP_STAT;
3541             }
3542             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3543                 /* PL_warn_nl is constant */
3544                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3545                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3546                 GCC_DIAG_RESTORE;
3547             }
3548             FT_RETURNUNDEF;
3549         }
3550         PL_laststype = OP_STAT;
3551         fd = PerlIO_fileno(fp);
3552         if (fd < 0) {
3553             (void)PerlIO_close(fp);
3554             SETERRNO(EBADF,RMS_IFI);
3555             FT_RETURNUNDEF;
3556         }
3557         PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3558         if (PL_laststatval < 0) {
3559             dSAVE_ERRNO;
3560             (void)PerlIO_close(fp);
3561             RESTORE_ERRNO;
3562             FT_RETURNUNDEF;
3563         }
3564         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3565         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3566         (void)PerlIO_close(fp);
3567         if (len <= 0) {
3568             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3569                 FT_RETURNNO;            /* special case NFS directories */
3570             FT_RETURNYES;               /* null file is anything */
3571         }
3572         s = tbuf;
3573     }
3574
3575     /* now scan s to look for textiness */
3576
3577 #if defined(DOSISH) || defined(USEMYBINMODE)
3578     /* ignore trailing ^Z on short files */
3579     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3580         --len;
3581 #endif
3582
3583     assert(len);
3584     if (! is_utf8_invariant_string((U8 *) s, len)) {
3585
3586         /* Here contains a variant under UTF-8 .  See if the entire string is
3587          * UTF-8. */
3588         if (is_utf8_fixed_width_buf_flags((U8 *) s, len, 0)) {
3589             if (PL_op->op_type == OP_FTTEXT) {
3590                 FT_RETURNYES;
3591             }
3592             else {
3593                 FT_RETURNNO;
3594             }
3595         }
3596     }
3597
3598     /* Here, is not UTF-8 or is entirely ASCII.  Look through the buffer for
3599      * things that wouldn't be in ASCII text or rich ASCII text.  Count these
3600      * in 'odd' */
3601     for (i = 0; i < len; i++, s++) {
3602         if (!*s) {                      /* null never allowed in text */
3603             odd += len;
3604             break;
3605         }
3606 #ifdef USE_LOCALE_CTYPE
3607         if (IN_LC_RUNTIME(LC_CTYPE)) {
3608             if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3609                 continue;
3610             }
3611         }
3612         else
3613 #endif
3614              if (  isPRINT_A(*s)
3615                     /* VT occurs so rarely in text, that we consider it odd */
3616                  || (isSPACE_A(*s) && *s != VT_NATIVE)
3617
3618                     /* But there is a fair amount of backspaces and escapes in
3619                      * some text */
3620                  || *s == '\b'
3621                  || *s == ESC_NATIVE)
3622         {
3623             continue;
3624         }
3625         odd++;
3626     }
3627
3628     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3629         FT_RETURNNO;
3630     else
3631         FT_RETURNYES;
3632 }
3633
3634 /* File calls. */
3635
3636 PP(pp_chdir)
3637 {
3638     dSP; dTARGET;
3639     const char *tmps = NULL;
3640     GV *gv = NULL;
3641
3642     if( MAXARG == 1 ) {
3643         SV * const sv = POPs;
3644         if (PL_op->op_flags & OPf_SPECIAL) {
3645             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3646             if (!gv) {
3647                 if (ckWARN(WARN_UNOPENED)) {
3648                     Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3649                                 "chdir() on unopened filehandle %" SVf, sv);
3650                 }
3651                 SETERRNO(EBADF,RMS_IFI);
3652                 PUSHi(0);
3653                 TAINT_PROPER("chdir");
3654                 RETURN;
3655             }
3656         }
3657         else if (!(gv = MAYBE_DEREF_GV(sv)))
3658                 tmps = SvPV_nomg_const_nolen(sv);
3659     }
3660     else {
3661         HV * const table = GvHVn(PL_envgv);
3662         SV **svp;
3663
3664         EXTEND(SP, 1);
3665         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3666              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3667 #ifdef VMS
3668              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3669 #endif
3670            )
3671         {
3672             tmps = SvPV_nolen_const(*svp);
3673         }
3674         else {
3675             PUSHi(0);
3676             SETERRNO(EINVAL, LIB_INVARG);
3677             TAINT_PROPER("chdir");
3678             RETURN;
3679         }
3680     }
3681
3682     TAINT_PROPER("chdir");
3683     if (gv) {
3684 #ifdef HAS_FCHDIR
3685         IO* const io = GvIO(gv);
3686         if (io) {
3687             if (IoDIRP(io)) {
3688                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3689             } else if (IoIFP(io)) {
3690                 int fd = PerlIO_fileno(IoIFP(io));
3691                 if (fd < 0) {
3692                     goto nuts;
3693                 }
3694                 PUSHi(fchdir(fd) >= 0);
3695             }
3696             else {
3697                 goto nuts;
3698             }
3699         } else {
3700             goto nuts;
3701         }
3702
3703 #else
3704         DIE(aTHX_ PL_no_func, "fchdir");
3705 #endif
3706     }
3707     else
3708         PUSHi( PerlDir_chdir(tmps) >= 0 );
3709 #ifdef VMS
3710     /* Clear the DEFAULT element of ENV so we'll get the new value
3711      * in the future. */
3712     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3713 #endif
3714     RETURN;
3715
3716 #ifdef HAS_FCHDIR
3717  nuts:
3718     report_evil_fh(gv);
3719     SETERRNO(EBADF,RMS_IFI);
3720     PUSHi(0);
3721     RETURN;
3722 #endif
3723 }
3724
3725
3726 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3727
3728 PP(pp_chown)
3729 {
3730     dSP; dMARK; dTARGET;
3731     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3732
3733     SP = MARK;
3734     XPUSHi(value);
3735     RETURN;
3736 }
3737
3738 PP(pp_chroot)
3739 {
3740 #ifdef HAS_CHROOT
3741     dSP; dTARGET;
3742     char * const tmps = POPpx;
3743     TAINT_PROPER("chroot");
3744     PUSHi( chroot(tmps) >= 0 );
3745     RETURN;
3746 #else
3747     DIE(aTHX_ PL_no_func, "chroot");
3748 #endif
3749 }
3750
3751 PP(pp_rename)
3752 {
3753     dSP; dTARGET;
3754     int anum;
3755 #ifndef HAS_RENAME
3756     Stat_t statbuf;
3757 #endif
3758     const char * const tmps2 = POPpconstx;
3759     const char * const tmps = SvPV_nolen_const(TOPs);
3760     TAINT_PROPER("rename");
3761 #ifdef HAS_RENAME
3762     anum = PerlLIO_rename(tmps, tmps2);
3763 #else
3764     if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3765         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3766             anum = 1;
3767         else {
3768             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3769                 (void)UNLINK(tmps2);
3770             if (!(anum = link(tmps, tmps2)))
3771                 anum = UNLINK(tmps);
3772         }
3773     }
3774 #endif
3775     SETi( anum >= 0 );
3776     RETURN;
3777 }
3778
3779
3780 /* also used for: pp_symlink() */
3781
3782 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3783 PP(pp_link)
3784 {
3785     dSP; dTARGET;
3786     const int op_type = PL_op->op_type;
3787     int result;
3788
3789 #  ifndef HAS_LINK
3790     if (op_type == OP_LINK)
3791         DIE(aTHX_ PL_no_func, "link");
3792 #  endif
3793 #  ifndef HAS_SYMLINK
3794     if (op_type == OP_SYMLINK)
3795         DIE(aTHX_ PL_no_func, "symlink");
3796 #  endif
3797
3798     {
3799         const char * const tmps2 = POPpconstx;
3800         const char * const tmps = SvPV_nolen_const(TOPs);
3801         TAINT_PROPER(PL_op_desc[op_type]);
3802         result =
3803 #  if defined(HAS_LINK)
3804 #    if defined(HAS_SYMLINK)
3805             /* Both present - need to choose which.  */
3806             (op_type == OP_LINK) ?
3807             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3808 #    else
3809     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3810         PerlLIO_link(tmps, tmps2);
3811 #    endif
3812 #  else
3813 #    if defined(HAS_SYMLINK)
3814     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3815         symlink(tmps, tmps2);
3816 #    endif
3817 #  endif
3818     }
3819
3820     SETi( result >= 0 );
3821     RETURN;
3822 }
3823 #else
3824
3825 /* also used for: pp_symlink() */
3826
3827 PP(pp_link)
3828 {
3829     /* Have neither.  */
3830     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3831 }
3832 #endif
3833
3834 PP(pp_readlink)
3835 {
3836     dSP;
3837 #ifdef HAS_SYMLINK
3838     dTARGET;
3839     const char *tmps;
3840     char buf[MAXPATHLEN];
3841     SSize_t len;
3842
3843     TAINT;
3844     tmps = POPpconstx;
3845     /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3846      * it is impossible to know whether the result was truncated. */
3847     len = readlink(tmps, buf, sizeof(buf) - 1);
3848     if (len < 0)
3849         RETPUSHUNDEF;
3850     if (len != -1)
3851         buf[len] = '\0';
3852     PUSHp(buf, len);
3853     RETURN;
3854 #else
3855     EXTEND(SP, 1);
3856     RETSETUNDEF;                /* just pretend it's a normal file */
3857 #endif
3858 }
3859
3860 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3861 STATIC int
3862 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3863 {
3864     char * const save_filename = filename;
3865     char *cmdline;
3866     char *s;
3867     PerlIO *myfp;
3868     int anum = 1;
3869     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3870
3871     PERL_ARGS_ASSERT_DOONELINER;
3872
3873     Newx(cmdline, size, char);
3874     my_strlcpy(cmdline, cmd, size);
3875     my_strlcat(cmdline, " ", size);
3876     for (s = cmdline + strlen(cmdline); *filename; ) {
3877         *s++ = '\\';
3878         *s++ = *filename++;
3879     }
3880     if (s - cmdline < size)
3881         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3882     myfp = PerlProc_popen(cmdline, "r");
3883     Safefree(cmdline);
3884
3885     if (myfp) {
3886         SV * const tmpsv = sv_newmortal();
3887         /* Need to save/restore 'PL_rs' ?? */
3888         s = sv_gets(tmpsv, myfp, 0);
3889         (void)PerlProc_pclose(myfp);
3890         if (s != NULL) {
3891             int e;
3892             for (e = 1;
3893 #ifdef HAS_SYS_ERRLIST
3894                  e <= sys_nerr
3895 #endif
3896                  ; e++)
3897             {
3898                 /* you don't see this */
3899                 const char * const errmsg = Strerror(e) ;
3900                 if (!errmsg)
3901                     break;
3902                 if (instr(s, errmsg)) {
3903                     SETERRNO(e,0);
3904                     return 0;
3905                 }
3906             }
3907             SETERRNO(0,0);
3908 #ifndef EACCES
3909 #define EACCES EPERM
3910 #endif
3911             if (instr(s, "cannot make"))
3912                 SETERRNO(EEXIST,RMS_FEX);
3913             else if (instr(s, "existing file"))
3914                 SETERRNO(EEXIST,RMS_FEX);
3915             else if (instr(s, "ile exists"))
3916                 SETERRNO(EEXIST,RMS_FEX);
3917             else if (instr(s, "non-exist"))
3918                 SETERRNO(ENOENT,RMS_FNF);
3919             else if (instr(s, "does not exist"))
3920                 SETERRNO(ENOENT,RMS_FNF);
3921             else if (instr(s, "not empty"))
3922                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3923             else if (instr(s, "cannot access"))
3924                 SETERRNO(EACCES,RMS_PRV);
3925             else
3926                 SETERRNO(EPERM,RMS_PRV);
3927             return 0;
3928         }
3929         else {  /* some mkdirs return no failure indication */
3930             Stat_t statbuf;
3931             anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3932             if (PL_op->op_type == OP_RMDIR)
3933                 anum = !anum;
3934             if (anum)
3935                 SETERRNO(0,0);
3936             else
3937                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3938         }
3939         return anum;
3940     }
3941     else
3942         return 0;
3943 }
3944 #endif
3945
3946 /* This macro removes trailing slashes from a directory name.
3947  * Different operating and file systems take differently to
3948  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3949  * any number of trailing slashes should be allowed.
3950  * Thusly we snip them away so that even non-conforming
3951  * systems are happy.
3952  * We should probably do this "filtering" for all
3953  * the functions that expect (potentially) directory names:
3954  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3955  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3956
3957 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3958     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3959         do { \
3960             (len)--; \
3961         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3962         (tmps) = savepvn((tmps), (len)); \
3963         (copy) = TRUE; \
3964     }
3965
3966 PP(pp_mkdir)
3967 {
3968     dSP; dTARGET;
3969     STRLEN len;
3970     const char *tmps;
3971     bool copy = FALSE;
3972     const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3973
3974     TRIMSLASHES(tmps,len,copy);
3975
3976     TAINT_PROPER("mkdir");
3977 #ifdef HAS_MKDIR
3978     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3979 #else
3980     {
3981     int oldumask;
3982     SETi( dooneliner("mkdir", tmps) );
3983     oldumask = PerlLIO_umask(0);
3984     PerlLIO_umask(oldumask);
3985     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3986     }
3987 #endif
3988     if (copy)
3989         Safefree(tmps);
3990     RETURN;
3991 }
3992
3993 PP(pp_rmdir)
3994 {
3995     dSP; dTARGET;
3996     STRLEN len;
3997     const char *tmps;
3998     bool copy = FALSE;
3999
4000     TRIMSLASHES(tmps,len,copy);
4001     TAINT_PROPER("rmdir");
4002 #ifdef HAS_RMDIR
4003     SETi( PerlDir_rmdir(tmps) >= 0 );
4004 #else
4005     SETi( dooneliner("rmdir", tmps) );
4006 #endif
4007     if (copy)
4008         Safefree(tmps);
4009     RETURN;
4010 }
4011
4012 /* Directory calls. */
4013
4014 PP(pp_open_dir)
4015 {
4016 #if defined(Direntry_t) && defined(HAS_READDIR)
4017     dSP;
4018     const char * const dirname = POPpconstx;
4019     GV * const gv = MUTABLE_GV(POPs);
4020     IO * const io = GvIOn(gv);
4021
4022     if ((IoIFP(io) || IoOFP(io)))
4023         Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
4024                          HEKfARG(GvENAME_HEK(gv)));
4025     if (IoDIRP(io))
4026         PerlDir_close(IoDIRP(io));
4027     if (!(IoDIRP(io) = PerlDir_open(dirname)))
4028         goto nope;
4029
4030     RETPUSHYES;
4031   nope:
4032     if (!errno)
4033         SETERRNO(EBADF,RMS_DIR);
4034     RETPUSHUNDEF;
4035 #else
4036     DIE(aTHX_ PL_no_dir_func, "opendir");
4037 #endif
4038 }
4039
4040 PP(pp_readdir)
4041 {
4042 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4043     DIE(aTHX_ PL_no_dir_func, "readdir");
4044 #else
4045 #if !defined(I_DIRENT) && !defined(VMS)
4046     Direntry_t *readdir (DIR *);
4047 #endif
4048     dSP;
4049
4050     SV *sv;
4051     const U8 gimme = GIMME_V;
4052     GV * const gv = MUTABLE_GV(POPs);
4053     const Direntry_t *dp;
4054     IO * const io = GvIOn(gv);
4055
4056     if (!IoDIRP(io)) {
4057         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4058                        "readdir() attempted on invalid dirhandle %" HEKf,
4059                             HEKfARG(GvENAME_HEK(gv)));
4060         goto nope;
4061     }
4062
4063     do {
4064         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4065         if (!dp)
4066             break;
4067 #ifdef DIRNAMLEN
4068         sv = newSVpvn(dp->d_name, dp->d_namlen);
4069 #else
4070         sv = newSVpv(dp->d_name, 0);
4071 #endif
4072         if (!(IoFLAGS(io) & IOf_UNTAINT))
4073             SvTAINTED_on(sv);
4074         mXPUSHs(sv);
4075     } while (gimme == G_ARRAY);
4076
4077     if (!dp && gimme != G_ARRAY)
4078         RETPUSHUNDEF;
4079
4080     RETURN;
4081
4082   nope:
4083     if (!errno)
4084         SETERRNO(EBADF,RMS_ISI);
4085     if (gimme == G_ARRAY)
4086         RETURN;
4087     else
4088         RETPUSHUNDEF;
4089 #endif
4090 }
4091
4092 PP(pp_telldir)
4093 {
4094 #if defined(HAS_TELLDIR) || defined(telldir)
4095     dSP; dTARGET;
4096  /* XXX does _anyone_ need this? --AD 2/20/1998 */
4097  /* XXX netbsd still seemed to.
4098     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4099     --JHI 1999-Feb-02 */
4100 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4101     long telldir (DIR *);
4102 # endif
4103     GV * const gv = MUTABLE_GV(POPs);
4104     IO * const io = GvIOn(gv);
4105
4106     if (!IoDIRP(io)) {
4107         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4108                        "telldir() attempted on invalid dirhandle %" HEKf,
4109                             HEKfARG(GvENAME_HEK(gv)));
4110         goto nope;
4111     }
4112
4113     PUSHi( PerlDir_tell(IoDIRP(io)) );
4114     RETURN;
4115   nope:
4116     if (!errno)
4117         SETERRNO(EBADF,RMS_ISI);
4118     RETPUSHUNDEF;
4119 #else
4120     DIE(aTHX_ PL_no_dir_func, "telldir");
4121 #endif
4122 }
4123
4124 PP(pp_seekdir)
4125 {
4126 #if defined(HAS_SEEKDIR) || defined(seekdir)
4127     dSP;
4128     const long along = POPl;
4129     GV * const gv = MUTABLE_GV(POPs);
4130     IO * const io = GvIOn(gv);
4131
4132     if (!IoDIRP(io)) {
4133         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4134                        "seekdir() attempted on invalid dirhandle %" HEKf,
4135                                 HEKfARG(GvENAME_HEK(gv)));
4136         goto nope;
4137     }
4138     (void)PerlDir_seek(IoDIRP(io), along);
4139
4140     RETPUSHYES;
4141   nope:
4142     if (!errno)
4143         SETERRNO(EBADF,RMS_ISI);
4144     RETPUSHUNDEF;
4145 #else
4146     DIE(aTHX_ PL_no_dir_func, "seekdir");
4147 #endif
4148 }
4149
4150 PP(pp_rewinddir)
4151 {
4152 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4153     dSP;
4154     GV * const gv = MUTABLE_GV(POPs);
4155     IO * const io = GvIOn(gv);
4156
4157     if (!IoDIRP(io)) {
4158         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4159                        "rewinddir() attempted on invalid dirhandle %" HEKf,
4160                                 HEKfARG(GvENAME_HEK(gv)));
4161         goto nope;
4162     }
4163     (void)PerlDir_rewind(IoDIRP(io));
4164     RETPUSHYES;
4165   nope:
4166     if (!errno)
4167         SETERRNO(EBADF,RMS_ISI);
4168     RETPUSHUNDEF;
4169 #else
4170     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4171 #endif
4172 }
4173
4174 PP(pp_closedir)
4175 {
4176 #if defined(Direntry_t) && defined(HAS_READDIR)
4177     dSP;
4178     GV * const gv = MUTABLE_GV(POPs);
4179     IO * const io = GvIOn(gv);
4180
4181     if (!IoDIRP(io)) {
4182         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4183                        "closedir() attempted on invalid dirhandle %" HEKf,
4184                                 HEKfARG(GvENAME_HEK(gv)));
4185         goto nope;
4186     }
4187 #ifdef VOID_CLOSEDIR
4188     PerlDir_close(IoDIRP(io));
4189 #else
4190     if (PerlDir_close(IoDIRP(io)) < 0) {
4191         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4192         goto nope;
4193     }
4194 #endif
4195     IoDIRP(io) = 0;
4196
4197     RETPUSHYES;
4198   nope:
4199     if (!errno)
4200         SETERRNO(EBADF,RMS_IFI);
4201     RETPUSHUNDEF;
4202 #else
4203     DIE(aTHX_ PL_no_dir_func, "closedir");
4204 #endif
4205 }
4206
4207 /* Process control. */
4208
4209 PP(pp_fork)
4210 {
4211 #ifdef HAS_FORK
4212     dSP; dTARGET;
4213     Pid_t childpid;
4214 #ifdef HAS_SIGPROCMASK
4215     sigset_t oldmask, newmask;
4216 #endif
4217
4218     EXTEND(SP, 1);
4219     PERL_FLUSHALL_FOR_CHILD;
4220 #ifdef HAS_SIGPROCMASK
4221     sigfillset(&newmask);
4222     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4223 #endif
4224     childpid = PerlProc_fork();
4225     if (childpid == 0) {
4226         int sig;
4227         PL_sig_pending = 0;
4228         if (PL_psig_pend)
4229             for (sig = 1; sig < SIG_SIZE; sig++)
4230                 PL_psig_pend[sig] = 0;
4231     }
4232 #ifdef HAS_SIGPROCMASK
4233     {
4234         dSAVE_ERRNO;
4235         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4236         RESTORE_ERRNO;
4237     }
4238 #endif
4239     if (childpid < 0)
4240         RETPUSHUNDEF;
4241     if (!childpid) {
4242 #ifdef PERL_USES_PL_PIDSTATUS
4243         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4244 #endif
4245     }
4246     PUSHi(childpid);
4247     RETURN;
4248 #else
4249 #  if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4250     dSP; dTARGET;
4251     Pid_t childpid;
4252
4253     EXTEND(SP, 1);
4254     PERL_FLUSHALL_FOR_CHILD;
4255     childpid = PerlProc_fork();
4256     if (childpid == -1)
4257         RETPUSHUNDEF;
4258     PUSHi(childpid);
4259     RETURN;
4260 #  else
4261     DIE(aTHX_ PL_no_func, "fork");
4262 #  endif
4263 #endif
4264 }
4265
4266 PP(pp_wait)
4267 {
4268 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4269     dSP; dTARGET;
4270     Pid_t childpid;
4271     int argflags;
4272
4273     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4274         childpid = wait4pid(-1, &argflags, 0);
4275     else {
4276         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4277                errno == EINTR) {
4278           PERL_ASYNC_CHECK();
4279         }
4280     }
4281 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4282     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4283     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4284 #  else
4285     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4286 #  endif
4287     XPUSHi(childpid);
4288     RETURN;
4289 #else
4290     DIE(aTHX_ PL_no_func, "wait");
4291 #endif
4292 }
4293
4294 PP(pp_waitpid)
4295 {
4296 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4297     dSP; dTARGET;
4298     const int optype = POPi;
4299     const Pid_t pid = TOPi;
4300     Pid_t result;
4301 #ifdef __amigaos4__
4302     int argflags = 0;
4303     result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4304     STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4305     result = result == 0 ? pid : -1;
4306 #else
4307     int argflags;
4308
4309     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4310         result = wait4pid(pid, &argflags, optype);
4311     else {
4312         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4313                errno == EINTR) {
4314           PERL_ASYNC_CHECK();
4315         }
4316     }
4317 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4318     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4319     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4320 #  else
4321     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4322 #  endif
4323 # endif /* __amigaos4__ */
4324     SETi(result);
4325     RETURN;
4326 #else
4327     DIE(aTHX_ PL_no_func, "waitpid");
4328 #endif
4329 }
4330
4331 PP(pp_system)
4332 {
4333     dSP; dMARK; dORIGMARK; dTARGET;
4334 #if defined(__LIBCATAMOUNT__)
4335     PL_statusvalue = -1;
4336     SP = ORIGMARK;
4337     XPUSHi(-1);
4338 #else
4339     I32 value;
4340 # ifdef __amigaos4__
4341     void * result;
4342 # else
4343     int result;
4344 # endif
4345
4346     if (TAINTING_get) {
4347         TAINT_ENV();
4348         while (++MARK <= SP) {
4349             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4350             if (TAINT_get)
4351                 break;
4352         }
4353         MARK = ORIGMARK;
4354         TAINT_PROPER("system");
4355     }
4356     PERL_FLUSHALL_FOR_CHILD;
4357 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4358     {
4359 #ifdef __amigaos4__
4360         struct UserData userdata;
4361         pthread_t proc;
4362 #else
4363         Pid_t childpid;
4364 #endif
4365         int pp[2];
4366         I32 did_pipes = 0;
4367         bool child_success = FALSE;
4368 #ifdef HAS_SIGPROCMASK
4369         sigset_t newset, oldset;
4370 #endif
4371
4372         if (PerlProc_pipe(pp) >= 0)
4373             did_pipes = 1;
4374 #ifdef __amigaos4__
4375         amigaos_fork_set_userdata(aTHX_
4376                                   &userdata,
4377                                   did_pipes,
4378                                   pp[1],
4379                                   SP,
4380                                   mark);
4381         pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4382         child_success = proc > 0;
4383 #else
4384 #ifdef HAS_SIGPROCMASK
4385         sigemptyset(&newset);
4386         sigaddset(&newset, SIGCHLD);
4387         sigprocmask(SIG_BLOCK, &newset, &oldset);
4388 #endif
4389         while ((childpid = PerlProc_fork()) == -1) {
4390             if (errno != EAGAIN) {
4391                 value = -1;
4392                 SP = ORIGMARK;
4393                 XPUSHi(value);
4394                 if (did_pipes) {
4395                     PerlLIO_close(pp[0]);
4396                     PerlLIO_close(pp[1]);
4397                 }
4398 #ifdef HAS_SIGPROCMASK
4399                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4400 #endif
4401                 RETURN;
4402             }
4403             sleep(5);
4404         }
4405         child_success = childpid > 0;
4406 #endif
4407         if (child_success) {
4408             Sigsave_t ihand,qhand; /* place to save signals during system() */
4409             int status;
4410
4411 #ifndef __amigaos4__
4412             if (did_pipes)
4413                 PerlLIO_close(pp[1]);
4414 #endif
4415 #ifndef PERL_MICRO
4416             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4417             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4418 #endif
4419 #ifdef __amigaos4__
4420             result = pthread_join(proc, (void **)&status);
4421 #else
4422             do {
4423                 result = wait4pid(childpid, &status, 0);
4424             } while (result == -1 && errno == EINTR);
4425 #endif
4426 #ifndef PERL_MICRO
4427 #ifdef HAS_SIGPROCMASK
4428             sigprocmask(SIG_SETMASK, &oldset, NULL);
4429 #endif
4430             (void)rsignal_restore(SIGINT, &ihand);
4431             (void)rsignal_restore(SIGQUIT, &qhand);
4432 #endif
4433             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4434             do_execfree();      /* free any memory child malloced on fork */
4435             SP = ORIGMARK;
4436             if (did_pipes) {
4437                 int errkid;
4438                 unsigned n = 0;
4439
4440                 while (n < sizeof(int)) {
4441                     const SSize_t n1 = PerlLIO_read(pp[0],
4442                                       (void*)(((char*)&errkid)+n),
4443                                       (sizeof(int)) - n);
4444                     if (n1 <= 0)
4445                         break;
4446                     n += n1;
4447                 }
4448                 PerlLIO_close(pp[0]);
4449                 if (n) {                        /* Error */
4450                     if (n != sizeof(int))
4451                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4452                     errno = errkid;             /* Propagate errno from kid */
4453 #ifdef __amigaos4__
4454                     /* The pipe always has something in it
4455                      * so n alone is not enough. */
4456                     if (errno > 0)
4457 #endif
4458                     {
4459                         STATUS_NATIVE_CHILD_SET(-1);
4460                     }
4461                 }
4462             }
4463             XPUSHi(STATUS_CURRENT);
4464             RETURN;
4465         }
4466 #ifndef __amigaos4__
4467 #ifdef HAS_SIGPROCMASK
4468         sigprocmask(SIG_SETMASK, &oldset, NULL);
4469 #endif
4470         if (did_pipes) {
4471             PerlLIO_close(pp[0]);
4472 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
4473             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4474                 RETPUSHUNDEF;
4475 #endif
4476         }
4477         if (PL_op->op_flags & OPf_STACKED) {
4478             SV * const really = *++MARK;
4479             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4480         }
4481         else if (SP - MARK != 1)
4482             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4483         else {
4484             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4485         }
4486 #endif /* __amigaos4__ */
4487         PerlProc__exit(-1);
4488     }
4489 #else /* ! FORK or VMS or OS/2 */
4490     PL_statusvalue = 0;
4491     result = 0;
4492     if (PL_op->op_flags & OPf_STACKED) {
4493         SV * const really = *++MARK;
4494 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4495         value = (I32)do_aspawn(really, MARK, SP);
4496 #  else
4497         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4498 #  endif
4499     }
4500     else if (SP - MARK != 1) {
4501 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4502         value = (I32)do_aspawn(NULL, MARK, SP);
4503 #  else
4504         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4505 #  endif
4506     }
4507     else {
4508         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4509     }
4510     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4511         result = 1;
4512     STATUS_NATIVE_CHILD_SET(value);
4513     do_execfree();
4514     SP = ORIGMARK;
4515     XPUSHi(result ? value : STATUS_CURRENT);
4516 #endif /* !FORK or VMS or OS/2 */
4517 #endif
4518     RETURN;
4519 }
4520
4521 PP(pp_exec)
4522 {
4523     dSP; dMARK; dORIGMARK; dTARGET;
4524     I32 value;
4525
4526     if (TAINTING_get) {
4527         TAINT_ENV();
4528         while (++MARK <= SP) {
4529             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4530             if (TAINT_get)
4531                 break;
4532         }
4533         MARK = ORIGMARK;
4534         TAINT_PROPER("exec");
4535     }
4536
4537     PERL_FLUSHALL_FOR_CHILD;
4538     if (PL_op->op_flags & OPf_STACKED) {
4539         SV * const really = *++MARK;
4540         value = (I32)do_aexec(really, MARK, SP);
4541     }
4542     else if (SP - MARK != 1)
4543 #ifdef VMS
4544         value = (I32)vms_do_aexec(NULL, MARK, SP);
4545 #else
4546         value = (I32)do_aexec(NULL, MARK, SP);
4547 #endif
4548     else {
4549 #ifdef VMS
4550         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4551 #else
4552         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4553 #endif
4554     }
4555     SP = ORIGMARK;
4556     XPUSHi(value);
4557     RETURN;
4558 }
4559
4560 PP(pp_getppid)
4561 {
4562 #ifdef HAS_GETPPID
4563     dSP; dTARGET;
4564     XPUSHi( getppid() );
4565     RETURN;
4566 #else
4567     DIE(aTHX_ PL_no_func, "getppid");
4568 #endif
4569 }
4570
4571 PP(pp_getpgrp)
4572 {
4573 #ifdef HAS_GETPGRP
4574     dSP; dTARGET;
4575     Pid_t pgrp;
4576     const Pid_t pid =
4577         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4578
4579 #ifdef BSD_GETPGRP
4580     pgrp = (I32)BSD_GETPGRP(pid);
4581 #else
4582     if (pid != 0 && pid != PerlProc_getpid())
4583         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4584     pgrp = getpgrp();
4585 #endif
4586     XPUSHi(pgrp);
4587     RETURN;
4588 #else
4589     DIE(aTHX_ PL_no_func, "getpgrp");
4590 #endif
4591 }
4592
4593 PP(pp_setpgrp)
4594 {
4595 #ifdef HAS_SETPGRP
4596     dSP; dTARGET;
4597     Pid_t pgrp;
4598     Pid_t pid;
4599     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4600     if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4601     else {
4602         pid = 0;
4603         EXTEND(SP,1);
4604         SP++;
4605     }
4606
4607     TAINT_PROPER("setpgrp");
4608 #ifdef BSD_SETPGRP
4609     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4610 #else
4611     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4612         || (pid != 0 && pid != PerlProc_getpid()))
4613     {
4614         DIE(aTHX_ "setpgrp can't take arguments");
4615     }
4616     SETi( setpgrp() >= 0 );
4617 #endif /* USE_BSDPGRP */
4618     RETURN;
4619 #else
4620     DIE(aTHX_ PL_no_func, "setpgrp");
4621 #endif
4622 }
4623
4624 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4625 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4626 #else
4627 #  define PRIORITY_WHICH_T(which) which
4628 #endif
4629
4630 PP(pp_getpriority)
4631 {
4632 #ifdef HAS_GETPRIORITY
4633     dSP; dTARGET;
4634     const int who = POPi;
4635     const int which = TOPi;
4636     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4637     RETURN;
4638 #else
4639     DIE(aTHX_ PL_no_func, "getpriority");
4640 #endif
4641 }
4642
4643 PP(pp_setpriority)
4644 {
4645 #ifdef HAS_SETPRIORITY
4646     dSP; dTARGET;
4647     const int niceval = POPi;
4648     const int who = POPi;
4649     const int which = TOPi;
4650     TAINT_PROPER("setpriority");
4651     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4652     RETURN;
4653 #else
4654     DIE(aTHX_ PL_no_func, "setpriority");
4655 #endif
4656 }
4657
4658 #undef PRIORITY_WHICH_T
4659
4660 /* Time calls. */
4661
4662 PP(pp_time)
4663 {
4664     dSP; dTARGET;
4665 #ifdef BIG_TIME
4666     XPUSHn( time(NULL) );
4667 #else
4668     XPUSHi( time(NULL) );
4669 #endif
4670     RETURN;
4671 }
4672
4673 PP(pp_tms)
4674 {
4675 #ifdef HAS_TIMES
4676     dSP;
4677     struct tms timesbuf;
4678
4679     EXTEND(SP, 4);
4680     (void)PerlProc_times(&timesbuf);
4681
4682     mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4683     if (GIMME_V == G_ARRAY) {
4684         mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4685         mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4686         mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4687     }
4688     RETURN;
4689 #else
4690 #   ifdef PERL_MICRO
4691     dSP;
4692     mPUSHn(0.0);
4693     EXTEND(SP, 4);
4694     if (GIMME_V == G_ARRAY) {
4695          mPUSHn(0.0);
4696          mPUSHn(0.0);
4697          mPUSHn(0.0);
4698     }
4699     RETURN;
4700 #   else
4701     DIE(aTHX_ "times not implemented");
4702 #   endif
4703 #endif /* HAS_TIMES */
4704 }
4705
4706 /* The 32 bit int year limits the times we can represent to these
4707    boundaries with a few days wiggle room to account for time zone
4708    offsets
4709 */
4710 /* Sat Jan  3 00:00:00 -2147481748 */
4711 #define TIME_LOWER_BOUND -67768100567755200.0
4712 /* Sun Dec 29 12:00:00  2147483647 */
4713 #define TIME_UPPER_BOUND  67767976233316800.0
4714
4715
4716 /* also used for: pp_localtime() */
4717
4718 PP(pp_gmtime)
4719 {
4720     dSP;
4721     Time64_T when;
4722     struct TM tmbuf;
4723     struct TM *err;
4724     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4725     static const char * const dayname[] =
4726         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4727     static const char * const monname[] =
4728         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4729          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4730
4731     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4732         time_t now;
4733         (void)time(&now);
4734         when = (Time64_T)now;
4735     }
4736     else {
4737         NV input = Perl_floor(POPn);
4738         const bool pl_isnan = Perl_isnan(input);
4739         when = (Time64_T)input;
4740         if (UNLIKELY(pl_isnan || when != input)) {
4741             /* diag_listed_as: gmtime(%f) too large */
4742             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4743                            "%s(%.0" NVff ") too large", opname, input);
4744             if (pl_isnan) {
4745                 err = NULL;
4746                 goto failed;
4747             }
4748         }
4749     }
4750
4751     if ( TIME_LOWER_BOUND > when ) {
4752         /* diag_listed_as: gmtime(%f) too small */
4753         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4754                        "%s(%.0" NVff ") too small", opname, when);
4755         err = NULL;
4756     }
4757     else if( when > TIME_UPPER_BOUND ) {
4758         /* diag_listed_as: gmtime(%f) too small */
4759         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4760                        "%s(%.0" NVff ") too large", opname, when);
4761         err = NULL;
4762     }
4763     else {
4764         if (PL_op->op_type == OP_LOCALTIME)
4765             err = Perl_localtime64_r(&when, &tmbuf);
4766         else
4767             err = Perl_gmtime64_r(&when, &tmbuf);
4768     }
4769
4770     if (err == NULL) {
4771         /* diag_listed_as: gmtime(%f) failed */
4772         /* XXX %lld broken for quads */
4773       failed:
4774         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4775                        "%s(%.0" NVff ") failed", opname, when);
4776     }
4777
4778     if (GIMME_V != G_ARRAY) {   /* scalar context */
4779         EXTEND(SP, 1);
4780         if (err == NULL)
4781             RETPUSHUNDEF;
4782        else {
4783            dTARGET;
4784            PUSHs(TARG);
4785            Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
4786                                 dayname[tmbuf.tm_wday],
4787                                 monname[tmbuf.tm_mon],
4788                                 tmbuf.tm_mday,
4789                                 tmbuf.tm_hour,
4790                                 tmbuf.tm_min,
4791                                 tmbuf.tm_sec,
4792                                 (IV)tmbuf.tm_year + 1900);
4793         }
4794     }
4795     else {                      /* list context */
4796         if ( err == NULL )
4797             RETURN;
4798
4799         EXTEND(SP, 9);
4800         EXTEND_MORTAL(9);
4801         mPUSHi(tmbuf.tm_sec);
4802         mPUSHi(tmbuf.tm_min);
4803         mPUSHi(tmbuf.tm_hour);
4804         mPUSHi(tmbuf.tm_mday);
4805         mPUSHi(tmbuf.tm_mon);
4806         mPUSHn(tmbuf.tm_year);
4807         mPUSHi(tmbuf.tm_wday);
4808         mPUSHi(tmbuf.tm_yday);
4809         mPUSHi(tmbuf.tm_isdst);
4810     }
4811     RETURN;
4812 }
4813
4814 PP(pp_alarm)
4815 {
4816 #ifdef HAS_ALARM
4817     dSP; dTARGET;
4818     /* alarm() takes an unsigned int number of seconds, and return the
4819      * unsigned int number of seconds remaining in the previous alarm
4820      * (alarms don't stack).  Therefore negative return values are not
4821      * possible. */
4822     int anum = POPi;
4823     if (anum < 0) {
4824         /* Note that while the C library function alarm() as such has
4825          * no errors defined (or in other words, properly behaving client
4826          * code shouldn't expect any), alarm() being obsoleted by
4827          * setitimer() and often being implemented in terms of
4828          * setitimer(), can fail. */
4829         /* diag_listed_as: %s() with negative argument */
4830         Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4831                          "alarm() with negative argument");
4832         SETERRNO(EINVAL, LIB_INVARG);
4833         RETPUSHUNDEF;
4834     }
4835     else {
4836         unsigned int retval = alarm(anum);
4837         if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4838             RETPUSHUNDEF;
4839         PUSHu(retval);
4840         RETURN;
4841     }
4842 #else
4843     DIE(aTHX_ PL_no_func, "alarm");
4844 #endif
4845 }
4846
4847 PP(pp_sleep)
4848 {
4849     dSP; dTARGET;
4850     Time_t lasttime;
4851     Time_t when;
4852
4853     (void)time(&lasttime);
4854     if (MAXARG < 1 || (!TOPs && !POPs))
4855         PerlProc_pause();
4856     else {
4857         const I32 duration = POPi;
4858         if (duration < 0) {
4859           /* diag_listed_as: %s() with negative argument */
4860           Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4861                            "sleep() with negative argument");
4862           SETERRNO(EINVAL, LIB_INVARG);
4863           XPUSHi(0);
4864           RETURN;
4865         } else {
4866           PerlProc_sleep((unsigned int)duration);
4867         }
4868     }
4869     (void)time(&when);
4870     XPUSHi(when - lasttime);
4871     RETURN;
4872 }
4873
4874 /* Shared memory. */
4875 /* Merged with some message passing. */
4876
4877 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4878
4879 PP(pp_shmwrite)
4880 {
4881 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4882     dSP; dMARK; dTARGET;
4883     const int op_type = PL_op->op_type;
4884     I32 value;
4885
4886     switch (op_type) {
4887     case OP_MSGSND:
4888         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4889         break;
4890     case OP_MSGRCV:
4891         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4892         break;
4893     case OP_SEMOP:
4894         value = (I32)(do_semop(MARK, SP) >= 0);
4895         break;
4896     default:
4897         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4898         break;
4899     }
4900
4901     SP = MARK;
4902     PUSHi(value);
4903     RETURN;
4904 #else
4905     return Perl_pp_semget(aTHX);
4906 #endif
4907 }
4908
4909 /* Semaphores. */
4910
4911 /* also used for: pp_msgget() pp_shmget() */
4912
4913 PP(pp_semget)
4914 {
4915 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4916     dSP; dMARK; dTARGET;
4917     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4918     SP = MARK;
4919     if (anum == -1)
4920         RETPUSHUNDEF;
4921     PUSHi(anum);
4922     RETURN;
4923 #else
4924     DIE(aTHX_ "System V IPC is not implemented on this machine");
4925 #endif
4926 }
4927
4928 /* also used for: pp_msgctl() pp_shmctl() */
4929
4930 PP(pp_semctl)
4931 {
4932 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4933     dSP; dMARK; dTARGET;
4934     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4935     SP = MARK;
4936     if (anum == -1)
4937         RETPUSHUNDEF;
4938     if (anum != 0) {
4939         PUSHi(anum);
4940     }
4941     else {
4942         PUSHp(zero_but_true, ZBTLEN);
4943     }
4944     RETURN;
4945 #else
4946     return Perl_pp_semget(aTHX);
4947 #endif
4948 }
4949
4950 /* I can't const this further without getting warnings about the types of
4951    various arrays passed in from structures.  */
4952 static SV *
4953 S_space_join_names_mortal(pTHX_ char *const *array)
4954 {
4955     SV *target;
4956
4957     if (array && *array) {
4958         target = newSVpvs_flags("", SVs_TEMP);
4959         while (1) {
4960             sv_catpv(target, *array);
4961             if (!*++array)
4962                 break;
4963             sv_catpvs(target, " ");
4964         }
4965     } else {
4966         target = sv_mortalcopy(&PL_sv_no);
4967     }
4968     return target;
4969 }
4970
4971 /* Get system info. */
4972
4973 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4974
4975 PP(pp_ghostent)
4976 {
4977 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4978     dSP;
4979     I32 which = PL_op->op_type;
4980     char **elem;
4981     SV *sv;
4982 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4983     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4984     struct hostent *gethostbyname(Netdb_name_t);
4985     struct hostent *gethostent(void);
4986 #endif
4987     struct hostent *hent = NULL;
4988     unsigned long len;
4989
4990     EXTEND(SP, 10);
4991     if (which == OP_GHBYNAME) {
4992 #ifdef HAS_GETHOSTBYNAME
4993         const char* const name = POPpbytex;
4994         hent = PerlSock_gethostbyname(name);
4995 #else
4996         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4997 #endif
4998     }
4999     else if (which == OP_GHBYADDR) {
5000 #ifdef HAS_GETHOSTBYADDR
5001         const int addrtype = POPi;
5002         SV * const addrsv = POPs;
5003         STRLEN addrlen;
5004         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
5005
5006         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
5007 #else
5008         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
5009 #endif
5010     }
5011     else
5012 #ifdef HAS_GETHOSTENT
5013         hent = PerlSock_gethostent();
5014 #else
5015         DIE(aTHX_ PL_no_sock_func, "gethostent");
5016 #endif
5017
5018 #ifdef HOST_NOT_FOUND
5019         if (!hent) {
5020 #ifdef USE_REENTRANT_API
5021 #   ifdef USE_GETHOSTENT_ERRNO
5022             h_errno = PL_reentrant_buffer->_gethostent_errno;
5023 #   endif
5024 #endif
5025             STATUS_UNIX_SET(h_errno);
5026         }
5027 #endif
5028
5029     if (GIMME_V != G_ARRAY) {
5030         PUSHs(sv = sv_newmortal());
5031         if (hent) {
5032             if (which == OP_GHBYNAME) {
5033                 if (hent->h_addr)
5034                     sv_setpvn(sv, hent->h_addr, hent->h_length);
5035             }
5036             else
5037                 sv_setpv(sv, (char*)hent->h_name);
5038         }
5039         RETURN;
5040     }
5041
5042     if (hent) {
5043         mPUSHs(newSVpv((char*)hent->h_name, 0));
5044         PUSHs(space_join_names_mortal(hent->h_aliases));
5045         mPUSHi(hent->h_addrtype);
5046         len = hent->h_length;
5047         mPUSHi(len);
5048 #ifdef h_addr
5049         for (elem = hent->h_addr_list; elem && *elem; elem++) {
5050             mXPUSHp(*elem, len);
5051         }
5052 #else
5053         if (hent->h_addr)
5054             mPUSHp(hent->h_addr, len);
5055         else
5056             PUSHs(sv_mortalcopy(&PL_sv_no));
5057 #endif /* h_addr */
5058     }
5059     RETURN;
5060 #else
5061     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5062 #endif
5063 }
5064
5065 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5066
5067 PP(pp_gnetent)
5068 {
5069 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5070     dSP;
5071     I32 which = PL_op->op_type;
5072     SV *sv;
5073 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5074     struct netent *getnetbyaddr(Netdb_net_t, int);
5075     struct netent *getnetbyname(Netdb_name_t);
5076     struct netent *getnetent(void);
5077 #endif
5078     struct netent *nent;
5079
5080     if (which == OP_GNBYNAME){
5081 #ifdef HAS_GETNETBYNAME
5082         const char * const name = POPpbytex;
5083         nent = PerlSock_getnetbyname(name);
5084 #else
5085         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5086 #endif
5087     }
5088     else if (which == OP_GNBYADDR) {
5089 #ifdef HAS_GETNETBYADDR
5090         const int addrtype = POPi;
5091         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5092         nent = PerlSock_getnetbyaddr(addr, addrtype);
5093 #else
5094         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5095 #endif
5096     }
5097     else
5098 #ifdef HAS_GETNETENT
5099         nent = PerlSock_getnetent();
5100 #else
5101         DIE(aTHX_ PL_no_sock_func, "getnetent");
5102 #endif
5103
5104 #ifdef HOST_NOT_FOUND
5105         if (!nent) {
5106 #ifdef USE_REENTRANT_API
5107 #   ifdef USE_GETNETENT_ERRNO
5108              h_errno = PL_reentrant_buffer->_getnetent_errno;
5109 #   endif
5110 #endif
5111             STATUS_UNIX_SET(h_errno);
5112         }
5113 #endif
5114
5115     EXTEND(SP, 4);
5116     if (GIMME_V != G_ARRAY) {
5117         PUSHs(sv = sv_newmortal());
5118         if (nent) {
5119             if (which == OP_GNBYNAME)
5120                 sv_setiv(sv, (IV)nent->n_net);
5121             else
5122                 sv_setpv(sv, nent->n_name);
5123         }
5124         RETURN;
5125     }
5126
5127     if (nent) {
5128         mPUSHs(newSVpv(nent->n_name, 0));
5129         PUSHs(space_join_names_mortal(nent->n_aliases));
5130         mPUSHi(nent->n_addrtype);
5131         mPUSHi(nent->n_net);
5132     }
5133
5134     RETURN;
5135 #else
5136     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5137 #endif
5138 }
5139
5140
5141 /* also used for: pp_gpbyname() pp_gpbynumber() */
5142
5143 PP(pp_gprotoent)
5144 {
5145 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5146     dSP;
5147     I32 which = PL_op->op_type;
5148     SV *sv;
5149 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5150     struct protoent *getprotobyname(Netdb_name_t);
5151     struct protoent *getprotobynumber(int);
5152     struct protoent *getprotoent(void);
5153 #endif
5154     struct protoent *pent;
5155
5156     if (which == OP_GPBYNAME) {
5157 #ifdef HAS_GETPROTOBYNAME
5158         const char* const name = POPpbytex;
5159         pent = PerlSock_getprotobyname(name);
5160 #else
5161         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5162 #endif
5163     }
5164     else if (which == OP_GPBYNUMBER) {
5165 #ifdef HAS_GETPROTOBYNUMBER
5166         const int number = POPi;
5167         pent = PerlSock_getprotobynumber(number);
5168 #else
5169         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5170 #endif
5171     }
5172     else
5173 #ifdef HAS_GETPROTOENT
5174         pent = PerlSock_getprotoent();
5175 #else
5176         DIE(aTHX_ PL_no_sock_func, "getprotoent");
5177 #endif
5178
5179     EXTEND(SP, 3);
5180     if (GIMME_V != G_ARRAY) {
5181         PUSHs(sv = sv_newmortal());
5182         if (pent) {
5183             if (which == OP_GPBYNAME)
5184                 sv_setiv(sv, (IV)pent->p_proto);
5185             else
5186                 sv_setpv(sv, pent->p_name);
5187         }
5188         RETURN;
5189     }
5190
5191     if (pent) {
5192         mPUSHs(newSVpv(pent->p_name, 0));
5193         PUSHs(space_join_names_mortal(pent->p_aliases));
5194         mPUSHi(pent->p_proto);
5195     }
5196
5197     RETURN;
5198 #else
5199     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5200 #endif
5201 }
5202
5203
5204 /* also used for: pp_gsbyname() pp_gsbyport() */
5205
5206 PP(pp_gservent)
5207 {
5208 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5209     dSP;
5210     I32 which = PL_op->op_type;
5211     SV *sv;
5212 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5213     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5214     struct servent *getservbyport(int, Netdb_name_t);
5215     struct servent *getservent(void);
5216 #endif
5217     struct servent *sent;
5218
5219     if (which == OP_GSBYNAME) {
5220 #ifdef HAS_GETSERVBYNAME
5221         const char * const proto = POPpbytex;
5222         const char * const name = POPpbytex;
5223         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5224 #else
5225         DIE(aTHX_ PL_no_sock_func, "getservbyname");
5226 #endif
5227     }
5228     else if (which == OP_GSBYPORT) {
5229 #ifdef HAS_GETSERVBYPORT
5230         const char * const proto = POPpbytex;
5231         unsigned short port = (unsigned short)POPu;
5232         port = PerlSock_htons(port);
5233         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5234 #else
5235         DIE(aTHX_ PL_no_sock_func, "getservbyport");
5236 #endif
5237     }
5238     else
5239 #ifdef HAS_GETSERVENT
5240         sent = PerlSock_getservent();
5241 #else
5242         DIE(aTHX_ PL_no_sock_func, "getservent");
5243 #endif
5244
5245     EXTEND(SP, 4);
5246     if (GIMME_V != G_ARRAY) {
5247         PUSHs(sv = sv_newmortal());
5248         if (sent) {
5249             if (which == OP_GSBYNAME) {
5250                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5251             }
5252             else
5253                 sv_setpv(sv, sent->s_name);
5254         }
5255         RETURN;
5256     }
5257
5258     if (sent) {
5259         mPUSHs(newSVpv(sent->s_name, 0));
5260         PUSHs(space_join_names_mortal(sent->s_aliases));
5261         mPUSHi(PerlSock_ntohs(sent->s_port));
5262         mPUSHs(newSVpv(sent->s_proto, 0));
5263     }
5264
5265     RETURN;
5266 #else
5267     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5268 #endif
5269 }
5270
5271
5272 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5273
5274 PP(pp_shostent)
5275 {
5276     dSP;
5277     const int stayopen = TOPi;
5278     switch(PL_op->op_type) {
5279     case OP_SHOSTENT:
5280 #ifdef HAS_SETHOSTENT
5281         PerlSock_sethostent(stayopen);
5282 #else
5283         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5284 #endif
5285         break;
5286 #ifdef HAS_SETNETENT
5287     case OP_SNETENT:
5288         PerlSock_setnetent(stayopen);
5289 #else
5290         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5291 #endif
5292         break;
5293     case OP_SPROTOENT:
5294 #ifdef HAS_SETPROTOENT
5295         PerlSock_setprotoent(stayopen);
5296 #else
5297         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5298 #endif
5299         break;
5300     case OP_SSERVENT:
5301 #ifdef HAS_SETSERVENT
5302         PerlSock_setservent(stayopen);
5303 #else
5304         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5305 #endif
5306         break;
5307     }
5308     RETSETYES;
5309 }
5310
5311
5312 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5313  *                pp_eservent() pp_sgrent() pp_spwent() */
5314
5315 PP(pp_ehostent)
5316 {
5317     dSP;
5318     switch(PL_op->op_type) {
5319     case OP_EHOSTENT:
5320 #ifdef HAS_ENDHOSTENT
5321         PerlSock_endhostent();
5322 #else
5323         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5324 #endif
5325         break;
5326     case OP_ENETENT:
5327 #ifdef HAS_ENDNETENT
5328         PerlSock_endnetent();
5329 #else
5330         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5331 #endif
5332         break;
5333     case OP_EPROTOENT:
5334 #ifdef HAS_ENDPROTOENT
5335         PerlSock_endprotoent();
5336 #else
5337         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5338 #endif
5339         break;
5340     case OP_ESERVENT:
5341 #ifdef HAS_ENDSERVENT
5342         PerlSock_endservent();
5343 #else
5344         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5345 #endif
5346         break;
5347     case OP_SGRENT:
5348 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5349         setgrent();
5350 #else
5351         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5352 #endif
5353         break;
5354     case OP_EGRENT:
5355 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5356         endgrent();
5357 #else
5358         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5359 #endif
5360         break;
5361     case OP_SPWENT:
5362 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5363         setpwent();
5364 #else
5365         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5366 #endif
5367         break;
5368     case OP_EPWENT:
5369 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5370         endpwent();
5371 #else
5372         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5373 #endif
5374         break;
5375     }
5376     EXTEND(SP,1);
5377     RETPUSHYES;
5378 }
5379
5380
5381 /* also used for: pp_gpwnam() pp_gpwuid() */
5382
5383 PP(pp_gpwent)
5384 {
5385 #ifdef HAS_PASSWD
5386     dSP;
5387     I32 which = PL_op->op_type;
5388     SV *sv;
5389     struct passwd *pwent  = NULL;
5390     /*
5391      * We currently support only the SysV getsp* shadow password interface.
5392      * The interface is declared in <shadow.h> and often one needs to link
5393      * with -lsecurity or some such.
5394      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5395      * (and SCO?)
5396      *
5397      * AIX getpwnam() is clever enough to return the encrypted password
5398      * only if the caller (euid?) is root.
5399      *
5400      * There are at least three other shadow password APIs.  Many platforms
5401      * seem to contain more than one interface for accessing the shadow
5402      * password databases, possibly for compatibility reasons.
5403      * The getsp*() is by far he simplest one, the other two interfaces
5404      * are much more complicated, but also very similar to each other.
5405      *
5406      * <sys/types.h>
5407      * <sys/security.h>
5408      * <prot.h>
5409      * struct pr_passwd *getprpw*();
5410      * The password is in
5411      * char getprpw*(...).ufld.fd_encrypt[]
5412      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5413      *
5414      * <sys/types.h>
5415      * <sys/security.h>
5416      * <prot.h>
5417      * struct es_passwd *getespw*();
5418      * The password is in
5419      * char *(getespw*(...).ufld.fd_encrypt)
5420      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5421      *
5422      * <userpw.h> (AIX)
5423      * struct userpw *getuserpw();
5424      * The password is in
5425      * char *(getuserpw(...)).spw_upw_passwd
5426      * (but the de facto standard getpwnam() should work okay)
5427      *
5428      * Mention I_PROT here so that Configure probes for it.
5429      *
5430      * In HP-UX for getprpw*() the manual page claims that one should include
5431      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5432      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5433      * and pp_sys.c already includes <shadow.h> if there is such.
5434      *
5435      * Note that <sys/security.h> is already probed for, but currently
5436      * it is only included in special cases.
5437      *
5438      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5439      * be preferred interface, even though also the getprpw*() interface
5440      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5441      * One also needs to call set_auth_parameters() in main() before
5442      * doing anything else, whether one is using getespw*() or getprpw*().
5443      *
5444      * Note that accessing the shadow databases can be magnitudes
5445      * slower than accessing the standard databases.
5446      *
5447      * --jhi
5448      */
5449
5450 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5451     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5452      * the pw_comment is left uninitialized. */
5453     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5454 #   endif
5455
5456     switch (which) {
5457     case OP_GPWNAM:
5458       {
5459         const char* const name = POPpbytex;
5460         pwent  = getpwnam(name);
5461       }
5462       break;
5463     case OP_GPWUID:
5464       {
5465         Uid_t uid = POPi;
5466         pwent = getpwuid(uid);
5467       }
5468         break;
5469     case OP_GPWENT:
5470 #   ifdef HAS_GETPWENT
5471         pwent  = getpwent();
5472 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5473         if (pwent) pwent = getpwnam(pwent->pw_name);
5474 #endif
5475 #   else
5476         DIE(aTHX_ PL_no_func, "getpwent");
5477 #   endif
5478         break;
5479     }
5480
5481     EXTEND(SP, 10);
5482     if (GIMME_V != G_ARRAY) {
5483         PUSHs(sv = sv_newmortal());
5484         if (pwent) {
5485             if (which == OP_GPWNAM)
5486                 sv_setuid(sv, pwent->pw_uid);
5487             else
5488                 sv_setpv(sv, pwent->pw_name);
5489         }
5490         RETURN;
5491     }
5492
5493     if (pwent) {
5494         mPUSHs(newSVpv(pwent->pw_name, 0));
5495
5496         sv = newSViv(0);
5497         mPUSHs(sv);
5498         /* If we have getspnam(), we try to dig up the shadow
5499          * password.  If we are underprivileged, the shadow
5500          * interface will set the errno to EACCES or similar,
5501          * and return a null pointer.  If this happens, we will
5502          * use the dummy password (usually "*" or "x") from the
5503          * standard password database.
5504          *
5505          * In theory we could skip the shadow call completely
5506          * if euid != 0 but in practice we cannot know which
5507          * security measures are guarding the shadow databases
5508          * on a random platform.
5509          *
5510          * Resist the urge to use additional shadow interfaces.
5511          * Divert the urge to writing an extension instead.
5512          *
5513          * --jhi */
5514         /* Some AIX setups falsely(?) detect some getspnam(), which
5515          * has a different API than the Solaris/IRIX one. */
5516 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5517         {
5518             dSAVE_ERRNO;
5519             const struct spwd * const spwent = getspnam(pwent->pw_name);
5520                           /* Save and restore errno so that
5521                            * underprivileged attempts seem
5522                            * to have never made the unsuccessful
5523                            * attempt to retrieve the shadow password. */
5524             RESTORE_ERRNO;
5525             if (spwent && spwent->sp_pwdp)
5526                 sv_setpv(sv, spwent->sp_pwdp);
5527         }
5528 #   endif
5529 #   ifdef PWPASSWD
5530         if (!SvPOK(sv)) /* Use the standard password, then. */
5531             sv_setpv(sv, pwent->pw_passwd);
5532 #   endif
5533
5534         /* passwd is tainted because user himself can diddle with it.
5535          * admittedly not much and in a very limited way, but nevertheless. */
5536         SvTAINTED_on(sv);
5537
5538         sv_setuid(PUSHmortal, pwent->pw_uid);
5539         sv_setgid(PUSHmortal, pwent->pw_gid);
5540
5541         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5542          * because of the poor interface of the Perl getpw*(),
5543          * not because there's some standard/convention saying so.
5544          * A better interface would have been to return a hash,
5545          * but we are accursed by our history, alas. --jhi.  */
5546 #   ifdef PWCHANGE
5547         mPUSHi(pwent->pw_change);
5548 #   else
5549 #       ifdef PWQUOTA
5550         mPUSHi(pwent->pw_quota);
5551 #       else
5552 #           ifdef PWAGE
5553         mPUSHs(newSVpv(pwent->pw_age, 0));
5554 #           else
5555         /* I think that you can never get this compiled, but just in case.  */
5556         PUSHs(sv_mortalcopy(&PL_sv_no));
5557 #           endif
5558 #       endif
5559 #   endif
5560
5561         /* pw_class and pw_comment are mutually exclusive--.
5562          * see the above note for pw_change, pw_quota, and pw_age. */
5563 #   ifdef PWCLASS
5564         mPUSHs(newSVpv(pwent->pw_class, 0));
5565 #   else
5566 #       ifdef PWCOMMENT
5567         mPUSHs(newSVpv(pwent->pw_comment, 0));
5568 #       else
5569         /* I think that you can never get this compiled, but just in case.  */
5570         PUSHs(sv_mortalcopy(&PL_sv_no));
5571 #       endif
5572 #   endif
5573
5574 #   ifdef PWGECOS
5575         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5576 #   else
5577         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5578 #   endif
5579         /* pw_gecos is tainted because user himself can diddle with it. */
5580         SvTAINTED_on(sv);
5581
5582         mPUSHs(newSVpv(pwent->pw_dir, 0));
5583
5584         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5585         /* pw_shell is tainted because user himself can diddle with it. */
5586         SvTAINTED_on(sv);
5587
5588 #   ifdef PWEXPIRE
5589         mPUSHi(pwent->pw_expire);
5590 #   endif
5591     }
5592     RETURN;
5593 #else
5594     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5595 #endif
5596 }
5597
5598
5599 /* also used for: pp_ggrgid() pp_ggrnam() */
5600
5601 PP(pp_ggrent)
5602 {
5603 #ifdef HAS_GROUP
5604     dSP;
5605     const I32 which = PL_op->op_type;
5606     const struct group *grent;
5607
5608     if (which == OP_GGRNAM) {
5609         const char* const name = POPpbytex;
5610         grent = (const struct group *)getgrnam(name);
5611     }
5612     else if (which == OP_GGRGID) {
5613 #if Gid_t_sign == 1
5614         const Gid_t gid = POPu;
5615 #elif Gid_t_sign == -1
5616         const Gid_t gid = POPi;
5617 #else
5618 #  error "Unexpected Gid_t_sign"
5619 #endif
5620         grent = (const struct group *)getgrgid(gid);
5621     }
5622     else
5623 #ifdef HAS_GETGRENT
5624         grent = (struct group *)getgrent();
5625 #else
5626         DIE(aTHX_ PL_no_func, "getgrent");
5627 #endif
5628
5629     EXTEND(SP, 4);
5630     if (GIMME_V != G_ARRAY) {
5631         SV * const sv = sv_newmortal();
5632
5633         PUSHs(sv);
5634         if (grent) {
5635             if (which == OP_GGRNAM)
5636                 sv_setgid(sv, grent->gr_gid);
5637             else
5638                 sv_setpv(sv, grent->gr_name);
5639         }
5640         RETURN;
5641     }
5642
5643     if (grent) {
5644         mPUSHs(newSVpv(grent->gr_name, 0));
5645
5646 #ifdef GRPASSWD
5647         mPUSHs(newSVpv(grent->gr_passwd, 0));
5648 #else
5649         PUSHs(sv_mortalcopy(&PL_sv_no));
5650 #endif
5651
5652         sv_setgid(PUSHmortal, grent->gr_gid);
5653
5654 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5655         /* In UNICOS/mk (_CRAYMPP) the multithreading
5656          * versions (getgrnam_r, getgrgid_r)
5657          * seem to return an illegal pointer
5658          * as the group members list, gr_mem.
5659          * getgrent() doesn't even have a _r version
5660          * but the gr_mem is poisonous anyway.
5661          * So yes, you cannot get the list of group
5662          * members if building multithreaded in UNICOS/mk. */
5663         PUSHs(space_join_names_mortal(grent->gr_mem));
5664 #endif
5665     }
5666
5667     RETURN;
5668 #else
5669     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5670 #endif
5671 }
5672
5673 PP(pp_getlogin)
5674 {
5675 #ifdef HAS_GETLOGIN
5676     dSP; dTARGET;
5677     char *tmps;
5678     EXTEND(SP, 1);
5679     if (!(tmps = PerlProc_getlogin()))
5680         RETPUSHUNDEF;
5681     sv_setpv_mg(TARG, tmps);
5682     PUSHs(TARG);
5683     RETURN;
5684 #else
5685     DIE(aTHX_ PL_no_func, "getlogin");
5686 #endif
5687 }
5688
5689 /* Miscellaneous. */
5690
5691 PP(pp_syscall)
5692 {
5693 #ifdef HAS_SYSCALL
5694     dSP; dMARK; dORIGMARK; dTARGET;
5695     I32 items = SP - MARK;
5696     unsigned long a[20];
5697     I32 i = 0;
5698     IV retval = -1;
5699
5700     if (TAINTING_get) {
5701         while (++MARK <= SP) {
5702             if (SvTAINTED(*MARK)) {
5703                 TAINT;
5704                 break;
5705             }
5706         }
5707         MARK = ORIGMARK;
5708         TAINT_PROPER("syscall");
5709     }
5710
5711     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5712      * or where sizeof(long) != sizeof(char*).  But such machines will
5713      * not likely have syscall implemented either, so who cares?
5714      */
5715     while (++MARK <= SP) {
5716         if (SvNIOK(*MARK) || !i)
5717             a[i++] = SvIV(*MARK);
5718         else if (*MARK == &PL_sv_undef)
5719             a[i++] = 0;
5720         else
5721             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5722         if (i > 15)
5723             break;
5724     }
5725     switch (items) {
5726     default:
5727         DIE(aTHX_ "Too many args to syscall");
5728     case 0:
5729         DIE(aTHX_ "Too few args to syscall");
5730     case 1:
5731         retval = syscall(a[0]);
5732         break;
5733     case 2:
5734         retval = syscall(a[0],a[1]);
5735         break;
5736     case 3:
5737         retval = syscall(a[0],a[1],a[2]);
5738         break;
5739     case 4:
5740         retval = syscall(a[0],a[1],a[2],a[3]);
5741         break;
5742     case 5:
5743         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5744         break;
5745     case 6:
5746         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5747         break;
5748     case 7:
5749         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5750         break;
5751     case 8:
5752         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5753         break;
5754     }
5755     SP = ORIGMARK;
5756     PUSHi(retval);
5757     RETURN;
5758 #else
5759     DIE(aTHX_ PL_no_func, "syscall");
5760 #endif
5761 }
5762
5763 #ifdef FCNTL_EMULATE_FLOCK
5764
5765 /*  XXX Emulate flock() with fcntl().
5766     What's really needed is a good file locking module.
5767 */
5768
5769 static int
5770 fcntl_emulate_flock(int fd, int operation)
5771 {
5772     int res;
5773     struct flock flock;
5774
5775     switch (operation & ~LOCK_NB) {
5776     case LOCK_SH:
5777         flock.l_type = F_RDLCK;
5778         break;
5779     case LOCK_EX:
5780         flock.l_type = F_WRLCK;
5781         break;
5782     case LOCK_UN:
5783         flock.l_type = F_UNLCK;
5784         break;
5785     default:
5786         errno = EINVAL;
5787         return -1;
5788     }
5789     flock.l_whence = SEEK_SET;
5790     flock.l_start = flock.l_len = (Off_t)0;
5791
5792     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5793     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5794         errno = EWOULDBLOCK;
5795     return res;
5796 }
5797
5798 #endif /* FCNTL_EMULATE_FLOCK */
5799
5800 #ifdef LOCKF_EMULATE_FLOCK
5801
5802 /*  XXX Emulate flock() with lockf().  This is just to increase
5803     portability of scripts.  The calls are not completely
5804     interchangeable.  What's really needed is a good file
5805     locking module.
5806 */
5807
5808 /*  The lockf() constants might have been defined in <unistd.h>.
5809     Unfortunately, <unistd.h> causes troubles on some mixed
5810     (BSD/POSIX) systems, such as SunOS 4.1.3.
5811
5812    Further, the lockf() constants aren't POSIX, so they might not be
5813    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5814    just stick in the SVID values and be done with it.  Sigh.
5815 */
5816
5817 # ifndef F_ULOCK
5818 #  define F_ULOCK       0       /* Unlock a previously locked region */
5819 # endif
5820 # ifndef F_LOCK
5821 #  define F_LOCK        1       /* Lock a region for exclusive use */
5822 # endif
5823 # ifndef F_TLOCK
5824 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5825 # endif
5826 # ifndef F_TEST
5827 #  define F_TEST        3       /* Test a region for other processes locks */
5828 # endif
5829
5830 static int
5831 lockf_emulate_flock(int fd, int operation)
5832 {
5833     int i;
5834     Off_t pos;
5835     dSAVE_ERRNO;
5836
5837     /* flock locks entire file so for lockf we need to do the same      */
5838     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5839     if (pos > 0)        /* is seekable and needs to be repositioned     */
5840         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5841             pos = -1;   /* seek failed, so don't seek back afterwards   */
5842     RESTORE_ERRNO;
5843
5844     switch (operation) {
5845
5846         /* LOCK_SH - get a shared lock */
5847         case LOCK_SH:
5848         /* LOCK_EX - get an exclusive lock */
5849         case LOCK_EX:
5850             i = lockf (fd, F_LOCK, 0);
5851             break;
5852
5853         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5854         case LOCK_SH|LOCK_NB:
5855         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5856         case LOCK_EX|LOCK_NB:
5857             i = lockf (fd, F_TLOCK, 0);
5858             if (i == -1)
5859                 if ((errno == EAGAIN) || (errno == EACCES))
5860                     errno = EWOULDBLOCK;
5861             break;
5862
5863         /* LOCK_UN - unlock (non-blocking is a no-op) */
5864         case LOCK_UN:
5865         case LOCK_UN|LOCK_NB:
5866             i = lockf (fd, F_ULOCK, 0);
5867             break;
5868
5869         /* Default - can't decipher operation */
5870         default:
5871             i = -1;
5872             errno = EINVAL;
5873             break;
5874     }
5875
5876     if (pos > 0)      /* need to restore position of the handle */
5877         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5878
5879     return (i);
5880 }
5881
5882 #endif /* LOCKF_EMULATE_FLOCK */
5883
5884 /*
5885  * ex: set ts=8 sts=4 sw=4 et:
5886  */