pp_sys.c

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