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