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