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