pp_sys.c

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