pp_sys.c

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