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