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