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