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