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