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