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