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