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