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