pp_sys.c

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