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