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