pp_sys.c

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