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