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