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