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 OPp_FT_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 = atoi(name);
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     /*   XXX ASCII dependent code */
3438
3439 #if defined(DOSISH) || defined(USEMYBINMODE)
3440     /* ignore trailing ^Z on short files */
3441     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3442         --len;
3443 #endif
3444
3445     for (i = 0; i < len; i++, s++) {
3446         if (!*s) {                      /* null never allowed in text */
3447             odd += len;
3448             break;
3449         }
3450 #ifdef EBCDIC
3451         else if (!(isPRINT(*s) || isSPACE(*s)))
3452             odd++;
3453 #else
3454         else if (*s & 128) {
3455 #ifdef USE_LOCALE_CTYPE
3456             if (IN_LC_RUNTIME(LC_CTYPE) && isALPHA_LC(*s))
3457                 continue;
3458 #endif
3459             /* utf8 characters don't count as odd */
3460             if (UTF8_IS_START(*s)) {
3461                 int ulen = UTF8SKIP(s);
3462                 if (ulen < len - i) {
3463                     int j;
3464                     for (j = 1; j < ulen; j++) {
3465                         if (!UTF8_IS_CONTINUATION(s[j]))
3466                             goto not_utf8;
3467                     }
3468                     --ulen;     /* loop does extra increment */
3469                     s += ulen;
3470                     i += ulen;
3471                     continue;
3472                 }
3473             }
3474           not_utf8:
3475             odd++;
3476         }
3477         else if (*s < 32 &&
3478           *s != '\n' && *s != '\r' && *s != '\b' &&
3479           *s != '\t' && *s != '\f' && *s != 27)
3480             odd++;
3481 #endif
3482     }
3483
3484     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3485         FT_RETURNNO;
3486     else
3487         FT_RETURNYES;
3488 }
3489
3490 /* File calls. */
3491
3492 PP(pp_chdir)
3493 {
3494     dSP; dTARGET;
3495     const char *tmps = NULL;
3496     GV *gv = NULL;
3497
3498     if( MAXARG == 1 ) {
3499         SV * const sv = POPs;
3500         if (PL_op->op_flags & OPf_SPECIAL) {
3501             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3502         }
3503         else if (!(gv = MAYBE_DEREF_GV(sv)))
3504                 tmps = SvPV_nomg_const_nolen(sv);
3505     }
3506
3507     if( !gv && (!tmps || !*tmps) ) {
3508         HV * const table = GvHVn(PL_envgv);
3509         SV **svp;
3510
3511         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3512              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3513 #ifdef VMS
3514              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3515 #endif
3516            )
3517         {
3518             if( MAXARG == 1 )
3519                 deprecate("chdir('') or chdir(undef) as chdir()");
3520             tmps = SvPV_nolen_const(*svp);
3521         }
3522         else {
3523             PUSHi(0);
3524             TAINT_PROPER("chdir");
3525             RETURN;
3526         }
3527     }
3528
3529     TAINT_PROPER("chdir");
3530     if (gv) {
3531 #ifdef HAS_FCHDIR
3532         IO* const io = GvIO(gv);
3533         if (io) {
3534             if (IoDIRP(io)) {
3535                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3536             } else if (IoIFP(io)) {
3537                 int fd = PerlIO_fileno(IoIFP(io));
3538                 if (fd < 0) {
3539                     goto nuts;
3540                 }
3541                 PUSHi(fchdir(fd) >= 0);
3542             }
3543             else {
3544                 goto nuts;
3545             }
3546         } else {
3547             goto nuts;
3548         }
3549
3550 #else
3551         DIE(aTHX_ PL_no_func, "fchdir");
3552 #endif
3553     }
3554     else
3555         PUSHi( PerlDir_chdir(tmps) >= 0 );
3556 #ifdef VMS
3557     /* Clear the DEFAULT element of ENV so we'll get the new value
3558      * in the future. */
3559     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3560 #endif
3561     RETURN;
3562
3563  nuts:
3564     report_evil_fh(gv);
3565     SETERRNO(EBADF,RMS_IFI);
3566     PUSHi(0);
3567     RETURN;
3568 }
3569
3570 PP(pp_chown)
3571 {
3572     dSP; dMARK; dTARGET;
3573     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3574
3575     SP = MARK;
3576     XPUSHi(value);
3577     RETURN;
3578 }
3579
3580 PP(pp_chroot)
3581 {
3582 #ifdef HAS_CHROOT
3583     dSP; dTARGET;
3584     char * const tmps = POPpx;
3585     TAINT_PROPER("chroot");
3586     PUSHi( chroot(tmps) >= 0 );
3587     RETURN;
3588 #else
3589     DIE(aTHX_ PL_no_func, "chroot");
3590 #endif
3591 }
3592
3593 PP(pp_rename)
3594 {
3595     dSP; dTARGET;
3596     int anum;
3597     const char * const tmps2 = POPpconstx;
3598     const char * const tmps = SvPV_nolen_const(TOPs);
3599     TAINT_PROPER("rename");
3600 #ifdef HAS_RENAME
3601     anum = PerlLIO_rename(tmps, tmps2);
3602 #else
3603     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3604         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3605             anum = 1;
3606         else {
3607             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3608                 (void)UNLINK(tmps2);
3609             if (!(anum = link(tmps, tmps2)))
3610                 anum = UNLINK(tmps);
3611         }
3612     }
3613 #endif
3614     SETi( anum >= 0 );
3615     RETURN;
3616 }
3617
3618 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3619 PP(pp_link)
3620 {
3621     dSP; dTARGET;
3622     const int op_type = PL_op->op_type;
3623     int result;
3624
3625 #  ifndef HAS_LINK
3626     if (op_type == OP_LINK)
3627         DIE(aTHX_ PL_no_func, "link");
3628 #  endif
3629 #  ifndef HAS_SYMLINK
3630     if (op_type == OP_SYMLINK)
3631         DIE(aTHX_ PL_no_func, "symlink");
3632 #  endif
3633
3634     {
3635         const char * const tmps2 = POPpconstx;
3636         const char * const tmps = SvPV_nolen_const(TOPs);
3637         TAINT_PROPER(PL_op_desc[op_type]);
3638         result =
3639 #  if defined(HAS_LINK)
3640 #    if defined(HAS_SYMLINK)
3641             /* Both present - need to choose which.  */
3642             (op_type == OP_LINK) ?
3643             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3644 #    else
3645     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3646         PerlLIO_link(tmps, tmps2);
3647 #    endif
3648 #  else
3649 #    if defined(HAS_SYMLINK)
3650     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3651         symlink(tmps, tmps2);
3652 #    endif
3653 #  endif
3654     }
3655
3656     SETi( result >= 0 );
3657     RETURN;
3658 }
3659 #else
3660 PP(pp_link)
3661 {
3662     /* Have neither.  */
3663     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3664 }
3665 #endif
3666
3667 PP(pp_readlink)
3668 {
3669     dSP;
3670 #ifdef HAS_SYMLINK
3671     dTARGET;
3672     const char *tmps;
3673     char buf[MAXPATHLEN];
3674     int len;
3675
3676     TAINT;
3677     tmps = POPpconstx;
3678     len = readlink(tmps, buf, sizeof(buf) - 1);
3679     if (len < 0)
3680         RETPUSHUNDEF;
3681     PUSHp(buf, len);
3682     RETURN;
3683 #else
3684     EXTEND(SP, 1);
3685     RETSETUNDEF;                /* just pretend it's a normal file */
3686 #endif
3687 }
3688
3689 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3690 STATIC int
3691 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3692 {
3693     char * const save_filename = filename;
3694     char *cmdline;
3695     char *s;
3696     PerlIO *myfp;
3697     int anum = 1;
3698     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3699
3700     PERL_ARGS_ASSERT_DOONELINER;
3701
3702     Newx(cmdline, size, char);
3703     my_strlcpy(cmdline, cmd, size);
3704     my_strlcat(cmdline, " ", size);
3705     for (s = cmdline + strlen(cmdline); *filename; ) {
3706         *s++ = '\\';
3707         *s++ = *filename++;
3708     }
3709     if (s - cmdline < size)
3710         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3711     myfp = PerlProc_popen(cmdline, "r");
3712     Safefree(cmdline);
3713
3714     if (myfp) {
3715         SV * const tmpsv = sv_newmortal();
3716         /* Need to save/restore 'PL_rs' ?? */
3717         s = sv_gets(tmpsv, myfp, 0);
3718         (void)PerlProc_pclose(myfp);
3719         if (s != NULL) {
3720             int e;
3721             for (e = 1;
3722 #ifdef HAS_SYS_ERRLIST
3723                  e <= sys_nerr
3724 #endif
3725                  ; e++)
3726             {
3727                 /* you don't see this */
3728                 const char * const errmsg = Strerror(e) ;
3729                 if (!errmsg)
3730                     break;
3731                 if (instr(s, errmsg)) {
3732                     SETERRNO(e,0);
3733                     return 0;
3734                 }
3735             }
3736             SETERRNO(0,0);
3737 #ifndef EACCES
3738 #define EACCES EPERM
3739 #endif
3740             if (instr(s, "cannot make"))
3741                 SETERRNO(EEXIST,RMS_FEX);
3742             else if (instr(s, "existing file"))
3743                 SETERRNO(EEXIST,RMS_FEX);
3744             else if (instr(s, "ile exists"))
3745                 SETERRNO(EEXIST,RMS_FEX);
3746             else if (instr(s, "non-exist"))
3747                 SETERRNO(ENOENT,RMS_FNF);
3748             else if (instr(s, "does not exist"))
3749                 SETERRNO(ENOENT,RMS_FNF);
3750             else if (instr(s, "not empty"))
3751                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3752             else if (instr(s, "cannot access"))
3753                 SETERRNO(EACCES,RMS_PRV);
3754             else
3755                 SETERRNO(EPERM,RMS_PRV);
3756             return 0;
3757         }
3758         else {  /* some mkdirs return no failure indication */
3759             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3760             if (PL_op->op_type == OP_RMDIR)
3761                 anum = !anum;
3762             if (anum)
3763                 SETERRNO(0,0);
3764             else
3765                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3766         }
3767         return anum;
3768     }
3769     else
3770         return 0;
3771 }
3772 #endif
3773
3774 /* This macro removes trailing slashes from a directory name.
3775  * Different operating and file systems take differently to
3776  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3777  * any number of trailing slashes should be allowed.
3778  * Thusly we snip them away so that even non-conforming
3779  * systems are happy.
3780  * We should probably do this "filtering" for all
3781  * the functions that expect (potentially) directory names:
3782  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3783  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3784
3785 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3786     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3787         do { \
3788             (len)--; \
3789         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3790         (tmps) = savepvn((tmps), (len)); \
3791         (copy) = TRUE; \
3792     }
3793
3794 PP(pp_mkdir)
3795 {
3796     dSP; dTARGET;
3797     STRLEN len;
3798     const char *tmps;
3799     bool copy = FALSE;
3800     const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3801
3802     TRIMSLASHES(tmps,len,copy);
3803
3804     TAINT_PROPER("mkdir");
3805 #ifdef HAS_MKDIR
3806     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3807 #else
3808     {
3809     int oldumask;
3810     SETi( dooneliner("mkdir", tmps) );
3811     oldumask = PerlLIO_umask(0);
3812     PerlLIO_umask(oldumask);
3813     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3814     }
3815 #endif
3816     if (copy)
3817         Safefree(tmps);
3818     RETURN;
3819 }
3820
3821 PP(pp_rmdir)
3822 {
3823     dSP; dTARGET;
3824     STRLEN len;
3825     const char *tmps;
3826     bool copy = FALSE;
3827
3828     TRIMSLASHES(tmps,len,copy);
3829     TAINT_PROPER("rmdir");
3830 #ifdef HAS_RMDIR
3831     SETi( PerlDir_rmdir(tmps) >= 0 );
3832 #else
3833     SETi( dooneliner("rmdir", tmps) );
3834 #endif
3835     if (copy)
3836         Safefree(tmps);
3837     RETURN;
3838 }
3839
3840 /* Directory calls. */
3841
3842 PP(pp_open_dir)
3843 {
3844 #if defined(Direntry_t) && defined(HAS_READDIR)
3845     dSP;
3846     const char * const dirname = POPpconstx;
3847     GV * const gv = MUTABLE_GV(POPs);
3848     IO * const io = GvIOn(gv);
3849
3850     if ((IoIFP(io) || IoOFP(io)))
3851         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3852                          "Opening filehandle %"HEKf" also as a directory",
3853                              HEKfARG(GvENAME_HEK(gv)) );
3854     if (IoDIRP(io))
3855         PerlDir_close(IoDIRP(io));
3856     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3857         goto nope;
3858
3859     RETPUSHYES;
3860 nope:
3861     if (!errno)
3862         SETERRNO(EBADF,RMS_DIR);
3863     RETPUSHUNDEF;
3864 #else
3865     DIE(aTHX_ PL_no_dir_func, "opendir");
3866 #endif
3867 }
3868
3869 PP(pp_readdir)
3870 {
3871 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3872     DIE(aTHX_ PL_no_dir_func, "readdir");
3873 #else
3874 #if !defined(I_DIRENT) && !defined(VMS)
3875     Direntry_t *readdir (DIR *);
3876 #endif
3877     dSP;
3878
3879     SV *sv;
3880     const I32 gimme = GIMME;
3881     GV * const gv = MUTABLE_GV(POPs);
3882     const Direntry_t *dp;
3883     IO * const io = GvIOn(gv);
3884
3885     if (!IoDIRP(io)) {
3886         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3887                        "readdir() attempted on invalid dirhandle %"HEKf,
3888                             HEKfARG(GvENAME_HEK(gv)));
3889         goto nope;
3890     }
3891
3892     do {
3893         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3894         if (!dp)
3895             break;
3896 #ifdef DIRNAMLEN
3897         sv = newSVpvn(dp->d_name, dp->d_namlen);
3898 #else
3899         sv = newSVpv(dp->d_name, 0);
3900 #endif
3901         if (!(IoFLAGS(io) & IOf_UNTAINT))
3902             SvTAINTED_on(sv);
3903         mXPUSHs(sv);
3904     } while (gimme == G_ARRAY);
3905
3906     if (!dp && gimme != G_ARRAY)
3907         RETPUSHUNDEF;
3908
3909     RETURN;
3910
3911 nope:
3912     if (!errno)
3913         SETERRNO(EBADF,RMS_ISI);
3914     if (GIMME == G_ARRAY)
3915         RETURN;
3916     else
3917         RETPUSHUNDEF;
3918 #endif
3919 }
3920
3921 PP(pp_telldir)
3922 {
3923 #if defined(HAS_TELLDIR) || defined(telldir)
3924     dSP; dTARGET;
3925  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3926  /* XXX netbsd still seemed to.
3927     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3928     --JHI 1999-Feb-02 */
3929 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3930     long telldir (DIR *);
3931 # endif
3932     GV * const gv = MUTABLE_GV(POPs);
3933     IO * const io = GvIOn(gv);
3934
3935     if (!IoDIRP(io)) {
3936         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3937                        "telldir() attempted on invalid dirhandle %"HEKf,
3938                             HEKfARG(GvENAME_HEK(gv)));
3939         goto nope;
3940     }
3941
3942     PUSHi( PerlDir_tell(IoDIRP(io)) );
3943     RETURN;
3944 nope:
3945     if (!errno)
3946         SETERRNO(EBADF,RMS_ISI);
3947     RETPUSHUNDEF;
3948 #else
3949     DIE(aTHX_ PL_no_dir_func, "telldir");
3950 #endif
3951 }
3952
3953 PP(pp_seekdir)
3954 {
3955 #if defined(HAS_SEEKDIR) || defined(seekdir)
3956     dSP;
3957     const long along = POPl;
3958     GV * const gv = MUTABLE_GV(POPs);
3959     IO * const io = GvIOn(gv);
3960
3961     if (!IoDIRP(io)) {
3962         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3963                        "seekdir() attempted on invalid dirhandle %"HEKf,
3964                                 HEKfARG(GvENAME_HEK(gv)));
3965         goto nope;
3966     }
3967     (void)PerlDir_seek(IoDIRP(io), along);
3968
3969     RETPUSHYES;
3970 nope:
3971     if (!errno)
3972         SETERRNO(EBADF,RMS_ISI);
3973     RETPUSHUNDEF;
3974 #else
3975     DIE(aTHX_ PL_no_dir_func, "seekdir");
3976 #endif
3977 }
3978
3979 PP(pp_rewinddir)
3980 {
3981 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3982     dSP;
3983     GV * const gv = MUTABLE_GV(POPs);
3984     IO * const io = GvIOn(gv);
3985
3986     if (!IoDIRP(io)) {
3987         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3988                        "rewinddir() attempted on invalid dirhandle %"HEKf,
3989                                 HEKfARG(GvENAME_HEK(gv)));
3990         goto nope;
3991     }
3992     (void)PerlDir_rewind(IoDIRP(io));
3993     RETPUSHYES;
3994 nope:
3995     if (!errno)
3996         SETERRNO(EBADF,RMS_ISI);
3997     RETPUSHUNDEF;
3998 #else
3999     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4000 #endif
4001 }
4002
4003 PP(pp_closedir)
4004 {
4005 #if defined(Direntry_t) && defined(HAS_READDIR)
4006     dSP;
4007     GV * const gv = MUTABLE_GV(POPs);
4008     IO * const io = GvIOn(gv);
4009
4010     if (!IoDIRP(io)) {
4011         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4012                        "closedir() attempted on invalid dirhandle %"HEKf,
4013                                 HEKfARG(GvENAME_HEK(gv)));
4014         goto nope;
4015     }
4016 #ifdef VOID_CLOSEDIR
4017     PerlDir_close(IoDIRP(io));
4018 #else
4019     if (PerlDir_close(IoDIRP(io)) < 0) {
4020         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4021         goto nope;
4022     }
4023 #endif
4024     IoDIRP(io) = 0;
4025
4026     RETPUSHYES;
4027 nope:
4028     if (!errno)
4029         SETERRNO(EBADF,RMS_IFI);
4030     RETPUSHUNDEF;
4031 #else
4032     DIE(aTHX_ PL_no_dir_func, "closedir");
4033 #endif
4034 }
4035
4036 /* Process control. */
4037
4038 PP(pp_fork)
4039 {
4040 #ifdef HAS_FORK
4041     dSP; dTARGET;
4042     Pid_t childpid;
4043 #ifdef HAS_SIGPROCMASK
4044     sigset_t oldmask, newmask;
4045 #endif
4046
4047     EXTEND(SP, 1);
4048     PERL_FLUSHALL_FOR_CHILD;
4049 #ifdef HAS_SIGPROCMASK
4050     sigfillset(&newmask);
4051     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4052 #endif
4053     childpid = PerlProc_fork();
4054     if (childpid == 0) {
4055         int sig;
4056         PL_sig_pending = 0;
4057         if (PL_psig_pend)
4058             for (sig = 1; sig < SIG_SIZE; sig++)
4059                 PL_psig_pend[sig] = 0;
4060     }
4061 #ifdef HAS_SIGPROCMASK
4062     {
4063         dSAVE_ERRNO;
4064         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4065         RESTORE_ERRNO;
4066     }
4067 #endif
4068     if (childpid < 0)
4069         RETPUSHUNDEF;
4070     if (!childpid) {
4071 #ifdef PERL_USES_PL_PIDSTATUS
4072         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4073 #endif
4074     }
4075     PUSHi(childpid);
4076     RETURN;
4077 #else
4078 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4079     dSP; dTARGET;
4080     Pid_t childpid;
4081
4082     EXTEND(SP, 1);
4083     PERL_FLUSHALL_FOR_CHILD;
4084     childpid = PerlProc_fork();
4085     if (childpid == -1)
4086         RETPUSHUNDEF;
4087     PUSHi(childpid);
4088     RETURN;
4089 #  else
4090     DIE(aTHX_ PL_no_func, "fork");
4091 #  endif
4092 #endif
4093 }
4094
4095 PP(pp_wait)
4096 {
4097 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4098     dSP; dTARGET;
4099     Pid_t childpid;
4100     int argflags;
4101
4102     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4103         childpid = wait4pid(-1, &argflags, 0);
4104     else {
4105         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4106                errno == EINTR) {
4107           PERL_ASYNC_CHECK();
4108         }
4109     }
4110 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4111     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4112     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4113 #  else
4114     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4115 #  endif
4116     XPUSHi(childpid);
4117     RETURN;
4118 #else
4119     DIE(aTHX_ PL_no_func, "wait");
4120 #endif
4121 }
4122
4123 PP(pp_waitpid)
4124 {
4125 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4126     dSP; dTARGET;
4127     const int optype = POPi;
4128     const Pid_t pid = TOPi;
4129     Pid_t result;
4130     int argflags;
4131
4132     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4133         result = wait4pid(pid, &argflags, optype);
4134     else {
4135         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4136                errno == EINTR) {
4137           PERL_ASYNC_CHECK();
4138         }
4139     }
4140 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4141     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4142     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4143 #  else
4144     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4145 #  endif
4146     SETi(result);
4147     RETURN;
4148 #else
4149     DIE(aTHX_ PL_no_func, "waitpid");
4150 #endif
4151 }
4152
4153 PP(pp_system)
4154 {
4155     dSP; dMARK; dORIGMARK; dTARGET;
4156 #if defined(__LIBCATAMOUNT__)
4157     PL_statusvalue = -1;
4158     SP = ORIGMARK;
4159     XPUSHi(-1);
4160 #else
4161     I32 value;
4162     int result;
4163
4164     if (TAINTING_get) {
4165         TAINT_ENV();
4166         while (++MARK <= SP) {
4167             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4168             if (TAINT_get)
4169                 break;
4170         }
4171         MARK = ORIGMARK;
4172         TAINT_PROPER("system");
4173     }
4174     PERL_FLUSHALL_FOR_CHILD;
4175 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4176     {
4177         Pid_t childpid;
4178         int pp[2];
4179         I32 did_pipes = 0;
4180 #ifdef HAS_SIGPROCMASK
4181         sigset_t newset, oldset;
4182 #endif
4183
4184         if (PerlProc_pipe(pp) >= 0)
4185             did_pipes = 1;
4186 #ifdef HAS_SIGPROCMASK
4187         sigemptyset(&newset);
4188         sigaddset(&newset, SIGCHLD);
4189         sigprocmask(SIG_BLOCK, &newset, &oldset);
4190 #endif
4191         while ((childpid = PerlProc_fork()) == -1) {
4192             if (errno != EAGAIN) {
4193                 value = -1;
4194                 SP = ORIGMARK;
4195                 XPUSHi(value);
4196                 if (did_pipes) {
4197                     PerlLIO_close(pp[0]);
4198                     PerlLIO_close(pp[1]);
4199                 }
4200 #ifdef HAS_SIGPROCMASK
4201                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4202 #endif
4203                 RETURN;
4204             }
4205             sleep(5);
4206         }
4207         if (childpid > 0) {
4208             Sigsave_t ihand,qhand; /* place to save signals during system() */
4209             int status;
4210
4211             if (did_pipes)
4212                 PerlLIO_close(pp[1]);
4213 #ifndef PERL_MICRO
4214             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4215             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4216 #endif
4217             do {
4218                 result = wait4pid(childpid, &status, 0);
4219             } while (result == -1 && errno == EINTR);
4220 #ifndef PERL_MICRO
4221 #ifdef HAS_SIGPROCMASK
4222             sigprocmask(SIG_SETMASK, &oldset, NULL);
4223 #endif
4224             (void)rsignal_restore(SIGINT, &ihand);
4225             (void)rsignal_restore(SIGQUIT, &qhand);
4226 #endif
4227             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4228             do_execfree();      /* free any memory child malloced on fork */
4229             SP = ORIGMARK;
4230             if (did_pipes) {
4231                 int errkid;
4232                 unsigned n = 0;
4233                 SSize_t n1;
4234
4235                 while (n < sizeof(int)) {
4236                     n1 = PerlLIO_read(pp[0],
4237                                       (void*)(((char*)&errkid)+n),
4238                                       (sizeof(int)) - n);
4239                     if (n1 <= 0)
4240                         break;
4241                     n += n1;
4242                 }
4243                 PerlLIO_close(pp[0]);
4244                 if (n) {                        /* Error */
4245                     if (n != sizeof(int))
4246                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4247                     errno = errkid;             /* Propagate errno from kid */
4248                     STATUS_NATIVE_CHILD_SET(-1);
4249                 }
4250             }
4251             XPUSHi(STATUS_CURRENT);
4252             RETURN;
4253         }
4254 #ifdef HAS_SIGPROCMASK
4255         sigprocmask(SIG_SETMASK, &oldset, NULL);
4256 #endif
4257         if (did_pipes) {
4258             PerlLIO_close(pp[0]);
4259 #if defined(HAS_FCNTL) && defined(F_SETFD)
4260             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4261                 RETPUSHUNDEF;
4262 #endif
4263         }
4264         if (PL_op->op_flags & OPf_STACKED) {
4265             SV * const really = *++MARK;
4266             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4267         }
4268         else if (SP - MARK != 1)
4269             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4270         else {
4271             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4272         }
4273         PerlProc__exit(-1);
4274     }
4275 #else /* ! FORK or VMS or OS/2 */
4276     PL_statusvalue = 0;
4277     result = 0;
4278     if (PL_op->op_flags & OPf_STACKED) {
4279         SV * const really = *++MARK;
4280 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4281         value = (I32)do_aspawn(really, MARK, SP);
4282 #  else
4283         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4284 #  endif
4285     }
4286     else if (SP - MARK != 1) {
4287 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4288         value = (I32)do_aspawn(NULL, MARK, SP);
4289 #  else
4290         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4291 #  endif
4292     }
4293     else {
4294         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4295     }
4296     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4297         result = 1;
4298     STATUS_NATIVE_CHILD_SET(value);
4299     do_execfree();
4300     SP = ORIGMARK;
4301     XPUSHi(result ? value : STATUS_CURRENT);
4302 #endif /* !FORK or VMS or OS/2 */
4303 #endif
4304     RETURN;
4305 }
4306
4307 PP(pp_exec)
4308 {
4309     dSP; dMARK; dORIGMARK; dTARGET;
4310     I32 value;
4311
4312     if (TAINTING_get) {
4313         TAINT_ENV();
4314         while (++MARK <= SP) {
4315             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4316             if (TAINT_get)
4317                 break;
4318         }
4319         MARK = ORIGMARK;
4320         TAINT_PROPER("exec");
4321     }
4322     PERL_FLUSHALL_FOR_CHILD;
4323     if (PL_op->op_flags & OPf_STACKED) {
4324         SV * const really = *++MARK;
4325         value = (I32)do_aexec(really, MARK, SP);
4326     }
4327     else if (SP - MARK != 1)
4328 #ifdef VMS
4329         value = (I32)vms_do_aexec(NULL, MARK, SP);
4330 #else
4331         value = (I32)do_aexec(NULL, MARK, SP);
4332 #endif
4333     else {
4334 #ifdef VMS
4335         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4336 #else
4337         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4338 #endif
4339     }
4340
4341     SP = ORIGMARK;
4342     XPUSHi(value);
4343     RETURN;
4344 }
4345
4346 PP(pp_getppid)
4347 {
4348 #ifdef HAS_GETPPID
4349     dSP; dTARGET;
4350     XPUSHi( getppid() );
4351     RETURN;
4352 #else
4353     DIE(aTHX_ PL_no_func, "getppid");
4354 #endif
4355 }
4356
4357 PP(pp_getpgrp)
4358 {
4359 #ifdef HAS_GETPGRP
4360     dSP; dTARGET;
4361     Pid_t pgrp;
4362     const Pid_t pid =
4363         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4364
4365 #ifdef BSD_GETPGRP
4366     pgrp = (I32)BSD_GETPGRP(pid);
4367 #else
4368     if (pid != 0 && pid != PerlProc_getpid())
4369         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4370     pgrp = getpgrp();
4371 #endif
4372     XPUSHi(pgrp);
4373     RETURN;
4374 #else
4375     DIE(aTHX_ PL_no_func, "getpgrp");
4376 #endif
4377 }
4378
4379 PP(pp_setpgrp)
4380 {
4381 #ifdef HAS_SETPGRP
4382     dSP; dTARGET;
4383     Pid_t pgrp;
4384     Pid_t pid;
4385     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4386     if (MAXARG > 0) pid = TOPs && TOPi;
4387     else {
4388         pid = 0;
4389         XPUSHi(-1);
4390     }
4391
4392     TAINT_PROPER("setpgrp");
4393 #ifdef BSD_SETPGRP
4394     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4395 #else
4396     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4397         || (pid != 0 && pid != PerlProc_getpid()))
4398     {
4399         DIE(aTHX_ "setpgrp can't take arguments");
4400     }
4401     SETi( setpgrp() >= 0 );
4402 #endif /* USE_BSDPGRP */
4403     RETURN;
4404 #else
4405     DIE(aTHX_ PL_no_func, "setpgrp");
4406 #endif
4407 }
4408
4409 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4410 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4411 #else
4412 #  define PRIORITY_WHICH_T(which) which
4413 #endif
4414
4415 PP(pp_getpriority)
4416 {
4417 #ifdef HAS_GETPRIORITY
4418     dSP; dTARGET;
4419     const int who = POPi;
4420     const int which = TOPi;
4421     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4422     RETURN;
4423 #else
4424     DIE(aTHX_ PL_no_func, "getpriority");
4425 #endif
4426 }
4427
4428 PP(pp_setpriority)
4429 {
4430 #ifdef HAS_SETPRIORITY
4431     dSP; dTARGET;
4432     const int niceval = POPi;
4433     const int who = POPi;
4434     const int which = TOPi;
4435     TAINT_PROPER("setpriority");
4436     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4437     RETURN;
4438 #else
4439     DIE(aTHX_ PL_no_func, "setpriority");
4440 #endif
4441 }
4442
4443 #undef PRIORITY_WHICH_T
4444
4445 /* Time calls. */
4446
4447 PP(pp_time)
4448 {
4449     dSP; dTARGET;
4450 #ifdef BIG_TIME
4451     XPUSHn( time(NULL) );
4452 #else
4453     XPUSHi( time(NULL) );
4454 #endif
4455     RETURN;
4456 }
4457
4458 PP(pp_tms)
4459 {
4460 #ifdef HAS_TIMES
4461     dSP;
4462     struct tms timesbuf;
4463
4464     EXTEND(SP, 4);
4465     (void)PerlProc_times(&timesbuf);
4466
4467     mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4468     if (GIMME == G_ARRAY) {
4469         mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4470         mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4471         mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4472     }
4473     RETURN;
4474 #else
4475 #   ifdef PERL_MICRO
4476     dSP;
4477     mPUSHn(0.0);
4478     EXTEND(SP, 4);
4479     if (GIMME == G_ARRAY) {
4480          mPUSHn(0.0);
4481          mPUSHn(0.0);
4482          mPUSHn(0.0);
4483     }
4484     RETURN;
4485 #   else
4486     DIE(aTHX_ "times not implemented");
4487 #   endif
4488 #endif /* HAS_TIMES */
4489 }
4490
4491 /* The 32 bit int year limits the times we can represent to these
4492    boundaries with a few days wiggle room to account for time zone
4493    offsets
4494 */
4495 /* Sat Jan  3 00:00:00 -2147481748 */
4496 #define TIME_LOWER_BOUND -67768100567755200.0
4497 /* Sun Dec 29 12:00:00  2147483647 */
4498 #define TIME_UPPER_BOUND  67767976233316800.0
4499
4500 PP(pp_gmtime)
4501 {
4502     dSP;
4503     Time64_T when;
4504     struct TM tmbuf;
4505     struct TM *err;
4506     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4507     static const char * const dayname[] =
4508         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4509     static const char * const monname[] =
4510         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4511          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4512
4513     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4514         time_t now;
4515         (void)time(&now);
4516         when = (Time64_T)now;
4517     }
4518     else {
4519         NV input = Perl_floor(POPn);
4520         when = (Time64_T)input;
4521         if (when != input) {
4522             /* diag_listed_as: gmtime(%f) too large */
4523             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4524                            "%s(%.0" NVff ") too large", opname, input);
4525         }
4526     }
4527
4528     if ( TIME_LOWER_BOUND > when ) {
4529         /* diag_listed_as: gmtime(%f) too small */
4530         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4531                        "%s(%.0" NVff ") too small", opname, when);
4532         err = NULL;
4533     }
4534     else if( when > TIME_UPPER_BOUND ) {
4535         /* diag_listed_as: gmtime(%f) too small */
4536         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4537                        "%s(%.0" NVff ") too large", opname, when);
4538         err = NULL;
4539     }
4540     else {
4541         if (PL_op->op_type == OP_LOCALTIME)
4542             err = S_localtime64_r(&when, &tmbuf);
4543         else
4544             err = S_gmtime64_r(&when, &tmbuf);
4545     }
4546
4547     if (err == NULL) {
4548         /* diag_listed_as: gmtime(%f) failed */
4549         /* XXX %lld broken for quads */
4550         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4551                        "%s(%.0" NVff ") failed", opname, when);
4552     }
4553
4554     if (GIMME != G_ARRAY) {     /* scalar context */
4555         EXTEND(SP, 1);
4556         EXTEND_MORTAL(1);
4557         if (err == NULL)
4558             RETPUSHUNDEF;
4559        else {
4560            mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4561                                 dayname[tmbuf.tm_wday],
4562                                 monname[tmbuf.tm_mon],
4563                                 tmbuf.tm_mday,
4564                                 tmbuf.tm_hour,
4565                                 tmbuf.tm_min,
4566                                 tmbuf.tm_sec,
4567                                 /* XXX newSVpvf()'s %lld type is broken,
4568                                  * so cheat with a double */
4569                                 (double)tmbuf.tm_year + 1900));
4570         }
4571     }
4572     else {                      /* list context */
4573         if ( err == NULL )
4574             RETURN;
4575
4576         EXTEND(SP, 9);
4577         EXTEND_MORTAL(9);
4578         mPUSHi(tmbuf.tm_sec);
4579         mPUSHi(tmbuf.tm_min);
4580         mPUSHi(tmbuf.tm_hour);
4581         mPUSHi(tmbuf.tm_mday);
4582         mPUSHi(tmbuf.tm_mon);
4583         mPUSHn(tmbuf.tm_year);
4584         mPUSHi(tmbuf.tm_wday);
4585         mPUSHi(tmbuf.tm_yday);
4586         mPUSHi(tmbuf.tm_isdst);
4587     }
4588     RETURN;
4589 }
4590
4591 PP(pp_alarm)
4592 {
4593 #ifdef HAS_ALARM
4594     dSP; dTARGET;
4595     int anum;
4596     anum = POPi;
4597     anum = alarm((unsigned int)anum);
4598     if (anum < 0)
4599         RETPUSHUNDEF;
4600     PUSHi(anum);
4601     RETURN;
4602 #else
4603     DIE(aTHX_ PL_no_func, "alarm");
4604 #endif
4605 }
4606
4607 PP(pp_sleep)
4608 {
4609     dSP; dTARGET;
4610     I32 duration;
4611     Time_t lasttime;
4612     Time_t when;
4613
4614     (void)time(&lasttime);
4615     if (MAXARG < 1 || (!TOPs && !POPs))
4616         PerlProc_pause();
4617     else {
4618         duration = POPi;
4619         PerlProc_sleep((unsigned int)duration);
4620     }
4621     (void)time(&when);
4622     XPUSHi(when - lasttime);
4623     RETURN;
4624 }
4625
4626 /* Shared memory. */
4627 /* Merged with some message passing. */
4628
4629 PP(pp_shmwrite)
4630 {
4631 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4632     dSP; dMARK; dTARGET;
4633     const int op_type = PL_op->op_type;
4634     I32 value;
4635
4636     switch (op_type) {
4637     case OP_MSGSND:
4638         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4639         break;
4640     case OP_MSGRCV:
4641         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4642         break;
4643     case OP_SEMOP:
4644         value = (I32)(do_semop(MARK, SP) >= 0);
4645         break;
4646     default:
4647         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4648         break;
4649     }
4650
4651     SP = MARK;
4652     PUSHi(value);
4653     RETURN;
4654 #else
4655     return Perl_pp_semget(aTHX);
4656 #endif
4657 }
4658
4659 /* Semaphores. */
4660
4661 PP(pp_semget)
4662 {
4663 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4664     dSP; dMARK; dTARGET;
4665     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4666     SP = MARK;
4667     if (anum == -1)
4668         RETPUSHUNDEF;
4669     PUSHi(anum);
4670     RETURN;
4671 #else
4672     DIE(aTHX_ "System V IPC is not implemented on this machine");
4673 #endif
4674 }
4675
4676 PP(pp_semctl)
4677 {
4678 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4679     dSP; dMARK; dTARGET;
4680     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4681     SP = MARK;
4682     if (anum == -1)
4683         RETSETUNDEF;
4684     if (anum != 0) {
4685         PUSHi(anum);
4686     }
4687     else {
4688         PUSHp(zero_but_true, ZBTLEN);
4689     }
4690     RETURN;
4691 #else
4692     return Perl_pp_semget(aTHX);
4693 #endif
4694 }
4695
4696 /* I can't const this further without getting warnings about the types of
4697    various arrays passed in from structures.  */
4698 static SV *
4699 S_space_join_names_mortal(pTHX_ char *const *array)
4700 {
4701     SV *target;
4702
4703     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4704
4705     if (array && *array) {
4706         target = newSVpvs_flags("", SVs_TEMP);
4707         while (1) {
4708             sv_catpv(target, *array);
4709             if (!*++array)
4710                 break;
4711             sv_catpvs(target, " ");
4712         }
4713     } else {
4714         target = sv_mortalcopy(&PL_sv_no);
4715     }
4716     return target;
4717 }
4718
4719 /* Get system info. */
4720
4721 PP(pp_ghostent)
4722 {
4723 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4724     dSP;
4725     I32 which = PL_op->op_type;
4726     char **elem;
4727     SV *sv;
4728 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4729     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4730     struct hostent *gethostbyname(Netdb_name_t);
4731     struct hostent *gethostent(void);
4732 #endif
4733     struct hostent *hent = NULL;
4734     unsigned long len;
4735
4736     EXTEND(SP, 10);
4737     if (which == OP_GHBYNAME) {
4738 #ifdef HAS_GETHOSTBYNAME
4739         const char* const name = POPpbytex;
4740         hent = PerlSock_gethostbyname(name);
4741 #else
4742         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4743 #endif
4744     }
4745     else if (which == OP_GHBYADDR) {
4746 #ifdef HAS_GETHOSTBYADDR
4747         const int addrtype = POPi;
4748         SV * const addrsv = POPs;
4749         STRLEN addrlen;
4750         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4751
4752         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4753 #else
4754         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4755 #endif
4756     }
4757     else
4758 #ifdef HAS_GETHOSTENT
4759         hent = PerlSock_gethostent();
4760 #else
4761         DIE(aTHX_ PL_no_sock_func, "gethostent");
4762 #endif
4763
4764 #ifdef HOST_NOT_FOUND
4765         if (!hent) {
4766 #ifdef USE_REENTRANT_API
4767 #   ifdef USE_GETHOSTENT_ERRNO
4768             h_errno = PL_reentrant_buffer->_gethostent_errno;
4769 #   endif
4770 #endif
4771             STATUS_UNIX_SET(h_errno);
4772         }
4773 #endif
4774
4775     if (GIMME != G_ARRAY) {
4776         PUSHs(sv = sv_newmortal());
4777         if (hent) {
4778             if (which == OP_GHBYNAME) {
4779                 if (hent->h_addr)
4780                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4781             }
4782             else
4783                 sv_setpv(sv, (char*)hent->h_name);
4784         }
4785         RETURN;
4786     }
4787
4788     if (hent) {
4789         mPUSHs(newSVpv((char*)hent->h_name, 0));
4790         PUSHs(space_join_names_mortal(hent->h_aliases));
4791         mPUSHi(hent->h_addrtype);
4792         len = hent->h_length;
4793         mPUSHi(len);
4794 #ifdef h_addr
4795         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4796             mXPUSHp(*elem, len);
4797         }
4798 #else
4799         if (hent->h_addr)
4800             mPUSHp(hent->h_addr, len);
4801         else
4802             PUSHs(sv_mortalcopy(&PL_sv_no));
4803 #endif /* h_addr */
4804     }
4805     RETURN;
4806 #else
4807     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4808 #endif
4809 }
4810
4811 PP(pp_gnetent)
4812 {
4813 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4814     dSP;
4815     I32 which = PL_op->op_type;
4816     SV *sv;
4817 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4818     struct netent *getnetbyaddr(Netdb_net_t, int);
4819     struct netent *getnetbyname(Netdb_name_t);
4820     struct netent *getnetent(void);
4821 #endif
4822     struct netent *nent;
4823
4824     if (which == OP_GNBYNAME){
4825 #ifdef HAS_GETNETBYNAME
4826         const char * const name = POPpbytex;
4827         nent = PerlSock_getnetbyname(name);
4828 #else
4829         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4830 #endif
4831     }
4832     else if (which == OP_GNBYADDR) {
4833 #ifdef HAS_GETNETBYADDR
4834         const int addrtype = POPi;
4835         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4836         nent = PerlSock_getnetbyaddr(addr, addrtype);
4837 #else
4838         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4839 #endif
4840     }
4841     else
4842 #ifdef HAS_GETNETENT
4843         nent = PerlSock_getnetent();
4844 #else
4845         DIE(aTHX_ PL_no_sock_func, "getnetent");
4846 #endif
4847
4848 #ifdef HOST_NOT_FOUND
4849         if (!nent) {
4850 #ifdef USE_REENTRANT_API
4851 #   ifdef USE_GETNETENT_ERRNO
4852              h_errno = PL_reentrant_buffer->_getnetent_errno;
4853 #   endif
4854 #endif
4855             STATUS_UNIX_SET(h_errno);
4856         }
4857 #endif
4858
4859     EXTEND(SP, 4);
4860     if (GIMME != G_ARRAY) {
4861         PUSHs(sv = sv_newmortal());
4862         if (nent) {
4863             if (which == OP_GNBYNAME)
4864                 sv_setiv(sv, (IV)nent->n_net);
4865             else
4866                 sv_setpv(sv, nent->n_name);
4867         }
4868         RETURN;
4869     }
4870
4871     if (nent) {
4872         mPUSHs(newSVpv(nent->n_name, 0));
4873         PUSHs(space_join_names_mortal(nent->n_aliases));
4874         mPUSHi(nent->n_addrtype);
4875         mPUSHi(nent->n_net);
4876     }
4877
4878     RETURN;
4879 #else
4880     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4881 #endif
4882 }
4883
4884 PP(pp_gprotoent)
4885 {
4886 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4887     dSP;
4888     I32 which = PL_op->op_type;
4889     SV *sv;
4890 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4891     struct protoent *getprotobyname(Netdb_name_t);
4892     struct protoent *getprotobynumber(int);
4893     struct protoent *getprotoent(void);
4894 #endif
4895     struct protoent *pent;
4896
4897     if (which == OP_GPBYNAME) {
4898 #ifdef HAS_GETPROTOBYNAME
4899         const char* const name = POPpbytex;
4900         pent = PerlSock_getprotobyname(name);
4901 #else
4902         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4903 #endif
4904     }
4905     else if (which == OP_GPBYNUMBER) {
4906 #ifdef HAS_GETPROTOBYNUMBER
4907         const int number = POPi;
4908         pent = PerlSock_getprotobynumber(number);
4909 #else
4910         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4911 #endif
4912     }
4913     else
4914 #ifdef HAS_GETPROTOENT
4915         pent = PerlSock_getprotoent();
4916 #else
4917         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4918 #endif
4919
4920     EXTEND(SP, 3);
4921     if (GIMME != G_ARRAY) {
4922         PUSHs(sv = sv_newmortal());
4923         if (pent) {
4924             if (which == OP_GPBYNAME)
4925                 sv_setiv(sv, (IV)pent->p_proto);
4926             else
4927                 sv_setpv(sv, pent->p_name);
4928         }
4929         RETURN;
4930     }
4931
4932     if (pent) {
4933         mPUSHs(newSVpv(pent->p_name, 0));
4934         PUSHs(space_join_names_mortal(pent->p_aliases));
4935         mPUSHi(pent->p_proto);
4936     }
4937
4938     RETURN;
4939 #else
4940     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4941 #endif
4942 }
4943
4944 PP(pp_gservent)
4945 {
4946 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4947     dSP;
4948     I32 which = PL_op->op_type;
4949     SV *sv;
4950 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4951     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4952     struct servent *getservbyport(int, Netdb_name_t);
4953     struct servent *getservent(void);
4954 #endif
4955     struct servent *sent;
4956
4957     if (which == OP_GSBYNAME) {
4958 #ifdef HAS_GETSERVBYNAME
4959         const char * const proto = POPpbytex;
4960         const char * const name = POPpbytex;
4961         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4962 #else
4963         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4964 #endif
4965     }
4966     else if (which == OP_GSBYPORT) {
4967 #ifdef HAS_GETSERVBYPORT
4968         const char * const proto = POPpbytex;
4969         unsigned short port = (unsigned short)POPu;
4970         port = PerlSock_htons(port);
4971         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4972 #else
4973         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4974 #endif
4975     }
4976     else
4977 #ifdef HAS_GETSERVENT
4978         sent = PerlSock_getservent();
4979 #else
4980         DIE(aTHX_ PL_no_sock_func, "getservent");
4981 #endif
4982
4983     EXTEND(SP, 4);
4984     if (GIMME != G_ARRAY) {
4985         PUSHs(sv = sv_newmortal());
4986         if (sent) {
4987             if (which == OP_GSBYNAME) {
4988                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4989             }
4990             else
4991                 sv_setpv(sv, sent->s_name);
4992         }
4993         RETURN;
4994     }
4995
4996     if (sent) {
4997         mPUSHs(newSVpv(sent->s_name, 0));
4998         PUSHs(space_join_names_mortal(sent->s_aliases));
4999         mPUSHi(PerlSock_ntohs(sent->s_port));
5000         mPUSHs(newSVpv(sent->s_proto, 0));
5001     }
5002
5003     RETURN;
5004 #else
5005     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5006 #endif
5007 }
5008
5009 PP(pp_shostent)
5010 {
5011     dSP;
5012     const int stayopen = TOPi;
5013     switch(PL_op->op_type) {
5014     case OP_SHOSTENT:
5015 #ifdef HAS_SETHOSTENT
5016         PerlSock_sethostent(stayopen);
5017 #else
5018         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5019 #endif
5020         break;
5021 #ifdef HAS_SETNETENT
5022     case OP_SNETENT:
5023         PerlSock_setnetent(stayopen);
5024 #else
5025         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5026 #endif
5027         break;
5028     case OP_SPROTOENT:
5029 #ifdef HAS_SETPROTOENT
5030         PerlSock_setprotoent(stayopen);
5031 #else
5032         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5033 #endif
5034         break;
5035     case OP_SSERVENT:
5036 #ifdef HAS_SETSERVENT
5037         PerlSock_setservent(stayopen);
5038 #else
5039         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5040 #endif
5041         break;
5042     }
5043     RETSETYES;
5044 }
5045
5046 PP(pp_ehostent)
5047 {
5048     dSP;
5049     switch(PL_op->op_type) {
5050     case OP_EHOSTENT:
5051 #ifdef HAS_ENDHOSTENT
5052         PerlSock_endhostent();
5053 #else
5054         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5055 #endif
5056         break;
5057     case OP_ENETENT:
5058 #ifdef HAS_ENDNETENT
5059         PerlSock_endnetent();
5060 #else
5061         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5062 #endif
5063         break;
5064     case OP_EPROTOENT:
5065 #ifdef HAS_ENDPROTOENT
5066         PerlSock_endprotoent();
5067 #else
5068         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5069 #endif
5070         break;
5071     case OP_ESERVENT:
5072 #ifdef HAS_ENDSERVENT
5073         PerlSock_endservent();
5074 #else
5075         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5076 #endif
5077         break;
5078     case OP_SGRENT:
5079 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5080         setgrent();
5081 #else
5082         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5083 #endif
5084         break;
5085     case OP_EGRENT:
5086 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5087         endgrent();
5088 #else
5089         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5090 #endif
5091         break;
5092     case OP_SPWENT:
5093 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5094         setpwent();
5095 #else
5096         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5097 #endif
5098         break;
5099     case OP_EPWENT:
5100 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5101         endpwent();
5102 #else
5103         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5104 #endif
5105         break;
5106     }
5107     EXTEND(SP,1);
5108     RETPUSHYES;
5109 }
5110
5111 PP(pp_gpwent)
5112 {
5113 #ifdef HAS_PASSWD
5114     dSP;
5115     I32 which = PL_op->op_type;
5116     SV *sv;
5117     struct passwd *pwent  = NULL;
5118     /*
5119      * We currently support only the SysV getsp* shadow password interface.
5120      * The interface is declared in <shadow.h> and often one needs to link
5121      * with -lsecurity or some such.
5122      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5123      * (and SCO?)
5124      *
5125      * AIX getpwnam() is clever enough to return the encrypted password
5126      * only if the caller (euid?) is root.
5127      *
5128      * There are at least three other shadow password APIs.  Many platforms
5129      * seem to contain more than one interface for accessing the shadow
5130      * password databases, possibly for compatibility reasons.
5131      * The getsp*() is by far he simplest one, the other two interfaces
5132      * are much more complicated, but also very similar to each other.
5133      *
5134      * <sys/types.h>
5135      * <sys/security.h>
5136      * <prot.h>
5137      * struct pr_passwd *getprpw*();
5138      * The password is in
5139      * char getprpw*(...).ufld.fd_encrypt[]
5140      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5141      *
5142      * <sys/types.h>
5143      * <sys/security.h>
5144      * <prot.h>
5145      * struct es_passwd *getespw*();
5146      * The password is in
5147      * char *(getespw*(...).ufld.fd_encrypt)
5148      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5149      *
5150      * <userpw.h> (AIX)
5151      * struct userpw *getuserpw();
5152      * The password is in
5153      * char *(getuserpw(...)).spw_upw_passwd
5154      * (but the de facto standard getpwnam() should work okay)
5155      *
5156      * Mention I_PROT here so that Configure probes for it.
5157      *
5158      * In HP-UX for getprpw*() the manual page claims that one should include
5159      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5160      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5161      * and pp_sys.c already includes <shadow.h> if there is such.
5162      *
5163      * Note that <sys/security.h> is already probed for, but currently
5164      * it is only included in special cases.
5165      *
5166      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5167      * be preferred interface, even though also the getprpw*() interface
5168      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5169      * One also needs to call set_auth_parameters() in main() before
5170      * doing anything else, whether one is using getespw*() or getprpw*().
5171      *
5172      * Note that accessing the shadow databases can be magnitudes
5173      * slower than accessing the standard databases.
5174      *
5175      * --jhi
5176      */
5177
5178 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5179     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5180      * the pw_comment is left uninitialized. */
5181     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5182 #   endif
5183
5184     switch (which) {
5185     case OP_GPWNAM:
5186       {
5187         const char* const name = POPpbytex;
5188         pwent  = getpwnam(name);
5189       }
5190       break;
5191     case OP_GPWUID:
5192       {
5193         Uid_t uid = POPi;
5194         pwent = getpwuid(uid);
5195       }
5196         break;
5197     case OP_GPWENT:
5198 #   ifdef HAS_GETPWENT
5199         pwent  = getpwent();
5200 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5201         if (pwent) pwent = getpwnam(pwent->pw_name);
5202 #endif
5203 #   else
5204         DIE(aTHX_ PL_no_func, "getpwent");
5205 #   endif
5206         break;
5207     }
5208
5209     EXTEND(SP, 10);
5210     if (GIMME != G_ARRAY) {
5211         PUSHs(sv = sv_newmortal());
5212         if (pwent) {
5213             if (which == OP_GPWNAM)
5214                 sv_setuid(sv, pwent->pw_uid);
5215             else
5216                 sv_setpv(sv, pwent->pw_name);
5217         }
5218         RETURN;
5219     }
5220
5221     if (pwent) {
5222         mPUSHs(newSVpv(pwent->pw_name, 0));
5223
5224         sv = newSViv(0);
5225         mPUSHs(sv);
5226         /* If we have getspnam(), we try to dig up the shadow
5227          * password.  If we are underprivileged, the shadow
5228          * interface will set the errno to EACCES or similar,
5229          * and return a null pointer.  If this happens, we will
5230          * use the dummy password (usually "*" or "x") from the
5231          * standard password database.
5232          *
5233          * In theory we could skip the shadow call completely
5234          * if euid != 0 but in practice we cannot know which
5235          * security measures are guarding the shadow databases
5236          * on a random platform.
5237          *
5238          * Resist the urge to use additional shadow interfaces.
5239          * Divert the urge to writing an extension instead.
5240          *
5241          * --jhi */
5242         /* Some AIX setups falsely(?) detect some getspnam(), which
5243          * has a different API than the Solaris/IRIX one. */
5244 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5245         {
5246             dSAVE_ERRNO;
5247             const struct spwd * const spwent = getspnam(pwent->pw_name);
5248                           /* Save and restore errno so that
5249                            * underprivileged attempts seem
5250                            * to have never made the unsuccessful
5251                            * attempt to retrieve the shadow password. */
5252             RESTORE_ERRNO;
5253             if (spwent && spwent->sp_pwdp)
5254                 sv_setpv(sv, spwent->sp_pwdp);
5255         }
5256 #   endif
5257 #   ifdef PWPASSWD
5258         if (!SvPOK(sv)) /* Use the standard password, then. */
5259             sv_setpv(sv, pwent->pw_passwd);
5260 #   endif
5261
5262         /* passwd is tainted because user himself can diddle with it.
5263          * admittedly not much and in a very limited way, but nevertheless. */
5264         SvTAINTED_on(sv);
5265
5266         sv_setuid(PUSHmortal, pwent->pw_uid);
5267         sv_setgid(PUSHmortal, pwent->pw_gid);
5268
5269         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5270          * because of the poor interface of the Perl getpw*(),
5271          * not because there's some standard/convention saying so.
5272          * A better interface would have been to return a hash,
5273          * but we are accursed by our history, alas. --jhi.  */
5274 #   ifdef PWCHANGE
5275         mPUSHi(pwent->pw_change);
5276 #   else
5277 #       ifdef PWQUOTA
5278         mPUSHi(pwent->pw_quota);
5279 #       else
5280 #           ifdef PWAGE
5281         mPUSHs(newSVpv(pwent->pw_age, 0));
5282 #           else
5283         /* I think that you can never get this compiled, but just in case.  */
5284         PUSHs(sv_mortalcopy(&PL_sv_no));
5285 #           endif
5286 #       endif
5287 #   endif
5288
5289         /* pw_class and pw_comment are mutually exclusive--.
5290          * see the above note for pw_change, pw_quota, and pw_age. */
5291 #   ifdef PWCLASS
5292         mPUSHs(newSVpv(pwent->pw_class, 0));
5293 #   else
5294 #       ifdef PWCOMMENT
5295         mPUSHs(newSVpv(pwent->pw_comment, 0));
5296 #       else
5297         /* I think that you can never get this compiled, but just in case.  */
5298         PUSHs(sv_mortalcopy(&PL_sv_no));
5299 #       endif
5300 #   endif
5301
5302 #   ifdef PWGECOS
5303         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5304 #   else
5305         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5306 #   endif
5307         /* pw_gecos is tainted because user himself can diddle with it. */
5308         SvTAINTED_on(sv);
5309
5310         mPUSHs(newSVpv(pwent->pw_dir, 0));
5311
5312         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5313         /* pw_shell is tainted because user himself can diddle with it. */
5314         SvTAINTED_on(sv);
5315
5316 #   ifdef PWEXPIRE
5317         mPUSHi(pwent->pw_expire);
5318 #   endif
5319     }
5320     RETURN;
5321 #else
5322     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5323 #endif
5324 }
5325
5326 PP(pp_ggrent)
5327 {
5328 #ifdef HAS_GROUP
5329     dSP;
5330     const I32 which = PL_op->op_type;
5331     const struct group *grent;
5332
5333     if (which == OP_GGRNAM) {
5334         const char* const name = POPpbytex;
5335         grent = (const struct group *)getgrnam(name);
5336     }
5337     else if (which == OP_GGRGID) {
5338         const Gid_t gid = POPi;
5339         grent = (const struct group *)getgrgid(gid);
5340     }
5341     else
5342 #ifdef HAS_GETGRENT
5343         grent = (struct group *)getgrent();
5344 #else
5345         DIE(aTHX_ PL_no_func, "getgrent");
5346 #endif
5347
5348     EXTEND(SP, 4);
5349     if (GIMME != G_ARRAY) {
5350         SV * const sv = sv_newmortal();
5351
5352         PUSHs(sv);
5353         if (grent) {
5354             if (which == OP_GGRNAM)
5355                 sv_setgid(sv, grent->gr_gid);
5356             else
5357                 sv_setpv(sv, grent->gr_name);
5358         }
5359         RETURN;
5360     }
5361
5362     if (grent) {
5363         mPUSHs(newSVpv(grent->gr_name, 0));
5364
5365 #ifdef GRPASSWD
5366         mPUSHs(newSVpv(grent->gr_passwd, 0));
5367 #else
5368         PUSHs(sv_mortalcopy(&PL_sv_no));
5369 #endif
5370
5371         sv_setgid(PUSHmortal, grent->gr_gid);
5372
5373 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5374         /* In UNICOS/mk (_CRAYMPP) the multithreading
5375          * versions (getgrnam_r, getgrgid_r)
5376          * seem to return an illegal pointer
5377          * as the group members list, gr_mem.
5378          * getgrent() doesn't even have a _r version
5379          * but the gr_mem is poisonous anyway.
5380          * So yes, you cannot get the list of group
5381          * members if building multithreaded in UNICOS/mk. */
5382         PUSHs(space_join_names_mortal(grent->gr_mem));
5383 #endif
5384     }
5385
5386     RETURN;
5387 #else
5388     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5389 #endif
5390 }
5391
5392 PP(pp_getlogin)
5393 {
5394 #ifdef HAS_GETLOGIN
5395     dSP; dTARGET;
5396     char *tmps;
5397     EXTEND(SP, 1);
5398     if (!(tmps = PerlProc_getlogin()))
5399         RETPUSHUNDEF;
5400     sv_setpv_mg(TARG, tmps);
5401     PUSHs(TARG);
5402     RETURN;
5403 #else
5404     DIE(aTHX_ PL_no_func, "getlogin");
5405 #endif
5406 }
5407
5408 /* Miscellaneous. */
5409
5410 PP(pp_syscall)
5411 {
5412 #ifdef HAS_SYSCALL
5413     dSP; dMARK; dORIGMARK; dTARGET;
5414     I32 items = SP - MARK;
5415     unsigned long a[20];
5416     I32 i = 0;
5417     IV retval = -1;
5418
5419     if (TAINTING_get) {
5420         while (++MARK <= SP) {
5421             if (SvTAINTED(*MARK)) {
5422                 TAINT;
5423                 break;
5424             }
5425         }
5426         MARK = ORIGMARK;
5427         TAINT_PROPER("syscall");
5428     }
5429
5430     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5431      * or where sizeof(long) != sizeof(char*).  But such machines will
5432      * not likely have syscall implemented either, so who cares?
5433      */
5434     while (++MARK <= SP) {
5435         if (SvNIOK(*MARK) || !i)
5436             a[i++] = SvIV(*MARK);
5437         else if (*MARK == &PL_sv_undef)
5438             a[i++] = 0;
5439         else
5440             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5441         if (i > 15)
5442             break;
5443     }
5444     switch (items) {
5445     default:
5446         DIE(aTHX_ "Too many args to syscall");
5447     case 0:
5448         DIE(aTHX_ "Too few args to syscall");
5449     case 1:
5450         retval = syscall(a[0]);
5451         break;
5452     case 2:
5453         retval = syscall(a[0],a[1]);
5454         break;
5455     case 3:
5456         retval = syscall(a[0],a[1],a[2]);
5457         break;
5458     case 4:
5459         retval = syscall(a[0],a[1],a[2],a[3]);
5460         break;
5461     case 5:
5462         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5463         break;
5464     case 6:
5465         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5466         break;
5467     case 7:
5468         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5469         break;
5470     case 8:
5471         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5472         break;
5473     }
5474     SP = ORIGMARK;
5475     PUSHi(retval);
5476     RETURN;
5477 #else
5478     DIE(aTHX_ PL_no_func, "syscall");
5479 #endif
5480 }
5481
5482 #ifdef FCNTL_EMULATE_FLOCK
5483
5484 /*  XXX Emulate flock() with fcntl().
5485     What's really needed is a good file locking module.
5486 */
5487
5488 static int
5489 fcntl_emulate_flock(int fd, int operation)
5490 {
5491     int res;
5492     struct flock flock;
5493
5494     switch (operation & ~LOCK_NB) {
5495     case LOCK_SH:
5496         flock.l_type = F_RDLCK;
5497         break;
5498     case LOCK_EX:
5499         flock.l_type = F_WRLCK;
5500         break;
5501     case LOCK_UN:
5502         flock.l_type = F_UNLCK;
5503         break;
5504     default:
5505         errno = EINVAL;
5506         return -1;
5507     }
5508     flock.l_whence = SEEK_SET;
5509     flock.l_start = flock.l_len = (Off_t)0;
5510
5511     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5512     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5513         errno = EWOULDBLOCK;
5514     return res;
5515 }
5516
5517 #endif /* FCNTL_EMULATE_FLOCK */
5518
5519 #ifdef LOCKF_EMULATE_FLOCK
5520
5521 /*  XXX Emulate flock() with lockf().  This is just to increase
5522     portability of scripts.  The calls are not completely
5523     interchangeable.  What's really needed is a good file
5524     locking module.
5525 */
5526
5527 /*  The lockf() constants might have been defined in <unistd.h>.
5528     Unfortunately, <unistd.h> causes troubles on some mixed
5529     (BSD/POSIX) systems, such as SunOS 4.1.3.
5530
5531    Further, the lockf() constants aren't POSIX, so they might not be
5532    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5533    just stick in the SVID values and be done with it.  Sigh.
5534 */
5535
5536 # ifndef F_ULOCK
5537 #  define F_ULOCK       0       /* Unlock a previously locked region */
5538 # endif
5539 # ifndef F_LOCK
5540 #  define F_LOCK        1       /* Lock a region for exclusive use */
5541 # endif
5542 # ifndef F_TLOCK
5543 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5544 # endif
5545 # ifndef F_TEST
5546 #  define F_TEST        3       /* Test a region for other processes locks */
5547 # endif
5548
5549 static int
5550 lockf_emulate_flock(int fd, int operation)
5551 {
5552     int i;
5553     Off_t pos;
5554     dSAVE_ERRNO;
5555
5556     /* flock locks entire file so for lockf we need to do the same      */
5557     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5558     if (pos > 0)        /* is seekable and needs to be repositioned     */
5559         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5560             pos = -1;   /* seek failed, so don't seek back afterwards   */
5561     RESTORE_ERRNO;
5562
5563     switch (operation) {
5564
5565         /* LOCK_SH - get a shared lock */
5566         case LOCK_SH:
5567         /* LOCK_EX - get an exclusive lock */
5568         case LOCK_EX:
5569             i = lockf (fd, F_LOCK, 0);
5570             break;
5571
5572         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5573         case LOCK_SH|LOCK_NB:
5574         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5575         case LOCK_EX|LOCK_NB:
5576             i = lockf (fd, F_TLOCK, 0);
5577             if (i == -1)
5578                 if ((errno == EAGAIN) || (errno == EACCES))
5579                     errno = EWOULDBLOCK;
5580             break;
5581
5582         /* LOCK_UN - unlock (non-blocking is a no-op) */
5583         case LOCK_UN:
5584         case LOCK_UN|LOCK_NB:
5585             i = lockf (fd, F_ULOCK, 0);
5586             break;
5587
5588         /* Default - can't decipher operation */
5589         default:
5590             i = -1;
5591             errno = EINVAL;
5592             break;
5593     }
5594
5595     if (pos > 0)      /* need to restore position of the handle */
5596         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5597
5598     return (i);
5599 }
5600
5601 #endif /* LOCKF_EMULATE_FLOCK */
5602
5603 /*
5604  * Local variables:
5605  * c-indentation-style: bsd
5606  * c-basic-offset: 4
5607  * indent-tabs-mode: nil
5608  * End:
5609  *
5610  * ex: set ts=8 sts=4 sw=4 et:
5611  */