pp_sys.c

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