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_ARRAY && 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 =head1 GV Functions
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_tindex(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( do_tell(gv) );
2183 #else
2184     PUSHi( 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 #if defined(__SYMBIAN32__)
2709 # define SETSOCKOPT_OPTION_VALUE_T void *
2710 #else
2711 # define SETSOCKOPT_OPTION_VALUE_T const char *
2712 #endif
2713         /* XXX TODO: We need to have a proper type (a Configure probe,
2714          * etc.) for what the C headers think of the third argument of
2715          * setsockopt(), the option_value read-only buffer: is it
2716          * a "char *", or a "void *", const or not.  Some compilers
2717          * don't take kindly to e.g. assuming that "char *" implicitly
2718          * promotes to a "void *", or to explicitly promoting/demoting
2719          * consts to non/vice versa.  The "const void *" is the SUS
2720          * definition, but that does not fly everywhere for the above
2721          * reasons. */
2722             SETSOCKOPT_OPTION_VALUE_T buf;
2723             int aint;
2724             if (SvPOKp(sv)) {
2725                 STRLEN l;
2726                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2727                 len = l;
2728             }
2729             else {
2730                 aint = (int)SvIV(sv);
2731                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2732                 len = sizeof(int);
2733             }
2734             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2735                 goto nuts2;
2736             PUSHs(&PL_sv_yes);
2737         }
2738         break;
2739     }
2740     RETURN;
2741
2742   nuts:
2743     report_evil_fh(gv);
2744     SETERRNO(EBADF,SS_IVCHAN);
2745   nuts2:
2746     RETPUSHUNDEF;
2747
2748 }
2749
2750
2751 /* also used for: pp_getsockname() */
2752
2753 PP(pp_getpeername)
2754 {
2755     dSP;
2756     const int optype = PL_op->op_type;
2757     GV * const gv = MUTABLE_GV(POPs);
2758     IO * const io = GvIOn(gv);
2759     Sock_size_t len;
2760     SV *sv;
2761     int fd;
2762
2763     if (!IoIFP(io))
2764         goto nuts;
2765
2766     sv = sv_2mortal(newSV(257));
2767     (void)SvPOK_only(sv);
2768     len = 256;
2769     SvCUR_set(sv, len);
2770     *SvEND(sv) ='\0';
2771     fd = PerlIO_fileno(IoIFP(io));
2772     if (fd < 0)
2773         goto nuts;
2774     switch (optype) {
2775     case OP_GETSOCKNAME:
2776         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2777             goto nuts2;
2778         break;
2779     case OP_GETPEERNAME:
2780         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2781             goto nuts2;
2782 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2783         {
2784             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";
2785             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2786             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2787                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2788                         sizeof(u_short) + sizeof(struct in_addr))) {
2789                 goto nuts2;
2790             }
2791         }
2792 #endif
2793         break;
2794     }
2795 #ifdef BOGUS_GETNAME_RETURN
2796     /* Interactive Unix, getpeername() and getsockname()
2797       does not return valid namelen */
2798     if (len == BOGUS_GETNAME_RETURN)
2799         len = sizeof(struct sockaddr);
2800 #endif
2801     SvCUR_set(sv, len);
2802     *SvEND(sv) ='\0';
2803     PUSHs(sv);
2804     RETURN;
2805
2806   nuts:
2807     report_evil_fh(gv);
2808     SETERRNO(EBADF,SS_IVCHAN);
2809   nuts2:
2810     RETPUSHUNDEF;
2811 }
2812
2813 #endif
2814
2815 /* Stat calls. */
2816
2817 /* also used for: pp_lstat() */
2818
2819 PP(pp_stat)
2820 {
2821     dSP;
2822     GV *gv = NULL;
2823     IO *io = NULL;
2824     U8 gimme;
2825     I32 max = 13;
2826     SV* sv;
2827
2828     if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2829                                   : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2830         if (PL_op->op_type == OP_LSTAT) {
2831             if (gv != PL_defgv) {
2832             do_fstat_warning_check:
2833                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2834                                "lstat() on filehandle%s%" SVf,
2835                                 gv ? " " : "",
2836                                 SVfARG(gv
2837                                         ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2838                                         : &PL_sv_no));
2839             } else if (PL_laststype != OP_LSTAT)
2840                 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2841                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2842         }
2843
2844         if (gv == PL_defgv) {
2845             if (PL_laststatval < 0)
2846                 SETERRNO(EBADF,RMS_IFI);
2847         } else {
2848           do_fstat_have_io:
2849             PL_laststype = OP_STAT;
2850             PL_statgv = gv ? gv : (GV *)io;
2851             SvPVCLEAR(PL_statname);
2852             if(gv) {
2853                 io = GvIO(gv);
2854             }
2855             if (io) {
2856                     if (IoIFP(io)) {
2857                         int fd = PerlIO_fileno(IoIFP(io));
2858                         if (fd < 0) {
2859                             report_evil_fh(gv);
2860                             PL_laststatval = -1;
2861                             SETERRNO(EBADF,RMS_IFI);
2862                         } else {
2863                             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2864                         }
2865                     } else if (IoDIRP(io)) {
2866                         PL_laststatval =
2867                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2868                     } else {
2869                         report_evil_fh(gv);
2870                         PL_laststatval = -1;
2871                         SETERRNO(EBADF,RMS_IFI);
2872                     }
2873             } else {
2874                 report_evil_fh(gv);
2875                 PL_laststatval = -1;
2876                 SETERRNO(EBADF,RMS_IFI);
2877             }
2878         }
2879
2880         if (PL_laststatval < 0) {
2881             max = 0;
2882         }
2883     }
2884     else {
2885         const char *file;
2886         const char *temp;
2887         STRLEN len;
2888         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2889             io = MUTABLE_IO(SvRV(sv));
2890             if (PL_op->op_type == OP_LSTAT)
2891                 goto do_fstat_warning_check;
2892             goto do_fstat_have_io;
2893         }
2894         SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2895         temp = SvPV_nomg_const(sv, len);
2896         sv_setpv(PL_statname, temp);
2897         PL_statgv = NULL;
2898         PL_laststype = PL_op->op_type;
2899         file = SvPV_nolen_const(PL_statname);
2900         if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
2901             PL_laststatval = -1;
2902         }
2903         else if (PL_op->op_type == OP_LSTAT)
2904             PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2905         else
2906             PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2907         if (PL_laststatval < 0) {
2908             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2909                 /* PL_warn_nl is constant */
2910                 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
2911                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2912                 GCC_DIAG_RESTORE_STMT;
2913             }
2914             max = 0;
2915         }
2916     }
2917
2918     gimme = GIMME_V;
2919     if (gimme != G_ARRAY) {
2920         if (gimme != G_VOID)
2921             XPUSHs(boolSV(max));
2922         RETURN;
2923     }
2924     if (max) {
2925         EXTEND(SP, max);
2926         EXTEND_MORTAL(max);
2927         mPUSHi(PL_statcache.st_dev);
2928         {
2929             /*
2930              * We try to represent st_ino as a native IV or UV where
2931              * possible, but fall back to a decimal string where
2932              * necessary.  The code to generate these decimal strings
2933              * is quite obtuse, because (a) we're portable to non-POSIX
2934              * platforms where st_ino might be signed; (b) we didn't
2935              * necessarily detect at Configure time whether st_ino is
2936              * signed; (c) we're portable to non-POSIX platforms where
2937              * ino_t isn't defined, so have no name for the type of
2938              * st_ino; and (d) sprintf() doesn't necessarily support
2939              * integers as large as st_ino.
2940              */
2941             bool neg;
2942             Stat_t s;
2943             CLANG_DIAG_IGNORE_STMT(-Wtautological-compare);
2944             GCC_DIAG_IGNORE_STMT(-Wtype-limits);
2945             neg = PL_statcache.st_ino < 0;
2946             GCC_DIAG_RESTORE_STMT;
2947             CLANG_DIAG_RESTORE_STMT;
2948             if (neg) {
2949                 s.st_ino = (IV)PL_statcache.st_ino;
2950                 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
2951                     mPUSHi(s.st_ino);
2952                 } else {
2953                     char buf[sizeof(s.st_ino)*3+1], *p;
2954                     s.st_ino = PL_statcache.st_ino;
2955                     for (p = buf + sizeof(buf); p != buf+1; ) {
2956                         Stat_t t;
2957                         t.st_ino = s.st_ino / 10;
2958                         *--p = '0' + (int)(t.st_ino*10 - s.st_ino);
2959                         s.st_ino = t.st_ino;
2960                     }
2961                     while (*p == '0')
2962                         p++;
2963                     *--p = '-';
2964                     mPUSHp(p, buf+sizeof(buf) - p);
2965                 }
2966             } else {
2967                 s.st_ino = (UV)PL_statcache.st_ino;
2968                 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
2969                     mPUSHu(s.st_ino);
2970                 } else {
2971                     char buf[sizeof(s.st_ino)*3], *p;
2972                     s.st_ino = PL_statcache.st_ino;
2973                     for (p = buf + sizeof(buf); p != buf; ) {
2974                         Stat_t t;
2975                         t.st_ino = s.st_ino / 10;
2976                         *--p = '0' + (int)(s.st_ino - t.st_ino*10);
2977                         s.st_ino = t.st_ino;
2978                     }
2979                     while (*p == '0')
2980                         p++;
2981                     mPUSHp(p, buf+sizeof(buf) - p);
2982                 }
2983             }
2984         }
2985         mPUSHu(PL_statcache.st_mode);
2986         mPUSHu(PL_statcache.st_nlink);
2987
2988         sv_setuid(PUSHmortal, PL_statcache.st_uid);
2989         sv_setgid(PUSHmortal, PL_statcache.st_gid);
2990
2991 #ifdef USE_STAT_RDEV
2992         mPUSHi(PL_statcache.st_rdev);
2993 #else
2994         PUSHs(newSVpvs_flags("", SVs_TEMP));
2995 #endif
2996 #if Off_t_size > IVSIZE
2997         mPUSHn(PL_statcache.st_size);
2998 #else
2999         mPUSHi(PL_statcache.st_size);
3000 #endif
3001 #ifdef BIG_TIME
3002         mPUSHn(PL_statcache.st_atime);
3003         mPUSHn(PL_statcache.st_mtime);
3004         mPUSHn(PL_statcache.st_ctime);
3005 #else
3006         mPUSHi(PL_statcache.st_atime);
3007         mPUSHi(PL_statcache.st_mtime);
3008         mPUSHi(PL_statcache.st_ctime);
3009 #endif
3010 #ifdef USE_STAT_BLOCKS
3011         mPUSHu(PL_statcache.st_blksize);
3012         mPUSHu(PL_statcache.st_blocks);
3013 #else
3014         PUSHs(newSVpvs_flags("", SVs_TEMP));
3015         PUSHs(newSVpvs_flags("", SVs_TEMP));
3016 #endif
3017     }
3018     RETURN;
3019 }
3020
3021 /* All filetest ops avoid manipulating the perl stack pointer in their main
3022    bodies (since commit d2c4d2d1e22d3125), and return using either
3023    S_ft_return_false() or S_ft_return_true().  These two helper functions are
3024    the only two which manipulate the perl stack.  To ensure that no stack
3025    manipulation macros are used, the filetest ops avoid defining a local copy
3026    of the stack pointer with dSP.  */
3027
3028 /* If the next filetest is stacked up with this one
3029    (PL_op->op_private & OPpFT_STACKING), we leave
3030    the original argument on the stack for success,
3031    and skip the stacked operators on failure.
3032    The next few macros/functions take care of this.
3033 */
3034
3035 static OP *
3036 S_ft_return_false(pTHX_ SV *ret) {
3037     OP *next = NORMAL;
3038     dSP;
3039
3040     if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3041     else                           SETs(ret);
3042     PUTBACK;
3043
3044     if (PL_op->op_private & OPpFT_STACKING) {
3045         while (next && OP_IS_FILETEST(next->op_type)
3046                && next->op_private & OPpFT_STACKED)
3047             next = next->op_next;
3048     }
3049     return next;
3050 }
3051
3052 PERL_STATIC_INLINE OP *
3053 S_ft_return_true(pTHX_ SV *ret) {
3054     dSP;
3055     if (PL_op->op_flags & OPf_REF)
3056         XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3057     else if (!(PL_op->op_private & OPpFT_STACKING))
3058         SETs(ret);
3059     PUTBACK;
3060     return NORMAL;
3061 }
3062
3063 #define FT_RETURNNO     return S_ft_return_false(aTHX_ &PL_sv_no)
3064 #define FT_RETURNUNDEF  return S_ft_return_false(aTHX_ &PL_sv_undef)
3065 #define FT_RETURNYES    return S_ft_return_true(aTHX_ &PL_sv_yes)
3066
3067 #define tryAMAGICftest_MG(chr) STMT_START { \
3068         if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3069                 && PL_op->op_flags & OPf_KIDS) {     \
3070             OP *next = S_try_amagic_ftest(aTHX_ chr);   \
3071             if (next) return next;                        \
3072         }                                                  \
3073     } STMT_END
3074
3075 STATIC OP *
3076 S_try_amagic_ftest(pTHX_ char chr) {
3077     SV *const arg = *PL_stack_sp;
3078
3079     assert(chr != '?');
3080     if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3081
3082     if (SvAMAGIC(arg))
3083     {
3084         const char tmpchr = chr;
3085         SV * const tmpsv = amagic_call(arg,
3086                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3087                                 ftest_amg, AMGf_unary);
3088
3089         if (!tmpsv)
3090             return NULL;
3091
3092         return SvTRUE(tmpsv)
3093             ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3094     }
3095     return NULL;
3096 }
3097
3098
3099 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3100  *                pp_ftrwrite() */
3101
3102 PP(pp_ftrread)
3103 {
3104     I32 result;
3105     /* Not const, because things tweak this below. Not bool, because there's
3106        no guarantee that OPpFT_ACCESS is <= CHAR_MAX  */
3107 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3108     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3109     /* Giving some sort of initial value silences compilers.  */
3110 #  ifdef R_OK
3111     int access_mode = R_OK;
3112 #  else
3113     int access_mode = 0;
3114 #  endif
3115 #else
3116     /* access_mode is never used, but leaving use_access in makes the
3117        conditional compiling below much clearer.  */
3118     I32 use_access = 0;
3119 #endif
3120     Mode_t stat_mode = S_IRUSR;
3121
3122     bool effective = FALSE;
3123     char opchar = '?';
3124
3125     switch (PL_op->op_type) {
3126     case OP_FTRREAD:    opchar = 'R'; break;
3127     case OP_FTRWRITE:   opchar = 'W'; break;
3128     case OP_FTREXEC:    opchar = 'X'; break;
3129     case OP_FTEREAD:    opchar = 'r'; break;
3130     case OP_FTEWRITE:   opchar = 'w'; break;
3131     case OP_FTEEXEC:    opchar = 'x'; break;
3132     }
3133     tryAMAGICftest_MG(opchar);
3134
3135     switch (PL_op->op_type) {
3136     case OP_FTRREAD:
3137 #if !(defined(HAS_ACCESS) && defined(R_OK))
3138         use_access = 0;
3139 #endif
3140         break;
3141
3142     case OP_FTRWRITE:
3143 #if defined(HAS_ACCESS) && defined(W_OK)
3144         access_mode = W_OK;
3145 #else
3146         use_access = 0;
3147 #endif
3148         stat_mode = S_IWUSR;
3149         break;
3150
3151     case OP_FTREXEC:
3152 #if defined(HAS_ACCESS) && defined(X_OK)
3153         access_mode = X_OK;
3154 #else
3155         use_access = 0;
3156 #endif
3157         stat_mode = S_IXUSR;
3158         break;
3159
3160     case OP_FTEWRITE:
3161 #ifdef PERL_EFF_ACCESS
3162         access_mode = W_OK;
3163 #endif
3164         stat_mode = S_IWUSR;
3165         /* FALLTHROUGH */
3166
3167     case OP_FTEREAD:
3168 #ifndef PERL_EFF_ACCESS
3169         use_access = 0;
3170 #endif
3171         effective = TRUE;
3172         break;
3173
3174     case OP_FTEEXEC:
3175 #ifdef PERL_EFF_ACCESS
3176         access_mode = X_OK;
3177 #else
3178         use_access = 0;
3179 #endif
3180         stat_mode = S_IXUSR;
3181         effective = TRUE;
3182         break;
3183     }
3184
3185     if (use_access) {
3186 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3187         STRLEN len;
3188         const char *name = SvPV(*PL_stack_sp, len);
3189         if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
3190             result = -1;
3191         }
3192         else if (effective) {
3193 #  ifdef PERL_EFF_ACCESS
3194             result = PERL_EFF_ACCESS(name, access_mode);
3195 #  else
3196             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3197                 OP_NAME(PL_op));
3198 #  endif
3199         }
3200         else {
3201 #  ifdef HAS_ACCESS
3202             result = access(name, access_mode);
3203 #  else
3204             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3205 #  endif
3206         }
3207         if (result == 0)
3208             FT_RETURNYES;
3209         if (result < 0)
3210             FT_RETURNUNDEF;
3211         FT_RETURNNO;
3212 #endif
3213     }
3214
3215     result = my_stat_flags(0);
3216     if (result < 0)
3217         FT_RETURNUNDEF;
3218     if (cando(stat_mode, effective, &PL_statcache))
3219         FT_RETURNYES;
3220     FT_RETURNNO;
3221 }
3222
3223
3224 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3225
3226 PP(pp_ftis)
3227 {
3228     I32 result;
3229     const int op_type = PL_op->op_type;
3230     char opchar = '?';
3231
3232     switch (op_type) {
3233     case OP_FTIS:       opchar = 'e'; break;
3234     case OP_FTSIZE:     opchar = 's'; break;
3235     case OP_FTMTIME:    opchar = 'M'; break;
3236     case OP_FTCTIME:    opchar = 'C'; break;
3237     case OP_FTATIME:    opchar = 'A'; break;
3238     }
3239     tryAMAGICftest_MG(opchar);
3240
3241     result = my_stat_flags(0);
3242     if (result < 0)
3243         FT_RETURNUNDEF;
3244     if (op_type == OP_FTIS)
3245         FT_RETURNYES;
3246     {
3247         /* You can't dTARGET inside OP_FTIS, because you'll get
3248            "panic: pad_sv po" - the op is not flagged to have a target.  */
3249         dTARGET;
3250         switch (op_type) {
3251         case OP_FTSIZE:
3252 #if Off_t_size > IVSIZE
3253             sv_setnv(TARG, (NV)PL_statcache.st_size);
3254 #else
3255             sv_setiv(TARG, (IV)PL_statcache.st_size);
3256 #endif
3257             break;
3258         case OP_FTMTIME:
3259             sv_setnv(TARG,
3260                     ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3261             break;
3262         case OP_FTATIME:
3263             sv_setnv(TARG,
3264                     ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3265             break;
3266         case OP_FTCTIME:
3267             sv_setnv(TARG,
3268                     ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3269             break;
3270         }
3271         SvSETMAGIC(TARG);
3272         return SvTRUE_nomg_NN(TARG)
3273             ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3274     }
3275 }
3276
3277
3278 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3279  *                pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3280  *                pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3281
3282 PP(pp_ftrowned)
3283 {
3284     I32 result;
3285     char opchar = '?';
3286
3287     switch (PL_op->op_type) {
3288     case OP_FTROWNED:   opchar = 'O'; break;
3289     case OP_FTEOWNED:   opchar = 'o'; break;
3290     case OP_FTZERO:     opchar = 'z'; break;
3291     case OP_FTSOCK:     opchar = 'S'; break;
3292     case OP_FTCHR:      opchar = 'c'; break;
3293     case OP_FTBLK:      opchar = 'b'; break;
3294     case OP_FTFILE:     opchar = 'f'; break;
3295     case OP_FTDIR:      opchar = 'd'; break;
3296     case OP_FTPIPE:     opchar = 'p'; break;
3297     case OP_FTSUID:     opchar = 'u'; break;
3298     case OP_FTSGID:     opchar = 'g'; break;
3299     case OP_FTSVTX:     opchar = 'k'; break;
3300     }
3301     tryAMAGICftest_MG(opchar);
3302
3303     result = my_stat_flags(0);
3304     if (result < 0)
3305         FT_RETURNUNDEF;
3306     switch (PL_op->op_type) {
3307     case OP_FTROWNED:
3308         if (PL_statcache.st_uid == PerlProc_getuid())
3309             FT_RETURNYES;
3310         break;
3311     case OP_FTEOWNED:
3312         if (PL_statcache.st_uid == PerlProc_geteuid())
3313             FT_RETURNYES;
3314         break;
3315     case OP_FTZERO:
3316         if (PL_statcache.st_size == 0)
3317             FT_RETURNYES;
3318         break;
3319     case OP_FTSOCK:
3320         if (S_ISSOCK(PL_statcache.st_mode))
3321             FT_RETURNYES;
3322         break;
3323     case OP_FTCHR:
3324         if (S_ISCHR(PL_statcache.st_mode))
3325             FT_RETURNYES;
3326         break;
3327     case OP_FTBLK:
3328         if (S_ISBLK(PL_statcache.st_mode))
3329             FT_RETURNYES;
3330         break;
3331     case OP_FTFILE:
3332         if (S_ISREG(PL_statcache.st_mode))
3333             FT_RETURNYES;
3334         break;
3335     case OP_FTDIR:
3336         if (S_ISDIR(PL_statcache.st_mode))
3337             FT_RETURNYES;
3338         break;
3339     case OP_FTPIPE:
3340         if (S_ISFIFO(PL_statcache.st_mode))
3341             FT_RETURNYES;
3342         break;
3343 #ifdef S_ISUID
3344     case OP_FTSUID:
3345         if (PL_statcache.st_mode & S_ISUID)
3346             FT_RETURNYES;
3347         break;
3348 #endif
3349 #ifdef S_ISGID
3350     case OP_FTSGID:
3351         if (PL_statcache.st_mode & S_ISGID)
3352             FT_RETURNYES;
3353         break;
3354 #endif
3355 #ifdef S_ISVTX
3356     case OP_FTSVTX:
3357         if (PL_statcache.st_mode & S_ISVTX)
3358             FT_RETURNYES;
3359         break;
3360 #endif
3361     }
3362     FT_RETURNNO;
3363 }
3364
3365 PP(pp_ftlink)
3366 {
3367     I32 result;
3368
3369     tryAMAGICftest_MG('l');
3370     result = my_lstat_flags(0);
3371
3372     if (result < 0)
3373         FT_RETURNUNDEF;
3374     if (S_ISLNK(PL_statcache.st_mode))
3375         FT_RETURNYES;
3376     FT_RETURNNO;
3377 }
3378
3379 PP(pp_fttty)
3380 {
3381     int fd;
3382     GV *gv;
3383     char *name = NULL;
3384     STRLEN namelen;
3385     UV uv;
3386
3387     tryAMAGICftest_MG('t');
3388
3389     if (PL_op->op_flags & OPf_REF)
3390         gv = cGVOP_gv;
3391     else {
3392       SV *tmpsv = *PL_stack_sp;
3393       if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3394         name = SvPV_nomg(tmpsv, namelen);
3395         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3396       }
3397     }
3398
3399     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3400         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3401     else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3402         fd = (int)uv;
3403     else
3404         fd = -1;
3405     if (fd < 0) {
3406         SETERRNO(EBADF,RMS_IFI);
3407         FT_RETURNUNDEF;
3408     }
3409     if (PerlLIO_isatty(fd))
3410         FT_RETURNYES;
3411     FT_RETURNNO;
3412 }
3413
3414
3415 /* also used for: pp_ftbinary() */
3416
3417 PP(pp_fttext)
3418 {
3419     I32 i;
3420     SSize_t len;
3421     I32 odd = 0;
3422     STDCHAR tbuf[512];
3423     STDCHAR *s;
3424     IO *io;
3425     SV *sv = NULL;
3426     GV *gv;
3427     PerlIO *fp;
3428     const U8 * first_variant;
3429
3430     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3431
3432     if (PL_op->op_flags & OPf_REF)
3433         gv = cGVOP_gv;
3434     else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3435              == OPpFT_STACKED)
3436         gv = PL_defgv;
3437     else {
3438         sv = *PL_stack_sp;
3439         gv = MAYBE_DEREF_GV_nomg(sv);
3440     }
3441
3442     if (gv) {
3443         if (gv == PL_defgv) {
3444             if (PL_statgv)
3445                 io = SvTYPE(PL_statgv) == SVt_PVIO
3446                     ? (IO *)PL_statgv
3447                     : GvIO(PL_statgv);
3448             else {
3449                 goto really_filename;
3450             }
3451         }
3452         else {
3453             PL_statgv = gv;
3454             SvPVCLEAR(PL_statname);
3455             io = GvIO(PL_statgv);
3456         }
3457         PL_laststatval = -1;
3458         PL_laststype = OP_STAT;
3459         if (io && IoIFP(io)) {
3460             int fd;
3461             if (! PerlIO_has_base(IoIFP(io)))
3462                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3463             fd = PerlIO_fileno(IoIFP(io));
3464             if (fd < 0) {
3465                 SETERRNO(EBADF,RMS_IFI);
3466                 FT_RETURNUNDEF;
3467             }
3468             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3469             if (PL_laststatval < 0)
3470                 FT_RETURNUNDEF;
3471             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3472                 if (PL_op->op_type == OP_FTTEXT)
3473                     FT_RETURNNO;
3474                 else
3475                     FT_RETURNYES;
3476             }
3477             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3478                 i = PerlIO_getc(IoIFP(io));
3479                 if (i != EOF)
3480                     (void)PerlIO_ungetc(IoIFP(io),i);
3481                 else
3482                     /* null file is anything */
3483                     FT_RETURNYES;
3484             }
3485             len = PerlIO_get_bufsiz(IoIFP(io));
3486             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3487             /* sfio can have large buffers - limit to 512 */
3488             if (len > 512)
3489                 len = 512;
3490         }
3491         else {
3492             SETERRNO(EBADF,RMS_IFI);
3493             report_evil_fh(gv);
3494             SETERRNO(EBADF,RMS_IFI);
3495             FT_RETURNUNDEF;
3496         }
3497     }
3498     else {
3499         const char *file;
3500         const char *temp;
3501         STRLEN temp_len;
3502         int fd;
3503
3504         assert(sv);
3505         temp = SvPV_nomg_const(sv, temp_len);
3506         sv_setpv(PL_statname, temp);
3507         if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
3508             PL_laststatval = -1;
3509             PL_laststype = OP_STAT;
3510             FT_RETURNUNDEF;
3511         }
3512       really_filename:
3513         file = SvPVX_const(PL_statname);
3514         PL_statgv = NULL;
3515         if (!(fp = PerlIO_open(file, "r"))) {
3516             if (!gv) {
3517                 PL_laststatval = -1;
3518                 PL_laststype = OP_STAT;
3519             }
3520             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3521                 /* PL_warn_nl is constant */
3522                 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
3523                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3524                 GCC_DIAG_RESTORE_STMT;
3525             }
3526             FT_RETURNUNDEF;
3527         }
3528         PL_laststype = OP_STAT;
3529         fd = PerlIO_fileno(fp);
3530         if (fd < 0) {
3531             (void)PerlIO_close(fp);
3532             SETERRNO(EBADF,RMS_IFI);
3533             FT_RETURNUNDEF;
3534         }
3535         PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3536         if (PL_laststatval < 0) {
3537             dSAVE_ERRNO;
3538             (void)PerlIO_close(fp);
3539             RESTORE_ERRNO;
3540             FT_RETURNUNDEF;
3541         }
3542         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3543         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3544         (void)PerlIO_close(fp);
3545         if (len <= 0) {
3546             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3547                 FT_RETURNNO;            /* special case NFS directories */
3548             FT_RETURNYES;               /* null file is anything */
3549         }
3550         s = tbuf;
3551     }
3552
3553     /* now scan s to look for textiness */
3554
3555 #if defined(DOSISH) || defined(USEMYBINMODE)
3556     /* ignore trailing ^Z on short files */
3557     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3558         --len;
3559 #endif
3560
3561     assert(len);
3562     if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) {
3563
3564         /* Here contains a variant under UTF-8 .  See if the entire string is
3565          * UTF-8. */
3566         if (is_utf8_fixed_width_buf_flags(first_variant,
3567                                           len - ((char *) first_variant - (char *) s),
3568                                           0))
3569         {
3570             if (PL_op->op_type == OP_FTTEXT) {
3571                 FT_RETURNYES;
3572             }
3573             else {
3574                 FT_RETURNNO;
3575             }
3576         }
3577     }
3578
3579     /* Here, is not UTF-8 or is entirely ASCII.  Look through the buffer for
3580      * things that wouldn't be in ASCII text or rich ASCII text.  Count these
3581      * in 'odd' */
3582     for (i = 0; i < len; i++, s++) {
3583         if (!*s) {                      /* null never allowed in text */
3584             odd += len;
3585             break;
3586         }
3587 #ifdef USE_LOCALE_CTYPE
3588         if (IN_LC_RUNTIME(LC_CTYPE)) {
3589             if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3590                 continue;
3591             }
3592         }
3593         else
3594 #endif
3595              if (  isPRINT_A(*s)
3596                     /* VT occurs so rarely in text, that we consider it odd */
3597                  || (isSPACE_A(*s) && *s != VT_NATIVE)
3598
3599                     /* But there is a fair amount of backspaces and escapes in
3600                      * some text */
3601                  || *s == '\b'
3602                  || *s == ESC_NATIVE)
3603         {
3604             continue;
3605         }
3606         odd++;
3607     }
3608
3609     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3610         FT_RETURNNO;
3611     else
3612         FT_RETURNYES;
3613 }
3614
3615 /* File calls. */
3616
3617 PP(pp_chdir)
3618 {
3619     dSP; dTARGET;
3620     const char *tmps = NULL;
3621     GV *gv = NULL;
3622
3623     if( MAXARG == 1 ) {
3624         SV * const sv = POPs;
3625         if (PL_op->op_flags & OPf_SPECIAL) {
3626             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3627             if (!gv) {
3628                 if (ckWARN(WARN_UNOPENED)) {
3629                     Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3630                                 "chdir() on unopened filehandle %" SVf, sv);
3631                 }
3632                 SETERRNO(EBADF,RMS_IFI);
3633                 PUSHs(&PL_sv_zero);
3634                 TAINT_PROPER("chdir");
3635                 RETURN;
3636             }
3637         }
3638         else if (!(gv = MAYBE_DEREF_GV(sv)))
3639                 tmps = SvPV_nomg_const_nolen(sv);
3640     }
3641     else {
3642         HV * const table = GvHVn(PL_envgv);
3643         SV **svp;
3644
3645         EXTEND(SP, 1);
3646         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3647              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3648 #ifdef VMS
3649              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3650 #endif
3651            )
3652         {
3653             tmps = SvPV_nolen_const(*svp);
3654         }
3655         else {
3656             PUSHs(&PL_sv_zero);
3657             SETERRNO(EINVAL, LIB_INVARG);
3658             TAINT_PROPER("chdir");
3659             RETURN;
3660         }
3661     }
3662
3663     TAINT_PROPER("chdir");
3664     if (gv) {
3665 #ifdef HAS_FCHDIR
3666         IO* const io = GvIO(gv);
3667         if (io) {
3668             if (IoDIRP(io)) {
3669                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3670             } else if (IoIFP(io)) {
3671                 int fd = PerlIO_fileno(IoIFP(io));
3672                 if (fd < 0) {
3673                     goto nuts;
3674                 }
3675                 PUSHi(fchdir(fd) >= 0);
3676             }
3677             else {
3678                 goto nuts;
3679             }
3680         } else {
3681             goto nuts;
3682         }
3683
3684 #else
3685         DIE(aTHX_ PL_no_func, "fchdir");
3686 #endif
3687     }
3688     else
3689         PUSHi( PerlDir_chdir(tmps) >= 0 );
3690 #ifdef VMS
3691     /* Clear the DEFAULT element of ENV so we'll get the new value
3692      * in the future. */
3693     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3694 #endif
3695     RETURN;
3696
3697 #ifdef HAS_FCHDIR
3698  nuts:
3699     report_evil_fh(gv);
3700     SETERRNO(EBADF,RMS_IFI);
3701     PUSHs(&PL_sv_zero);
3702     RETURN;
3703 #endif
3704 }
3705
3706
3707 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3708
3709 PP(pp_chown)
3710 {
3711     dSP; dMARK; dTARGET;
3712     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3713
3714     SP = MARK;
3715     XPUSHi(value);
3716     RETURN;
3717 }
3718
3719 PP(pp_chroot)
3720 {
3721 #ifdef HAS_CHROOT
3722     dSP; dTARGET;
3723     char * const tmps = POPpx;
3724     TAINT_PROPER("chroot");
3725     PUSHi( chroot(tmps) >= 0 );
3726     RETURN;
3727 #else
3728     DIE(aTHX_ PL_no_func, "chroot");
3729 #endif
3730 }
3731
3732 PP(pp_rename)
3733 {
3734     dSP; dTARGET;
3735     int anum;
3736 #ifndef HAS_RENAME
3737     Stat_t statbuf;
3738 #endif
3739     const char * const tmps2 = POPpconstx;
3740     const char * const tmps = SvPV_nolen_const(TOPs);
3741     TAINT_PROPER("rename");
3742 #ifdef HAS_RENAME
3743     anum = PerlLIO_rename(tmps, tmps2);
3744 #else
3745     if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3746         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3747             anum = 1;
3748         else {
3749             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3750                 (void)UNLINK(tmps2);
3751             if (!(anum = link(tmps, tmps2)))
3752                 anum = UNLINK(tmps);
3753         }
3754     }
3755 #endif
3756     SETi( anum >= 0 );
3757     RETURN;
3758 }
3759
3760
3761 /* also used for: pp_symlink() */
3762
3763 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3764 PP(pp_link)
3765 {
3766     dSP; dTARGET;
3767     const int op_type = PL_op->op_type;
3768     int result;
3769
3770 #  ifndef HAS_LINK
3771     if (op_type == OP_LINK)
3772         DIE(aTHX_ PL_no_func, "link");
3773 #  endif
3774 #  ifndef HAS_SYMLINK
3775     if (op_type == OP_SYMLINK)
3776         DIE(aTHX_ PL_no_func, "symlink");
3777 #  endif
3778
3779     {
3780         const char * const tmps2 = POPpconstx;
3781         const char * const tmps = SvPV_nolen_const(TOPs);
3782         TAINT_PROPER(PL_op_desc[op_type]);
3783         result =
3784 #  if defined(HAS_LINK) && defined(HAS_SYMLINK)
3785             /* Both present - need to choose which.  */
3786             (op_type == OP_LINK) ?
3787             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3788 #  elif defined(HAS_LINK)
3789     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3790         PerlLIO_link(tmps, tmps2);
3791 #  elif defined(HAS_SYMLINK)
3792     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3793         symlink(tmps, tmps2);
3794 #  endif
3795     }
3796
3797     SETi( result >= 0 );
3798     RETURN;
3799 }
3800 #else
3801
3802 /* also used for: pp_symlink() */
3803
3804 PP(pp_link)
3805 {
3806     /* Have neither.  */
3807     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3808 }
3809 #endif
3810
3811 PP(pp_readlink)
3812 {
3813     dSP;
3814 #ifdef HAS_SYMLINK
3815     dTARGET;
3816     const char *tmps;
3817     char buf[MAXPATHLEN];
3818     SSize_t len;
3819
3820     TAINT;
3821     tmps = POPpconstx;
3822     /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3823      * it is impossible to know whether the result was truncated. */
3824     len = readlink(tmps, buf, sizeof(buf) - 1);
3825     if (len < 0)
3826         RETPUSHUNDEF;
3827     buf[len] = '\0';
3828     PUSHp(buf, len);
3829     RETURN;
3830 #else
3831     EXTEND(SP, 1);
3832     RETSETUNDEF;                /* just pretend it's a normal file */
3833 #endif
3834 }
3835
3836 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3837 STATIC int
3838 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3839 {
3840     char * const save_filename = filename;
3841     char *cmdline;
3842     char *s;
3843     PerlIO *myfp;
3844     int anum = 1;
3845     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3846
3847     PERL_ARGS_ASSERT_DOONELINER;
3848
3849     Newx(cmdline, size, char);
3850     my_strlcpy(cmdline, cmd, size);
3851     my_strlcat(cmdline, " ", size);
3852     for (s = cmdline + strlen(cmdline); *filename; ) {
3853         *s++ = '\\';
3854         *s++ = *filename++;
3855     }
3856     if (s - cmdline < size)
3857         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3858     myfp = PerlProc_popen(cmdline, "r");
3859     Safefree(cmdline);
3860
3861     if (myfp) {
3862         SV * const tmpsv = sv_newmortal();
3863         /* Need to save/restore 'PL_rs' ?? */
3864         s = sv_gets(tmpsv, myfp, 0);
3865         (void)PerlProc_pclose(myfp);
3866         if (s != NULL) {
3867             int e;
3868             for (e = 1;
3869 #ifdef HAS_SYS_ERRLIST
3870                  e <= sys_nerr
3871 #endif
3872                  ; e++)
3873             {
3874                 /* you don't see this */
3875                 const char * const errmsg = Strerror(e) ;
3876                 if (!errmsg)
3877                     break;
3878                 if (instr(s, errmsg)) {
3879                     SETERRNO(e,0);
3880                     return 0;
3881                 }
3882             }
3883             SETERRNO(0,0);
3884 #ifndef EACCES
3885 #define EACCES EPERM
3886 #endif
3887             if (instr(s, "cannot make"))
3888                 SETERRNO(EEXIST,RMS_FEX);
3889             else if (instr(s, "existing file"))
3890                 SETERRNO(EEXIST,RMS_FEX);
3891             else if (instr(s, "ile exists"))
3892                 SETERRNO(EEXIST,RMS_FEX);
3893             else if (instr(s, "non-exist"))
3894                 SETERRNO(ENOENT,RMS_FNF);
3895             else if (instr(s, "does not exist"))
3896                 SETERRNO(ENOENT,RMS_FNF);
3897             else if (instr(s, "not empty"))
3898                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3899             else if (instr(s, "cannot access"))
3900                 SETERRNO(EACCES,RMS_PRV);
3901             else
3902                 SETERRNO(EPERM,RMS_PRV);
3903             return 0;
3904         }
3905         else {  /* some mkdirs return no failure indication */
3906             Stat_t statbuf;
3907             anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3908             if (PL_op->op_type == OP_RMDIR)
3909                 anum = !anum;
3910             if (anum)
3911                 SETERRNO(0,0);
3912             else
3913                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3914         }
3915         return anum;
3916     }
3917     else
3918         return 0;
3919 }
3920 #endif
3921
3922 /* This macro removes trailing slashes from a directory name.
3923  * Different operating and file systems take differently to
3924  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3925  * any number of trailing slashes should be allowed.
3926  * Thusly we snip them away so that even non-conforming
3927  * systems are happy.
3928  * We should probably do this "filtering" for all
3929  * the functions that expect (potentially) directory names:
3930  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3931  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3932
3933 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3934     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3935         do { \
3936             (len)--; \
3937         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3938         (tmps) = savepvn((tmps), (len)); \
3939         (copy) = TRUE; \
3940     }
3941
3942 PP(pp_mkdir)
3943 {
3944     dSP; dTARGET;
3945     STRLEN len;
3946     const char *tmps;
3947     bool copy = FALSE;
3948     const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3949
3950     TRIMSLASHES(tmps,len,copy);
3951
3952     TAINT_PROPER("mkdir");
3953 #ifdef HAS_MKDIR
3954     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3955 #else
3956     {
3957     int oldumask;
3958     SETi( dooneliner("mkdir", tmps) );
3959     oldumask = PerlLIO_umask(0);
3960     PerlLIO_umask(oldumask);
3961     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3962     }
3963 #endif
3964     if (copy)
3965         Safefree(tmps);
3966     RETURN;
3967 }
3968
3969 PP(pp_rmdir)
3970 {
3971     dSP; dTARGET;
3972     STRLEN len;
3973     const char *tmps;
3974     bool copy = FALSE;
3975
3976     TRIMSLASHES(tmps,len,copy);
3977     TAINT_PROPER("rmdir");
3978 #ifdef HAS_RMDIR
3979     SETi( PerlDir_rmdir(tmps) >= 0 );
3980 #else
3981     SETi( dooneliner("rmdir", tmps) );
3982 #endif
3983     if (copy)
3984         Safefree(tmps);
3985     RETURN;
3986 }
3987
3988 /* Directory calls. */
3989
3990 PP(pp_open_dir)
3991 {
3992 #if defined(Direntry_t) && defined(HAS_READDIR)
3993     dSP;
3994     const char * const dirname = POPpconstx;
3995     GV * const gv = MUTABLE_GV(POPs);
3996     IO * const io = GvIOn(gv);
3997
3998     if ((IoIFP(io) || IoOFP(io)))
3999         Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
4000                          HEKfARG(GvENAME_HEK(gv)));
4001     if (IoDIRP(io))
4002         PerlDir_close(IoDIRP(io));
4003     if (!(IoDIRP(io) = PerlDir_open(dirname)))
4004         goto nope;
4005
4006     RETPUSHYES;
4007   nope:
4008     if (!errno)
4009         SETERRNO(EBADF,RMS_DIR);
4010     RETPUSHUNDEF;
4011 #else
4012     DIE(aTHX_ PL_no_dir_func, "opendir");
4013 #endif
4014 }
4015
4016 PP(pp_readdir)
4017 {
4018 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4019     DIE(aTHX_ PL_no_dir_func, "readdir");
4020 #else
4021 #if !defined(I_DIRENT) && !defined(VMS)
4022     Direntry_t *readdir (DIR *);
4023 #endif
4024     dSP;
4025
4026     SV *sv;
4027     const U8 gimme = GIMME_V;
4028     GV * const gv = MUTABLE_GV(POPs);
4029     const Direntry_t *dp;
4030     IO * const io = GvIOn(gv);
4031
4032     if (!IoDIRP(io)) {
4033         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4034                        "readdir() attempted on invalid dirhandle %" HEKf,
4035                             HEKfARG(GvENAME_HEK(gv)));
4036         goto nope;
4037     }
4038
4039     do {
4040         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4041         if (!dp)
4042             break;
4043 #ifdef DIRNAMLEN
4044         sv = newSVpvn(dp->d_name, dp->d_namlen);
4045 #else
4046         sv = newSVpv(dp->d_name, 0);
4047 #endif
4048         if (!(IoFLAGS(io) & IOf_UNTAINT))
4049             SvTAINTED_on(sv);
4050         mXPUSHs(sv);
4051     } while (gimme == G_ARRAY);
4052
4053     if (!dp && gimme != G_ARRAY)
4054         RETPUSHUNDEF;
4055
4056     RETURN;
4057
4058   nope:
4059     if (!errno)
4060         SETERRNO(EBADF,RMS_ISI);
4061     if (gimme == G_ARRAY)
4062         RETURN;
4063     else
4064         RETPUSHUNDEF;
4065 #endif
4066 }
4067
4068 PP(pp_telldir)
4069 {
4070 #if defined(HAS_TELLDIR) || defined(telldir)
4071     dSP; dTARGET;
4072  /* XXX does _anyone_ need this? --AD 2/20/1998 */
4073  /* XXX netbsd still seemed to.
4074     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4075     --JHI 1999-Feb-02 */
4076 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4077     long telldir (DIR *);
4078 # endif
4079     GV * const gv = MUTABLE_GV(POPs);
4080     IO * const io = GvIOn(gv);
4081
4082     if (!IoDIRP(io)) {
4083         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4084                        "telldir() attempted on invalid dirhandle %" HEKf,
4085                             HEKfARG(GvENAME_HEK(gv)));
4086         goto nope;
4087     }
4088
4089     PUSHi( PerlDir_tell(IoDIRP(io)) );
4090     RETURN;
4091   nope:
4092     if (!errno)
4093         SETERRNO(EBADF,RMS_ISI);
4094     RETPUSHUNDEF;
4095 #else
4096     DIE(aTHX_ PL_no_dir_func, "telldir");
4097 #endif
4098 }
4099
4100 PP(pp_seekdir)
4101 {
4102 #if defined(HAS_SEEKDIR) || defined(seekdir)
4103     dSP;
4104     const long along = POPl;
4105     GV * const gv = MUTABLE_GV(POPs);
4106     IO * const io = GvIOn(gv);
4107
4108     if (!IoDIRP(io)) {
4109         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4110                        "seekdir() attempted on invalid dirhandle %" HEKf,
4111                                 HEKfARG(GvENAME_HEK(gv)));
4112         goto nope;
4113     }
4114     (void)PerlDir_seek(IoDIRP(io), along);
4115
4116     RETPUSHYES;
4117   nope:
4118     if (!errno)
4119         SETERRNO(EBADF,RMS_ISI);
4120     RETPUSHUNDEF;
4121 #else
4122     DIE(aTHX_ PL_no_dir_func, "seekdir");
4123 #endif
4124 }
4125
4126 PP(pp_rewinddir)
4127 {
4128 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4129     dSP;
4130     GV * const gv = MUTABLE_GV(POPs);
4131     IO * const io = GvIOn(gv);
4132
4133     if (!IoDIRP(io)) {
4134         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4135                        "rewinddir() attempted on invalid dirhandle %" HEKf,
4136                                 HEKfARG(GvENAME_HEK(gv)));
4137         goto nope;
4138     }
4139     (void)PerlDir_rewind(IoDIRP(io));
4140     RETPUSHYES;
4141   nope:
4142     if (!errno)
4143         SETERRNO(EBADF,RMS_ISI);
4144     RETPUSHUNDEF;
4145 #else
4146     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4147 #endif
4148 }
4149
4150 PP(pp_closedir)
4151 {
4152 #if defined(Direntry_t) && defined(HAS_READDIR)
4153     dSP;
4154     GV * const gv = MUTABLE_GV(POPs);
4155     IO * const io = GvIOn(gv);
4156
4157     if (!IoDIRP(io)) {
4158         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4159                        "closedir() attempted on invalid dirhandle %" HEKf,
4160                                 HEKfARG(GvENAME_HEK(gv)));
4161         goto nope;
4162     }
4163 #ifdef VOID_CLOSEDIR
4164     PerlDir_close(IoDIRP(io));
4165 #else
4166     if (PerlDir_close(IoDIRP(io)) < 0) {
4167         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4168         goto nope;
4169     }
4170 #endif
4171     IoDIRP(io) = 0;
4172
4173     RETPUSHYES;
4174   nope:
4175     if (!errno)
4176         SETERRNO(EBADF,RMS_IFI);
4177     RETPUSHUNDEF;
4178 #else
4179     DIE(aTHX_ PL_no_dir_func, "closedir");
4180 #endif
4181 }
4182
4183 /* Process control. */
4184
4185 PP(pp_fork)
4186 {
4187 #ifdef HAS_FORK
4188     dSP; dTARGET;
4189     Pid_t childpid;
4190 #ifdef HAS_SIGPROCMASK
4191     sigset_t oldmask, newmask;
4192 #endif
4193
4194     EXTEND(SP, 1);
4195     PERL_FLUSHALL_FOR_CHILD;
4196 #ifdef HAS_SIGPROCMASK
4197     sigfillset(&newmask);
4198     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4199 #endif
4200     childpid = PerlProc_fork();
4201     if (childpid == 0) {
4202         int sig;
4203         PL_sig_pending = 0;
4204         if (PL_psig_pend)
4205             for (sig = 1; sig < SIG_SIZE; sig++)
4206                 PL_psig_pend[sig] = 0;
4207     }
4208 #ifdef HAS_SIGPROCMASK
4209     {
4210         dSAVE_ERRNO;
4211         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4212         RESTORE_ERRNO;
4213     }
4214 #endif
4215     if (childpid < 0)
4216         RETPUSHUNDEF;
4217     if (!childpid) {
4218 #ifdef PERL_USES_PL_PIDSTATUS
4219         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4220 #endif
4221     }
4222     PUSHi(childpid);
4223     RETURN;
4224 #elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4225     dSP; dTARGET;
4226     Pid_t childpid;
4227
4228     EXTEND(SP, 1);
4229     PERL_FLUSHALL_FOR_CHILD;
4230     childpid = PerlProc_fork();
4231     if (childpid == -1)
4232         RETPUSHUNDEF;
4233     PUSHi(childpid);
4234     RETURN;
4235 #else
4236     DIE(aTHX_ PL_no_func, "fork");
4237 #endif
4238 }
4239
4240 PP(pp_wait)
4241 {
4242 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4243     dSP; dTARGET;
4244     Pid_t childpid;
4245     int argflags;
4246
4247     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4248         childpid = wait4pid(-1, &argflags, 0);
4249     else {
4250         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4251                errno == EINTR) {
4252           PERL_ASYNC_CHECK();
4253         }
4254     }
4255 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4256     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4257     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4258 #  else
4259     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4260 #  endif
4261     XPUSHi(childpid);
4262     RETURN;
4263 #else
4264     DIE(aTHX_ PL_no_func, "wait");
4265 #endif
4266 }
4267
4268 PP(pp_waitpid)
4269 {
4270 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4271     dSP; dTARGET;
4272     const int optype = POPi;
4273     const Pid_t pid = TOPi;
4274     Pid_t result;
4275 #ifdef __amigaos4__
4276     int argflags = 0;
4277     result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4278     STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4279     result = result == 0 ? pid : -1;
4280 #else
4281     int argflags;
4282
4283     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4284         result = wait4pid(pid, &argflags, optype);
4285     else {
4286         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4287                errno == EINTR) {
4288           PERL_ASYNC_CHECK();
4289         }
4290     }
4291 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4292     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4293     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4294 #  else
4295     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4296 #  endif
4297 # endif /* __amigaos4__ */
4298     SETi(result);
4299     RETURN;
4300 #else
4301     DIE(aTHX_ PL_no_func, "waitpid");
4302 #endif
4303 }
4304
4305 PP(pp_system)
4306 {
4307     dSP; dMARK; dORIGMARK; dTARGET;
4308 #if defined(__LIBCATAMOUNT__)
4309     PL_statusvalue = -1;
4310     SP = ORIGMARK;
4311     XPUSHi(-1);
4312 #else
4313     I32 value;
4314 # ifdef __amigaos4__
4315     void * result;
4316 # else
4317     int result;
4318 # endif
4319
4320     while (++MARK <= SP) {
4321         SV *origsv = *MARK, *copysv;
4322         STRLEN len;
4323         char *pv;
4324         SvGETMAGIC(origsv);
4325 #if defined(WIN32) || defined(__VMS)
4326         /*
4327          * Because of a nasty platform-specific variation on the meaning
4328          * of arguments to this op, we must preserve numeric arguments
4329          * as numeric, not just retain the string value.
4330          */
4331         if (SvNIOK(origsv) || SvNIOKp(origsv)) {
4332             copysv = newSV_type(SVt_PVNV);
4333             sv_2mortal(copysv);
4334             if (SvPOK(origsv) || SvPOKp(origsv)) {
4335                 pv = SvPV_nomg(origsv, len);
4336                 sv_setpvn(copysv, pv, len);
4337                 SvPOK_off(copysv);
4338             }
4339             if (SvIOK(origsv) || SvIOKp(origsv))
4340                 SvIV_set(copysv, SvIVX(origsv));
4341             if (SvNOK(origsv) || SvNOKp(origsv))
4342                 SvNV_set(copysv, SvNVX(origsv));
4343             SvFLAGS(copysv) |= SvFLAGS(origsv) &
4344                 (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK|
4345                     SVf_UTF8|SVf_IVisUV);
4346         } else
4347 #endif
4348         {
4349             pv = SvPV_nomg(origsv, len);
4350             copysv = newSVpvn_flags(pv, len,
4351                         (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
4352         }
4353         *MARK = copysv;
4354     }
4355     MARK = ORIGMARK;
4356
4357     if (TAINTING_get) {
4358         TAINT_ENV();
4359         TAINT_PROPER("system");
4360     }
4361     PERL_FLUSHALL_FOR_CHILD;
4362 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4363     {
4364 #ifdef __amigaos4__
4365         struct UserData userdata;
4366         pthread_t proc;
4367 #else
4368         Pid_t childpid;
4369 #endif
4370         int pp[2];
4371         I32 did_pipes = 0;
4372         bool child_success = FALSE;
4373 #ifdef HAS_SIGPROCMASK
4374         sigset_t newset, oldset;
4375 #endif
4376
4377         if (PerlProc_pipe_cloexec(pp) >= 0)
4378             did_pipes = 1;
4379 #ifdef __amigaos4__
4380         amigaos_fork_set_userdata(aTHX_
4381                                   &userdata,
4382                                   did_pipes,
4383                                   pp[1],
4384                                   SP,
4385                                   mark);
4386         pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4387         child_success = proc > 0;
4388 #else
4389 #ifdef HAS_SIGPROCMASK
4390         sigemptyset(&newset);
4391         sigaddset(&newset, SIGCHLD);
4392         sigprocmask(SIG_BLOCK, &newset, &oldset);
4393 #endif
4394         while ((childpid = PerlProc_fork()) == -1) {
4395             if (errno != EAGAIN) {
4396                 value = -1;
4397                 SP = ORIGMARK;
4398                 XPUSHi(value);
4399                 if (did_pipes) {
4400                     PerlLIO_close(pp[0]);
4401                     PerlLIO_close(pp[1]);
4402                 }
4403 #ifdef HAS_SIGPROCMASK
4404                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4405 #endif
4406                 RETURN;
4407             }
4408             sleep(5);
4409         }
4410         child_success = childpid > 0;
4411 #endif
4412         if (child_success) {
4413             Sigsave_t ihand,qhand; /* place to save signals during system() */
4414             int status;
4415
4416 #ifndef __amigaos4__
4417             if (did_pipes)
4418                 PerlLIO_close(pp[1]);
4419 #endif
4420 #ifndef PERL_MICRO
4421             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4422             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4423 #endif
4424 #ifdef __amigaos4__
4425             result = pthread_join(proc, (void **)&status);
4426 #else
4427             do {
4428                 result = wait4pid(childpid, &status, 0);
4429             } while (result == -1 && errno == EINTR);
4430 #endif
4431 #ifndef PERL_MICRO
4432 #ifdef HAS_SIGPROCMASK
4433             sigprocmask(SIG_SETMASK, &oldset, NULL);
4434 #endif
4435             (void)rsignal_restore(SIGINT, &ihand);
4436             (void)rsignal_restore(SIGQUIT, &qhand);
4437 #endif
4438             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4439             SP = ORIGMARK;
4440             if (did_pipes) {
4441                 int errkid;
4442                 unsigned n = 0;
4443
4444                 while (n < sizeof(int)) {
4445                     const SSize_t n1 = PerlLIO_read(pp[0],
4446                                       (void*)(((char*)&errkid)+n),
4447                                       (sizeof(int)) - n);
4448                     if (n1 <= 0)
4449                         break;
4450                     n += n1;
4451                 }
4452                 PerlLIO_close(pp[0]);
4453                 if (n) {                        /* Error */
4454                     if (n != sizeof(int))
4455                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4456                     errno = errkid;             /* Propagate errno from kid */
4457 #ifdef __amigaos4__
4458                     /* The pipe always has something in it
4459                      * so n alone is not enough. */
4460                     if (errno > 0)
4461 #endif
4462                     {
4463                         STATUS_NATIVE_CHILD_SET(-1);
4464                     }
4465                 }
4466             }
4467             XPUSHi(STATUS_CURRENT);
4468             RETURN;
4469         }
4470 #ifndef __amigaos4__
4471 #ifdef HAS_SIGPROCMASK
4472         sigprocmask(SIG_SETMASK, &oldset, NULL);
4473 #endif
4474         if (did_pipes)
4475             PerlLIO_close(pp[0]);
4476         if (PL_op->op_flags & OPf_STACKED) {
4477             SV * const really = *++MARK;
4478             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4479         }
4480         else if (SP - MARK != 1)
4481             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4482         else {
4483             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4484         }
4485 #endif /* __amigaos4__ */
4486         PerlProc__exit(-1);
4487     }
4488 #else /* ! FORK or VMS or OS/2 */
4489     PL_statusvalue = 0;
4490     result = 0;
4491     if (PL_op->op_flags & OPf_STACKED) {
4492         SV * const really = *++MARK;
4493 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4494         value = (I32)do_aspawn(really, MARK, SP);
4495 #  else
4496         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4497 #  endif
4498     }
4499     else if (SP - MARK != 1) {
4500 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4501         value = (I32)do_aspawn(NULL, MARK, SP);
4502 #  else
4503         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4504 #  endif
4505     }
4506     else {
4507         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4508     }
4509     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4510         result = 1;
4511     STATUS_NATIVE_CHILD_SET(value);
4512     SP = ORIGMARK;
4513     XPUSHi(result ? value : STATUS_CURRENT);
4514 #endif /* !FORK or VMS or OS/2 */
4515 #endif
4516     RETURN;
4517 }
4518
4519 PP(pp_exec)
4520 {
4521     dSP; dMARK; dORIGMARK; dTARGET;
4522     I32 value;
4523
4524     if (TAINTING_get) {
4525         TAINT_ENV();
4526         while (++MARK <= SP) {
4527             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4528             if (TAINT_get)
4529                 break;
4530         }
4531         MARK = ORIGMARK;
4532         TAINT_PROPER("exec");
4533     }
4534
4535     PERL_FLUSHALL_FOR_CHILD;
4536     if (PL_op->op_flags & OPf_STACKED) {
4537         SV * const really = *++MARK;
4538         value = (I32)do_aexec(really, MARK, SP);
4539     }
4540     else if (SP - MARK != 1)
4541 #ifdef VMS
4542         value = (I32)vms_do_aexec(NULL, MARK, SP);
4543 #else
4544         value = (I32)do_aexec(NULL, MARK, SP);
4545 #endif
4546     else {
4547 #ifdef VMS
4548         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4549 #else
4550         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4551 #endif
4552     }
4553     SP = ORIGMARK;
4554     XPUSHi(value);
4555     RETURN;
4556 }
4557
4558 PP(pp_getppid)
4559 {
4560 #ifdef HAS_GETPPID
4561     dSP; dTARGET;
4562     XPUSHi( getppid() );
4563     RETURN;
4564 #else
4565     DIE(aTHX_ PL_no_func, "getppid");
4566 #endif
4567 }
4568
4569 PP(pp_getpgrp)
4570 {
4571 #ifdef HAS_GETPGRP
4572     dSP; dTARGET;
4573     Pid_t pgrp;
4574     const Pid_t pid =
4575         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4576
4577 #ifdef BSD_GETPGRP
4578     pgrp = (I32)BSD_GETPGRP(pid);
4579 #else
4580     if (pid != 0 && pid != PerlProc_getpid())
4581         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4582     pgrp = getpgrp();
4583 #endif
4584     XPUSHi(pgrp);
4585     RETURN;
4586 #else
4587     DIE(aTHX_ PL_no_func, "getpgrp");
4588 #endif
4589 }
4590
4591 PP(pp_setpgrp)
4592 {
4593 #ifdef HAS_SETPGRP
4594     dSP; dTARGET;
4595     Pid_t pgrp;
4596     Pid_t pid;
4597     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4598     if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4599     else {
4600         pid = 0;
4601         EXTEND(SP,1);
4602         SP++;
4603     }
4604
4605     TAINT_PROPER("setpgrp");
4606 #ifdef BSD_SETPGRP
4607     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4608 #else
4609     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4610         || (pid != 0 && pid != PerlProc_getpid()))
4611     {
4612         DIE(aTHX_ "setpgrp can't take arguments");
4613     }
4614     SETi( setpgrp() >= 0 );
4615 #endif /* USE_BSDPGRP */
4616     RETURN;
4617 #else
4618     DIE(aTHX_ PL_no_func, "setpgrp");
4619 #endif
4620 }
4621
4622 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4623 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4624 #else
4625 #  define PRIORITY_WHICH_T(which) which
4626 #endif
4627
4628 PP(pp_getpriority)
4629 {
4630 #ifdef HAS_GETPRIORITY
4631     dSP; dTARGET;
4632     const int who = POPi;
4633     const int which = TOPi;
4634     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4635     RETURN;
4636 #else
4637     DIE(aTHX_ PL_no_func, "getpriority");
4638 #endif
4639 }
4640
4641 PP(pp_setpriority)
4642 {
4643 #ifdef HAS_SETPRIORITY
4644     dSP; dTARGET;
4645     const int niceval = POPi;
4646     const int who = POPi;
4647     const int which = TOPi;
4648     TAINT_PROPER("setpriority");
4649     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4650     RETURN;
4651 #else
4652     DIE(aTHX_ PL_no_func, "setpriority");
4653 #endif
4654 }
4655
4656 #undef PRIORITY_WHICH_T
4657
4658 /* Time calls. */
4659
4660 PP(pp_time)
4661 {
4662     dSP; dTARGET;
4663 #ifdef BIG_TIME
4664     XPUSHn( time(NULL) );
4665 #else
4666     XPUSHi( time(NULL) );
4667 #endif
4668     RETURN;
4669 }
4670
4671 PP(pp_tms)
4672 {
4673 #ifdef HAS_TIMES
4674     dSP;
4675     struct tms timesbuf;
4676
4677     EXTEND(SP, 4);
4678     (void)PerlProc_times(&timesbuf);
4679
4680     mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4681     if (GIMME_V == G_ARRAY) {
4682         mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4683         mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4684         mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4685     }
4686     RETURN;
4687 #elif defined(PERL_MICRO)
4688     dSP;
4689     mPUSHn(0.0);
4690     EXTEND(SP, 4);
4691     if (GIMME_V == G_ARRAY) {
4692          mPUSHn(0.0);
4693          mPUSHn(0.0);
4694          mPUSHn(0.0);
4695     }
4696     RETURN;
4697 #else
4698     DIE(aTHX_ "times not implemented");
4699 #endif /* HAS_TIMES */
4700 }
4701
4702 /* The 32 bit int year limits the times we can represent to these
4703    boundaries with a few days wiggle room to account for time zone
4704    offsets
4705 */
4706 /* Sat Jan  3 00:00:00 -2147481748 */
4707 #define TIME_LOWER_BOUND -67768100567755200.0
4708 /* Sun Dec 29 12:00:00  2147483647 */
4709 #define TIME_UPPER_BOUND  67767976233316800.0
4710
4711
4712 /* also used for: pp_localtime() */
4713
4714 PP(pp_gmtime)
4715 {
4716     dSP;
4717     Time64_T when;
4718     struct TM tmbuf;
4719     struct TM *err;
4720     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4721     static const char * const dayname[] =
4722         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4723     static const char * const monname[] =
4724         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4725          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4726
4727     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4728         time_t now;
4729         (void)time(&now);
4730         when = (Time64_T)now;
4731     }
4732     else {
4733         NV input = Perl_floor(POPn);
4734         const bool pl_isnan = Perl_isnan(input);
4735         when = (Time64_T)input;
4736         if (UNLIKELY(pl_isnan || when != input)) {
4737             /* diag_listed_as: gmtime(%f) too large */
4738             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4739                            "%s(%.0" NVff ") too large", opname, input);
4740             if (pl_isnan) {
4741                 err = NULL;
4742                 goto failed;
4743             }
4744         }
4745     }
4746
4747     if ( TIME_LOWER_BOUND > when ) {
4748         /* diag_listed_as: gmtime(%f) too small */
4749         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4750                        "%s(%.0" NVff ") too small", opname, when);
4751         err = NULL;
4752     }
4753     else if( when > TIME_UPPER_BOUND ) {
4754         /* diag_listed_as: gmtime(%f) too small */
4755         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4756                        "%s(%.0" NVff ") too large", opname, when);
4757         err = NULL;
4758     }
4759     else {
4760         if (PL_op->op_type == OP_LOCALTIME)
4761             err = Perl_localtime64_r(&when, &tmbuf);
4762         else
4763             err = Perl_gmtime64_r(&when, &tmbuf);
4764     }
4765
4766     if (err == NULL) {
4767         /* diag_listed_as: gmtime(%f) failed */
4768         /* XXX %lld broken for quads */
4769       failed:
4770         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4771                        "%s(%.0" NVff ") failed", opname, when);
4772     }
4773
4774     if (GIMME_V != G_ARRAY) {   /* scalar context */
4775         EXTEND(SP, 1);
4776         if (err == NULL)
4777             RETPUSHUNDEF;
4778        else {
4779            dTARGET;
4780            PUSHs(TARG);
4781            Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
4782                                 dayname[tmbuf.tm_wday],
4783                                 monname[tmbuf.tm_mon],
4784                                 tmbuf.tm_mday,
4785                                 tmbuf.tm_hour,
4786                                 tmbuf.tm_min,
4787                                 tmbuf.tm_sec,
4788                                 (IV)tmbuf.tm_year + 1900);
4789         }
4790     }
4791     else {                      /* list context */
4792         if ( err == NULL )
4793             RETURN;
4794
4795         EXTEND(SP, 9);
4796         EXTEND_MORTAL(9);
4797         mPUSHi(tmbuf.tm_sec);
4798         mPUSHi(tmbuf.tm_min);
4799         mPUSHi(tmbuf.tm_hour);
4800         mPUSHi(tmbuf.tm_mday);
4801         mPUSHi(tmbuf.tm_mon);
4802         mPUSHn(tmbuf.tm_year);
4803         mPUSHi(tmbuf.tm_wday);
4804         mPUSHi(tmbuf.tm_yday);
4805         mPUSHi(tmbuf.tm_isdst);
4806     }
4807     RETURN;
4808 }
4809
4810 PP(pp_alarm)
4811 {
4812 #ifdef HAS_ALARM
4813     dSP; dTARGET;
4814     /* alarm() takes an unsigned int number of seconds, and return the
4815      * unsigned int number of seconds remaining in the previous alarm
4816      * (alarms don't stack).  Therefore negative return values are not
4817      * possible. */
4818     int anum = POPi;
4819     if (anum < 0) {
4820         /* Note that while the C library function alarm() as such has
4821          * no errors defined (or in other words, properly behaving client
4822          * code shouldn't expect any), alarm() being obsoleted by
4823          * setitimer() and often being implemented in terms of
4824          * setitimer(), can fail. */
4825         /* diag_listed_as: %s() with negative argument */
4826         Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4827                          "alarm() with negative argument");
4828         SETERRNO(EINVAL, LIB_INVARG);
4829         RETPUSHUNDEF;
4830     }
4831     else {
4832         unsigned int retval = alarm(anum);
4833         if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4834             RETPUSHUNDEF;
4835         PUSHu(retval);
4836         RETURN;
4837     }
4838 #else
4839     DIE(aTHX_ PL_no_func, "alarm");
4840 #endif
4841 }
4842
4843 PP(pp_sleep)
4844 {
4845     dSP; dTARGET;
4846     Time_t lasttime;
4847     Time_t when;
4848
4849     (void)time(&lasttime);
4850     if (MAXARG < 1 || (!TOPs && !POPs))
4851         PerlProc_pause();
4852     else {
4853         const I32 duration = POPi;
4854         if (duration < 0) {
4855           /* diag_listed_as: %s() with negative argument */
4856           Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4857                            "sleep() with negative argument");
4858           SETERRNO(EINVAL, LIB_INVARG);
4859           XPUSHs(&PL_sv_zero);
4860           RETURN;
4861         } else {
4862           PerlProc_sleep((unsigned int)duration);
4863         }
4864     }
4865     (void)time(&when);
4866     XPUSHi(when - lasttime);
4867     RETURN;
4868 }
4869
4870 /* Shared memory. */
4871 /* Merged with some message passing. */
4872
4873 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4874
4875 PP(pp_shmwrite)
4876 {
4877 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4878     dSP; dMARK; dTARGET;
4879     const int op_type = PL_op->op_type;
4880     I32 value;
4881
4882     switch (op_type) {
4883     case OP_MSGSND:
4884         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4885         break;
4886     case OP_MSGRCV:
4887         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4888         break;
4889     case OP_SEMOP:
4890         value = (I32)(do_semop(MARK, SP) >= 0);
4891         break;
4892     default:
4893         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4894         break;
4895     }
4896
4897     SP = MARK;
4898     PUSHi(value);
4899     RETURN;
4900 #else
4901     return Perl_pp_semget(aTHX);
4902 #endif
4903 }
4904
4905 /* Semaphores. */
4906
4907 /* also used for: pp_msgget() pp_shmget() */
4908
4909 PP(pp_semget)
4910 {
4911 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4912     dSP; dMARK; dTARGET;
4913     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4914     SP = MARK;
4915     if (anum == -1)
4916         RETPUSHUNDEF;
4917     PUSHi(anum);
4918     RETURN;
4919 #else
4920     DIE(aTHX_ "System V IPC is not implemented on this machine");
4921 #endif
4922 }
4923
4924 /* also used for: pp_msgctl() pp_shmctl() */
4925
4926 PP(pp_semctl)
4927 {
4928 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4929     dSP; dMARK; dTARGET;
4930     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4931     SP = MARK;
4932     if (anum == -1)
4933         RETPUSHUNDEF;
4934     if (anum != 0) {
4935         PUSHi(anum);
4936     }
4937     else {
4938         PUSHp(zero_but_true, ZBTLEN);
4939     }
4940     RETURN;
4941 #else
4942     return Perl_pp_semget(aTHX);
4943 #endif
4944 }
4945
4946 /* I can't const this further without getting warnings about the types of
4947    various arrays passed in from structures.  */
4948 static SV *
4949 S_space_join_names_mortal(pTHX_ char *const *array)
4950 {
4951     SV *target;
4952
4953     if (array && *array) {
4954         target = newSVpvs_flags("", SVs_TEMP);
4955         while (1) {
4956             sv_catpv(target, *array);
4957             if (!*++array)
4958                 break;
4959             sv_catpvs(target, " ");
4960         }
4961     } else {
4962         target = sv_mortalcopy(&PL_sv_no);
4963     }
4964     return target;
4965 }
4966
4967 /* Get system info. */
4968
4969 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4970
4971 PP(pp_ghostent)
4972 {
4973 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4974     dSP;
4975     I32 which = PL_op->op_type;
4976     char **elem;
4977     SV *sv;
4978 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4979     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4980     struct hostent *gethostbyname(Netdb_name_t);
4981     struct hostent *gethostent(void);
4982 #endif
4983     struct hostent *hent = NULL;
4984     unsigned long len;
4985
4986     EXTEND(SP, 10);
4987     if (which == OP_GHBYNAME) {
4988 #ifdef HAS_GETHOSTBYNAME
4989         const char* const name = POPpbytex;
4990         hent = PerlSock_gethostbyname(name);
4991 #else
4992         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4993 #endif
4994     }
4995     else if (which == OP_GHBYADDR) {
4996 #ifdef HAS_GETHOSTBYADDR
4997         const int addrtype = POPi;
4998         SV * const addrsv = POPs;
4999         STRLEN addrlen;
5000         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
5001
5002         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
5003 #else
5004         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
5005 #endif
5006     }
5007     else
5008 #ifdef HAS_GETHOSTENT
5009         hent = PerlSock_gethostent();
5010 #else
5011         DIE(aTHX_ PL_no_sock_func, "gethostent");
5012 #endif
5013
5014 #ifdef HOST_NOT_FOUND
5015         if (!hent) {
5016 #ifdef USE_REENTRANT_API
5017 #   ifdef USE_GETHOSTENT_ERRNO
5018             h_errno = PL_reentrant_buffer->_gethostent_errno;
5019 #   endif
5020 #endif
5021             STATUS_UNIX_SET(h_errno);
5022         }
5023 #endif
5024
5025     if (GIMME_V != G_ARRAY) {
5026         PUSHs(sv = sv_newmortal());
5027         if (hent) {
5028             if (which == OP_GHBYNAME) {
5029                 if (hent->h_addr)
5030                     sv_setpvn(sv, hent->h_addr, hent->h_length);
5031             }
5032             else
5033                 sv_setpv(sv, (char*)hent->h_name);
5034         }
5035         RETURN;
5036     }
5037
5038     if (hent) {
5039         mPUSHs(newSVpv((char*)hent->h_name, 0));
5040         PUSHs(space_join_names_mortal(hent->h_aliases));
5041         mPUSHi(hent->h_addrtype);
5042         len = hent->h_length;
5043         mPUSHi(len);
5044 #ifdef h_addr
5045         for (elem = hent->h_addr_list; elem && *elem; elem++) {
5046             mXPUSHp(*elem, len);
5047         }
5048 #else
5049         if (hent->h_addr)
5050             mPUSHp(hent->h_addr, len);
5051         else
5052             PUSHs(sv_mortalcopy(&PL_sv_no));
5053 #endif /* h_addr */
5054     }
5055     RETURN;
5056 #else
5057     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5058 #endif
5059 }
5060
5061 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5062
5063 PP(pp_gnetent)
5064 {
5065 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5066     dSP;
5067     I32 which = PL_op->op_type;
5068     SV *sv;
5069 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5070     struct netent *getnetbyaddr(Netdb_net_t, int);
5071     struct netent *getnetbyname(Netdb_name_t);
5072     struct netent *getnetent(void);
5073 #endif
5074     struct netent *nent;
5075
5076     if (which == OP_GNBYNAME){
5077 #ifdef HAS_GETNETBYNAME
5078         const char * const name = POPpbytex;
5079         nent = PerlSock_getnetbyname(name);
5080 #else
5081         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5082 #endif
5083     }
5084     else if (which == OP_GNBYADDR) {
5085 #ifdef HAS_GETNETBYADDR
5086         const int addrtype = POPi;
5087         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5088         nent = PerlSock_getnetbyaddr(addr, addrtype);
5089 #else
5090         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5091 #endif
5092     }
5093     else
5094 #ifdef HAS_GETNETENT
5095         nent = PerlSock_getnetent();
5096 #else
5097         DIE(aTHX_ PL_no_sock_func, "getnetent");
5098 #endif
5099
5100 #ifdef HOST_NOT_FOUND
5101         if (!nent) {
5102 #ifdef USE_REENTRANT_API
5103 #   ifdef USE_GETNETENT_ERRNO
5104              h_errno = PL_reentrant_buffer->_getnetent_errno;
5105 #   endif
5106 #endif
5107             STATUS_UNIX_SET(h_errno);
5108         }
5109 #endif
5110
5111     EXTEND(SP, 4);
5112     if (GIMME_V != G_ARRAY) {
5113         PUSHs(sv = sv_newmortal());
5114         if (nent) {
5115             if (which == OP_GNBYNAME)
5116                 sv_setiv(sv, (IV)nent->n_net);
5117             else
5118                 sv_setpv(sv, nent->n_name);
5119         }
5120         RETURN;
5121     }
5122
5123     if (nent) {
5124         mPUSHs(newSVpv(nent->n_name, 0));
5125         PUSHs(space_join_names_mortal(nent->n_aliases));
5126         mPUSHi(nent->n_addrtype);
5127         mPUSHi(nent->n_net);
5128     }
5129
5130     RETURN;
5131 #else
5132     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5133 #endif
5134 }
5135
5136
5137 /* also used for: pp_gpbyname() pp_gpbynumber() */
5138
5139 PP(pp_gprotoent)
5140 {
5141 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5142     dSP;
5143     I32 which = PL_op->op_type;
5144     SV *sv;
5145 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5146     struct protoent *getprotobyname(Netdb_name_t);
5147     struct protoent *getprotobynumber(int);
5148     struct protoent *getprotoent(void);
5149 #endif
5150     struct protoent *pent;
5151
5152     if (which == OP_GPBYNAME) {
5153 #ifdef HAS_GETPROTOBYNAME
5154         const char* const name = POPpbytex;
5155         pent = PerlSock_getprotobyname(name);
5156 #else
5157         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5158 #endif
5159     }
5160     else if (which == OP_GPBYNUMBER) {
5161 #ifdef HAS_GETPROTOBYNUMBER
5162         const int number = POPi;
5163         pent = PerlSock_getprotobynumber(number);
5164 #else
5165         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5166 #endif
5167     }
5168     else
5169 #ifdef HAS_GETPROTOENT
5170         pent = PerlSock_getprotoent();
5171 #else
5172         DIE(aTHX_ PL_no_sock_func, "getprotoent");
5173 #endif
5174
5175     EXTEND(SP, 3);
5176     if (GIMME_V != G_ARRAY) {
5177         PUSHs(sv = sv_newmortal());
5178         if (pent) {
5179             if (which == OP_GPBYNAME)
5180                 sv_setiv(sv, (IV)pent->p_proto);
5181             else
5182                 sv_setpv(sv, pent->p_name);
5183         }
5184         RETURN;
5185     }
5186
5187     if (pent) {
5188         mPUSHs(newSVpv(pent->p_name, 0));
5189         PUSHs(space_join_names_mortal(pent->p_aliases));
5190         mPUSHi(pent->p_proto);
5191     }
5192
5193     RETURN;
5194 #else
5195     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5196 #endif
5197 }
5198
5199
5200 /* also used for: pp_gsbyname() pp_gsbyport() */
5201
5202 PP(pp_gservent)
5203 {
5204 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5205     dSP;
5206     I32 which = PL_op->op_type;
5207     SV *sv;
5208 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5209     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5210     struct servent *getservbyport(int, Netdb_name_t);
5211     struct servent *getservent(void);
5212 #endif
5213     struct servent *sent;
5214
5215     if (which == OP_GSBYNAME) {
5216 #ifdef HAS_GETSERVBYNAME
5217         const char * const proto = POPpbytex;
5218         const char * const name = POPpbytex;
5219         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5220 #else
5221         DIE(aTHX_ PL_no_sock_func, "getservbyname");
5222 #endif
5223     }
5224     else if (which == OP_GSBYPORT) {
5225 #ifdef HAS_GETSERVBYPORT
5226         const char * const proto = POPpbytex;
5227         unsigned short port = (unsigned short)POPu;
5228         port = PerlSock_htons(port);
5229         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5230 #else
5231         DIE(aTHX_ PL_no_sock_func, "getservbyport");
5232 #endif
5233     }
5234     else
5235 #ifdef HAS_GETSERVENT
5236         sent = PerlSock_getservent();
5237 #else
5238         DIE(aTHX_ PL_no_sock_func, "getservent");
5239 #endif
5240
5241     EXTEND(SP, 4);
5242     if (GIMME_V != G_ARRAY) {
5243         PUSHs(sv = sv_newmortal());
5244         if (sent) {
5245             if (which == OP_GSBYNAME) {
5246                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5247             }
5248             else
5249                 sv_setpv(sv, sent->s_name);
5250         }
5251         RETURN;
5252     }
5253
5254     if (sent) {
5255         mPUSHs(newSVpv(sent->s_name, 0));
5256         PUSHs(space_join_names_mortal(sent->s_aliases));
5257         mPUSHi(PerlSock_ntohs(sent->s_port));
5258         mPUSHs(newSVpv(sent->s_proto, 0));
5259     }
5260
5261     RETURN;
5262 #else
5263     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5264 #endif
5265 }
5266
5267
5268 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5269
5270 PP(pp_shostent)
5271 {
5272     dSP;
5273     const int stayopen = TOPi;
5274     switch(PL_op->op_type) {
5275     case OP_SHOSTENT:
5276 #ifdef HAS_SETHOSTENT
5277         PerlSock_sethostent(stayopen);
5278 #else
5279         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5280 #endif
5281         break;
5282     case OP_SNETENT:
5283 #ifdef HAS_SETNETENT
5284         PerlSock_setnetent(stayopen);
5285 #else
5286         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5287 #endif
5288         break;
5289     case OP_SPROTOENT:
5290 #ifdef HAS_SETPROTOENT
5291         PerlSock_setprotoent(stayopen);
5292 #else
5293         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5294 #endif
5295         break;
5296     case OP_SSERVENT:
5297 #ifdef HAS_SETSERVENT
5298         PerlSock_setservent(stayopen);
5299 #else
5300         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5301 #endif
5302         break;
5303     }
5304     RETSETYES;
5305 }
5306
5307
5308 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5309  *                pp_eservent() pp_sgrent() pp_spwent() */
5310
5311 PP(pp_ehostent)
5312 {
5313     dSP;
5314     switch(PL_op->op_type) {
5315     case OP_EHOSTENT:
5316 #ifdef HAS_ENDHOSTENT
5317         PerlSock_endhostent();
5318 #else
5319         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5320 #endif
5321         break;
5322     case OP_ENETENT:
5323 #ifdef HAS_ENDNETENT
5324         PerlSock_endnetent();
5325 #else
5326         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5327 #endif
5328         break;
5329     case OP_EPROTOENT:
5330 #ifdef HAS_ENDPROTOENT
5331         PerlSock_endprotoent();
5332 #else
5333         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5334 #endif
5335         break;
5336     case OP_ESERVENT:
5337 #ifdef HAS_ENDSERVENT
5338         PerlSock_endservent();
5339 #else
5340         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5341 #endif
5342         break;
5343     case OP_SGRENT:
5344 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5345         setgrent();
5346 #else
5347         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5348 #endif
5349         break;
5350     case OP_EGRENT:
5351 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5352         endgrent();
5353 #else
5354         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5355 #endif
5356         break;
5357     case OP_SPWENT:
5358 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5359         setpwent();
5360 #else
5361         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5362 #endif
5363         break;
5364     case OP_EPWENT:
5365 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5366         endpwent();
5367 #else
5368         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5369 #endif
5370         break;
5371     }
5372     EXTEND(SP,1);
5373     RETPUSHYES;
5374 }
5375
5376
5377 /* also used for: pp_gpwnam() pp_gpwuid() */
5378
5379 PP(pp_gpwent)
5380 {
5381 #ifdef HAS_PASSWD
5382     dSP;
5383     I32 which = PL_op->op_type;
5384     SV *sv;
5385     struct passwd *pwent  = NULL;
5386     /*
5387      * We currently support only the SysV getsp* shadow password interface.
5388      * The interface is declared in <shadow.h> and often one needs to link
5389      * with -lsecurity or some such.
5390      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5391      * (and SCO?)
5392      *
5393      * AIX getpwnam() is clever enough to return the encrypted password
5394      * only if the caller (euid?) is root.
5395      *
5396      * There are at least three other shadow password APIs.  Many platforms
5397      * seem to contain more than one interface for accessing the shadow
5398      * password databases, possibly for compatibility reasons.
5399      * The getsp*() is by far he simplest one, the other two interfaces
5400      * are much more complicated, but also very similar to each other.
5401      *
5402      * <sys/types.h>
5403      * <sys/security.h>
5404      * <prot.h>
5405      * struct pr_passwd *getprpw*();
5406      * The password is in
5407      * char getprpw*(...).ufld.fd_encrypt[]
5408      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5409      *
5410      * <sys/types.h>
5411      * <sys/security.h>
5412      * <prot.h>
5413      * struct es_passwd *getespw*();
5414      * The password is in
5415      * char *(getespw*(...).ufld.fd_encrypt)
5416      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5417      *
5418      * <userpw.h> (AIX)
5419      * struct userpw *getuserpw();
5420      * The password is in
5421      * char *(getuserpw(...)).spw_upw_passwd
5422      * (but the de facto standard getpwnam() should work okay)
5423      *
5424      * Mention I_PROT here so that Configure probes for it.
5425      *
5426      * In HP-UX for getprpw*() the manual page claims that one should include
5427      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5428      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5429      * and pp_sys.c already includes <shadow.h> if there is such.
5430      *
5431      * Note that <sys/security.h> is already probed for, but currently
5432      * it is only included in special cases.
5433      *
5434      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5435      * be preferred interface, even though also the getprpw*() interface
5436      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5437      * One also needs to call set_auth_parameters() in main() before
5438      * doing anything else, whether one is using getespw*() or getprpw*().
5439      *
5440      * Note that accessing the shadow databases can be magnitudes
5441      * slower than accessing the standard databases.
5442      *
5443      * --jhi
5444      */
5445
5446 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5447     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5448      * the pw_comment is left uninitialized. */
5449     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5450 #   endif
5451
5452     switch (which) {
5453     case OP_GPWNAM:
5454       {
5455         const char* const name = POPpbytex;
5456         pwent  = getpwnam(name);
5457       }
5458       break;
5459     case OP_GPWUID:
5460       {
5461         Uid_t uid = POPi;
5462         pwent = getpwuid(uid);
5463       }
5464         break;
5465     case OP_GPWENT:
5466 #   ifdef HAS_GETPWENT
5467         pwent  = getpwent();
5468 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5469         if (pwent) pwent = getpwnam(pwent->pw_name);
5470 #endif
5471 #   else
5472         DIE(aTHX_ PL_no_func, "getpwent");
5473 #   endif
5474         break;
5475     }
5476
5477     EXTEND(SP, 10);
5478     if (GIMME_V != G_ARRAY) {
5479         PUSHs(sv = sv_newmortal());
5480         if (pwent) {
5481             if (which == OP_GPWNAM)
5482                 sv_setuid(sv, pwent->pw_uid);
5483             else
5484                 sv_setpv(sv, pwent->pw_name);
5485         }
5486         RETURN;
5487     }
5488
5489     if (pwent) {
5490         mPUSHs(newSVpv(pwent->pw_name, 0));
5491
5492         sv = newSViv(0);
5493         mPUSHs(sv);
5494         /* If we have getspnam(), we try to dig up the shadow
5495          * password.  If we are underprivileged, the shadow
5496          * interface will set the errno to EACCES or similar,
5497          * and return a null pointer.  If this happens, we will
5498          * use the dummy password (usually "*" or "x") from the
5499          * standard password database.
5500          *
5501          * In theory we could skip the shadow call completely
5502          * if euid != 0 but in practice we cannot know which
5503          * security measures are guarding the shadow databases
5504          * on a random platform.
5505          *
5506          * Resist the urge to use additional shadow interfaces.
5507          * Divert the urge to writing an extension instead.
5508          *
5509          * --jhi */
5510         /* Some AIX setups falsely(?) detect some getspnam(), which
5511          * has a different API than the Solaris/IRIX one. */
5512 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5513         {
5514             dSAVE_ERRNO;
5515             const struct spwd * const spwent = getspnam(pwent->pw_name);
5516                           /* Save and restore errno so that
5517                            * underprivileged attempts seem
5518                            * to have never made the unsuccessful
5519                            * attempt to retrieve the shadow password. */
5520             RESTORE_ERRNO;
5521             if (spwent && spwent->sp_pwdp)
5522                 sv_setpv(sv, spwent->sp_pwdp);
5523         }
5524 #   endif
5525 #   ifdef PWPASSWD
5526         if (!SvPOK(sv)) /* Use the standard password, then. */
5527             sv_setpv(sv, pwent->pw_passwd);
5528 #   endif
5529
5530         /* passwd is tainted because user himself can diddle with it.
5531          * admittedly not much and in a very limited way, but nevertheless. */
5532         SvTAINTED_on(sv);
5533
5534         sv_setuid(PUSHmortal, pwent->pw_uid);
5535         sv_setgid(PUSHmortal, pwent->pw_gid);
5536
5537         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5538          * because of the poor interface of the Perl getpw*(),
5539          * not because there's some standard/convention saying so.
5540          * A better interface would have been to return a hash,
5541          * but we are accursed by our history, alas. --jhi.  */
5542 #   ifdef PWCHANGE
5543         mPUSHi(pwent->pw_change);
5544 #   elif defined(PWQUOTA)
5545         mPUSHi(pwent->pw_quota);
5546 #   elif defined(PWAGE)
5547         mPUSHs(newSVpv(pwent->pw_age, 0));
5548 #   else
5549         /* I think that you can never get this compiled, but just in case.  */
5550         PUSHs(sv_mortalcopy(&PL_sv_no));
5551 #   endif
5552
5553         /* pw_class and pw_comment are mutually exclusive--.
5554          * see the above note for pw_change, pw_quota, and pw_age. */
5555 #   ifdef PWCLASS
5556         mPUSHs(newSVpv(pwent->pw_class, 0));
5557 #   elif defined(PWCOMMENT)
5558         mPUSHs(newSVpv(pwent->pw_comment, 0));
5559 #   else
5560         /* I think that you can never get this compiled, but just in case.  */
5561         PUSHs(sv_mortalcopy(&PL_sv_no));
5562 #   endif
5563
5564 #   ifdef PWGECOS
5565         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5566 #   else
5567         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5568 #   endif
5569         /* pw_gecos is tainted because user himself can diddle with it. */
5570         SvTAINTED_on(sv);
5571
5572         mPUSHs(newSVpv(pwent->pw_dir, 0));
5573
5574         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5575         /* pw_shell is tainted because user himself can diddle with it. */
5576         SvTAINTED_on(sv);
5577
5578 #   ifdef PWEXPIRE
5579         mPUSHi(pwent->pw_expire);
5580 #   endif
5581     }
5582     RETURN;
5583 #else
5584     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5585 #endif
5586 }
5587
5588
5589 /* also used for: pp_ggrgid() pp_ggrnam() */
5590
5591 PP(pp_ggrent)
5592 {
5593 #ifdef HAS_GROUP
5594     dSP;
5595     const I32 which = PL_op->op_type;
5596     const struct group *grent;
5597
5598     if (which == OP_GGRNAM) {
5599         const char* const name = POPpbytex;
5600         grent = (const struct group *)getgrnam(name);
5601     }
5602     else if (which == OP_GGRGID) {
5603 #if Gid_t_sign == 1
5604         const Gid_t gid = POPu;
5605 #elif Gid_t_sign == -1
5606         const Gid_t gid = POPi;
5607 #else
5608 #  error "Unexpected Gid_t_sign"
5609 #endif
5610         grent = (const struct group *)getgrgid(gid);
5611     }
5612     else
5613 #ifdef HAS_GETGRENT
5614         grent = (struct group *)getgrent();
5615 #else
5616         DIE(aTHX_ PL_no_func, "getgrent");
5617 #endif
5618
5619     EXTEND(SP, 4);
5620     if (GIMME_V != G_ARRAY) {
5621         SV * const sv = sv_newmortal();
5622
5623         PUSHs(sv);
5624         if (grent) {
5625             if (which == OP_GGRNAM)
5626                 sv_setgid(sv, grent->gr_gid);
5627             else
5628                 sv_setpv(sv, grent->gr_name);
5629         }
5630         RETURN;
5631     }
5632
5633     if (grent) {
5634         mPUSHs(newSVpv(grent->gr_name, 0));
5635
5636 #ifdef GRPASSWD
5637         mPUSHs(newSVpv(grent->gr_passwd, 0));
5638 #else
5639         PUSHs(sv_mortalcopy(&PL_sv_no));
5640 #endif
5641
5642         sv_setgid(PUSHmortal, grent->gr_gid);
5643
5644 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5645         /* In UNICOS/mk (_CRAYMPP) the multithreading
5646          * versions (getgrnam_r, getgrgid_r)
5647          * seem to return an illegal pointer
5648          * as the group members list, gr_mem.
5649          * getgrent() doesn't even have a _r version
5650          * but the gr_mem is poisonous anyway.
5651          * So yes, you cannot get the list of group
5652          * members if building multithreaded in UNICOS/mk. */
5653         PUSHs(space_join_names_mortal(grent->gr_mem));
5654 #endif
5655     }
5656
5657     RETURN;
5658 #else
5659     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5660 #endif
5661 }
5662
5663 PP(pp_getlogin)
5664 {
5665 #ifdef HAS_GETLOGIN
5666     dSP; dTARGET;
5667     char *tmps;
5668     EXTEND(SP, 1);
5669     if (!(tmps = PerlProc_getlogin()))
5670         RETPUSHUNDEF;
5671     sv_setpv_mg(TARG, tmps);
5672     PUSHs(TARG);
5673     RETURN;
5674 #else
5675     DIE(aTHX_ PL_no_func, "getlogin");
5676 #endif
5677 }
5678
5679 /* Miscellaneous. */
5680
5681 PP(pp_syscall)
5682 {
5683 #ifdef HAS_SYSCALL
5684     dSP; dMARK; dORIGMARK; dTARGET;
5685     I32 items = SP - MARK;
5686     unsigned long a[20];
5687     I32 i = 0;
5688     IV retval = -1;
5689
5690     if (TAINTING_get) {
5691         while (++MARK <= SP) {
5692             if (SvTAINTED(*MARK)) {
5693                 TAINT;
5694                 break;
5695             }
5696         }
5697         MARK = ORIGMARK;
5698         TAINT_PROPER("syscall");
5699     }
5700
5701     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5702      * or where sizeof(long) != sizeof(char*).  But such machines will
5703      * not likely have syscall implemented either, so who cares?
5704      */
5705     while (++MARK <= SP) {
5706         if (SvNIOK(*MARK) || !i)
5707             a[i++] = SvIV(*MARK);
5708         else if (*MARK == &PL_sv_undef)
5709             a[i++] = 0;
5710         else
5711             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5712         if (i > 15)
5713             break;
5714     }
5715     switch (items) {
5716     default:
5717         DIE(aTHX_ "Too many args to syscall");
5718     case 0:
5719         DIE(aTHX_ "Too few args to syscall");
5720     case 1:
5721         retval = syscall(a[0]);
5722         break;
5723     case 2:
5724         retval = syscall(a[0],a[1]);
5725         break;
5726     case 3:
5727         retval = syscall(a[0],a[1],a[2]);
5728         break;
5729     case 4:
5730         retval = syscall(a[0],a[1],a[2],a[3]);
5731         break;
5732     case 5:
5733         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5734         break;
5735     case 6:
5736         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5737         break;
5738     case 7:
5739         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5740         break;
5741     case 8:
5742         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5743         break;
5744     }
5745     SP = ORIGMARK;
5746     PUSHi(retval);
5747     RETURN;
5748 #else
5749     DIE(aTHX_ PL_no_func, "syscall");
5750 #endif
5751 }
5752
5753 #ifdef FCNTL_EMULATE_FLOCK
5754
5755 /*  XXX Emulate flock() with fcntl().
5756     What's really needed is a good file locking module.
5757 */
5758
5759 static int
5760 fcntl_emulate_flock(int fd, int operation)
5761 {
5762     int res;
5763     struct flock flock;
5764
5765     switch (operation & ~LOCK_NB) {
5766     case LOCK_SH:
5767         flock.l_type = F_RDLCK;
5768         break;
5769     case LOCK_EX:
5770         flock.l_type = F_WRLCK;
5771         break;
5772     case LOCK_UN:
5773         flock.l_type = F_UNLCK;
5774         break;
5775     default:
5776         errno = EINVAL;
5777         return -1;
5778     }
5779     flock.l_whence = SEEK_SET;
5780     flock.l_start = flock.l_len = (Off_t)0;
5781
5782     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5783     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5784         errno = EWOULDBLOCK;
5785     return res;
5786 }
5787
5788 #endif /* FCNTL_EMULATE_FLOCK */
5789
5790 #ifdef LOCKF_EMULATE_FLOCK
5791
5792 /*  XXX Emulate flock() with lockf().  This is just to increase
5793     portability of scripts.  The calls are not completely
5794     interchangeable.  What's really needed is a good file
5795     locking module.
5796 */
5797
5798 /*  The lockf() constants might have been defined in <unistd.h>.
5799     Unfortunately, <unistd.h> causes troubles on some mixed
5800     (BSD/POSIX) systems, such as SunOS 4.1.3.
5801
5802    Further, the lockf() constants aren't POSIX, so they might not be
5803    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5804    just stick in the SVID values and be done with it.  Sigh.
5805 */
5806
5807 # ifndef F_ULOCK
5808 #  define F_ULOCK       0       /* Unlock a previously locked region */
5809 # endif
5810 # ifndef F_LOCK
5811 #  define F_LOCK        1       /* Lock a region for exclusive use */
5812 # endif
5813 # ifndef F_TLOCK
5814 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5815 # endif
5816 # ifndef F_TEST
5817 #  define F_TEST        3       /* Test a region for other processes locks */
5818 # endif
5819
5820 static int
5821 lockf_emulate_flock(int fd, int operation)
5822 {
5823     int i;
5824     Off_t pos;
5825     dSAVE_ERRNO;
5826
5827     /* flock locks entire file so for lockf we need to do the same      */
5828     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5829     if (pos > 0)        /* is seekable and needs to be repositioned     */
5830         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5831             pos = -1;   /* seek failed, so don't seek back afterwards   */
5832     RESTORE_ERRNO;
5833
5834     switch (operation) {
5835
5836         /* LOCK_SH - get a shared lock */
5837         case LOCK_SH:
5838         /* LOCK_EX - get an exclusive lock */
5839         case LOCK_EX:
5840             i = lockf (fd, F_LOCK, 0);
5841             break;
5842
5843         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5844         case LOCK_SH|LOCK_NB:
5845         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5846         case LOCK_EX|LOCK_NB:
5847             i = lockf (fd, F_TLOCK, 0);
5848             if (i == -1)
5849                 if ((errno == EAGAIN) || (errno == EACCES))
5850                     errno = EWOULDBLOCK;
5851             break;
5852
5853         /* LOCK_UN - unlock (non-blocking is a no-op) */
5854         case LOCK_UN:
5855         case LOCK_UN|LOCK_NB:
5856             i = lockf (fd, F_ULOCK, 0);
5857             break;
5858
5859         /* Default - can't decipher operation */
5860         default:
5861             i = -1;
5862             errno = EINVAL;
5863             break;
5864     }
5865
5866     if (pos > 0)      /* need to restore position of the handle */
5867         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5868
5869     return (i);
5870 }
5871
5872 #endif /* LOCKF_EMULATE_FLOCK */
5873
5874 /*
5875  * ex: set ts=8 sts=4 sw=4 et:
5876  */