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