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