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