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