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