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