pp_sys.c

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