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