pp_sys.c

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