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