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