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