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 =
3671 #ifdef HAS_SYS_ERRLIST
3672                     sys_errlist[e]
3673 #else
3674                     strerror(e)
3675 #endif
3676                     ;
3677                 if (!errmsg)
3678                     break;
3679                 if (instr(s, errmsg)) {
3680                     SETERRNO(e,0);
3681                     return 0;
3682                 }
3683             }
3684             SETERRNO(0,0);
3685 #ifndef EACCES
3686 #define EACCES EPERM
3687 #endif
3688             if (instr(s, "cannot make"))
3689                 SETERRNO(EEXIST,RMS_FEX);
3690             else if (instr(s, "existing file"))
3691                 SETERRNO(EEXIST,RMS_FEX);
3692             else if (instr(s, "ile exists"))
3693                 SETERRNO(EEXIST,RMS_FEX);
3694             else if (instr(s, "non-exist"))
3695                 SETERRNO(ENOENT,RMS_FNF);
3696             else if (instr(s, "does not exist"))
3697                 SETERRNO(ENOENT,RMS_FNF);
3698             else if (instr(s, "not empty"))
3699                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3700             else if (instr(s, "cannot access"))
3701                 SETERRNO(EACCES,RMS_PRV);
3702             else
3703                 SETERRNO(EPERM,RMS_PRV);
3704             return 0;
3705         }
3706         else {  /* some mkdirs return no failure indication */
3707             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3708             if (PL_op->op_type == OP_RMDIR)
3709                 anum = !anum;
3710             if (anum)
3711                 SETERRNO(0,0);
3712             else
3713                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3714         }
3715         return anum;
3716     }
3717     else
3718         return 0;
3719 }
3720 #endif
3721
3722 /* This macro removes trailing slashes from a directory name.
3723  * Different operating and file systems take differently to
3724  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3725  * any number of trailing slashes should be allowed.
3726  * Thusly we snip them away so that even non-conforming
3727  * systems are happy.
3728  * We should probably do this "filtering" for all
3729  * the functions that expect (potentially) directory names:
3730  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3731  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3732
3733 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3734     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3735         do { \
3736             (len)--; \
3737         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3738         (tmps) = savepvn((tmps), (len)); \
3739         (copy) = TRUE; \
3740     }
3741
3742 PP(pp_mkdir)
3743 {
3744     dVAR; dSP; dTARGET;
3745     STRLEN len;
3746     const char *tmps;
3747     bool copy = FALSE;
3748     const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3749
3750     TRIMSLASHES(tmps,len,copy);
3751
3752     TAINT_PROPER("mkdir");
3753 #ifdef HAS_MKDIR
3754     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3755 #else
3756     {
3757     int oldumask;
3758     SETi( dooneliner("mkdir", tmps) );
3759     oldumask = PerlLIO_umask(0);
3760     PerlLIO_umask(oldumask);
3761     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3762     }
3763 #endif
3764     if (copy)
3765         Safefree(tmps);
3766     RETURN;
3767 }
3768
3769 PP(pp_rmdir)
3770 {
3771     dVAR; dSP; dTARGET;
3772     STRLEN len;
3773     const char *tmps;
3774     bool copy = FALSE;
3775
3776     TRIMSLASHES(tmps,len,copy);
3777     TAINT_PROPER("rmdir");
3778 #ifdef HAS_RMDIR
3779     SETi( PerlDir_rmdir(tmps) >= 0 );
3780 #else
3781     SETi( dooneliner("rmdir", tmps) );
3782 #endif
3783     if (copy)
3784         Safefree(tmps);
3785     RETURN;
3786 }
3787
3788 /* Directory calls. */
3789
3790 PP(pp_open_dir)
3791 {
3792 #if defined(Direntry_t) && defined(HAS_READDIR)
3793     dVAR; dSP;
3794     const char * const dirname = POPpconstx;
3795     GV * const gv = MUTABLE_GV(POPs);
3796     IO * const io = GvIOn(gv);
3797
3798     if (!io)
3799         goto nope;
3800
3801     if ((IoIFP(io) || IoOFP(io)))
3802         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3803                          "Opening filehandle %"HEKf" also as a directory",
3804                              HEKfARG(GvENAME_HEK(gv)) );
3805     if (IoDIRP(io))
3806         PerlDir_close(IoDIRP(io));
3807     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3808         goto nope;
3809
3810     RETPUSHYES;
3811 nope:
3812     if (!errno)
3813         SETERRNO(EBADF,RMS_DIR);
3814     RETPUSHUNDEF;
3815 #else
3816     DIE(aTHX_ PL_no_dir_func, "opendir");
3817 #endif
3818 }
3819
3820 PP(pp_readdir)
3821 {
3822 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3823     DIE(aTHX_ PL_no_dir_func, "readdir");
3824 #else
3825 #if !defined(I_DIRENT) && !defined(VMS)
3826     Direntry_t *readdir (DIR *);
3827 #endif
3828     dVAR;
3829     dSP;
3830
3831     SV *sv;
3832     const I32 gimme = GIMME;
3833     GV * const gv = MUTABLE_GV(POPs);
3834     const Direntry_t *dp;
3835     IO * const io = GvIOn(gv);
3836
3837     if (!io || !IoDIRP(io)) {
3838         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3839                        "readdir() attempted on invalid dirhandle %"HEKf,
3840                             HEKfARG(GvENAME_HEK(gv)));
3841         goto nope;
3842     }
3843
3844     do {
3845         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3846         if (!dp)
3847             break;
3848 #ifdef DIRNAMLEN
3849         sv = newSVpvn(dp->d_name, dp->d_namlen);
3850 #else
3851         sv = newSVpv(dp->d_name, 0);
3852 #endif
3853 #ifndef INCOMPLETE_TAINTS
3854         if (!(IoFLAGS(io) & IOf_UNTAINT))
3855             SvTAINTED_on(sv);
3856 #endif
3857         mXPUSHs(sv);
3858     } while (gimme == G_ARRAY);
3859
3860     if (!dp && gimme != G_ARRAY)
3861         goto nope;
3862
3863     RETURN;
3864
3865 nope:
3866     if (!errno)
3867         SETERRNO(EBADF,RMS_ISI);
3868     if (GIMME == G_ARRAY)
3869         RETURN;
3870     else
3871         RETPUSHUNDEF;
3872 #endif
3873 }
3874
3875 PP(pp_telldir)
3876 {
3877 #if defined(HAS_TELLDIR) || defined(telldir)
3878     dVAR; dSP; dTARGET;
3879  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3880  /* XXX netbsd still seemed to.
3881     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3882     --JHI 1999-Feb-02 */
3883 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3884     long telldir (DIR *);
3885 # endif
3886     GV * const gv = MUTABLE_GV(POPs);
3887     IO * const io = GvIOn(gv);
3888
3889     if (!io || !IoDIRP(io)) {
3890         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3891                        "telldir() attempted on invalid dirhandle %"HEKf,
3892                             HEKfARG(GvENAME_HEK(gv)));
3893         goto nope;
3894     }
3895
3896     PUSHi( PerlDir_tell(IoDIRP(io)) );
3897     RETURN;
3898 nope:
3899     if (!errno)
3900         SETERRNO(EBADF,RMS_ISI);
3901     RETPUSHUNDEF;
3902 #else
3903     DIE(aTHX_ PL_no_dir_func, "telldir");
3904 #endif
3905 }
3906
3907 PP(pp_seekdir)
3908 {
3909 #if defined(HAS_SEEKDIR) || defined(seekdir)
3910     dVAR; dSP;
3911     const long along = POPl;
3912     GV * const gv = MUTABLE_GV(POPs);
3913     IO * const io = GvIOn(gv);
3914
3915     if (!io || !IoDIRP(io)) {
3916         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3917                        "seekdir() attempted on invalid dirhandle %"HEKf,
3918                                 HEKfARG(GvENAME_HEK(gv)));
3919         goto nope;
3920     }
3921     (void)PerlDir_seek(IoDIRP(io), along);
3922
3923     RETPUSHYES;
3924 nope:
3925     if (!errno)
3926         SETERRNO(EBADF,RMS_ISI);
3927     RETPUSHUNDEF;
3928 #else
3929     DIE(aTHX_ PL_no_dir_func, "seekdir");
3930 #endif
3931 }
3932
3933 PP(pp_rewinddir)
3934 {
3935 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3936     dVAR; dSP;
3937     GV * const gv = MUTABLE_GV(POPs);
3938     IO * const io = GvIOn(gv);
3939
3940     if (!io || !IoDIRP(io)) {
3941         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3942                        "rewinddir() attempted on invalid dirhandle %"HEKf,
3943                                 HEKfARG(GvENAME_HEK(gv)));
3944         goto nope;
3945     }
3946     (void)PerlDir_rewind(IoDIRP(io));
3947     RETPUSHYES;
3948 nope:
3949     if (!errno)
3950         SETERRNO(EBADF,RMS_ISI);
3951     RETPUSHUNDEF;
3952 #else
3953     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3954 #endif
3955 }
3956
3957 PP(pp_closedir)
3958 {
3959 #if defined(Direntry_t) && defined(HAS_READDIR)
3960     dVAR; dSP;
3961     GV * const gv = MUTABLE_GV(POPs);
3962     IO * const io = GvIOn(gv);
3963
3964     if (!io || !IoDIRP(io)) {
3965         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3966                        "closedir() attempted on invalid dirhandle %"HEKf,
3967                                 HEKfARG(GvENAME_HEK(gv)));
3968         goto nope;
3969     }
3970 #ifdef VOID_CLOSEDIR
3971     PerlDir_close(IoDIRP(io));
3972 #else
3973     if (PerlDir_close(IoDIRP(io)) < 0) {
3974         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3975         goto nope;
3976     }
3977 #endif
3978     IoDIRP(io) = 0;
3979
3980     RETPUSHYES;
3981 nope:
3982     if (!errno)
3983         SETERRNO(EBADF,RMS_IFI);
3984     RETPUSHUNDEF;
3985 #else
3986     DIE(aTHX_ PL_no_dir_func, "closedir");
3987 #endif
3988 }
3989
3990 /* Process control. */
3991
3992 PP(pp_fork)
3993 {
3994 #ifdef HAS_FORK
3995     dVAR; dSP; dTARGET;
3996     Pid_t childpid;
3997 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
3998     sigset_t oldmask, newmask;
3999 #endif
4000
4001     EXTEND(SP, 1);
4002     PERL_FLUSHALL_FOR_CHILD;
4003 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4004     sigfillset(&newmask);
4005     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4006 #endif
4007     childpid = PerlProc_fork();
4008     if (childpid == 0) {
4009         int sig;
4010         PL_sig_pending = 0;
4011         if (PL_psig_pend)
4012             for (sig = 1; sig < SIG_SIZE; sig++)
4013                 PL_psig_pend[sig] = 0;
4014     }
4015 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4016     {
4017         dSAVE_ERRNO;
4018         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4019         RESTORE_ERRNO;
4020     }
4021 #endif
4022     if (childpid < 0)
4023         RETPUSHUNDEF;
4024     if (!childpid) {
4025 #ifdef PERL_USES_PL_PIDSTATUS
4026         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4027 #endif
4028     }
4029     PUSHi(childpid);
4030     RETURN;
4031 #else
4032 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4033     dSP; dTARGET;
4034     Pid_t childpid;
4035
4036     EXTEND(SP, 1);
4037     PERL_FLUSHALL_FOR_CHILD;
4038     childpid = PerlProc_fork();
4039     if (childpid == -1)
4040         RETPUSHUNDEF;
4041     PUSHi(childpid);
4042     RETURN;
4043 #  else
4044     DIE(aTHX_ PL_no_func, "fork");
4045 #  endif
4046 #endif
4047 }
4048
4049 PP(pp_wait)
4050 {
4051 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4052     dVAR; dSP; dTARGET;
4053     Pid_t childpid;
4054     int argflags;
4055
4056     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4057         childpid = wait4pid(-1, &argflags, 0);
4058     else {
4059         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4060                errno == EINTR) {
4061           PERL_ASYNC_CHECK();
4062         }
4063     }
4064 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4065     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4066     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4067 #  else
4068     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4069 #  endif
4070     XPUSHi(childpid);
4071     RETURN;
4072 #else
4073     DIE(aTHX_ PL_no_func, "wait");
4074 #endif
4075 }
4076
4077 PP(pp_waitpid)
4078 {
4079 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4080     dVAR; dSP; dTARGET;
4081     const int optype = POPi;
4082     const Pid_t pid = TOPi;
4083     Pid_t result;
4084     int argflags;
4085
4086     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4087         result = wait4pid(pid, &argflags, optype);
4088     else {
4089         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4090                errno == EINTR) {
4091           PERL_ASYNC_CHECK();
4092         }
4093     }
4094 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4095     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4096     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4097 #  else
4098     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4099 #  endif
4100     SETi(result);
4101     RETURN;
4102 #else
4103     DIE(aTHX_ PL_no_func, "waitpid");
4104 #endif
4105 }
4106
4107 PP(pp_system)
4108 {
4109     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4110 #if defined(__LIBCATAMOUNT__)
4111     PL_statusvalue = -1;
4112     SP = ORIGMARK;
4113     XPUSHi(-1);
4114 #else
4115     I32 value;
4116     int result;
4117
4118     if (TAINTING_get) {
4119         TAINT_ENV();
4120         while (++MARK <= SP) {
4121             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4122             if (TAINT_get)
4123                 break;
4124         }
4125         MARK = ORIGMARK;
4126         TAINT_PROPER("system");
4127     }
4128     PERL_FLUSHALL_FOR_CHILD;
4129 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4130     {
4131         Pid_t childpid;
4132         int pp[2];
4133         I32 did_pipes = 0;
4134 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4135         sigset_t newset, oldset;
4136 #endif
4137
4138         if (PerlProc_pipe(pp) >= 0)
4139             did_pipes = 1;
4140 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4141         sigemptyset(&newset);
4142         sigaddset(&newset, SIGCHLD);
4143         sigprocmask(SIG_BLOCK, &newset, &oldset);
4144 #endif
4145         while ((childpid = PerlProc_fork()) == -1) {
4146             if (errno != EAGAIN) {
4147                 value = -1;
4148                 SP = ORIGMARK;
4149                 XPUSHi(value);
4150                 if (did_pipes) {
4151                     PerlLIO_close(pp[0]);
4152                     PerlLIO_close(pp[1]);
4153                 }
4154 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4155                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4156 #endif
4157                 RETURN;
4158             }
4159             sleep(5);
4160         }
4161         if (childpid > 0) {
4162             Sigsave_t ihand,qhand; /* place to save signals during system() */
4163             int status;
4164
4165             if (did_pipes)
4166                 PerlLIO_close(pp[1]);
4167 #ifndef PERL_MICRO
4168             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4169             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4170 #endif
4171             do {
4172                 result = wait4pid(childpid, &status, 0);
4173             } while (result == -1 && errno == EINTR);
4174 #ifndef PERL_MICRO
4175 #ifdef HAS_SIGPROCMASK
4176             sigprocmask(SIG_SETMASK, &oldset, NULL);
4177 #endif
4178             (void)rsignal_restore(SIGINT, &ihand);
4179             (void)rsignal_restore(SIGQUIT, &qhand);
4180 #endif
4181             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4182             do_execfree();      /* free any memory child malloced on fork */
4183             SP = ORIGMARK;
4184             if (did_pipes) {
4185                 int errkid;
4186                 unsigned n = 0;
4187                 SSize_t n1;
4188
4189                 while (n < sizeof(int)) {
4190                     n1 = PerlLIO_read(pp[0],
4191                                       (void*)(((char*)&errkid)+n),
4192                                       (sizeof(int)) - n);
4193                     if (n1 <= 0)
4194                         break;
4195                     n += n1;
4196                 }
4197                 PerlLIO_close(pp[0]);
4198                 if (n) {                        /* Error */
4199                     if (n != sizeof(int))
4200                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4201                     errno = errkid;             /* Propagate errno from kid */
4202                     STATUS_NATIVE_CHILD_SET(-1);
4203                 }
4204             }
4205             XPUSHi(STATUS_CURRENT);
4206             RETURN;
4207         }
4208 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4209         sigprocmask(SIG_SETMASK, &oldset, NULL);
4210 #endif
4211         if (did_pipes) {
4212             PerlLIO_close(pp[0]);
4213 #if defined(HAS_FCNTL) && defined(F_SETFD)
4214             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4215 #endif
4216         }
4217         if (PL_op->op_flags & OPf_STACKED) {
4218             SV * const really = *++MARK;
4219             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4220         }
4221         else if (SP - MARK != 1)
4222             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4223         else {
4224             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4225         }
4226         PerlProc__exit(-1);
4227     }
4228 #else /* ! FORK or VMS or OS/2 */
4229     PL_statusvalue = 0;
4230     result = 0;
4231     if (PL_op->op_flags & OPf_STACKED) {
4232         SV * const really = *++MARK;
4233 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4234         value = (I32)do_aspawn(really, MARK, SP);
4235 #  else
4236         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4237 #  endif
4238     }
4239     else if (SP - MARK != 1) {
4240 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4241         value = (I32)do_aspawn(NULL, MARK, SP);
4242 #  else
4243         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4244 #  endif
4245     }
4246     else {
4247         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4248     }
4249     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4250         result = 1;
4251     STATUS_NATIVE_CHILD_SET(value);
4252     do_execfree();
4253     SP = ORIGMARK;
4254     XPUSHi(result ? value : STATUS_CURRENT);
4255 #endif /* !FORK or VMS or OS/2 */
4256 #endif
4257     RETURN;
4258 }
4259
4260 PP(pp_exec)
4261 {
4262     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4263     I32 value;
4264
4265     if (TAINTING_get) {
4266         TAINT_ENV();
4267         while (++MARK <= SP) {
4268             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4269             if (TAINT_get)
4270                 break;
4271         }
4272         MARK = ORIGMARK;
4273         TAINT_PROPER("exec");
4274     }
4275     PERL_FLUSHALL_FOR_CHILD;
4276     if (PL_op->op_flags & OPf_STACKED) {
4277         SV * const really = *++MARK;
4278         value = (I32)do_aexec(really, MARK, SP);
4279     }
4280     else if (SP - MARK != 1)
4281 #ifdef VMS
4282         value = (I32)vms_do_aexec(NULL, MARK, SP);
4283 #else
4284         value = (I32)do_aexec(NULL, MARK, SP);
4285 #endif
4286     else {
4287 #ifdef VMS
4288         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4289 #else
4290         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4291 #endif
4292     }
4293
4294     SP = ORIGMARK;
4295     XPUSHi(value);
4296     RETURN;
4297 }
4298
4299 PP(pp_getppid)
4300 {
4301 #ifdef HAS_GETPPID
4302     dVAR; dSP; dTARGET;
4303     XPUSHi( getppid() );
4304     RETURN;
4305 #else
4306     DIE(aTHX_ PL_no_func, "getppid");
4307 #endif
4308 }
4309
4310 PP(pp_getpgrp)
4311 {
4312 #ifdef HAS_GETPGRP
4313     dVAR; dSP; dTARGET;
4314     Pid_t pgrp;
4315     const Pid_t pid =
4316         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4317
4318 #ifdef BSD_GETPGRP
4319     pgrp = (I32)BSD_GETPGRP(pid);
4320 #else
4321     if (pid != 0 && pid != PerlProc_getpid())
4322         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4323     pgrp = getpgrp();
4324 #endif
4325     XPUSHi(pgrp);
4326     RETURN;
4327 #else
4328     DIE(aTHX_ PL_no_func, "getpgrp()");
4329 #endif
4330 }
4331
4332 PP(pp_setpgrp)
4333 {
4334 #ifdef HAS_SETPGRP
4335     dVAR; dSP; dTARGET;
4336     Pid_t pgrp;
4337     Pid_t pid;
4338     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4339     if (MAXARG > 0) pid = TOPs && TOPi;
4340     else {
4341         pid = 0;
4342         XPUSHi(-1);
4343     }
4344
4345     TAINT_PROPER("setpgrp");
4346 #ifdef BSD_SETPGRP
4347     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4348 #else
4349     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4350         || (pid != 0 && pid != PerlProc_getpid()))
4351     {
4352         DIE(aTHX_ "setpgrp can't take arguments");
4353     }
4354     SETi( setpgrp() >= 0 );
4355 #endif /* USE_BSDPGRP */
4356     RETURN;
4357 #else
4358     DIE(aTHX_ PL_no_func, "setpgrp()");
4359 #endif
4360 }
4361
4362 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4363 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4364 #else
4365 #  define PRIORITY_WHICH_T(which) which
4366 #endif
4367
4368 PP(pp_getpriority)
4369 {
4370 #ifdef HAS_GETPRIORITY
4371     dVAR; dSP; dTARGET;
4372     const int who = POPi;
4373     const int which = TOPi;
4374     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4375     RETURN;
4376 #else
4377     DIE(aTHX_ PL_no_func, "getpriority()");
4378 #endif
4379 }
4380
4381 PP(pp_setpriority)
4382 {
4383 #ifdef HAS_SETPRIORITY
4384     dVAR; dSP; dTARGET;
4385     const int niceval = POPi;
4386     const int who = POPi;
4387     const int which = TOPi;
4388     TAINT_PROPER("setpriority");
4389     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4390     RETURN;
4391 #else
4392     DIE(aTHX_ PL_no_func, "setpriority()");
4393 #endif
4394 }
4395
4396 #undef PRIORITY_WHICH_T
4397
4398 /* Time calls. */
4399
4400 PP(pp_time)
4401 {
4402     dVAR; dSP; dTARGET;
4403 #ifdef BIG_TIME
4404     XPUSHn( time(NULL) );
4405 #else
4406     XPUSHi( time(NULL) );
4407 #endif
4408     RETURN;
4409 }
4410
4411 PP(pp_tms)
4412 {
4413 #ifdef HAS_TIMES
4414     dVAR;
4415     dSP;
4416     EXTEND(SP, 4);
4417 #ifndef VMS
4418     (void)PerlProc_times(&PL_timesbuf);
4419 #else
4420     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4421                                                    /* struct tms, though same data   */
4422                                                    /* is returned.                   */
4423 #endif
4424
4425     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4426     if (GIMME == G_ARRAY) {
4427         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4428         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4429         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4430     }
4431     RETURN;
4432 #else
4433 #   ifdef PERL_MICRO
4434     dSP;
4435     mPUSHn(0.0);
4436     EXTEND(SP, 4);
4437     if (GIMME == G_ARRAY) {
4438          mPUSHn(0.0);
4439          mPUSHn(0.0);
4440          mPUSHn(0.0);
4441     }
4442     RETURN;
4443 #   else
4444     DIE(aTHX_ "times not implemented");
4445 #   endif
4446 #endif /* HAS_TIMES */
4447 }
4448
4449 /* The 32 bit int year limits the times we can represent to these
4450    boundaries with a few days wiggle room to account for time zone
4451    offsets
4452 */
4453 /* Sat Jan  3 00:00:00 -2147481748 */
4454 #define TIME_LOWER_BOUND -67768100567755200.0
4455 /* Sun Dec 29 12:00:00  2147483647 */
4456 #define TIME_UPPER_BOUND  67767976233316800.0
4457
4458 PP(pp_gmtime)
4459 {
4460     dVAR;
4461     dSP;
4462     Time64_T when;
4463     struct TM tmbuf;
4464     struct TM *err;
4465     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4466     static const char * const dayname[] =
4467         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4468     static const char * const monname[] =
4469         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4470          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4471
4472     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4473         time_t now;
4474         (void)time(&now);
4475         when = (Time64_T)now;
4476     }
4477     else {
4478         NV input = Perl_floor(POPn);
4479         when = (Time64_T)input;
4480         if (when != input) {
4481             /* diag_listed_as: gmtime(%f) too large */
4482             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4483                            "%s(%.0" NVff ") too large", opname, input);
4484         }
4485     }
4486
4487     if ( TIME_LOWER_BOUND > when ) {
4488         /* diag_listed_as: gmtime(%f) too small */
4489         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4490                        "%s(%.0" NVff ") too small", opname, when);
4491         err = NULL;
4492     }
4493     else if( when > TIME_UPPER_BOUND ) {
4494         /* diag_listed_as: gmtime(%f) too small */
4495         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4496                        "%s(%.0" NVff ") too large", opname, when);
4497         err = NULL;
4498     }
4499     else {
4500         if (PL_op->op_type == OP_LOCALTIME)
4501             err = S_localtime64_r(&when, &tmbuf);
4502         else
4503             err = S_gmtime64_r(&when, &tmbuf);
4504     }
4505
4506     if (err == NULL) {
4507         /* XXX %lld broken for quads */
4508         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4509                        "%s(%.0" NVff ") failed", opname, when);
4510     }
4511
4512     if (GIMME != G_ARRAY) {     /* scalar context */
4513         SV *tsv;
4514         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4515         double year = (double)tmbuf.tm_year + 1900;
4516
4517         EXTEND(SP, 1);
4518         EXTEND_MORTAL(1);
4519         if (err == NULL)
4520             RETPUSHUNDEF;
4521
4522         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4523                             dayname[tmbuf.tm_wday],
4524                             monname[tmbuf.tm_mon],
4525                             tmbuf.tm_mday,
4526                             tmbuf.tm_hour,
4527                             tmbuf.tm_min,
4528                             tmbuf.tm_sec,
4529                             year);
4530         mPUSHs(tsv);
4531     }
4532     else {                      /* list context */
4533         if ( err == NULL )
4534             RETURN;
4535
4536         EXTEND(SP, 9);
4537         EXTEND_MORTAL(9);
4538         mPUSHi(tmbuf.tm_sec);
4539         mPUSHi(tmbuf.tm_min);
4540         mPUSHi(tmbuf.tm_hour);
4541         mPUSHi(tmbuf.tm_mday);
4542         mPUSHi(tmbuf.tm_mon);
4543         mPUSHn(tmbuf.tm_year);
4544         mPUSHi(tmbuf.tm_wday);
4545         mPUSHi(tmbuf.tm_yday);
4546         mPUSHi(tmbuf.tm_isdst);
4547     }
4548     RETURN;
4549 }
4550
4551 PP(pp_alarm)
4552 {
4553 #ifdef HAS_ALARM
4554     dVAR; dSP; dTARGET;
4555     int anum;
4556     anum = POPi;
4557     anum = alarm((unsigned int)anum);
4558     if (anum < 0)
4559         RETPUSHUNDEF;
4560     PUSHi(anum);
4561     RETURN;
4562 #else
4563     DIE(aTHX_ PL_no_func, "alarm");
4564 #endif
4565 }
4566
4567 PP(pp_sleep)
4568 {
4569     dVAR; dSP; dTARGET;
4570     I32 duration;
4571     Time_t lasttime;
4572     Time_t when;
4573
4574     (void)time(&lasttime);
4575     if (MAXARG < 1 || (!TOPs && !POPs))
4576         PerlProc_pause();
4577     else {
4578         duration = POPi;
4579         PerlProc_sleep((unsigned int)duration);
4580     }
4581     (void)time(&when);
4582     XPUSHi(when - lasttime);
4583     RETURN;
4584 }
4585
4586 /* Shared memory. */
4587 /* Merged with some message passing. */
4588
4589 PP(pp_shmwrite)
4590 {
4591 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4592     dVAR; dSP; dMARK; dTARGET;
4593     const int op_type = PL_op->op_type;
4594     I32 value;
4595
4596     switch (op_type) {
4597     case OP_MSGSND:
4598         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4599         break;
4600     case OP_MSGRCV:
4601         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4602         break;
4603     case OP_SEMOP:
4604         value = (I32)(do_semop(MARK, SP) >= 0);
4605         break;
4606     default:
4607         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4608         break;
4609     }
4610
4611     SP = MARK;
4612     PUSHi(value);
4613     RETURN;
4614 #else
4615     return Perl_pp_semget(aTHX);
4616 #endif
4617 }
4618
4619 /* Semaphores. */
4620
4621 PP(pp_semget)
4622 {
4623 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4624     dVAR; dSP; dMARK; dTARGET;
4625     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4626     SP = MARK;
4627     if (anum == -1)
4628         RETPUSHUNDEF;
4629     PUSHi(anum);
4630     RETURN;
4631 #else
4632     DIE(aTHX_ "System V IPC is not implemented on this machine");
4633 #endif
4634 }
4635
4636 PP(pp_semctl)
4637 {
4638 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4639     dVAR; dSP; dMARK; dTARGET;
4640     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4641     SP = MARK;
4642     if (anum == -1)
4643         RETSETUNDEF;
4644     if (anum != 0) {
4645         PUSHi(anum);
4646     }
4647     else {
4648         PUSHp(zero_but_true, ZBTLEN);
4649     }
4650     RETURN;
4651 #else
4652     return Perl_pp_semget(aTHX);
4653 #endif
4654 }
4655
4656 /* I can't const this further without getting warnings about the types of
4657    various arrays passed in from structures.  */
4658 static SV *
4659 S_space_join_names_mortal(pTHX_ char *const *array)
4660 {
4661     SV *target;
4662
4663     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4664
4665     if (array && *array) {
4666         target = newSVpvs_flags("", SVs_TEMP);
4667         while (1) {
4668             sv_catpv(target, *array);
4669             if (!*++array)
4670                 break;
4671             sv_catpvs(target, " ");
4672         }
4673     } else {
4674         target = sv_mortalcopy(&PL_sv_no);
4675     }
4676     return target;
4677 }
4678
4679 /* Get system info. */
4680
4681 PP(pp_ghostent)
4682 {
4683 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4684     dVAR; dSP;
4685     I32 which = PL_op->op_type;
4686     char **elem;
4687     SV *sv;
4688 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4689     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4690     struct hostent *gethostbyname(Netdb_name_t);
4691     struct hostent *gethostent(void);
4692 #endif
4693     struct hostent *hent = NULL;
4694     unsigned long len;
4695
4696     EXTEND(SP, 10);
4697     if (which == OP_GHBYNAME) {
4698 #ifdef HAS_GETHOSTBYNAME
4699         const char* const name = POPpbytex;
4700         hent = PerlSock_gethostbyname(name);
4701 #else
4702         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4703 #endif
4704     }
4705     else if (which == OP_GHBYADDR) {
4706 #ifdef HAS_GETHOSTBYADDR
4707         const int addrtype = POPi;
4708         SV * const addrsv = POPs;
4709         STRLEN addrlen;
4710         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4711
4712         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4713 #else
4714         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4715 #endif
4716     }
4717     else
4718 #ifdef HAS_GETHOSTENT
4719         hent = PerlSock_gethostent();
4720 #else
4721         DIE(aTHX_ PL_no_sock_func, "gethostent");
4722 #endif
4723
4724 #ifdef HOST_NOT_FOUND
4725         if (!hent) {
4726 #ifdef USE_REENTRANT_API
4727 #   ifdef USE_GETHOSTENT_ERRNO
4728             h_errno = PL_reentrant_buffer->_gethostent_errno;
4729 #   endif
4730 #endif
4731             STATUS_UNIX_SET(h_errno);
4732         }
4733 #endif
4734
4735     if (GIMME != G_ARRAY) {
4736         PUSHs(sv = sv_newmortal());
4737         if (hent) {
4738             if (which == OP_GHBYNAME) {
4739                 if (hent->h_addr)
4740                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4741             }
4742             else
4743                 sv_setpv(sv, (char*)hent->h_name);
4744         }
4745         RETURN;
4746     }
4747
4748     if (hent) {
4749         mPUSHs(newSVpv((char*)hent->h_name, 0));
4750         PUSHs(space_join_names_mortal(hent->h_aliases));
4751         mPUSHi(hent->h_addrtype);
4752         len = hent->h_length;
4753         mPUSHi(len);
4754 #ifdef h_addr
4755         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4756             mXPUSHp(*elem, len);
4757         }
4758 #else
4759         if (hent->h_addr)
4760             mPUSHp(hent->h_addr, len);
4761         else
4762             PUSHs(sv_mortalcopy(&PL_sv_no));
4763 #endif /* h_addr */
4764     }
4765     RETURN;
4766 #else
4767     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4768 #endif
4769 }
4770
4771 PP(pp_gnetent)
4772 {
4773 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4774     dVAR; dSP;
4775     I32 which = PL_op->op_type;
4776     SV *sv;
4777 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4778     struct netent *getnetbyaddr(Netdb_net_t, int);
4779     struct netent *getnetbyname(Netdb_name_t);
4780     struct netent *getnetent(void);
4781 #endif
4782     struct netent *nent;
4783
4784     if (which == OP_GNBYNAME){
4785 #ifdef HAS_GETNETBYNAME
4786         const char * const name = POPpbytex;
4787         nent = PerlSock_getnetbyname(name);
4788 #else
4789         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4790 #endif
4791     }
4792     else if (which == OP_GNBYADDR) {
4793 #ifdef HAS_GETNETBYADDR
4794         const int addrtype = POPi;
4795         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4796         nent = PerlSock_getnetbyaddr(addr, addrtype);
4797 #else
4798         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4799 #endif
4800     }
4801     else
4802 #ifdef HAS_GETNETENT
4803         nent = PerlSock_getnetent();
4804 #else
4805         DIE(aTHX_ PL_no_sock_func, "getnetent");
4806 #endif
4807
4808 #ifdef HOST_NOT_FOUND
4809         if (!nent) {
4810 #ifdef USE_REENTRANT_API
4811 #   ifdef USE_GETNETENT_ERRNO
4812              h_errno = PL_reentrant_buffer->_getnetent_errno;
4813 #   endif
4814 #endif
4815             STATUS_UNIX_SET(h_errno);
4816         }
4817 #endif
4818
4819     EXTEND(SP, 4);
4820     if (GIMME != G_ARRAY) {
4821         PUSHs(sv = sv_newmortal());
4822         if (nent) {
4823             if (which == OP_GNBYNAME)
4824                 sv_setiv(sv, (IV)nent->n_net);
4825             else
4826                 sv_setpv(sv, nent->n_name);
4827         }
4828         RETURN;
4829     }
4830
4831     if (nent) {
4832         mPUSHs(newSVpv(nent->n_name, 0));
4833         PUSHs(space_join_names_mortal(nent->n_aliases));
4834         mPUSHi(nent->n_addrtype);
4835         mPUSHi(nent->n_net);
4836     }
4837
4838     RETURN;
4839 #else
4840     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4841 #endif
4842 }
4843
4844 PP(pp_gprotoent)
4845 {
4846 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4847     dVAR; dSP;
4848     I32 which = PL_op->op_type;
4849     SV *sv;
4850 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4851     struct protoent *getprotobyname(Netdb_name_t);
4852     struct protoent *getprotobynumber(int);
4853     struct protoent *getprotoent(void);
4854 #endif
4855     struct protoent *pent;
4856
4857     if (which == OP_GPBYNAME) {
4858 #ifdef HAS_GETPROTOBYNAME
4859         const char* const name = POPpbytex;
4860         pent = PerlSock_getprotobyname(name);
4861 #else
4862         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4863 #endif
4864     }
4865     else if (which == OP_GPBYNUMBER) {
4866 #ifdef HAS_GETPROTOBYNUMBER
4867         const int number = POPi;
4868         pent = PerlSock_getprotobynumber(number);
4869 #else
4870         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4871 #endif
4872     }
4873     else
4874 #ifdef HAS_GETPROTOENT
4875         pent = PerlSock_getprotoent();
4876 #else
4877         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4878 #endif
4879
4880     EXTEND(SP, 3);
4881     if (GIMME != G_ARRAY) {
4882         PUSHs(sv = sv_newmortal());
4883         if (pent) {
4884             if (which == OP_GPBYNAME)
4885                 sv_setiv(sv, (IV)pent->p_proto);
4886             else
4887                 sv_setpv(sv, pent->p_name);
4888         }
4889         RETURN;
4890     }
4891
4892     if (pent) {
4893         mPUSHs(newSVpv(pent->p_name, 0));
4894         PUSHs(space_join_names_mortal(pent->p_aliases));
4895         mPUSHi(pent->p_proto);
4896     }
4897
4898     RETURN;
4899 #else
4900     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4901 #endif
4902 }
4903
4904 PP(pp_gservent)
4905 {
4906 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4907     dVAR; dSP;
4908     I32 which = PL_op->op_type;
4909     SV *sv;
4910 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4911     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4912     struct servent *getservbyport(int, Netdb_name_t);
4913     struct servent *getservent(void);
4914 #endif
4915     struct servent *sent;
4916
4917     if (which == OP_GSBYNAME) {
4918 #ifdef HAS_GETSERVBYNAME
4919         const char * const proto = POPpbytex;
4920         const char * const name = POPpbytex;
4921         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4922 #else
4923         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4924 #endif
4925     }
4926     else if (which == OP_GSBYPORT) {
4927 #ifdef HAS_GETSERVBYPORT
4928         const char * const proto = POPpbytex;
4929         unsigned short port = (unsigned short)POPu;
4930         port = PerlSock_htons(port);
4931         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4932 #else
4933         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4934 #endif
4935     }
4936     else
4937 #ifdef HAS_GETSERVENT
4938         sent = PerlSock_getservent();
4939 #else
4940         DIE(aTHX_ PL_no_sock_func, "getservent");
4941 #endif
4942
4943     EXTEND(SP, 4);
4944     if (GIMME != G_ARRAY) {
4945         PUSHs(sv = sv_newmortal());
4946         if (sent) {
4947             if (which == OP_GSBYNAME) {
4948                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4949             }
4950             else
4951                 sv_setpv(sv, sent->s_name);
4952         }
4953         RETURN;
4954     }
4955
4956     if (sent) {
4957         mPUSHs(newSVpv(sent->s_name, 0));
4958         PUSHs(space_join_names_mortal(sent->s_aliases));
4959         mPUSHi(PerlSock_ntohs(sent->s_port));
4960         mPUSHs(newSVpv(sent->s_proto, 0));
4961     }
4962
4963     RETURN;
4964 #else
4965     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4966 #endif
4967 }
4968
4969 PP(pp_shostent)
4970 {
4971     dVAR; dSP;
4972     const int stayopen = TOPi;
4973     switch(PL_op->op_type) {
4974     case OP_SHOSTENT:
4975 #ifdef HAS_SETHOSTENT
4976         PerlSock_sethostent(stayopen);
4977 #else
4978         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4979 #endif
4980         break;
4981 #ifdef HAS_SETNETENT
4982     case OP_SNETENT:
4983         PerlSock_setnetent(stayopen);
4984 #else
4985         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4986 #endif
4987         break;
4988     case OP_SPROTOENT:
4989 #ifdef HAS_SETPROTOENT
4990         PerlSock_setprotoent(stayopen);
4991 #else
4992         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4993 #endif
4994         break;
4995     case OP_SSERVENT:
4996 #ifdef HAS_SETSERVENT
4997         PerlSock_setservent(stayopen);
4998 #else
4999         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5000 #endif
5001         break;
5002     }
5003     RETSETYES;
5004 }
5005
5006 PP(pp_ehostent)
5007 {
5008     dVAR; dSP;
5009     switch(PL_op->op_type) {
5010     case OP_EHOSTENT:
5011 #ifdef HAS_ENDHOSTENT
5012         PerlSock_endhostent();
5013 #else
5014         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5015 #endif
5016         break;
5017     case OP_ENETENT:
5018 #ifdef HAS_ENDNETENT
5019         PerlSock_endnetent();
5020 #else
5021         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5022 #endif
5023         break;
5024     case OP_EPROTOENT:
5025 #ifdef HAS_ENDPROTOENT
5026         PerlSock_endprotoent();
5027 #else
5028         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5029 #endif
5030         break;
5031     case OP_ESERVENT:
5032 #ifdef HAS_ENDSERVENT
5033         PerlSock_endservent();
5034 #else
5035         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5036 #endif
5037         break;
5038     case OP_SGRENT:
5039 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5040         setgrent();
5041 #else
5042         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5043 #endif
5044         break;
5045     case OP_EGRENT:
5046 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5047         endgrent();
5048 #else
5049         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5050 #endif
5051         break;
5052     case OP_SPWENT:
5053 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5054         setpwent();
5055 #else
5056         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5057 #endif
5058         break;
5059     case OP_EPWENT:
5060 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5061         endpwent();
5062 #else
5063         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5064 #endif
5065         break;
5066     }
5067     EXTEND(SP,1);
5068     RETPUSHYES;
5069 }
5070
5071 PP(pp_gpwent)
5072 {
5073 #ifdef HAS_PASSWD
5074     dVAR; dSP;
5075     I32 which = PL_op->op_type;
5076     SV *sv;
5077     struct passwd *pwent  = NULL;
5078     /*
5079      * We currently support only the SysV getsp* shadow password interface.
5080      * The interface is declared in <shadow.h> and often one needs to link
5081      * with -lsecurity or some such.
5082      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5083      * (and SCO?)
5084      *
5085      * AIX getpwnam() is clever enough to return the encrypted password
5086      * only if the caller (euid?) is root.
5087      *
5088      * There are at least three other shadow password APIs.  Many platforms
5089      * seem to contain more than one interface for accessing the shadow
5090      * password databases, possibly for compatibility reasons.
5091      * The getsp*() is by far he simplest one, the other two interfaces
5092      * are much more complicated, but also very similar to each other.
5093      *
5094      * <sys/types.h>
5095      * <sys/security.h>
5096      * <prot.h>
5097      * struct pr_passwd *getprpw*();
5098      * The password is in
5099      * char getprpw*(...).ufld.fd_encrypt[]
5100      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5101      *
5102      * <sys/types.h>
5103      * <sys/security.h>
5104      * <prot.h>
5105      * struct es_passwd *getespw*();
5106      * The password is in
5107      * char *(getespw*(...).ufld.fd_encrypt)
5108      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5109      *
5110      * <userpw.h> (AIX)
5111      * struct userpw *getuserpw();
5112      * The password is in
5113      * char *(getuserpw(...)).spw_upw_passwd
5114      * (but the de facto standard getpwnam() should work okay)
5115      *
5116      * Mention I_PROT here so that Configure probes for it.
5117      *
5118      * In HP-UX for getprpw*() the manual page claims that one should include
5119      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5120      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5121      * and pp_sys.c already includes <shadow.h> if there is such.
5122      *
5123      * Note that <sys/security.h> is already probed for, but currently
5124      * it is only included in special cases.
5125      *
5126      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5127      * be preferred interface, even though also the getprpw*() interface
5128      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5129      * One also needs to call set_auth_parameters() in main() before
5130      * doing anything else, whether one is using getespw*() or getprpw*().
5131      *
5132      * Note that accessing the shadow databases can be magnitudes
5133      * slower than accessing the standard databases.
5134      *
5135      * --jhi
5136      */
5137
5138 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5139     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5140      * the pw_comment is left uninitialized. */
5141     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5142 #   endif
5143
5144     switch (which) {
5145     case OP_GPWNAM:
5146       {
5147         const char* const name = POPpbytex;
5148         pwent  = getpwnam(name);
5149       }
5150       break;
5151     case OP_GPWUID:
5152       {
5153         Uid_t uid = POPi;
5154         pwent = getpwuid(uid);
5155       }
5156         break;
5157     case OP_GPWENT:
5158 #   ifdef HAS_GETPWENT
5159         pwent  = getpwent();
5160 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5161         if (pwent) pwent = getpwnam(pwent->pw_name);
5162 #endif
5163 #   else
5164         DIE(aTHX_ PL_no_func, "getpwent");
5165 #   endif
5166         break;
5167     }
5168
5169     EXTEND(SP, 10);
5170     if (GIMME != G_ARRAY) {
5171         PUSHs(sv = sv_newmortal());
5172         if (pwent) {
5173             if (which == OP_GPWNAM)
5174                 sv_setuid(sv, pwent->pw_uid);
5175             else
5176                 sv_setpv(sv, pwent->pw_name);
5177         }
5178         RETURN;
5179     }
5180
5181     if (pwent) {
5182         mPUSHs(newSVpv(pwent->pw_name, 0));
5183
5184         sv = newSViv(0);
5185         mPUSHs(sv);
5186         /* If we have getspnam(), we try to dig up the shadow
5187          * password.  If we are underprivileged, the shadow
5188          * interface will set the errno to EACCES or similar,
5189          * and return a null pointer.  If this happens, we will
5190          * use the dummy password (usually "*" or "x") from the
5191          * standard password database.
5192          *
5193          * In theory we could skip the shadow call completely
5194          * if euid != 0 but in practice we cannot know which
5195          * security measures are guarding the shadow databases
5196          * on a random platform.
5197          *
5198          * Resist the urge to use additional shadow interfaces.
5199          * Divert the urge to writing an extension instead.
5200          *
5201          * --jhi */
5202         /* Some AIX setups falsely(?) detect some getspnam(), which
5203          * has a different API than the Solaris/IRIX one. */
5204 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5205         {
5206             dSAVE_ERRNO;
5207             const struct spwd * const spwent = getspnam(pwent->pw_name);
5208                           /* Save and restore errno so that
5209                            * underprivileged attempts seem
5210                            * to have never made the unsuccessful
5211                            * attempt to retrieve the shadow password. */
5212             RESTORE_ERRNO;
5213             if (spwent && spwent->sp_pwdp)
5214                 sv_setpv(sv, spwent->sp_pwdp);
5215         }
5216 #   endif
5217 #   ifdef PWPASSWD
5218         if (!SvPOK(sv)) /* Use the standard password, then. */
5219             sv_setpv(sv, pwent->pw_passwd);
5220 #   endif
5221
5222 #   ifndef INCOMPLETE_TAINTS
5223         /* passwd is tainted because user himself can diddle with it.
5224          * admittedly not much and in a very limited way, but nevertheless. */
5225         SvTAINTED_on(sv);
5226 #   endif
5227
5228         sv_setuid(PUSHmortal, pwent->pw_uid);
5229         sv_setgid(PUSHmortal, pwent->pw_gid);
5230
5231         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5232          * because of the poor interface of the Perl getpw*(),
5233          * not because there's some standard/convention saying so.
5234          * A better interface would have been to return a hash,
5235          * but we are accursed by our history, alas. --jhi.  */
5236 #   ifdef PWCHANGE
5237         mPUSHi(pwent->pw_change);
5238 #   else
5239 #       ifdef PWQUOTA
5240         mPUSHi(pwent->pw_quota);
5241 #       else
5242 #           ifdef PWAGE
5243         mPUSHs(newSVpv(pwent->pw_age, 0));
5244 #           else
5245         /* I think that you can never get this compiled, but just in case.  */
5246         PUSHs(sv_mortalcopy(&PL_sv_no));
5247 #           endif
5248 #       endif
5249 #   endif
5250
5251         /* pw_class and pw_comment are mutually exclusive--.
5252          * see the above note for pw_change, pw_quota, and pw_age. */
5253 #   ifdef PWCLASS
5254         mPUSHs(newSVpv(pwent->pw_class, 0));
5255 #   else
5256 #       ifdef PWCOMMENT
5257         mPUSHs(newSVpv(pwent->pw_comment, 0));
5258 #       else
5259         /* I think that you can never get this compiled, but just in case.  */
5260         PUSHs(sv_mortalcopy(&PL_sv_no));
5261 #       endif
5262 #   endif
5263
5264 #   ifdef PWGECOS
5265         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5266 #   else
5267         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5268 #   endif
5269 #   ifndef INCOMPLETE_TAINTS
5270         /* pw_gecos is tainted because user himself can diddle with it. */
5271         SvTAINTED_on(sv);
5272 #   endif
5273
5274         mPUSHs(newSVpv(pwent->pw_dir, 0));
5275
5276         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5277 #   ifndef INCOMPLETE_TAINTS
5278         /* pw_shell is tainted because user himself can diddle with it. */
5279         SvTAINTED_on(sv);
5280 #   endif
5281
5282 #   ifdef PWEXPIRE
5283         mPUSHi(pwent->pw_expire);
5284 #   endif
5285     }
5286     RETURN;
5287 #else
5288     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5289 #endif
5290 }
5291
5292 PP(pp_ggrent)
5293 {
5294 #ifdef HAS_GROUP
5295     dVAR; dSP;
5296     const I32 which = PL_op->op_type;
5297     const struct group *grent;
5298
5299     if (which == OP_GGRNAM) {
5300         const char* const name = POPpbytex;
5301         grent = (const struct group *)getgrnam(name);
5302     }
5303     else if (which == OP_GGRGID) {
5304         const Gid_t gid = POPi;
5305         grent = (const struct group *)getgrgid(gid);
5306     }
5307     else
5308 #ifdef HAS_GETGRENT
5309         grent = (struct group *)getgrent();
5310 #else
5311         DIE(aTHX_ PL_no_func, "getgrent");
5312 #endif
5313
5314     EXTEND(SP, 4);
5315     if (GIMME != G_ARRAY) {
5316         SV * const sv = sv_newmortal();
5317
5318         PUSHs(sv);
5319         if (grent) {
5320             if (which == OP_GGRNAM)
5321                 sv_setgid(sv, grent->gr_gid);
5322             else
5323                 sv_setpv(sv, grent->gr_name);
5324         }
5325         RETURN;
5326     }
5327
5328     if (grent) {
5329         mPUSHs(newSVpv(grent->gr_name, 0));
5330
5331 #ifdef GRPASSWD
5332         mPUSHs(newSVpv(grent->gr_passwd, 0));
5333 #else
5334         PUSHs(sv_mortalcopy(&PL_sv_no));
5335 #endif
5336
5337         sv_setgid(PUSHmortal, grent->gr_gid);
5338
5339 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5340         /* In UNICOS/mk (_CRAYMPP) the multithreading
5341          * versions (getgrnam_r, getgrgid_r)
5342          * seem to return an illegal pointer
5343          * as the group members list, gr_mem.
5344          * getgrent() doesn't even have a _r version
5345          * but the gr_mem is poisonous anyway.
5346          * So yes, you cannot get the list of group
5347          * members if building multithreaded in UNICOS/mk. */
5348         PUSHs(space_join_names_mortal(grent->gr_mem));
5349 #endif
5350     }
5351
5352     RETURN;
5353 #else
5354     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5355 #endif
5356 }
5357
5358 PP(pp_getlogin)
5359 {
5360 #ifdef HAS_GETLOGIN
5361     dVAR; dSP; dTARGET;
5362     char *tmps;
5363     EXTEND(SP, 1);
5364     if (!(tmps = PerlProc_getlogin()))
5365         RETPUSHUNDEF;
5366     sv_setpv_mg(TARG, tmps);
5367     PUSHs(TARG);
5368     RETURN;
5369 #else
5370     DIE(aTHX_ PL_no_func, "getlogin");
5371 #endif
5372 }
5373
5374 /* Miscellaneous. */
5375
5376 PP(pp_syscall)
5377 {
5378 #ifdef HAS_SYSCALL
5379     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5380     I32 items = SP - MARK;
5381     unsigned long a[20];
5382     I32 i = 0;
5383     IV retval = -1;
5384
5385     if (TAINTING_get) {
5386         while (++MARK <= SP) {
5387             if (SvTAINTED(*MARK)) {
5388                 TAINT;
5389                 break;
5390             }
5391         }
5392         MARK = ORIGMARK;
5393         TAINT_PROPER("syscall");
5394     }
5395
5396     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5397      * or where sizeof(long) != sizeof(char*).  But such machines will
5398      * not likely have syscall implemented either, so who cares?
5399      */
5400     while (++MARK <= SP) {
5401         if (SvNIOK(*MARK) || !i)
5402             a[i++] = SvIV(*MARK);
5403         else if (*MARK == &PL_sv_undef)
5404             a[i++] = 0;
5405         else
5406             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5407         if (i > 15)
5408             break;
5409     }
5410     switch (items) {
5411     default:
5412         DIE(aTHX_ "Too many args to syscall");
5413     case 0:
5414         DIE(aTHX_ "Too few args to syscall");
5415     case 1:
5416         retval = syscall(a[0]);
5417         break;
5418     case 2:
5419         retval = syscall(a[0],a[1]);
5420         break;
5421     case 3:
5422         retval = syscall(a[0],a[1],a[2]);
5423         break;
5424     case 4:
5425         retval = syscall(a[0],a[1],a[2],a[3]);
5426         break;
5427     case 5:
5428         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5429         break;
5430     case 6:
5431         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5432         break;
5433     case 7:
5434         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5435         break;
5436     case 8:
5437         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5438         break;
5439     }
5440     SP = ORIGMARK;
5441     PUSHi(retval);
5442     RETURN;
5443 #else
5444     DIE(aTHX_ PL_no_func, "syscall");
5445 #endif
5446 }
5447
5448 #ifdef FCNTL_EMULATE_FLOCK
5449
5450 /*  XXX Emulate flock() with fcntl().
5451     What's really needed is a good file locking module.
5452 */
5453
5454 static int
5455 fcntl_emulate_flock(int fd, int operation)
5456 {
5457     int res;
5458     struct flock flock;
5459
5460     switch (operation & ~LOCK_NB) {
5461     case LOCK_SH:
5462         flock.l_type = F_RDLCK;
5463         break;
5464     case LOCK_EX:
5465         flock.l_type = F_WRLCK;
5466         break;
5467     case LOCK_UN:
5468         flock.l_type = F_UNLCK;
5469         break;
5470     default:
5471         errno = EINVAL;
5472         return -1;
5473     }
5474     flock.l_whence = SEEK_SET;
5475     flock.l_start = flock.l_len = (Off_t)0;
5476
5477     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5478     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5479         errno = EWOULDBLOCK;
5480     return res;
5481 }
5482
5483 #endif /* FCNTL_EMULATE_FLOCK */
5484
5485 #ifdef LOCKF_EMULATE_FLOCK
5486
5487 /*  XXX Emulate flock() with lockf().  This is just to increase
5488     portability of scripts.  The calls are not completely
5489     interchangeable.  What's really needed is a good file
5490     locking module.
5491 */
5492
5493 /*  The lockf() constants might have been defined in <unistd.h>.
5494     Unfortunately, <unistd.h> causes troubles on some mixed
5495     (BSD/POSIX) systems, such as SunOS 4.1.3.
5496
5497    Further, the lockf() constants aren't POSIX, so they might not be
5498    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5499    just stick in the SVID values and be done with it.  Sigh.
5500 */
5501
5502 # ifndef F_ULOCK
5503 #  define F_ULOCK       0       /* Unlock a previously locked region */
5504 # endif
5505 # ifndef F_LOCK
5506 #  define F_LOCK        1       /* Lock a region for exclusive use */
5507 # endif
5508 # ifndef F_TLOCK
5509 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5510 # endif
5511 # ifndef F_TEST
5512 #  define F_TEST        3       /* Test a region for other processes locks */
5513 # endif
5514
5515 static int
5516 lockf_emulate_flock(int fd, int operation)
5517 {
5518     int i;
5519     Off_t pos;
5520     dSAVE_ERRNO;
5521
5522     /* flock locks entire file so for lockf we need to do the same      */
5523     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5524     if (pos > 0)        /* is seekable and needs to be repositioned     */
5525         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5526             pos = -1;   /* seek failed, so don't seek back afterwards   */
5527     RESTORE_ERRNO;
5528
5529     switch (operation) {
5530
5531         /* LOCK_SH - get a shared lock */
5532         case LOCK_SH:
5533         /* LOCK_EX - get an exclusive lock */
5534         case LOCK_EX:
5535             i = lockf (fd, F_LOCK, 0);
5536             break;
5537
5538         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5539         case LOCK_SH|LOCK_NB:
5540         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5541         case LOCK_EX|LOCK_NB:
5542             i = lockf (fd, F_TLOCK, 0);
5543             if (i == -1)
5544                 if ((errno == EAGAIN) || (errno == EACCES))
5545                     errno = EWOULDBLOCK;
5546             break;
5547
5548         /* LOCK_UN - unlock (non-blocking is a no-op) */
5549         case LOCK_UN:
5550         case LOCK_UN|LOCK_NB:
5551             i = lockf (fd, F_ULOCK, 0);
5552             break;
5553
5554         /* Default - can't decipher operation */
5555         default:
5556             i = -1;
5557             errno = EINVAL;
5558             break;
5559     }
5560
5561     if (pos > 0)      /* need to restore position of the handle */
5562         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5563
5564     return (i);
5565 }
5566
5567 #endif /* LOCKF_EMULATE_FLOCK */
5568
5569 /*
5570  * Local variables:
5571  * c-indentation-style: bsd
5572  * c-basic-offset: 4
5573  * indent-tabs-mode: nil
5574  * End:
5575  *
5576  * ex: set ts=8 sts=4 sw=4 et:
5577  */