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 #ifdef THREADS_HAVE_PIDS
4021         PL_ppid = (IV)getppid();
4022 #endif
4023 #ifdef PERL_USES_PL_PIDSTATUS
4024         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4025 #endif
4026     }
4027     PUSHi(childpid);
4028     RETURN;
4029 #else
4030 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4031     dSP; dTARGET;
4032     Pid_t childpid;
4033
4034     EXTEND(SP, 1);
4035     PERL_FLUSHALL_FOR_CHILD;
4036     childpid = PerlProc_fork();
4037     if (childpid == -1)
4038         RETSETUNDEF;
4039     PUSHi(childpid);
4040     RETURN;
4041 #  else
4042     DIE(aTHX_ PL_no_func, "fork");
4043 #  endif
4044 #endif
4045 }
4046
4047 PP(pp_wait)
4048 {
4049 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4050     dVAR; dSP; dTARGET;
4051     Pid_t childpid;
4052     int argflags;
4053
4054     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4055         childpid = wait4pid(-1, &argflags, 0);
4056     else {
4057         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4058                errno == EINTR) {
4059           PERL_ASYNC_CHECK();
4060         }
4061     }
4062 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4063     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4064     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4065 #  else
4066     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4067 #  endif
4068     XPUSHi(childpid);
4069     RETURN;
4070 #else
4071     DIE(aTHX_ PL_no_func, "wait");
4072 #endif
4073 }
4074
4075 PP(pp_waitpid)
4076 {
4077 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4078     dVAR; dSP; dTARGET;
4079     const int optype = POPi;
4080     const Pid_t pid = TOPi;
4081     Pid_t result;
4082     int argflags;
4083
4084     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4085         result = wait4pid(pid, &argflags, optype);
4086     else {
4087         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4088                errno == EINTR) {
4089           PERL_ASYNC_CHECK();
4090         }
4091     }
4092 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4093     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4094     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4095 #  else
4096     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4097 #  endif
4098     SETi(result);
4099     RETURN;
4100 #else
4101     DIE(aTHX_ PL_no_func, "waitpid");
4102 #endif
4103 }
4104
4105 PP(pp_system)
4106 {
4107     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4108 #if defined(__LIBCATAMOUNT__)
4109     PL_statusvalue = -1;
4110     SP = ORIGMARK;
4111     XPUSHi(-1);
4112 #else
4113     I32 value;
4114     int result;
4115
4116     if (PL_tainting) {
4117         TAINT_ENV();
4118         while (++MARK <= SP) {
4119             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4120             if (PL_tainted)
4121                 break;
4122         }
4123         MARK = ORIGMARK;
4124         TAINT_PROPER("system");
4125     }
4126     PERL_FLUSHALL_FOR_CHILD;
4127 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4128     {
4129         Pid_t childpid;
4130         int pp[2];
4131         I32 did_pipes = 0;
4132
4133         if (PerlProc_pipe(pp) >= 0)
4134             did_pipes = 1;
4135         while ((childpid = PerlProc_fork()) == -1) {
4136             if (errno != EAGAIN) {
4137                 value = -1;
4138                 SP = ORIGMARK;
4139                 XPUSHi(value);
4140                 if (did_pipes) {
4141                     PerlLIO_close(pp[0]);
4142                     PerlLIO_close(pp[1]);
4143                 }
4144                 RETURN;
4145             }
4146             sleep(5);
4147         }
4148         if (childpid > 0) {
4149             Sigsave_t ihand,qhand; /* place to save signals during system() */
4150             int status;
4151
4152             if (did_pipes)
4153                 PerlLIO_close(pp[1]);
4154 #ifndef PERL_MICRO
4155             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4156             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4157 #endif
4158             do {
4159                 result = wait4pid(childpid, &status, 0);
4160             } while (result == -1 && errno == EINTR);
4161 #ifndef PERL_MICRO
4162             (void)rsignal_restore(SIGINT, &ihand);
4163             (void)rsignal_restore(SIGQUIT, &qhand);
4164 #endif
4165             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4166             do_execfree();      /* free any memory child malloced on fork */
4167             SP = ORIGMARK;
4168             if (did_pipes) {
4169                 int errkid;
4170                 unsigned n = 0;
4171                 SSize_t n1;
4172
4173                 while (n < sizeof(int)) {
4174                     n1 = PerlLIO_read(pp[0],
4175                                       (void*)(((char*)&errkid)+n),
4176                                       (sizeof(int)) - n);
4177                     if (n1 <= 0)
4178                         break;
4179                     n += n1;
4180                 }
4181                 PerlLIO_close(pp[0]);
4182                 if (n) {                        /* Error */
4183                     if (n != sizeof(int))
4184                         DIE(aTHX_ "panic: kid popen errno read");
4185                     errno = errkid;             /* Propagate errno from kid */
4186                     STATUS_NATIVE_CHILD_SET(-1);
4187                 }
4188             }
4189             XPUSHi(STATUS_CURRENT);
4190             RETURN;
4191         }
4192         if (did_pipes) {
4193             PerlLIO_close(pp[0]);
4194 #if defined(HAS_FCNTL) && defined(F_SETFD)
4195             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4196 #endif
4197         }
4198         if (PL_op->op_flags & OPf_STACKED) {
4199             SV * const really = *++MARK;
4200             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4201         }
4202         else if (SP - MARK != 1)
4203             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4204         else {
4205             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4206         }
4207         PerlProc__exit(-1);
4208     }
4209 #else /* ! FORK or VMS or OS/2 */
4210     PL_statusvalue = 0;
4211     result = 0;
4212     if (PL_op->op_flags & OPf_STACKED) {
4213         SV * const really = *++MARK;
4214 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4215         value = (I32)do_aspawn(really, MARK, SP);
4216 #  else
4217         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4218 #  endif
4219     }
4220     else if (SP - MARK != 1) {
4221 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4222         value = (I32)do_aspawn(NULL, MARK, SP);
4223 #  else
4224         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4225 #  endif
4226     }
4227     else {
4228         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4229     }
4230     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4231         result = 1;
4232     STATUS_NATIVE_CHILD_SET(value);
4233     do_execfree();
4234     SP = ORIGMARK;
4235     XPUSHi(result ? value : STATUS_CURRENT);
4236 #endif /* !FORK or VMS or OS/2 */
4237 #endif
4238     RETURN;
4239 }
4240
4241 PP(pp_exec)
4242 {
4243     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4244     I32 value;
4245
4246     if (PL_tainting) {
4247         TAINT_ENV();
4248         while (++MARK <= SP) {
4249             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4250             if (PL_tainted)
4251                 break;
4252         }
4253         MARK = ORIGMARK;
4254         TAINT_PROPER("exec");
4255     }
4256     PERL_FLUSHALL_FOR_CHILD;
4257     if (PL_op->op_flags & OPf_STACKED) {
4258         SV * const really = *++MARK;
4259         value = (I32)do_aexec(really, MARK, SP);
4260     }
4261     else if (SP - MARK != 1)
4262 #ifdef VMS
4263         value = (I32)vms_do_aexec(NULL, MARK, SP);
4264 #else
4265 #  ifdef __OPEN_VM
4266         {
4267            (void ) do_aspawn(NULL, MARK, SP);
4268            value = 0;
4269         }
4270 #  else
4271         value = (I32)do_aexec(NULL, MARK, SP);
4272 #  endif
4273 #endif
4274     else {
4275 #ifdef VMS
4276         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4277 #else
4278 #  ifdef __OPEN_VM
4279         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4280         value = 0;
4281 #  else
4282         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4283 #  endif
4284 #endif
4285     }
4286
4287     SP = ORIGMARK;
4288     XPUSHi(value);
4289     RETURN;
4290 }
4291
4292 PP(pp_getppid)
4293 {
4294 #ifdef HAS_GETPPID
4295     dVAR; dSP; dTARGET;
4296 #   ifdef THREADS_HAVE_PIDS
4297     if (PL_ppid != 1 && getppid() == 1)
4298         /* maybe the parent process has died. Refresh ppid cache */
4299         PL_ppid = 1;
4300     XPUSHi( PL_ppid );
4301 #   else
4302     XPUSHi( getppid() );
4303 #   endif
4304     RETURN;
4305 #else
4306     DIE(aTHX_ PL_no_func, "getppid");
4307 #endif
4308 }
4309
4310 PP(pp_getpgrp)
4311 {
4312 #ifdef HAS_GETPGRP
4313     dVAR; dSP; dTARGET;
4314     Pid_t pgrp;
4315     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4316
4317 #ifdef BSD_GETPGRP
4318     pgrp = (I32)BSD_GETPGRP(pid);
4319 #else
4320     if (pid != 0 && pid != PerlProc_getpid())
4321         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4322     pgrp = getpgrp();
4323 #endif
4324     XPUSHi(pgrp);
4325     RETURN;
4326 #else
4327     DIE(aTHX_ PL_no_func, "getpgrp()");
4328 #endif
4329 }
4330
4331 PP(pp_setpgrp)
4332 {
4333 #ifdef HAS_SETPGRP
4334     dVAR; dSP; dTARGET;
4335     Pid_t pgrp;
4336     Pid_t pid;
4337     if (MAXARG < 2) {
4338         pgrp = 0;
4339         pid = 0;
4340         XPUSHi(-1);
4341     }
4342     else {
4343         pgrp = POPi;
4344         pid = TOPi;
4345     }
4346
4347     TAINT_PROPER("setpgrp");
4348 #ifdef BSD_SETPGRP
4349     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4350 #else
4351     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4352         || (pid != 0 && pid != PerlProc_getpid()))
4353     {
4354         DIE(aTHX_ "setpgrp can't take arguments");
4355     }
4356     SETi( setpgrp() >= 0 );
4357 #endif /* USE_BSDPGRP */
4358     RETURN;
4359 #else
4360     DIE(aTHX_ PL_no_func, "setpgrp()");
4361 #endif
4362 }
4363
4364 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4365 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4366 #else
4367 #  define PRIORITY_WHICH_T(which) which
4368 #endif
4369
4370 PP(pp_getpriority)
4371 {
4372 #ifdef HAS_GETPRIORITY
4373     dVAR; dSP; dTARGET;
4374     const int who = POPi;
4375     const int which = TOPi;
4376     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4377     RETURN;
4378 #else
4379     DIE(aTHX_ PL_no_func, "getpriority()");
4380 #endif
4381 }
4382
4383 PP(pp_setpriority)
4384 {
4385 #ifdef HAS_SETPRIORITY
4386     dVAR; dSP; dTARGET;
4387     const int niceval = POPi;
4388     const int who = POPi;
4389     const int which = TOPi;
4390     TAINT_PROPER("setpriority");
4391     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4392     RETURN;
4393 #else
4394     DIE(aTHX_ PL_no_func, "setpriority()");
4395 #endif
4396 }
4397
4398 #undef PRIORITY_WHICH_T
4399
4400 /* Time calls. */
4401
4402 PP(pp_time)
4403 {
4404     dVAR; dSP; dTARGET;
4405 #ifdef BIG_TIME
4406     XPUSHn( time(NULL) );
4407 #else
4408     XPUSHi( time(NULL) );
4409 #endif
4410     RETURN;
4411 }
4412
4413 PP(pp_tms)
4414 {
4415 #ifdef HAS_TIMES
4416     dVAR;
4417     dSP;
4418     EXTEND(SP, 4);
4419 #ifndef VMS
4420     (void)PerlProc_times(&PL_timesbuf);
4421 #else
4422     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4423                                                    /* struct tms, though same data   */
4424                                                    /* is returned.                   */
4425 #endif
4426
4427     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4428     if (GIMME == G_ARRAY) {
4429         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4430         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4431         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4432     }
4433     RETURN;
4434 #else
4435 #   ifdef PERL_MICRO
4436     dSP;
4437     mPUSHn(0.0);
4438     EXTEND(SP, 4);
4439     if (GIMME == G_ARRAY) {
4440          mPUSHn(0.0);
4441          mPUSHn(0.0);
4442          mPUSHn(0.0);
4443     }
4444     RETURN;
4445 #   else
4446     DIE(aTHX_ "times not implemented");
4447 #   endif
4448 #endif /* HAS_TIMES */
4449 }
4450
4451 /* The 32 bit int year limits the times we can represent to these
4452    boundaries with a few days wiggle room to account for time zone
4453    offsets
4454 */
4455 /* Sat Jan  3 00:00:00 -2147481748 */
4456 #define TIME_LOWER_BOUND -67768100567755200.0
4457 /* Sun Dec 29 12:00:00  2147483647 */
4458 #define TIME_UPPER_BOUND  67767976233316800.0
4459
4460 PP(pp_gmtime)
4461 {
4462     dVAR;
4463     dSP;
4464     Time64_T when;
4465     struct TM tmbuf;
4466     struct TM *err;
4467     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4468     static const char * const dayname[] =
4469         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4470     static const char * const monname[] =
4471         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4472          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4473
4474     if (MAXARG < 1) {
4475         time_t now;
4476         (void)time(&now);
4477         when = (Time64_T)now;
4478     }
4479     else {
4480         NV input = Perl_floor(POPn);
4481         when = (Time64_T)input;
4482         if (when != input) {
4483             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4484                            "%s(%.0" NVff ") too large", opname, input);
4485         }
4486     }
4487
4488     if ( TIME_LOWER_BOUND > when ) {
4489         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4490                        "%s(%.0" NVff ") too small", opname, when);
4491         err = NULL;
4492     }
4493     else if( when > TIME_UPPER_BOUND ) {
4494         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4495                        "%s(%.0" NVff ") too large", opname, when);
4496         err = NULL;
4497     }
4498     else {
4499         if (PL_op->op_type == OP_LOCALTIME)
4500             err = S_localtime64_r(&when, &tmbuf);
4501         else
4502             err = S_gmtime64_r(&when, &tmbuf);
4503     }
4504
4505     if (err == NULL) {
4506         /* XXX %lld broken for quads */
4507         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4508                        "%s(%.0" NVff ") failed", opname, when);
4509     }
4510
4511     if (GIMME != G_ARRAY) {     /* scalar context */
4512         SV *tsv;
4513         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4514         double year = (double)tmbuf.tm_year + 1900;
4515
4516         EXTEND(SP, 1);
4517         EXTEND_MORTAL(1);
4518         if (err == NULL)
4519             RETPUSHUNDEF;
4520
4521         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4522                             dayname[tmbuf.tm_wday],
4523                             monname[tmbuf.tm_mon],
4524                             tmbuf.tm_mday,
4525                             tmbuf.tm_hour,
4526                             tmbuf.tm_min,
4527                             tmbuf.tm_sec,
4528                             year);
4529         mPUSHs(tsv);
4530     }
4531     else {                      /* list context */
4532         if ( err == NULL )
4533             RETURN;
4534
4535         EXTEND(SP, 9);
4536         EXTEND_MORTAL(9);
4537         mPUSHi(tmbuf.tm_sec);
4538         mPUSHi(tmbuf.tm_min);
4539         mPUSHi(tmbuf.tm_hour);
4540         mPUSHi(tmbuf.tm_mday);
4541         mPUSHi(tmbuf.tm_mon);
4542         mPUSHn(tmbuf.tm_year);
4543         mPUSHi(tmbuf.tm_wday);
4544         mPUSHi(tmbuf.tm_yday);
4545         mPUSHi(tmbuf.tm_isdst);
4546     }
4547     RETURN;
4548 }
4549
4550 PP(pp_alarm)
4551 {
4552 #ifdef HAS_ALARM
4553     dVAR; dSP; dTARGET;
4554     int anum;
4555     anum = POPi;
4556     anum = alarm((unsigned int)anum);
4557     if (anum < 0)
4558         RETPUSHUNDEF;
4559     PUSHi(anum);
4560     RETURN;
4561 #else
4562     DIE(aTHX_ PL_no_func, "alarm");
4563 #endif
4564 }
4565
4566 PP(pp_sleep)
4567 {
4568     dVAR; dSP; dTARGET;
4569     I32 duration;
4570     Time_t lasttime;
4571     Time_t when;
4572
4573     (void)time(&lasttime);
4574     if (MAXARG < 1)
4575         PerlProc_pause();
4576     else {
4577         duration = POPi;
4578         PerlProc_sleep((unsigned int)duration);
4579     }
4580     (void)time(&when);
4581     XPUSHi(when - lasttime);
4582     RETURN;
4583 }
4584
4585 /* Shared memory. */
4586 /* Merged with some message passing. */
4587
4588 PP(pp_shmwrite)
4589 {
4590 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4591     dVAR; dSP; dMARK; dTARGET;
4592     const int op_type = PL_op->op_type;
4593     I32 value;
4594
4595     switch (op_type) {
4596     case OP_MSGSND:
4597         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4598         break;
4599     case OP_MSGRCV:
4600         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4601         break;
4602     case OP_SEMOP:
4603         value = (I32)(do_semop(MARK, SP) >= 0);
4604         break;
4605     default:
4606         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4607         break;
4608     }
4609
4610     SP = MARK;
4611     PUSHi(value);
4612     RETURN;
4613 #else
4614     return Perl_pp_semget(aTHX);
4615 #endif
4616 }
4617
4618 /* Semaphores. */
4619
4620 PP(pp_semget)
4621 {
4622 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4623     dVAR; dSP; dMARK; dTARGET;
4624     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4625     SP = MARK;
4626     if (anum == -1)
4627         RETPUSHUNDEF;
4628     PUSHi(anum);
4629     RETURN;
4630 #else
4631     DIE(aTHX_ "System V IPC is not implemented on this machine");
4632 #endif
4633 }
4634
4635 PP(pp_semctl)
4636 {
4637 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4638     dVAR; dSP; dMARK; dTARGET;
4639     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4640     SP = MARK;
4641     if (anum == -1)
4642         RETSETUNDEF;
4643     if (anum != 0) {
4644         PUSHi(anum);
4645     }
4646     else {
4647         PUSHp(zero_but_true, ZBTLEN);
4648     }
4649     RETURN;
4650 #else
4651     return Perl_pp_semget(aTHX);
4652 #endif
4653 }
4654
4655 /* I can't const this further without getting warnings about the types of
4656    various arrays passed in from structures.  */
4657 static SV *
4658 S_space_join_names_mortal(pTHX_ char *const *array)
4659 {
4660     SV *target;
4661
4662     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4663
4664     if (array && *array) {
4665         target = newSVpvs_flags("", SVs_TEMP);
4666         while (1) {
4667             sv_catpv(target, *array);
4668             if (!*++array)
4669                 break;
4670             sv_catpvs(target, " ");
4671         }
4672     } else {
4673         target = sv_mortalcopy(&PL_sv_no);
4674     }
4675     return target;
4676 }
4677
4678 /* Get system info. */
4679
4680 PP(pp_ghostent)
4681 {
4682 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4683     dVAR; dSP;
4684     I32 which = PL_op->op_type;
4685     register char **elem;
4686     register SV *sv;
4687 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4688     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4689     struct hostent *gethostbyname(Netdb_name_t);
4690     struct hostent *gethostent(void);
4691 #endif
4692     struct hostent *hent = NULL;
4693     unsigned long len;
4694
4695     EXTEND(SP, 10);
4696     if (which == OP_GHBYNAME) {
4697 #ifdef HAS_GETHOSTBYNAME
4698         const char* const name = POPpbytex;
4699         hent = PerlSock_gethostbyname(name);
4700 #else
4701         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4702 #endif
4703     }
4704     else if (which == OP_GHBYADDR) {
4705 #ifdef HAS_GETHOSTBYADDR
4706         const int addrtype = POPi;
4707         SV * const addrsv = POPs;
4708         STRLEN addrlen;
4709         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4710
4711         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4712 #else
4713         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4714 #endif
4715     }
4716     else
4717 #ifdef HAS_GETHOSTENT
4718         hent = PerlSock_gethostent();
4719 #else
4720         DIE(aTHX_ PL_no_sock_func, "gethostent");
4721 #endif
4722
4723 #ifdef HOST_NOT_FOUND
4724         if (!hent) {
4725 #ifdef USE_REENTRANT_API
4726 #   ifdef USE_GETHOSTENT_ERRNO
4727             h_errno = PL_reentrant_buffer->_gethostent_errno;
4728 #   endif
4729 #endif
4730             STATUS_UNIX_SET(h_errno);
4731         }
4732 #endif
4733
4734     if (GIMME != G_ARRAY) {
4735         PUSHs(sv = sv_newmortal());
4736         if (hent) {
4737             if (which == OP_GHBYNAME) {
4738                 if (hent->h_addr)
4739                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4740             }
4741             else
4742                 sv_setpv(sv, (char*)hent->h_name);
4743         }
4744         RETURN;
4745     }
4746
4747     if (hent) {
4748         mPUSHs(newSVpv((char*)hent->h_name, 0));
4749         PUSHs(space_join_names_mortal(hent->h_aliases));
4750         mPUSHi(hent->h_addrtype);
4751         len = hent->h_length;
4752         mPUSHi(len);
4753 #ifdef h_addr
4754         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4755             mXPUSHp(*elem, len);
4756         }
4757 #else
4758         if (hent->h_addr)
4759             mPUSHp(hent->h_addr, len);
4760         else
4761             PUSHs(sv_mortalcopy(&PL_sv_no));
4762 #endif /* h_addr */
4763     }
4764     RETURN;
4765 #else
4766     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4767 #endif
4768 }
4769
4770 PP(pp_gnetent)
4771 {
4772 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4773     dVAR; dSP;
4774     I32 which = PL_op->op_type;
4775     register SV *sv;
4776 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4777     struct netent *getnetbyaddr(Netdb_net_t, int);
4778     struct netent *getnetbyname(Netdb_name_t);
4779     struct netent *getnetent(void);
4780 #endif
4781     struct netent *nent;
4782
4783     if (which == OP_GNBYNAME){
4784 #ifdef HAS_GETNETBYNAME
4785         const char * const name = POPpbytex;
4786         nent = PerlSock_getnetbyname(name);
4787 #else
4788         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4789 #endif
4790     }
4791     else if (which == OP_GNBYADDR) {
4792 #ifdef HAS_GETNETBYADDR
4793         const int addrtype = POPi;
4794         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4795         nent = PerlSock_getnetbyaddr(addr, addrtype);
4796 #else
4797         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4798 #endif
4799     }
4800     else
4801 #ifdef HAS_GETNETENT
4802         nent = PerlSock_getnetent();
4803 #else
4804         DIE(aTHX_ PL_no_sock_func, "getnetent");
4805 #endif
4806
4807 #ifdef HOST_NOT_FOUND
4808         if (!nent) {
4809 #ifdef USE_REENTRANT_API
4810 #   ifdef USE_GETNETENT_ERRNO
4811              h_errno = PL_reentrant_buffer->_getnetent_errno;
4812 #   endif
4813 #endif
4814             STATUS_UNIX_SET(h_errno);
4815         }
4816 #endif
4817
4818     EXTEND(SP, 4);
4819     if (GIMME != G_ARRAY) {
4820         PUSHs(sv = sv_newmortal());
4821         if (nent) {
4822             if (which == OP_GNBYNAME)
4823                 sv_setiv(sv, (IV)nent->n_net);
4824             else
4825                 sv_setpv(sv, nent->n_name);
4826         }
4827         RETURN;
4828     }
4829
4830     if (nent) {
4831         mPUSHs(newSVpv(nent->n_name, 0));
4832         PUSHs(space_join_names_mortal(nent->n_aliases));
4833         mPUSHi(nent->n_addrtype);
4834         mPUSHi(nent->n_net);
4835     }
4836
4837     RETURN;
4838 #else
4839     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4840 #endif
4841 }
4842
4843 PP(pp_gprotoent)
4844 {
4845 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4846     dVAR; dSP;
4847     I32 which = PL_op->op_type;
4848     register SV *sv;
4849 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4850     struct protoent *getprotobyname(Netdb_name_t);
4851     struct protoent *getprotobynumber(int);
4852     struct protoent *getprotoent(void);
4853 #endif
4854     struct protoent *pent;
4855
4856     if (which == OP_GPBYNAME) {
4857 #ifdef HAS_GETPROTOBYNAME
4858         const char* const name = POPpbytex;
4859         pent = PerlSock_getprotobyname(name);
4860 #else
4861         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4862 #endif
4863     }
4864     else if (which == OP_GPBYNUMBER) {
4865 #ifdef HAS_GETPROTOBYNUMBER
4866         const int number = POPi;
4867         pent = PerlSock_getprotobynumber(number);
4868 #else
4869         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4870 #endif
4871     }
4872     else
4873 #ifdef HAS_GETPROTOENT
4874         pent = PerlSock_getprotoent();
4875 #else
4876         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4877 #endif
4878
4879     EXTEND(SP, 3);
4880     if (GIMME != G_ARRAY) {
4881         PUSHs(sv = sv_newmortal());
4882         if (pent) {
4883             if (which == OP_GPBYNAME)
4884                 sv_setiv(sv, (IV)pent->p_proto);
4885             else
4886                 sv_setpv(sv, pent->p_name);
4887         }
4888         RETURN;
4889     }
4890
4891     if (pent) {
4892         mPUSHs(newSVpv(pent->p_name, 0));
4893         PUSHs(space_join_names_mortal(pent->p_aliases));
4894         mPUSHi(pent->p_proto);
4895     }
4896
4897     RETURN;
4898 #else
4899     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4900 #endif
4901 }
4902
4903 PP(pp_gservent)
4904 {
4905 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4906     dVAR; dSP;
4907     I32 which = PL_op->op_type;
4908     register SV *sv;
4909 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4910     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4911     struct servent *getservbyport(int, Netdb_name_t);
4912     struct servent *getservent(void);
4913 #endif
4914     struct servent *sent;
4915
4916     if (which == OP_GSBYNAME) {
4917 #ifdef HAS_GETSERVBYNAME
4918         const char * const proto = POPpbytex;
4919         const char * const name = POPpbytex;
4920         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4921 #else
4922         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4923 #endif
4924     }
4925     else if (which == OP_GSBYPORT) {
4926 #ifdef HAS_GETSERVBYPORT
4927         const char * const proto = POPpbytex;
4928         unsigned short port = (unsigned short)POPu;
4929 #ifdef HAS_HTONS
4930         port = PerlSock_htons(port);
4931 #endif
4932         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4933 #else
4934         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4935 #endif
4936     }
4937     else
4938 #ifdef HAS_GETSERVENT
4939         sent = PerlSock_getservent();
4940 #else
4941         DIE(aTHX_ PL_no_sock_func, "getservent");
4942 #endif
4943
4944     EXTEND(SP, 4);
4945     if (GIMME != G_ARRAY) {
4946         PUSHs(sv = sv_newmortal());
4947         if (sent) {
4948             if (which == OP_GSBYNAME) {
4949 #ifdef HAS_NTOHS
4950                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4951 #else
4952                 sv_setiv(sv, (IV)(sent->s_port));
4953 #endif
4954             }
4955             else
4956                 sv_setpv(sv, sent->s_name);
4957         }
4958         RETURN;
4959     }
4960
4961     if (sent) {
4962         mPUSHs(newSVpv(sent->s_name, 0));
4963         PUSHs(space_join_names_mortal(sent->s_aliases));
4964 #ifdef HAS_NTOHS
4965         mPUSHi(PerlSock_ntohs(sent->s_port));
4966 #else
4967         mPUSHi(sent->s_port);
4968 #endif
4969         mPUSHs(newSVpv(sent->s_proto, 0));
4970     }
4971
4972     RETURN;
4973 #else
4974     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4975 #endif
4976 }
4977
4978 PP(pp_shostent)
4979 {
4980     dVAR; dSP;
4981     const int stayopen = TOPi;
4982     switch(PL_op->op_type) {
4983     case OP_SHOSTENT:
4984 #ifdef HAS_SETHOSTENT
4985         PerlSock_sethostent(stayopen);
4986 #else
4987         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4988 #endif
4989         break;
4990 #ifdef HAS_SETNETENT
4991     case OP_SNETENT:
4992         PerlSock_setnetent(stayopen);
4993 #else
4994         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4995 #endif
4996         break;
4997     case OP_SPROTOENT:
4998 #ifdef HAS_SETPROTOENT
4999         PerlSock_setprotoent(stayopen);
5000 #else
5001         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5002 #endif
5003         break;
5004     case OP_SSERVENT:
5005 #ifdef HAS_SETSERVENT
5006         PerlSock_setservent(stayopen);
5007 #else
5008         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5009 #endif
5010         break;
5011     }
5012     RETSETYES;
5013 }
5014
5015 PP(pp_ehostent)
5016 {
5017     dVAR; dSP;
5018     switch(PL_op->op_type) {
5019     case OP_EHOSTENT:
5020 #ifdef HAS_ENDHOSTENT
5021         PerlSock_endhostent();
5022 #else
5023         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5024 #endif
5025         break;
5026     case OP_ENETENT:
5027 #ifdef HAS_ENDNETENT
5028         PerlSock_endnetent();
5029 #else
5030         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5031 #endif
5032         break;
5033     case OP_EPROTOENT:
5034 #ifdef HAS_ENDPROTOENT
5035         PerlSock_endprotoent();
5036 #else
5037         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5038 #endif
5039         break;
5040     case OP_ESERVENT:
5041 #ifdef HAS_ENDSERVENT
5042         PerlSock_endservent();
5043 #else
5044         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5045 #endif
5046         break;
5047     case OP_SGRENT:
5048 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5049         setgrent();
5050 #else
5051         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5052 #endif
5053         break;
5054     case OP_EGRENT:
5055 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5056         endgrent();
5057 #else
5058         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5059 #endif
5060         break;
5061     case OP_SPWENT:
5062 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5063         setpwent();
5064 #else
5065         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5066 #endif
5067         break;
5068     case OP_EPWENT:
5069 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5070         endpwent();
5071 #else
5072         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5073 #endif
5074         break;
5075     }
5076     EXTEND(SP,1);
5077     RETPUSHYES;
5078 }
5079
5080 PP(pp_gpwent)
5081 {
5082 #ifdef HAS_PASSWD
5083     dVAR; dSP;
5084     I32 which = PL_op->op_type;
5085     register SV *sv;
5086     struct passwd *pwent  = NULL;
5087     /*
5088      * We currently support only the SysV getsp* shadow password interface.
5089      * The interface is declared in <shadow.h> and often one needs to link
5090      * with -lsecurity or some such.
5091      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5092      * (and SCO?)
5093      *
5094      * AIX getpwnam() is clever enough to return the encrypted password
5095      * only if the caller (euid?) is root.
5096      *
5097      * There are at least three other shadow password APIs.  Many platforms
5098      * seem to contain more than one interface for accessing the shadow
5099      * password databases, possibly for compatibility reasons.
5100      * The getsp*() is by far he simplest one, the other two interfaces
5101      * are much more complicated, but also very similar to each other.
5102      *
5103      * <sys/types.h>
5104      * <sys/security.h>
5105      * <prot.h>
5106      * struct pr_passwd *getprpw*();
5107      * The password is in
5108      * char getprpw*(...).ufld.fd_encrypt[]
5109      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5110      *
5111      * <sys/types.h>
5112      * <sys/security.h>
5113      * <prot.h>
5114      * struct es_passwd *getespw*();
5115      * The password is in
5116      * char *(getespw*(...).ufld.fd_encrypt)
5117      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5118      *
5119      * <userpw.h> (AIX)
5120      * struct userpw *getuserpw();
5121      * The password is in
5122      * char *(getuserpw(...)).spw_upw_passwd
5123      * (but the de facto standard getpwnam() should work okay)
5124      *
5125      * Mention I_PROT here so that Configure probes for it.
5126      *
5127      * In HP-UX for getprpw*() the manual page claims that one should include
5128      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5129      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5130      * and pp_sys.c already includes <shadow.h> if there is such.
5131      *
5132      * Note that <sys/security.h> is already probed for, but currently
5133      * it is only included in special cases.
5134      *
5135      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5136      * be preferred interface, even though also the getprpw*() interface
5137      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5138      * One also needs to call set_auth_parameters() in main() before
5139      * doing anything else, whether one is using getespw*() or getprpw*().
5140      *
5141      * Note that accessing the shadow databases can be magnitudes
5142      * slower than accessing the standard databases.
5143      *
5144      * --jhi
5145      */
5146
5147 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5148     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5149      * the pw_comment is left uninitialized. */
5150     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5151 #   endif
5152
5153     switch (which) {
5154     case OP_GPWNAM:
5155       {
5156         const char* const name = POPpbytex;
5157         pwent  = getpwnam(name);
5158       }
5159       break;
5160     case OP_GPWUID:
5161       {
5162         Uid_t uid = POPi;
5163         pwent = getpwuid(uid);
5164       }
5165         break;
5166     case OP_GPWENT:
5167 #   ifdef HAS_GETPWENT
5168         pwent  = getpwent();
5169 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5170         if (pwent) pwent = getpwnam(pwent->pw_name);
5171 #endif
5172 #   else
5173         DIE(aTHX_ PL_no_func, "getpwent");
5174 #   endif
5175         break;
5176     }
5177
5178     EXTEND(SP, 10);
5179     if (GIMME != G_ARRAY) {
5180         PUSHs(sv = sv_newmortal());
5181         if (pwent) {
5182             if (which == OP_GPWNAM)
5183 #   if Uid_t_sign <= 0
5184                 sv_setiv(sv, (IV)pwent->pw_uid);
5185 #   else
5186                 sv_setuv(sv, (UV)pwent->pw_uid);
5187 #   endif
5188             else
5189                 sv_setpv(sv, pwent->pw_name);
5190         }
5191         RETURN;
5192     }
5193
5194     if (pwent) {
5195         mPUSHs(newSVpv(pwent->pw_name, 0));
5196
5197         sv = newSViv(0);
5198         mPUSHs(sv);
5199         /* If we have getspnam(), we try to dig up the shadow
5200          * password.  If we are underprivileged, the shadow
5201          * interface will set the errno to EACCES or similar,
5202          * and return a null pointer.  If this happens, we will
5203          * use the dummy password (usually "*" or "x") from the
5204          * standard password database.
5205          *
5206          * In theory we could skip the shadow call completely
5207          * if euid != 0 but in practice we cannot know which
5208          * security measures are guarding the shadow databases
5209          * on a random platform.
5210          *
5211          * Resist the urge to use additional shadow interfaces.
5212          * Divert the urge to writing an extension instead.
5213          *
5214          * --jhi */
5215         /* Some AIX setups falsely(?) detect some getspnam(), which
5216          * has a different API than the Solaris/IRIX one. */
5217 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5218         {
5219             dSAVE_ERRNO;
5220             const struct spwd * const spwent = getspnam(pwent->pw_name);
5221                           /* Save and restore errno so that
5222                            * underprivileged attempts seem
5223                            * to have never made the unsuccessful
5224                            * attempt to retrieve the shadow password. */
5225             RESTORE_ERRNO;
5226             if (spwent && spwent->sp_pwdp)
5227                 sv_setpv(sv, spwent->sp_pwdp);
5228         }
5229 #   endif
5230 #   ifdef PWPASSWD
5231         if (!SvPOK(sv)) /* Use the standard password, then. */
5232             sv_setpv(sv, pwent->pw_passwd);
5233 #   endif
5234
5235 #   ifndef INCOMPLETE_TAINTS
5236         /* passwd is tainted because user himself can diddle with it.
5237          * admittedly not much and in a very limited way, but nevertheless. */
5238         SvTAINTED_on(sv);
5239 #   endif
5240
5241 #   if Uid_t_sign <= 0
5242         mPUSHi(pwent->pw_uid);
5243 #   else
5244         mPUSHu(pwent->pw_uid);
5245 #   endif
5246
5247 #   if Uid_t_sign <= 0
5248         mPUSHi(pwent->pw_gid);
5249 #   else
5250         mPUSHu(pwent->pw_gid);
5251 #   endif
5252         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5253          * because of the poor interface of the Perl getpw*(),
5254          * not because there's some standard/convention saying so.
5255          * A better interface would have been to return a hash,
5256          * but we are accursed by our history, alas. --jhi.  */
5257 #   ifdef PWCHANGE
5258         mPUSHi(pwent->pw_change);
5259 #   else
5260 #       ifdef PWQUOTA
5261         mPUSHi(pwent->pw_quota);
5262 #       else
5263 #           ifdef PWAGE
5264         mPUSHs(newSVpv(pwent->pw_age, 0));
5265 #           else
5266         /* I think that you can never get this compiled, but just in case.  */
5267         PUSHs(sv_mortalcopy(&PL_sv_no));
5268 #           endif
5269 #       endif
5270 #   endif
5271
5272         /* pw_class and pw_comment are mutually exclusive--.
5273          * see the above note for pw_change, pw_quota, and pw_age. */
5274 #   ifdef PWCLASS
5275         mPUSHs(newSVpv(pwent->pw_class, 0));
5276 #   else
5277 #       ifdef PWCOMMENT
5278         mPUSHs(newSVpv(pwent->pw_comment, 0));
5279 #       else
5280         /* I think that you can never get this compiled, but just in case.  */
5281         PUSHs(sv_mortalcopy(&PL_sv_no));
5282 #       endif
5283 #   endif
5284
5285 #   ifdef PWGECOS
5286         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5287 #   else
5288         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5289 #   endif
5290 #   ifndef INCOMPLETE_TAINTS
5291         /* pw_gecos is tainted because user himself can diddle with it. */
5292         SvTAINTED_on(sv);
5293 #   endif
5294
5295         mPUSHs(newSVpv(pwent->pw_dir, 0));
5296
5297         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5298 #   ifndef INCOMPLETE_TAINTS
5299         /* pw_shell is tainted because user himself can diddle with it. */
5300         SvTAINTED_on(sv);
5301 #   endif
5302
5303 #   ifdef PWEXPIRE
5304         mPUSHi(pwent->pw_expire);
5305 #   endif
5306     }
5307     RETURN;
5308 #else
5309     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5310 #endif
5311 }
5312
5313 PP(pp_ggrent)
5314 {
5315 #ifdef HAS_GROUP
5316     dVAR; dSP;
5317     const I32 which = PL_op->op_type;
5318     const struct group *grent;
5319
5320     if (which == OP_GGRNAM) {
5321         const char* const name = POPpbytex;
5322         grent = (const struct group *)getgrnam(name);
5323     }
5324     else if (which == OP_GGRGID) {
5325         const Gid_t gid = POPi;
5326         grent = (const struct group *)getgrgid(gid);
5327     }
5328     else
5329 #ifdef HAS_GETGRENT
5330         grent = (struct group *)getgrent();
5331 #else
5332         DIE(aTHX_ PL_no_func, "getgrent");
5333 #endif
5334
5335     EXTEND(SP, 4);
5336     if (GIMME != G_ARRAY) {
5337         SV * const sv = sv_newmortal();
5338
5339         PUSHs(sv);
5340         if (grent) {
5341             if (which == OP_GGRNAM)
5342 #if Gid_t_sign <= 0
5343                 sv_setiv(sv, (IV)grent->gr_gid);
5344 #else
5345                 sv_setuv(sv, (UV)grent->gr_gid);
5346 #endif
5347             else
5348                 sv_setpv(sv, grent->gr_name);
5349         }
5350         RETURN;
5351     }
5352
5353     if (grent) {
5354         mPUSHs(newSVpv(grent->gr_name, 0));
5355
5356 #ifdef GRPASSWD
5357         mPUSHs(newSVpv(grent->gr_passwd, 0));
5358 #else
5359         PUSHs(sv_mortalcopy(&PL_sv_no));
5360 #endif
5361
5362 #if Gid_t_sign <= 0
5363         mPUSHi(grent->gr_gid);
5364 #else
5365         mPUSHu(grent->gr_gid);
5366 #endif
5367
5368 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5369         /* In UNICOS/mk (_CRAYMPP) the multithreading
5370          * versions (getgrnam_r, getgrgid_r)
5371          * seem to return an illegal pointer
5372          * as the group members list, gr_mem.
5373          * getgrent() doesn't even have a _r version
5374          * but the gr_mem is poisonous anyway.
5375          * So yes, you cannot get the list of group
5376          * members if building multithreaded in UNICOS/mk. */
5377         PUSHs(space_join_names_mortal(grent->gr_mem));
5378 #endif
5379     }
5380
5381     RETURN;
5382 #else
5383     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5384 #endif
5385 }
5386
5387 PP(pp_getlogin)
5388 {
5389 #ifdef HAS_GETLOGIN
5390     dVAR; dSP; dTARGET;
5391     char *tmps;
5392     EXTEND(SP, 1);
5393     if (!(tmps = PerlProc_getlogin()))
5394         RETPUSHUNDEF;
5395     sv_setpv_mg(TARG, tmps);
5396     PUSHs(TARG);
5397     RETURN;
5398 #else
5399     DIE(aTHX_ PL_no_func, "getlogin");
5400 #endif
5401 }
5402
5403 /* Miscellaneous. */
5404
5405 PP(pp_syscall)
5406 {
5407 #ifdef HAS_SYSCALL
5408     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5409     register I32 items = SP - MARK;
5410     unsigned long a[20];
5411     register I32 i = 0;
5412     I32 retval = -1;
5413
5414     if (PL_tainting) {
5415         while (++MARK <= SP) {
5416             if (SvTAINTED(*MARK)) {
5417                 TAINT;
5418                 break;
5419             }
5420         }
5421         MARK = ORIGMARK;
5422         TAINT_PROPER("syscall");
5423     }
5424
5425     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5426      * or where sizeof(long) != sizeof(char*).  But such machines will
5427      * not likely have syscall implemented either, so who cares?
5428      */
5429     while (++MARK <= SP) {
5430         if (SvNIOK(*MARK) || !i)
5431             a[i++] = SvIV(*MARK);
5432         else if (*MARK == &PL_sv_undef)
5433             a[i++] = 0;
5434         else
5435             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5436         if (i > 15)
5437             break;
5438     }
5439     switch (items) {
5440     default:
5441         DIE(aTHX_ "Too many args to syscall");
5442     case 0:
5443         DIE(aTHX_ "Too few args to syscall");
5444     case 1:
5445         retval = syscall(a[0]);
5446         break;
5447     case 2:
5448         retval = syscall(a[0],a[1]);
5449         break;
5450     case 3:
5451         retval = syscall(a[0],a[1],a[2]);
5452         break;
5453     case 4:
5454         retval = syscall(a[0],a[1],a[2],a[3]);
5455         break;
5456     case 5:
5457         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5458         break;
5459     case 6:
5460         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5461         break;
5462     case 7:
5463         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5464         break;
5465     case 8:
5466         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5467         break;
5468 #ifdef atarist
5469     case 9:
5470         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5471         break;
5472     case 10:
5473         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5474         break;
5475     case 11:
5476         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5477           a[10]);
5478         break;
5479     case 12:
5480         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5481           a[10],a[11]);
5482         break;
5483     case 13:
5484         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5485           a[10],a[11],a[12]);
5486         break;
5487     case 14:
5488         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5489           a[10],a[11],a[12],a[13]);
5490         break;
5491 #endif /* atarist */
5492     }
5493     SP = ORIGMARK;
5494     PUSHi(retval);
5495     RETURN;
5496 #else
5497     DIE(aTHX_ PL_no_func, "syscall");
5498 #endif
5499 }
5500
5501 #ifdef FCNTL_EMULATE_FLOCK
5502
5503 /*  XXX Emulate flock() with fcntl().
5504     What's really needed is a good file locking module.
5505 */
5506
5507 static int
5508 fcntl_emulate_flock(int fd, int operation)
5509 {
5510     int res;
5511     struct flock flock;
5512
5513     switch (operation & ~LOCK_NB) {
5514     case LOCK_SH:
5515         flock.l_type = F_RDLCK;
5516         break;
5517     case LOCK_EX:
5518         flock.l_type = F_WRLCK;
5519         break;
5520     case LOCK_UN:
5521         flock.l_type = F_UNLCK;
5522         break;
5523     default:
5524         errno = EINVAL;
5525         return -1;
5526     }
5527     flock.l_whence = SEEK_SET;
5528     flock.l_start = flock.l_len = (Off_t)0;
5529
5530     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5531     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5532         errno = EWOULDBLOCK;
5533     return res;
5534 }
5535
5536 #endif /* FCNTL_EMULATE_FLOCK */
5537
5538 #ifdef LOCKF_EMULATE_FLOCK
5539
5540 /*  XXX Emulate flock() with lockf().  This is just to increase
5541     portability of scripts.  The calls are not completely
5542     interchangeable.  What's really needed is a good file
5543     locking module.
5544 */
5545
5546 /*  The lockf() constants might have been defined in <unistd.h>.
5547     Unfortunately, <unistd.h> causes troubles on some mixed
5548     (BSD/POSIX) systems, such as SunOS 4.1.3.
5549
5550    Further, the lockf() constants aren't POSIX, so they might not be
5551    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5552    just stick in the SVID values and be done with it.  Sigh.
5553 */
5554
5555 # ifndef F_ULOCK
5556 #  define F_ULOCK       0       /* Unlock a previously locked region */
5557 # endif
5558 # ifndef F_LOCK
5559 #  define F_LOCK        1       /* Lock a region for exclusive use */
5560 # endif
5561 # ifndef F_TLOCK
5562 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5563 # endif
5564 # ifndef F_TEST
5565 #  define F_TEST        3       /* Test a region for other processes locks */
5566 # endif
5567
5568 static int
5569 lockf_emulate_flock(int fd, int operation)
5570 {
5571     int i;
5572     Off_t pos;
5573     dSAVE_ERRNO;
5574
5575     /* flock locks entire file so for lockf we need to do the same      */
5576     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5577     if (pos > 0)        /* is seekable and needs to be repositioned     */
5578         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5579             pos = -1;   /* seek failed, so don't seek back afterwards   */
5580     RESTORE_ERRNO;
5581
5582     switch (operation) {
5583
5584         /* LOCK_SH - get a shared lock */
5585         case LOCK_SH:
5586         /* LOCK_EX - get an exclusive lock */
5587         case LOCK_EX:
5588             i = lockf (fd, F_LOCK, 0);
5589             break;
5590
5591         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5592         case LOCK_SH|LOCK_NB:
5593         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5594         case LOCK_EX|LOCK_NB:
5595             i = lockf (fd, F_TLOCK, 0);
5596             if (i == -1)
5597                 if ((errno == EAGAIN) || (errno == EACCES))
5598                     errno = EWOULDBLOCK;
5599             break;
5600
5601         /* LOCK_UN - unlock (non-blocking is a no-op) */
5602         case LOCK_UN:
5603         case LOCK_UN|LOCK_NB:
5604             i = lockf (fd, F_ULOCK, 0);
5605             break;
5606
5607         /* Default - can't decipher operation */
5608         default:
5609             i = -1;
5610             errno = EINVAL;
5611             break;
5612     }
5613
5614     if (pos > 0)      /* need to restore position of the handle */
5615         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5616
5617     return (i);
5618 }
5619
5620 #endif /* LOCKF_EMULATE_FLOCK */
5621
5622 /*
5623  * Local variables:
5624  * c-indentation-style: bsd
5625  * c-basic-offset: 4
5626  * indent-tabs-mode: t
5627  * End:
5628  *
5629  * ex: set ts=8 sts=4 sw=4 noet:
5630  */