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