pp_sys.c

   1 /*    pp_sys.c
   2  *
   3  *    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4  *    2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * But only a short way ahead its floor and the walls on either side were
  13  * cloven by a great fissure, out of which the red glare came, now leaping
  14  * up, now dying down into darkness; and all the while far below there was
  15  * a rumour and a trouble as of great engines throbbing and labouring.
  16  *
  17  *     [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
  18  */
  19
  20 /* This file contains system pp ("push/pop") functions that
  21  * execute the opcodes that make up a perl program. A typical pp function
  22  * expects to find its arguments on the stack, and usually pushes its
  23  * results onto the stack, hence the 'pp' terminology. Each OP structure
  24  * contains a pointer to the relevant pp_foo() function.
  25  *
  26  * By 'system', we mean ops which interact with the OS, such as pp_open().
  27  */
  28
  29 #include "EXTERN.h"
  30 #define PERL_IN_PP_SYS_C
  31 #include "perl.h"
  32 #include "time64.h"
  33 #include "time64.c"
  34
  35 #ifdef I_SHADOW
  36 /* Shadow password support for solaris - pdo@cs.umd.edu
  37  * Not just Solaris: at least HP-UX, IRIX, Linux.
  38  * The API is from SysV.
  39  *
  40  * There are at least two more shadow interfaces,
  41  * see the comments in pp_gpwent().
  42  *
  43  * --jhi */
  44 #   ifdef __hpux__
  45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
  46  * and another MAXINT from "perl.h" <- <sys/param.h>. */
  47 #       undef MAXINT
  48 #   endif
  49 #   include <shadow.h>
  50 #endif
  51
  52 #ifdef I_SYS_WAIT
  53 # include <sys/wait.h>
  54 #endif
  55
  56 #ifdef I_SYS_RESOURCE
  57 # include <sys/resource.h>
  58 #endif
  59
  60 #ifdef NETWARE
  61 NETDB_DEFINE_CONTEXT
  62 #endif
  63
  64 #ifdef HAS_SELECT
  65 # ifdef I_SYS_SELECT
  66 #  include <sys/select.h>
  67 # endif
  68 #endif
  69
  70 /* XXX Configure test needed.
  71    h_errno might not be a simple 'int', especially for multi-threaded
  72    applications, see "extern int errno in perl.h".  Creating such
  73    a test requires taking into account the differences between
  74    compiling multithreaded and singlethreaded ($ccflags et al).
  75    HOST_NOT_FOUND is typically defined in <netdb.h>.
  76 */
  77 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
  78 extern int h_errno;
  79 #endif
  80
  81 #ifdef HAS_PASSWD
  82 # ifdef I_PWD
  83 #  include <pwd.h>
  84 # else
  85 #  if !defined(VMS)
  86     struct passwd *getpwnam (char *);
  87     struct passwd *getpwuid (Uid_t);
  88 #  endif
  89 # endif
  90 # ifdef HAS_GETPWENT
  91 #ifndef getpwent
  92   struct passwd *getpwent (void);
  93 #elif defined (VMS) && defined (my_getpwent)
  94   struct passwd *Perl_my_getpwent (pTHX);
  95 #endif
  96 # endif
  97 #endif
  98
  99 #ifdef HAS_GROUP
 100 # ifdef I_GRP
 101 #  include <grp.h>
 102 # else
 103     struct group *getgrnam (char *);
 104     struct group *getgrgid (Gid_t);
 105 # endif
 106 # ifdef HAS_GETGRENT
 107 #ifndef getgrent
 108     struct group *getgrent (void);
 109 #endif
 110 # endif
 111 #endif
 112
 113 #ifdef I_UTIME
 114 #  if defined(_MSC_VER) || defined(__MINGW32__)
 115 #    include <sys/utime.h>
 116 #  else
 117 #    include <utime.h>
 118 #  endif
 119 #endif
 120
 121 #ifdef HAS_CHSIZE
 122 # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
 123 #   undef my_chsize
 124 # endif
 125 # define my_chsize PerlLIO_chsize
 126 #else
 127 # ifdef HAS_TRUNCATE
 128 #   define my_chsize PerlLIO_chsize
 129 # else
 130 I32 my_chsize(int fd, Off_t length);
 131 # endif
 132 #endif
 133
 134 #ifdef HAS_FLOCK
 135 #  define FLOCK flock
 136 #else /* no flock() */
 137
 138    /* fcntl.h might not have been included, even if it exists, because
 139       the current Configure only sets I_FCNTL if it's needed to pick up
 140       the *_OK constants.  Make sure it has been included before testing
 141       the fcntl() locking constants. */
 142 #  if defined(HAS_FCNTL) && !defined(I_FCNTL)
 143 #    include <fcntl.h>
 144 #  endif
 145
 146 #  if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
 147 #    define FLOCK fcntl_emulate_flock
 148 #    define FCNTL_EMULATE_FLOCK
 149 #  else /* no flock() or fcntl(F_SETLK,...) */
 150 #    ifdef HAS_LOCKF
 151 #      define FLOCK lockf_emulate_flock
 152 #      define LOCKF_EMULATE_FLOCK
 153 #    endif /* lockf */
 154 #  endif /* no flock() or fcntl(F_SETLK,...) */
 155
 156 #  ifdef FLOCK
 157      static int FLOCK (int, int);
 158
 159     /*
 160      * These are the flock() constants.  Since this sytems doesn't have
 161      * flock(), the values of the constants are probably not available.
 162      */
 163 #    ifndef LOCK_SH
 164 #      define LOCK_SH 1
 165 #    endif
 166 #    ifndef LOCK_EX
 167 #      define LOCK_EX 2
 168 #    endif
 169 #    ifndef LOCK_NB
 170 #      define LOCK_NB 4
 171 #    endif
 172 #    ifndef LOCK_UN
 173 #      define LOCK_UN 8
 174 #    endif
 175 #  endif /* emulating flock() */
 176
 177 #endif /* no flock() */
 178
 179 #define ZBTLEN 10
 180 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
 181
 182 #if defined(I_SYS_ACCESS) && !defined(R_OK)
 183 #  include <sys/access.h>
 184 #endif
 185
 186 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
 187 #  define FD_CLOEXEC 1          /* NeXT needs this */
 188 #endif
 189
 190 #include "reentr.h"
 191
 192 #ifdef __Lynx__
 193 /* Missing protos on LynxOS */
 194 void sethostent(int);
 195 void endhostent(void);
 196 void setnetent(int);
 197 void endnetent(void);
 198 void setprotoent(int);
 199 void endprotoent(void);
 200 void setservent(int);
 201 void endservent(void);
 202 #endif
 203
 204 #undef PERL_EFF_ACCESS  /* EFFective uid/gid ACCESS */
 205
 206 /* F_OK unused: if stat() cannot find it... */
 207
 208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
 209     /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
 210 #   define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
 211 #endif
 212
 213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
 214 #   ifdef I_SYS_SECURITY
 215 #       include <sys/security.h>
 216 #   endif
 217 #   ifdef ACC_SELF
 218         /* HP SecureWare */
 219 #       define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
 220 #   else
 221         /* SCO */
 222 #       define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
 223 #   endif
 224 #endif
 225
 226 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
 227     /* AIX */
 228 #   define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
 229 #endif
 230
 231
 232 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS)    \
 233     && (defined(HAS_SETREUID) || defined(HAS_SETRESUID)         \
 234         || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
 235 /* The Hard Way. */
 236 STATIC int
 237 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
 238 {
 239     const Uid_t ruid = getuid();
 240     const Uid_t euid = geteuid();
 241     const Gid_t rgid = getgid();
 242     const Gid_t egid = getegid();
 243     int res;
 244
 245 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
 246     Perl_croak(aTHX_ "switching effective uid is not implemented");
 247 #else
 248 #ifdef HAS_SETREUID
 249     if (setreuid(euid, ruid))
 250 #else
 251 #ifdef HAS_SETRESUID
 252     if (setresuid(euid, ruid, (Uid_t)-1))
 253 #endif
 254 #endif
 255         Perl_croak(aTHX_ "entering effective uid failed");
 256 #endif
 257
 258 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
 259     Perl_croak(aTHX_ "switching effective gid is not implemented");
 260 #else
 261 #ifdef HAS_SETREGID
 262     if (setregid(egid, rgid))
 263 #else
 264 #ifdef HAS_SETRESGID
 265     if (setresgid(egid, rgid, (Gid_t)-1))
 266 #endif
 267 #endif
 268         Perl_croak(aTHX_ "entering effective gid failed");
 269 #endif
 270
 271     res = access(path, mode);
 272
 273 #ifdef HAS_SETREUID
 274     if (setreuid(ruid, euid))
 275 #else
 276 #ifdef HAS_SETRESUID
 277     if (setresuid(ruid, euid, (Uid_t)-1))
 278 #endif
 279 #endif
 280         Perl_croak(aTHX_ "leaving effective uid failed");
 281
 282 #ifdef HAS_SETREGID
 283     if (setregid(rgid, egid))
 284 #else
 285 #ifdef HAS_SETRESGID
 286     if (setresgid(rgid, egid, (Gid_t)-1))
 287 #endif
 288 #endif
 289         Perl_croak(aTHX_ "leaving effective gid failed");
 290
 291     return res;
 292 }
 293 #   define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
 294 #endif
 295
 296 PP(pp_backtick)
 297 {
 298     dVAR; dSP; dTARGET;
 299     PerlIO *fp;
 300     const char * const tmps = POPpconstx;
 301     const I32 gimme = GIMME_V;
 302     const char *mode = "r";
 303
 304     TAINT_PROPER("``");
 305     if (PL_op->op_private & OPpOPEN_IN_RAW)
 306         mode = "rb";
 307     else if (PL_op->op_private & OPpOPEN_IN_CRLF)
 308         mode = "rt";
 309     fp = PerlProc_popen(tmps, mode);
 310     if (fp) {
 311         const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
 312         if (type && *type)
 313             PerlIO_apply_layers(aTHX_ fp,mode,type);
 314
 315         if (gimme == G_VOID) {
 316             char tmpbuf[256];
 317             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
 318                 NOOP;
 319         }
 320         else if (gimme == G_SCALAR) {
 321             ENTER_with_name("backtick");
 322             SAVESPTR(PL_rs);
 323             PL_rs = &PL_sv_undef;
 324             sv_setpvs(TARG, "");        /* note that this preserves previous buffer */
 325             while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
 326                 NOOP;
 327             LEAVE_with_name("backtick");
 328             XPUSHs(TARG);
 329             SvTAINTED_on(TARG);
 330         }
 331         else {
 332             for (;;) {
 333                 SV * const sv = newSV(79);
 334                 if (sv_gets(sv, fp, 0) == NULL) {
 335                     SvREFCNT_dec(sv);
 336                     break;
 337                 }
 338                 mXPUSHs(sv);
 339                 if (SvLEN(sv) - SvCUR(sv) > 20) {
 340                     SvPV_shrink_to_cur(sv);
 341                 }
 342                 SvTAINTED_on(sv);
 343             }
 344         }
 345         STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
 346         TAINT;          /* "I believe that this is not gratuitous!" */
 347     }
 348     else {
 349         STATUS_NATIVE_CHILD_SET(-1);
 350         if (gimme == G_SCALAR)
 351             RETPUSHUNDEF;
 352     }
 353
 354     RETURN;
 355 }
 356
 357 PP(pp_glob)
 358 {
 359     dVAR;
 360     OP *result;
 361     dSP;
 362     /* make a copy of the pattern, to ensure that magic is called once
 363      * and only once */
 364     TOPm1s = sv_2mortal(newSVsv(TOPm1s));
 365
 366     tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
 367
 368     if (PL_op->op_flags & OPf_SPECIAL) {
 369         /* call Perl-level glob function instead. Stack args are:
 370          * MARK, wildcard, csh_glob context index
 371          * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
 372          * */
 373         return NORMAL;
 374     }
 375     /* stack args are: wildcard, gv(_GEN_n) */
 376
 377
 378     /* Note that we only ever get here if File::Glob fails to load
 379      * without at the same time croaking, for some reason, or if
 380      * perl was built with PERL_EXTERNAL_GLOB */
 381
 382     ENTER_with_name("glob");
 383
 384 #ifndef VMS
 385     if (PL_tainting) {
 386         /*
 387          * The external globbing program may use things we can't control,
 388          * so for security reasons we must assume the worst.
 389          */
 390         TAINT;
 391         taint_proper(PL_no_security, "glob");
 392     }
 393 #endif /* !VMS */
 394
 395     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
 396     PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
 397
 398     SAVESPTR(PL_rs);            /* This is not permanent, either. */
 399     PL_rs = newSVpvs_flags("\000", SVs_TEMP);
 400 #ifndef DOSISH
 401 #ifndef CSH
 402     *SvPVX(PL_rs) = '\n';
 403 #endif  /* !CSH */
 404 #endif  /* !DOSISH */
 405
 406     result = do_readline();
 407     LEAVE_with_name("glob");
 408     return result;
 409 }
 410
 411 PP(pp_rcatline)
 412 {
 413     dVAR;
 414     PL_last_in_gv = cGVOP_gv;
 415     return do_readline();
 416 }
 417
 418 PP(pp_warn)
 419 {
 420     dVAR; dSP; dMARK;
 421     SV *exsv;
 422     const char *pv;
 423     STRLEN len;
 424     if (SP - MARK > 1) {
 425         dTARGET;
 426         do_join(TARG, &PL_sv_no, MARK, SP);
 427         exsv = TARG;
 428         SP = MARK + 1;
 429     }
 430     else if (SP == MARK) {
 431         exsv = &PL_sv_no;
 432         EXTEND(SP, 1);
 433         SP = MARK + 1;
 434     }
 435     else {
 436         exsv = TOPs;
 437     }
 438
 439     if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
 440         /* well-formed exception supplied */
 441     }
 442     else if (SvROK(ERRSV)) {
 443         exsv = ERRSV;
 444     }
 445     else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
 446         exsv = sv_mortalcopy(ERRSV);
 447         sv_catpvs(exsv, "\t...caught");
 448     }
 449     else {
 450         exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
 451     }
 452     if (SvROK(exsv) && !PL_warnhook)
 453          Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
 454     else warn_sv(exsv);
 455     RETSETYES;
 456 }
 457
 458 PP(pp_die)
 459 {
 460     dVAR; dSP; dMARK;
 461     SV *exsv;
 462     const char *pv;
 463     STRLEN len;
 464 #ifdef VMS
 465     VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
 466 #endif
 467     if (SP - MARK != 1) {
 468         dTARGET;
 469         do_join(TARG, &PL_sv_no, MARK, SP);
 470         exsv = TARG;
 471         SP = MARK + 1;
 472     }
 473     else {
 474         exsv = TOPs;
 475     }
 476
 477     if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
 478         /* well-formed exception supplied */
 479     }
 480     else if (SvROK(ERRSV)) {
 481         exsv = ERRSV;
 482         if (sv_isobject(exsv)) {
 483             HV * const stash = SvSTASH(SvRV(exsv));
 484             GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
 485             if (gv) {
 486                 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
 487                 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
 488                 EXTEND(SP, 3);
 489                 PUSHMARK(SP);
 490                 PUSHs(exsv);
 491                 PUSHs(file);
 492                 PUSHs(line);
 493                 PUTBACK;
 494                 call_sv(MUTABLE_SV(GvCV(gv)),
 495                         G_SCALAR|G_EVAL|G_KEEPERR);
 496                 exsv = sv_mortalcopy(*PL_stack_sp--);
 497             }
 498         }
 499     }
 500     else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
 501         exsv = sv_mortalcopy(ERRSV);
 502         sv_catpvs(exsv, "\t...propagated");
 503     }
 504     else {
 505         exsv = newSVpvs_flags("Died", SVs_TEMP);
 506     }
 507     return die_sv(exsv);
 508 }
 509
 510 /* I/O. */
 511
 512 OP *
 513 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
 514                  const MAGIC *const mg, const U32 flags, U32 argc, ...)
 515 {
 516     PERL_ARGS_ASSERT_TIED_METHOD;
 517
 518     /* Ensure that our flag bits do not overlap.  */
 519     assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
 520     assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
 521     assert((TIED_METHOD_SAY & G_WANT) == 0);
 522
 523     PUSHMARK(sp);
 524     PUSHs(SvTIED_obj(sv, mg));
 525     if (flags & TIED_METHOD_ARGUMENTS_ON_STACK)
 526         sp += argc;
 527     else if (argc) {
 528         const U32 mortalize_not_needed
 529             = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
 530         va_list args;
 531         va_start(args, argc);
 532         do {
 533             SV *const arg = va_arg(args, SV *);
 534             if(mortalize_not_needed)
 535                 PUSHs(arg);
 536             else
 537                 mPUSHs(arg);
 538         } while (--argc);
 539         va_end(args);
 540     }
 541
 542     PUTBACK;
 543     ENTER_with_name("call_tied_method");
 544     if (flags & TIED_METHOD_SAY) {
 545         /* local $\ = "\n" */
 546         SAVEGENERICSV(PL_ors_sv);
 547         PL_ors_sv = newSVpvs("\n");
 548     }
 549     call_method(methname, flags & G_WANT);
 550     LEAVE_with_name("call_tied_method");
 551     return NORMAL;
 552 }
 553
 554 #define tied_method0(a,b,c,d)           \
 555     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
 556 #define tied_method1(a,b,c,d,e)         \
 557     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
 558 #define tied_method2(a,b,c,d,e,f)       \
 559     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
 560
 561 PP(pp_open)
 562 {
 563     dVAR; dSP;
 564     dMARK; dORIGMARK;
 565     dTARGET;
 566     SV *sv;
 567     IO *io;
 568     const char *tmps;
 569     STRLEN len;
 570     bool  ok;
 571
 572     GV * const gv = MUTABLE_GV(*++MARK);
 573
 574     if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
 575         DIE(aTHX_ PL_no_usym, "filehandle");
 576
 577     if ((io = GvIOp(gv))) {
 578         const MAGIC *mg;
 579         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 580
 581         if (IoDIRP(io))
 582             Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
 583                              "Opening dirhandle %s also as a file",
 584                              GvENAME(gv));
 585
 586         mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 587         if (mg) {
 588             /* Method's args are same as ours ... */
 589             /* ... except handle is replaced by the object */
 590             return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
 591                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
 592                                     sp - mark);
 593         }
 594     }
 595
 596     if (MARK < SP) {
 597         sv = *++MARK;
 598     }
 599     else {
 600         sv = GvSVn(gv);
 601     }
 602
 603     tmps = SvPV_const(sv, len);
 604     ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
 605     SP = ORIGMARK;
 606     if (ok)
 607         PUSHi( (I32)PL_forkprocess );
 608     else if (PL_forkprocess == 0)               /* we are a new child */
 609         PUSHi(0);
 610     else
 611         RETPUSHUNDEF;
 612     RETURN;
 613 }
 614
 615 PP(pp_close)
 616 {
 617     dVAR; dSP;
 618     GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
 619
 620     if (MAXARG == 0)
 621         EXTEND(SP, 1);
 622
 623     if (gv) {
 624         IO * const io = GvIO(gv);
 625         if (io) {
 626             const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 627             if (mg) {
 628                 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
 629             }
 630         }
 631     }
 632     PUSHs(boolSV(do_close(gv, TRUE)));
 633     RETURN;
 634 }
 635
 636 PP(pp_pipe_op)
 637 {
 638 #ifdef HAS_PIPE
 639     dVAR;
 640     dSP;
 641     register IO *rstio;
 642     register IO *wstio;
 643     int fd[2];
 644
 645     GV * const wgv = MUTABLE_GV(POPs);
 646     GV * const rgv = MUTABLE_GV(POPs);
 647
 648     if (!rgv || !wgv)
 649         goto badexit;
 650
 651     if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
 652         DIE(aTHX_ PL_no_usym, "filehandle");
 653     rstio = GvIOn(rgv);
 654     wstio = GvIOn(wgv);
 655
 656     if (IoIFP(rstio))
 657         do_close(rgv, FALSE);
 658     if (IoIFP(wstio))
 659         do_close(wgv, FALSE);
 660
 661     if (PerlProc_pipe(fd) < 0)
 662         goto badexit;
 663
 664     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
 665     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
 666     IoOFP(rstio) = IoIFP(rstio);
 667     IoIFP(wstio) = IoOFP(wstio);
 668     IoTYPE(rstio) = IoTYPE_RDONLY;
 669     IoTYPE(wstio) = IoTYPE_WRONLY;
 670
 671     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 672         if (IoIFP(rstio))
 673             PerlIO_close(IoIFP(rstio));
 674         else
 675             PerlLIO_close(fd[0]);
 676         if (IoOFP(wstio))
 677             PerlIO_close(IoOFP(wstio));
 678         else
 679             PerlLIO_close(fd[1]);
 680         goto badexit;
 681     }
 682 #if defined(HAS_FCNTL) && defined(F_SETFD)
 683     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
 684     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
 685 #endif
 686     RETPUSHYES;
 687
 688 badexit:
 689     RETPUSHUNDEF;
 690 #else
 691     DIE(aTHX_ PL_no_func, "pipe");
 692 #endif
 693 }
 694
 695 PP(pp_fileno)
 696 {
 697     dVAR; dSP; dTARGET;
 698     GV *gv;
 699     IO *io;
 700     PerlIO *fp;
 701     const MAGIC *mg;
 702
 703     if (MAXARG < 1)
 704         RETPUSHUNDEF;
 705     gv = MUTABLE_GV(POPs);
 706     io = GvIO(gv);
 707
 708     if (io
 709         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 710     {
 711         return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
 712     }
 713
 714     if (!io || !(fp = IoIFP(io))) {
 715         /* Can't do this because people seem to do things like
 716            defined(fileno($foo)) to check whether $foo is a valid fh.
 717
 718            report_evil_fh(gv);
 719             */
 720         RETPUSHUNDEF;
 721     }
 722
 723     PUSHi(PerlIO_fileno(fp));
 724     RETURN;
 725 }
 726
 727 PP(pp_umask)
 728 {
 729     dVAR;
 730     dSP;
 731 #ifdef HAS_UMASK
 732     dTARGET;
 733     Mode_t anum;
 734
 735     if (MAXARG < 1) {
 736         anum = PerlLIO_umask(022);
 737         /* setting it to 022 between the two calls to umask avoids
 738          * to have a window where the umask is set to 0 -- meaning
 739          * that another thread could create world-writeable files. */
 740         if (anum != 022)
 741             (void)PerlLIO_umask(anum);
 742     }
 743     else
 744         anum = PerlLIO_umask(POPi);
 745     TAINT_PROPER("umask");
 746     XPUSHi(anum);
 747 #else
 748     /* Only DIE if trying to restrict permissions on "user" (self).
 749      * Otherwise it's harmless and more useful to just return undef
 750      * since 'group' and 'other' concepts probably don't exist here. */
 751     if (MAXARG >= 1 && (POPi & 0700))
 752         DIE(aTHX_ "umask not implemented");
 753     XPUSHs(&PL_sv_undef);
 754 #endif
 755     RETURN;
 756 }
 757
 758 PP(pp_binmode)
 759 {
 760     dVAR; dSP;
 761     GV *gv;
 762     IO *io;
 763     PerlIO *fp;
 764     SV *discp = NULL;
 765
 766     if (MAXARG < 1)
 767         RETPUSHUNDEF;
 768     if (MAXARG > 1) {
 769         discp = POPs;
 770     }
 771
 772     gv = MUTABLE_GV(POPs);
 773     io = GvIO(gv);
 774
 775     if (io) {
 776         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 777         if (mg) {
 778             /* This takes advantage of the implementation of the varargs
 779                function, which I don't think that the optimiser will be able to
 780                figure out. Although, as it's a static function, in theory it
 781                could.  */
 782             return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
 783                                     G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
 784                                     discp ? 1 : 0, discp);
 785         }
 786     }
 787
 788     if (!io || !(fp = IoIFP(io))) {
 789         report_evil_fh(gv);
 790         SETERRNO(EBADF,RMS_IFI);
 791         RETPUSHUNDEF;
 792     }
 793
 794     PUTBACK;
 795     {
 796         STRLEN len = 0;
 797         const char *d = NULL;
 798         int mode;
 799         if (discp)
 800             d = SvPV_const(discp, len);
 801         mode = mode_from_discipline(d, len);
 802         if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
 803             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
 804                 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
 805                     SPAGAIN;
 806                     RETPUSHUNDEF;
 807                 }
 808             }
 809             SPAGAIN;
 810             RETPUSHYES;
 811         }
 812         else {
 813             SPAGAIN;
 814             RETPUSHUNDEF;
 815         }
 816     }
 817 }
 818
 819 PP(pp_tie)
 820 {
 821     dVAR; dSP; dMARK;
 822     HV* stash;
 823     GV *gv = NULL;
 824     SV *sv;
 825     const I32 markoff = MARK - PL_stack_base;
 826     const char *methname;
 827     int how = PERL_MAGIC_tied;
 828     U32 items;
 829     SV *varsv = *++MARK;
 830
 831     switch(SvTYPE(varsv)) {
 832         case SVt_PVHV:
 833             methname = "TIEHASH";
 834             HvEITER_set(MUTABLE_HV(varsv), 0);
 835             break;
 836         case SVt_PVAV:
 837             methname = "TIEARRAY";
 838             break;
 839         case SVt_PVGV:
 840         case SVt_PVLV:
 841             if (isGV_with_GP(varsv)) {
 842                 if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
 843                     deprecate("tie on a handle without *");
 844                     GvFLAGS(varsv) |= GVf_TIEWARNED;
 845                 }
 846                 methname = "TIEHANDLE";
 847                 how = PERL_MAGIC_tiedscalar;
 848                 /* For tied filehandles, we apply tiedscalar magic to the IO
 849                    slot of the GP rather than the GV itself. AMS 20010812 */
 850                 if (!GvIOp(varsv))
 851                     GvIOp(varsv) = newIO();
 852                 varsv = MUTABLE_SV(GvIOp(varsv));
 853                 break;
 854             }
 855             /* FALL THROUGH */
 856         default:
 857             methname = "TIESCALAR";
 858             how = PERL_MAGIC_tiedscalar;
 859             break;
 860     }
 861     items = SP - MARK++;
 862     if (sv_isobject(*MARK)) { /* Calls GET magic. */
 863         ENTER_with_name("call_TIE");
 864         PUSHSTACKi(PERLSI_MAGIC);
 865         PUSHMARK(SP);
 866         EXTEND(SP,(I32)items);
 867         while (items--)
 868             PUSHs(*MARK++);
 869         PUTBACK;
 870         call_method(methname, G_SCALAR);
 871     }
 872     else {
 873         /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
 874          * will attempt to invoke IO::File::TIEARRAY, with (best case) the
 875          * wrong error message, and worse case, supreme action at a distance.
 876          * (Sorry obfuscation writers. You're not going to be given this one.)
 877          */
 878         STRLEN len;
 879         const char *name = SvPV_nomg_const(*MARK, len);
 880         stash = gv_stashpvn(name, len, 0);
 881         if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 882             DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
 883                  methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
 884         }
 885         ENTER_with_name("call_TIE");
 886         PUSHSTACKi(PERLSI_MAGIC);
 887         PUSHMARK(SP);
 888         EXTEND(SP,(I32)items);
 889         while (items--)
 890             PUSHs(*MARK++);
 891         PUTBACK;
 892         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
 893     }
 894     SPAGAIN;
 895
 896     sv = TOPs;
 897     POPSTACK;
 898     if (sv_isobject(sv)) {
 899         sv_unmagic(varsv, how);
 900         /* Croak if a self-tie on an aggregate is attempted. */
 901         if (varsv == SvRV(sv) &&
 902             (SvTYPE(varsv) == SVt_PVAV ||
 903              SvTYPE(varsv) == SVt_PVHV))
 904             Perl_croak(aTHX_
 905                        "Self-ties of arrays and hashes are not supported");
 906         sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
 907     }
 908     LEAVE_with_name("call_TIE");
 909     SP = PL_stack_base + markoff;
 910     PUSHs(sv);
 911     RETURN;
 912 }
 913
 914 PP(pp_untie)
 915 {
 916     dVAR; dSP;
 917     MAGIC *mg;
 918     SV *sv = POPs;
 919     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
 920                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
 921
 922     if (isGV_with_GP(sv)) {
 923       if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
 924         deprecate("untie on a handle without *");
 925         GvFLAGS(sv) |= GVf_TIEWARNED;
 926       }
 927       if (!(sv = MUTABLE_SV(GvIOp(sv))))
 928         RETPUSHYES;
 929     }
 930
 931     if ((mg = SvTIED_mg(sv, how))) {
 932         SV * const obj = SvRV(SvTIED_obj(sv, mg));
 933         if (obj) {
 934             GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
 935             CV *cv;
 936             if (gv && isGV(gv) && (cv = GvCV(gv))) {
 937                PUSHMARK(SP);
 938                PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
 939                mXPUSHi(SvREFCNT(obj) - 1);
 940                PUTBACK;
 941                ENTER_with_name("call_UNTIE");
 942                call_sv(MUTABLE_SV(cv), G_VOID);
 943                LEAVE_with_name("call_UNTIE");
 944                SPAGAIN;
 945             }
 946             else if (mg && SvREFCNT(obj) > 1) {
 947                 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
 948                                "untie attempted while %"UVuf" inner references still exist",
 949                                (UV)SvREFCNT(obj) - 1 ) ;
 950             }
 951         }
 952     }
 953     sv_unmagic(sv, how) ;
 954     RETPUSHYES;
 955 }
 956
 957 PP(pp_tied)
 958 {
 959     dVAR;
 960     dSP;
 961     const MAGIC *mg;
 962     SV *sv = POPs;
 963     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
 964                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
 965
 966     if (isGV_with_GP(sv)) {
 967       if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
 968         deprecate("tied on a handle without *");
 969         GvFLAGS(sv) |= GVf_TIEWARNED;
 970       }
 971       if (!(sv = MUTABLE_SV(GvIOp(sv))))
 972         RETPUSHUNDEF;
 973     }
 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         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4023         if (tmpgv) {
4024             SvREADONLY_off(GvSV(tmpgv));
4025             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4026             SvREADONLY_on(GvSV(tmpgv));
4027         }
4028 #ifdef THREADS_HAVE_PIDS
4029         PL_ppid = (IV)getppid();
4030 #endif
4031 #ifdef PERL_USES_PL_PIDSTATUS
4032         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4033 #endif
4034     }
4035     PUSHi(childpid);
4036     RETURN;
4037 #else
4038 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4039     dSP; dTARGET;
4040     Pid_t childpid;
4041
4042     EXTEND(SP, 1);
4043     PERL_FLUSHALL_FOR_CHILD;
4044     childpid = PerlProc_fork();
4045     if (childpid == -1)
4046         RETSETUNDEF;
4047     PUSHi(childpid);
4048     RETURN;
4049 #  else
4050     DIE(aTHX_ PL_no_func, "fork");
4051 #  endif
4052 #endif
4053 }
4054
4055 PP(pp_wait)
4056 {
4057 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4058     dVAR; dSP; dTARGET;
4059     Pid_t childpid;
4060     int argflags;
4061
4062     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4063         childpid = wait4pid(-1, &argflags, 0);
4064     else {
4065         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4066                errno == EINTR) {
4067           PERL_ASYNC_CHECK();
4068         }
4069     }
4070 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4071     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4072     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4073 #  else
4074     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4075 #  endif
4076     XPUSHi(childpid);
4077     RETURN;
4078 #else
4079     DIE(aTHX_ PL_no_func, "wait");
4080 #endif
4081 }
4082
4083 PP(pp_waitpid)
4084 {
4085 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4086     dVAR; dSP; dTARGET;
4087     const int optype = POPi;
4088     const Pid_t pid = TOPi;
4089     Pid_t result;
4090     int argflags;
4091
4092     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4093         result = wait4pid(pid, &argflags, optype);
4094     else {
4095         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4096                errno == EINTR) {
4097           PERL_ASYNC_CHECK();
4098         }
4099     }
4100 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4101     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4102     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4103 #  else
4104     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4105 #  endif
4106     SETi(result);
4107     RETURN;
4108 #else
4109     DIE(aTHX_ PL_no_func, "waitpid");
4110 #endif
4111 }
4112
4113 PP(pp_system)
4114 {
4115     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4116 #if defined(__LIBCATAMOUNT__)
4117     PL_statusvalue = -1;
4118     SP = ORIGMARK;
4119     XPUSHi(-1);
4120 #else
4121     I32 value;
4122     int result;
4123
4124     if (PL_tainting) {
4125         TAINT_ENV();
4126         while (++MARK <= SP) {
4127             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4128             if (PL_tainted)
4129                 break;
4130         }
4131         MARK = ORIGMARK;
4132         TAINT_PROPER("system");
4133     }
4134     PERL_FLUSHALL_FOR_CHILD;
4135 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4136     {
4137         Pid_t childpid;
4138         int pp[2];
4139         I32 did_pipes = 0;
4140
4141         if (PerlProc_pipe(pp) >= 0)
4142             did_pipes = 1;
4143         while ((childpid = PerlProc_fork()) == -1) {
4144             if (errno != EAGAIN) {
4145                 value = -1;
4146                 SP = ORIGMARK;
4147                 XPUSHi(value);
4148                 if (did_pipes) {
4149                     PerlLIO_close(pp[0]);
4150                     PerlLIO_close(pp[1]);
4151                 }
4152                 RETURN;
4153             }
4154             sleep(5);
4155         }
4156         if (childpid > 0) {
4157             Sigsave_t ihand,qhand; /* place to save signals during system() */
4158             int status;
4159
4160             if (did_pipes)
4161                 PerlLIO_close(pp[1]);
4162 #ifndef PERL_MICRO
4163             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4164             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4165 #endif
4166             do {
4167                 result = wait4pid(childpid, &status, 0);
4168             } while (result == -1 && errno == EINTR);
4169 #ifndef PERL_MICRO
4170             (void)rsignal_restore(SIGINT, &ihand);
4171             (void)rsignal_restore(SIGQUIT, &qhand);
4172 #endif
4173             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4174             do_execfree();      /* free any memory child malloced on fork */
4175             SP = ORIGMARK;
4176             if (did_pipes) {
4177                 int errkid;
4178                 unsigned n = 0;
4179                 SSize_t n1;
4180
4181                 while (n < sizeof(int)) {
4182                     n1 = PerlLIO_read(pp[0],
4183                                       (void*)(((char*)&errkid)+n),
4184                                       (sizeof(int)) - n);
4185                     if (n1 <= 0)
4186                         break;
4187                     n += n1;
4188                 }
4189                 PerlLIO_close(pp[0]);
4190                 if (n) {                        /* Error */
4191                     if (n != sizeof(int))
4192                         DIE(aTHX_ "panic: kid popen errno read");
4193                     errno = errkid;             /* Propagate errno from kid */
4194                     STATUS_NATIVE_CHILD_SET(-1);
4195                 }
4196             }
4197             XPUSHi(STATUS_CURRENT);
4198             RETURN;
4199         }
4200         if (did_pipes) {
4201             PerlLIO_close(pp[0]);
4202 #if defined(HAS_FCNTL) && defined(F_SETFD)
4203             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4204 #endif
4205         }
4206         if (PL_op->op_flags & OPf_STACKED) {
4207             SV * const really = *++MARK;
4208             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4209         }
4210         else if (SP - MARK != 1)
4211             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4212         else {
4213             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4214         }
4215         PerlProc__exit(-1);
4216     }
4217 #else /* ! FORK or VMS or OS/2 */
4218     PL_statusvalue = 0;
4219     result = 0;
4220     if (PL_op->op_flags & OPf_STACKED) {
4221         SV * const really = *++MARK;
4222 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4223         value = (I32)do_aspawn(really, MARK, SP);
4224 #  else
4225         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4226 #  endif
4227     }
4228     else if (SP - MARK != 1) {
4229 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4230         value = (I32)do_aspawn(NULL, MARK, SP);
4231 #  else
4232         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4233 #  endif
4234     }
4235     else {
4236         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4237     }
4238     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4239         result = 1;
4240     STATUS_NATIVE_CHILD_SET(value);
4241     do_execfree();
4242     SP = ORIGMARK;
4243     XPUSHi(result ? value : STATUS_CURRENT);
4244 #endif /* !FORK or VMS or OS/2 */
4245 #endif
4246     RETURN;
4247 }
4248
4249 PP(pp_exec)
4250 {
4251     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4252     I32 value;
4253
4254     if (PL_tainting) {
4255         TAINT_ENV();
4256         while (++MARK <= SP) {
4257             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4258             if (PL_tainted)
4259                 break;
4260         }
4261         MARK = ORIGMARK;
4262         TAINT_PROPER("exec");
4263     }
4264     PERL_FLUSHALL_FOR_CHILD;
4265     if (PL_op->op_flags & OPf_STACKED) {
4266         SV * const really = *++MARK;
4267         value = (I32)do_aexec(really, MARK, SP);
4268     }
4269     else if (SP - MARK != 1)
4270 #ifdef VMS
4271         value = (I32)vms_do_aexec(NULL, MARK, SP);
4272 #else
4273 #  ifdef __OPEN_VM
4274         {
4275            (void ) do_aspawn(NULL, MARK, SP);
4276            value = 0;
4277         }
4278 #  else
4279         value = (I32)do_aexec(NULL, MARK, SP);
4280 #  endif
4281 #endif
4282     else {
4283 #ifdef VMS
4284         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4285 #else
4286 #  ifdef __OPEN_VM
4287         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4288         value = 0;
4289 #  else
4290         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4291 #  endif
4292 #endif
4293     }
4294
4295     SP = ORIGMARK;
4296     XPUSHi(value);
4297     RETURN;
4298 }
4299
4300 PP(pp_getppid)
4301 {
4302 #ifdef HAS_GETPPID
4303     dVAR; dSP; dTARGET;
4304 #   ifdef THREADS_HAVE_PIDS
4305     if (PL_ppid != 1 && getppid() == 1)
4306         /* maybe the parent process has died. Refresh ppid cache */
4307         PL_ppid = 1;
4308     XPUSHi( PL_ppid );
4309 #   else
4310     XPUSHi( getppid() );
4311 #   endif
4312     RETURN;
4313 #else
4314     DIE(aTHX_ PL_no_func, "getppid");
4315 #endif
4316 }
4317
4318 PP(pp_getpgrp)
4319 {
4320 #ifdef HAS_GETPGRP
4321     dVAR; dSP; dTARGET;
4322     Pid_t pgrp;
4323     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4324
4325 #ifdef BSD_GETPGRP
4326     pgrp = (I32)BSD_GETPGRP(pid);
4327 #else
4328     if (pid != 0 && pid != PerlProc_getpid())
4329         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4330     pgrp = getpgrp();
4331 #endif
4332     XPUSHi(pgrp);
4333     RETURN;
4334 #else
4335     DIE(aTHX_ PL_no_func, "getpgrp()");
4336 #endif
4337 }
4338
4339 PP(pp_setpgrp)
4340 {
4341 #ifdef HAS_SETPGRP
4342     dVAR; dSP; dTARGET;
4343     Pid_t pgrp;
4344     Pid_t pid;
4345     if (MAXARG < 2) {
4346         pgrp = 0;
4347         pid = 0;
4348         XPUSHi(-1);
4349     }
4350     else {
4351         pgrp = POPi;
4352         pid = TOPi;
4353     }
4354
4355     TAINT_PROPER("setpgrp");
4356 #ifdef BSD_SETPGRP
4357     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4358 #else
4359     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4360         || (pid != 0 && pid != PerlProc_getpid()))
4361     {
4362         DIE(aTHX_ "setpgrp can't take arguments");
4363     }
4364     SETi( setpgrp() >= 0 );
4365 #endif /* USE_BSDPGRP */
4366     RETURN;
4367 #else
4368     DIE(aTHX_ PL_no_func, "setpgrp()");
4369 #endif
4370 }
4371
4372 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4373 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4374 #else
4375 #  define PRIORITY_WHICH_T(which) which
4376 #endif
4377
4378 PP(pp_getpriority)
4379 {
4380 #ifdef HAS_GETPRIORITY
4381     dVAR; dSP; dTARGET;
4382     const int who = POPi;
4383     const int which = TOPi;
4384     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4385     RETURN;
4386 #else
4387     DIE(aTHX_ PL_no_func, "getpriority()");
4388 #endif
4389 }
4390
4391 PP(pp_setpriority)
4392 {
4393 #ifdef HAS_SETPRIORITY
4394     dVAR; dSP; dTARGET;
4395     const int niceval = POPi;
4396     const int who = POPi;
4397     const int which = TOPi;
4398     TAINT_PROPER("setpriority");
4399     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4400     RETURN;
4401 #else
4402     DIE(aTHX_ PL_no_func, "setpriority()");
4403 #endif
4404 }
4405
4406 #undef PRIORITY_WHICH_T
4407
4408 /* Time calls. */
4409
4410 PP(pp_time)
4411 {
4412     dVAR; dSP; dTARGET;
4413 #ifdef BIG_TIME
4414     XPUSHn( time(NULL) );
4415 #else
4416     XPUSHi( time(NULL) );
4417 #endif
4418     RETURN;
4419 }
4420
4421 PP(pp_tms)
4422 {
4423 #ifdef HAS_TIMES
4424     dVAR;
4425     dSP;
4426     EXTEND(SP, 4);
4427 #ifndef VMS
4428     (void)PerlProc_times(&PL_timesbuf);
4429 #else
4430     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4431                                                    /* struct tms, though same data   */
4432                                                    /* is returned.                   */
4433 #endif
4434
4435     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4436     if (GIMME == G_ARRAY) {
4437         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4438         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4439         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4440     }
4441     RETURN;
4442 #else
4443 #   ifdef PERL_MICRO
4444     dSP;
4445     mPUSHn(0.0);
4446     EXTEND(SP, 4);
4447     if (GIMME == G_ARRAY) {
4448          mPUSHn(0.0);
4449          mPUSHn(0.0);
4450          mPUSHn(0.0);
4451     }
4452     RETURN;
4453 #   else
4454     DIE(aTHX_ "times not implemented");
4455 #   endif
4456 #endif /* HAS_TIMES */
4457 }
4458
4459 /* The 32 bit int year limits the times we can represent to these
4460    boundaries with a few days wiggle room to account for time zone
4461    offsets
4462 */
4463 /* Sat Jan  3 00:00:00 -2147481748 */
4464 #define TIME_LOWER_BOUND -67768100567755200.0
4465 /* Sun Dec 29 12:00:00  2147483647 */
4466 #define TIME_UPPER_BOUND  67767976233316800.0
4467
4468 PP(pp_gmtime)
4469 {
4470     dVAR;
4471     dSP;
4472     Time64_T when;
4473     struct TM tmbuf;
4474     struct TM *err;
4475     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4476     static const char * const dayname[] =
4477         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4478     static const char * const monname[] =
4479         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4480          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4481
4482     if (MAXARG < 1) {
4483         time_t now;
4484         (void)time(&now);
4485         when = (Time64_T)now;
4486     }
4487     else {
4488         NV input = Perl_floor(POPn);
4489         when = (Time64_T)input;
4490         if (when != input) {
4491             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4492                            "%s(%.0" NVff ") too large", opname, input);
4493         }
4494     }
4495
4496     if ( TIME_LOWER_BOUND > when ) {
4497         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4498                        "%s(%.0" NVff ") too small", opname, when);
4499         err = NULL;
4500     }
4501     else if( when > TIME_UPPER_BOUND ) {
4502         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4503                        "%s(%.0" NVff ") too large", opname, when);
4504         err = NULL;
4505     }
4506     else {
4507         if (PL_op->op_type == OP_LOCALTIME)
4508             err = S_localtime64_r(&when, &tmbuf);
4509         else
4510             err = S_gmtime64_r(&when, &tmbuf);
4511     }
4512
4513     if (err == NULL) {
4514         /* XXX %lld broken for quads */
4515         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4516                        "%s(%.0" NVff ") failed", opname, when);
4517     }
4518
4519     if (GIMME != G_ARRAY) {     /* scalar context */
4520         SV *tsv;
4521         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4522         double year = (double)tmbuf.tm_year + 1900;
4523
4524         EXTEND(SP, 1);
4525         EXTEND_MORTAL(1);
4526         if (err == NULL)
4527             RETPUSHUNDEF;
4528
4529         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4530                             dayname[tmbuf.tm_wday],
4531                             monname[tmbuf.tm_mon],
4532                             tmbuf.tm_mday,
4533                             tmbuf.tm_hour,
4534                             tmbuf.tm_min,
4535                             tmbuf.tm_sec,
4536                             year);
4537         mPUSHs(tsv);
4538     }
4539     else {                      /* list context */
4540         if ( err == NULL )
4541             RETURN;
4542
4543         EXTEND(SP, 9);
4544         EXTEND_MORTAL(9);
4545         mPUSHi(tmbuf.tm_sec);
4546         mPUSHi(tmbuf.tm_min);
4547         mPUSHi(tmbuf.tm_hour);
4548         mPUSHi(tmbuf.tm_mday);
4549         mPUSHi(tmbuf.tm_mon);
4550         mPUSHn(tmbuf.tm_year);
4551         mPUSHi(tmbuf.tm_wday);
4552         mPUSHi(tmbuf.tm_yday);
4553         mPUSHi(tmbuf.tm_isdst);
4554     }
4555     RETURN;
4556 }
4557
4558 PP(pp_alarm)
4559 {
4560 #ifdef HAS_ALARM
4561     dVAR; dSP; dTARGET;
4562     int anum;
4563     anum = POPi;
4564     anum = alarm((unsigned int)anum);
4565     if (anum < 0)
4566         RETPUSHUNDEF;
4567     PUSHi(anum);
4568     RETURN;
4569 #else
4570     DIE(aTHX_ PL_no_func, "alarm");
4571 #endif
4572 }
4573
4574 PP(pp_sleep)
4575 {
4576     dVAR; dSP; dTARGET;
4577     I32 duration;
4578     Time_t lasttime;
4579     Time_t when;
4580
4581     (void)time(&lasttime);
4582     if (MAXARG < 1)
4583         PerlProc_pause();
4584     else {
4585         duration = POPi;
4586         PerlProc_sleep((unsigned int)duration);
4587     }
4588     (void)time(&when);
4589     XPUSHi(when - lasttime);
4590     RETURN;
4591 }
4592
4593 /* Shared memory. */
4594 /* Merged with some message passing. */
4595
4596 PP(pp_shmwrite)
4597 {
4598 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4599     dVAR; dSP; dMARK; dTARGET;
4600     const int op_type = PL_op->op_type;
4601     I32 value;
4602
4603     switch (op_type) {
4604     case OP_MSGSND:
4605         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4606         break;
4607     case OP_MSGRCV:
4608         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4609         break;
4610     case OP_SEMOP:
4611         value = (I32)(do_semop(MARK, SP) >= 0);
4612         break;
4613     default:
4614         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4615         break;
4616     }
4617
4618     SP = MARK;
4619     PUSHi(value);
4620     RETURN;
4621 #else
4622     return Perl_pp_semget(aTHX);
4623 #endif
4624 }
4625
4626 /* Semaphores. */
4627
4628 PP(pp_semget)
4629 {
4630 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4631     dVAR; dSP; dMARK; dTARGET;
4632     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4633     SP = MARK;
4634     if (anum == -1)
4635         RETPUSHUNDEF;
4636     PUSHi(anum);
4637     RETURN;
4638 #else
4639     DIE(aTHX_ "System V IPC is not implemented on this machine");
4640 #endif
4641 }
4642
4643 PP(pp_semctl)
4644 {
4645 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4646     dVAR; dSP; dMARK; dTARGET;
4647     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4648     SP = MARK;
4649     if (anum == -1)
4650         RETSETUNDEF;
4651     if (anum != 0) {
4652         PUSHi(anum);
4653     }
4654     else {
4655         PUSHp(zero_but_true, ZBTLEN);
4656     }
4657     RETURN;
4658 #else
4659     return Perl_pp_semget(aTHX);
4660 #endif
4661 }
4662
4663 /* I can't const this further without getting warnings about the types of
4664    various arrays passed in from structures.  */
4665 static SV *
4666 S_space_join_names_mortal(pTHX_ char *const *array)
4667 {
4668     SV *target;
4669
4670     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4671
4672     if (array && *array) {
4673         target = newSVpvs_flags("", SVs_TEMP);
4674         while (1) {
4675             sv_catpv(target, *array);
4676             if (!*++array)
4677                 break;
4678             sv_catpvs(target, " ");
4679         }
4680     } else {
4681         target = sv_mortalcopy(&PL_sv_no);
4682     }
4683     return target;
4684 }
4685
4686 /* Get system info. */
4687
4688 PP(pp_ghostent)
4689 {
4690 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4691     dVAR; dSP;
4692     I32 which = PL_op->op_type;
4693     register char **elem;
4694     register SV *sv;
4695 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4696     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4697     struct hostent *gethostbyname(Netdb_name_t);
4698     struct hostent *gethostent(void);
4699 #endif
4700     struct hostent *hent = NULL;
4701     unsigned long len;
4702
4703     EXTEND(SP, 10);
4704     if (which == OP_GHBYNAME) {
4705 #ifdef HAS_GETHOSTBYNAME
4706         const char* const name = POPpbytex;
4707         hent = PerlSock_gethostbyname(name);
4708 #else
4709         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4710 #endif
4711     }
4712     else if (which == OP_GHBYADDR) {
4713 #ifdef HAS_GETHOSTBYADDR
4714         const int addrtype = POPi;
4715         SV * const addrsv = POPs;
4716         STRLEN addrlen;
4717         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4718
4719         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4720 #else
4721         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4722 #endif
4723     }
4724     else
4725 #ifdef HAS_GETHOSTENT
4726         hent = PerlSock_gethostent();
4727 #else
4728         DIE(aTHX_ PL_no_sock_func, "gethostent");
4729 #endif
4730
4731 #ifdef HOST_NOT_FOUND
4732         if (!hent) {
4733 #ifdef USE_REENTRANT_API
4734 #   ifdef USE_GETHOSTENT_ERRNO
4735             h_errno = PL_reentrant_buffer->_gethostent_errno;
4736 #   endif
4737 #endif
4738             STATUS_UNIX_SET(h_errno);
4739         }
4740 #endif
4741
4742     if (GIMME != G_ARRAY) {
4743         PUSHs(sv = sv_newmortal());
4744         if (hent) {
4745             if (which == OP_GHBYNAME) {
4746                 if (hent->h_addr)
4747                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4748             }
4749             else
4750                 sv_setpv(sv, (char*)hent->h_name);
4751         }
4752         RETURN;
4753     }
4754
4755     if (hent) {
4756         mPUSHs(newSVpv((char*)hent->h_name, 0));
4757         PUSHs(space_join_names_mortal(hent->h_aliases));
4758         mPUSHi(hent->h_addrtype);
4759         len = hent->h_length;
4760         mPUSHi(len);
4761 #ifdef h_addr
4762         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4763             mXPUSHp(*elem, len);
4764         }
4765 #else
4766         if (hent->h_addr)
4767             mPUSHp(hent->h_addr, len);
4768         else
4769             PUSHs(sv_mortalcopy(&PL_sv_no));
4770 #endif /* h_addr */
4771     }
4772     RETURN;
4773 #else
4774     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4775 #endif
4776 }
4777
4778 PP(pp_gnetent)
4779 {
4780 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4781     dVAR; dSP;
4782     I32 which = PL_op->op_type;
4783     register SV *sv;
4784 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4785     struct netent *getnetbyaddr(Netdb_net_t, int);
4786     struct netent *getnetbyname(Netdb_name_t);
4787     struct netent *getnetent(void);
4788 #endif
4789     struct netent *nent;
4790
4791     if (which == OP_GNBYNAME){
4792 #ifdef HAS_GETNETBYNAME
4793         const char * const name = POPpbytex;
4794         nent = PerlSock_getnetbyname(name);
4795 #else
4796         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4797 #endif
4798     }
4799     else if (which == OP_GNBYADDR) {
4800 #ifdef HAS_GETNETBYADDR
4801         const int addrtype = POPi;
4802         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4803         nent = PerlSock_getnetbyaddr(addr, addrtype);
4804 #else
4805         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4806 #endif
4807     }
4808     else
4809 #ifdef HAS_GETNETENT
4810         nent = PerlSock_getnetent();
4811 #else
4812         DIE(aTHX_ PL_no_sock_func, "getnetent");
4813 #endif
4814
4815 #ifdef HOST_NOT_FOUND
4816         if (!nent) {
4817 #ifdef USE_REENTRANT_API
4818 #   ifdef USE_GETNETENT_ERRNO
4819              h_errno = PL_reentrant_buffer->_getnetent_errno;
4820 #   endif
4821 #endif
4822             STATUS_UNIX_SET(h_errno);
4823         }
4824 #endif
4825
4826     EXTEND(SP, 4);
4827     if (GIMME != G_ARRAY) {
4828         PUSHs(sv = sv_newmortal());
4829         if (nent) {
4830             if (which == OP_GNBYNAME)
4831                 sv_setiv(sv, (IV)nent->n_net);
4832             else
4833                 sv_setpv(sv, nent->n_name);
4834         }
4835         RETURN;
4836     }
4837
4838     if (nent) {
4839         mPUSHs(newSVpv(nent->n_name, 0));
4840         PUSHs(space_join_names_mortal(nent->n_aliases));
4841         mPUSHi(nent->n_addrtype);
4842         mPUSHi(nent->n_net);
4843     }
4844
4845     RETURN;
4846 #else
4847     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4848 #endif
4849 }
4850
4851 PP(pp_gprotoent)
4852 {
4853 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4854     dVAR; dSP;
4855     I32 which = PL_op->op_type;
4856     register SV *sv;
4857 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4858     struct protoent *getprotobyname(Netdb_name_t);
4859     struct protoent *getprotobynumber(int);
4860     struct protoent *getprotoent(void);
4861 #endif
4862     struct protoent *pent;
4863
4864     if (which == OP_GPBYNAME) {
4865 #ifdef HAS_GETPROTOBYNAME
4866         const char* const name = POPpbytex;
4867         pent = PerlSock_getprotobyname(name);
4868 #else
4869         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4870 #endif
4871     }
4872     else if (which == OP_GPBYNUMBER) {
4873 #ifdef HAS_GETPROTOBYNUMBER
4874         const int number = POPi;
4875         pent = PerlSock_getprotobynumber(number);
4876 #else
4877         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4878 #endif
4879     }
4880     else
4881 #ifdef HAS_GETPROTOENT
4882         pent = PerlSock_getprotoent();
4883 #else
4884         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4885 #endif
4886
4887     EXTEND(SP, 3);
4888     if (GIMME != G_ARRAY) {
4889         PUSHs(sv = sv_newmortal());
4890         if (pent) {
4891             if (which == OP_GPBYNAME)
4892                 sv_setiv(sv, (IV)pent->p_proto);
4893             else
4894                 sv_setpv(sv, pent->p_name);
4895         }
4896         RETURN;
4897     }
4898
4899     if (pent) {
4900         mPUSHs(newSVpv(pent->p_name, 0));
4901         PUSHs(space_join_names_mortal(pent->p_aliases));
4902         mPUSHi(pent->p_proto);
4903     }
4904
4905     RETURN;
4906 #else
4907     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4908 #endif
4909 }
4910
4911 PP(pp_gservent)
4912 {
4913 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4914     dVAR; dSP;
4915     I32 which = PL_op->op_type;
4916     register SV *sv;
4917 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4918     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4919     struct servent *getservbyport(int, Netdb_name_t);
4920     struct servent *getservent(void);
4921 #endif
4922     struct servent *sent;
4923
4924     if (which == OP_GSBYNAME) {
4925 #ifdef HAS_GETSERVBYNAME
4926         const char * const proto = POPpbytex;
4927         const char * const name = POPpbytex;
4928         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4929 #else
4930         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4931 #endif
4932     }
4933     else if (which == OP_GSBYPORT) {
4934 #ifdef HAS_GETSERVBYPORT
4935         const char * const proto = POPpbytex;
4936         unsigned short port = (unsigned short)POPu;
4937 #ifdef HAS_HTONS
4938         port = PerlSock_htons(port);
4939 #endif
4940         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4941 #else
4942         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4943 #endif
4944     }
4945     else
4946 #ifdef HAS_GETSERVENT
4947         sent = PerlSock_getservent();
4948 #else
4949         DIE(aTHX_ PL_no_sock_func, "getservent");
4950 #endif
4951
4952     EXTEND(SP, 4);
4953     if (GIMME != G_ARRAY) {
4954         PUSHs(sv = sv_newmortal());
4955         if (sent) {
4956             if (which == OP_GSBYNAME) {
4957 #ifdef HAS_NTOHS
4958                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4959 #else
4960                 sv_setiv(sv, (IV)(sent->s_port));
4961 #endif
4962             }
4963             else
4964                 sv_setpv(sv, sent->s_name);
4965         }
4966         RETURN;
4967     }
4968
4969     if (sent) {
4970         mPUSHs(newSVpv(sent->s_name, 0));
4971         PUSHs(space_join_names_mortal(sent->s_aliases));
4972 #ifdef HAS_NTOHS
4973         mPUSHi(PerlSock_ntohs(sent->s_port));
4974 #else
4975         mPUSHi(sent->s_port);
4976 #endif
4977         mPUSHs(newSVpv(sent->s_proto, 0));
4978     }
4979
4980     RETURN;
4981 #else
4982     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4983 #endif
4984 }
4985
4986 PP(pp_shostent)
4987 {
4988     dVAR; dSP;
4989     const int stayopen = TOPi;
4990     switch(PL_op->op_type) {
4991     case OP_SHOSTENT:
4992 #ifdef HAS_SETHOSTENT
4993         PerlSock_sethostent(stayopen);
4994 #else
4995         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4996 #endif
4997         break;
4998 #ifdef HAS_SETNETENT
4999     case OP_SNETENT:
5000         PerlSock_setnetent(stayopen);
5001 #else
5002         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5003 #endif
5004         break;
5005     case OP_SPROTOENT:
5006 #ifdef HAS_SETPROTOENT
5007         PerlSock_setprotoent(stayopen);
5008 #else
5009         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5010 #endif
5011         break;
5012     case OP_SSERVENT:
5013 #ifdef HAS_SETSERVENT
5014         PerlSock_setservent(stayopen);
5015 #else
5016         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5017 #endif
5018         break;
5019     }
5020     RETSETYES;
5021 }
5022
5023 PP(pp_ehostent)
5024 {
5025     dVAR; dSP;
5026     switch(PL_op->op_type) {
5027     case OP_EHOSTENT:
5028 #ifdef HAS_ENDHOSTENT
5029         PerlSock_endhostent();
5030 #else
5031         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5032 #endif
5033         break;
5034     case OP_ENETENT:
5035 #ifdef HAS_ENDNETENT
5036         PerlSock_endnetent();
5037 #else
5038         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5039 #endif
5040         break;
5041     case OP_EPROTOENT:
5042 #ifdef HAS_ENDPROTOENT
5043         PerlSock_endprotoent();
5044 #else
5045         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5046 #endif
5047         break;
5048     case OP_ESERVENT:
5049 #ifdef HAS_ENDSERVENT
5050         PerlSock_endservent();
5051 #else
5052         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5053 #endif
5054         break;
5055     case OP_SGRENT:
5056 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5057         setgrent();
5058 #else
5059         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5060 #endif
5061         break;
5062     case OP_EGRENT:
5063 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5064         endgrent();
5065 #else
5066         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5067 #endif
5068         break;
5069     case OP_SPWENT:
5070 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5071         setpwent();
5072 #else
5073         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5074 #endif
5075         break;
5076     case OP_EPWENT:
5077 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5078         endpwent();
5079 #else
5080         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5081 #endif
5082         break;
5083     }
5084     EXTEND(SP,1);
5085     RETPUSHYES;
5086 }
5087
5088 PP(pp_gpwent)
5089 {
5090 #ifdef HAS_PASSWD
5091     dVAR; dSP;
5092     I32 which = PL_op->op_type;
5093     register SV *sv;
5094     struct passwd *pwent  = NULL;
5095     /*
5096      * We currently support only the SysV getsp* shadow password interface.
5097      * The interface is declared in <shadow.h> and often one needs to link
5098      * with -lsecurity or some such.
5099      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5100      * (and SCO?)
5101      *
5102      * AIX getpwnam() is clever enough to return the encrypted password
5103      * only if the caller (euid?) is root.
5104      *
5105      * There are at least three other shadow password APIs.  Many platforms
5106      * seem to contain more than one interface for accessing the shadow
5107      * password databases, possibly for compatibility reasons.
5108      * The getsp*() is by far he simplest one, the other two interfaces
5109      * are much more complicated, but also very similar to each other.
5110      *
5111      * <sys/types.h>
5112      * <sys/security.h>
5113      * <prot.h>
5114      * struct pr_passwd *getprpw*();
5115      * The password is in
5116      * char getprpw*(...).ufld.fd_encrypt[]
5117      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5118      *
5119      * <sys/types.h>
5120      * <sys/security.h>
5121      * <prot.h>
5122      * struct es_passwd *getespw*();
5123      * The password is in
5124      * char *(getespw*(...).ufld.fd_encrypt)
5125      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5126      *
5127      * <userpw.h> (AIX)
5128      * struct userpw *getuserpw();
5129      * The password is in
5130      * char *(getuserpw(...)).spw_upw_passwd
5131      * (but the de facto standard getpwnam() should work okay)
5132      *
5133      * Mention I_PROT here so that Configure probes for it.
5134      *
5135      * In HP-UX for getprpw*() the manual page claims that one should include
5136      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5137      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5138      * and pp_sys.c already includes <shadow.h> if there is such.
5139      *
5140      * Note that <sys/security.h> is already probed for, but currently
5141      * it is only included in special cases.
5142      *
5143      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5144      * be preferred interface, even though also the getprpw*() interface
5145      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5146      * One also needs to call set_auth_parameters() in main() before
5147      * doing anything else, whether one is using getespw*() or getprpw*().
5148      *
5149      * Note that accessing the shadow databases can be magnitudes
5150      * slower than accessing the standard databases.
5151      *
5152      * --jhi
5153      */
5154
5155 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5156     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5157      * the pw_comment is left uninitialized. */
5158     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5159 #   endif
5160
5161     switch (which) {
5162     case OP_GPWNAM:
5163       {
5164         const char* const name = POPpbytex;
5165         pwent  = getpwnam(name);
5166       }
5167       break;
5168     case OP_GPWUID:
5169       {
5170         Uid_t uid = POPi;
5171         pwent = getpwuid(uid);
5172       }
5173         break;
5174     case OP_GPWENT:
5175 #   ifdef HAS_GETPWENT
5176         pwent  = getpwent();
5177 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5178         if (pwent) pwent = getpwnam(pwent->pw_name);
5179 #endif
5180 #   else
5181         DIE(aTHX_ PL_no_func, "getpwent");
5182 #   endif
5183         break;
5184     }
5185
5186     EXTEND(SP, 10);
5187     if (GIMME != G_ARRAY) {
5188         PUSHs(sv = sv_newmortal());
5189         if (pwent) {
5190             if (which == OP_GPWNAM)
5191 #   if Uid_t_sign <= 0
5192                 sv_setiv(sv, (IV)pwent->pw_uid);
5193 #   else
5194                 sv_setuv(sv, (UV)pwent->pw_uid);
5195 #   endif
5196             else
5197                 sv_setpv(sv, pwent->pw_name);
5198         }
5199         RETURN;
5200     }
5201
5202     if (pwent) {
5203         mPUSHs(newSVpv(pwent->pw_name, 0));
5204
5205         sv = newSViv(0);
5206         mPUSHs(sv);
5207         /* If we have getspnam(), we try to dig up the shadow
5208          * password.  If we are underprivileged, the shadow
5209          * interface will set the errno to EACCES or similar,
5210          * and return a null pointer.  If this happens, we will
5211          * use the dummy password (usually "*" or "x") from the
5212          * standard password database.
5213          *
5214          * In theory we could skip the shadow call completely
5215          * if euid != 0 but in practice we cannot know which
5216          * security measures are guarding the shadow databases
5217          * on a random platform.
5218          *
5219          * Resist the urge to use additional shadow interfaces.
5220          * Divert the urge to writing an extension instead.
5221          *
5222          * --jhi */
5223         /* Some AIX setups falsely(?) detect some getspnam(), which
5224          * has a different API than the Solaris/IRIX one. */
5225 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5226         {
5227             dSAVE_ERRNO;
5228             const struct spwd * const spwent = getspnam(pwent->pw_name);
5229                           /* Save and restore errno so that
5230                            * underprivileged attempts seem
5231                            * to have never made the unsuccessful
5232                            * attempt to retrieve the shadow password. */
5233             RESTORE_ERRNO;
5234             if (spwent && spwent->sp_pwdp)
5235                 sv_setpv(sv, spwent->sp_pwdp);
5236         }
5237 #   endif
5238 #   ifdef PWPASSWD
5239         if (!SvPOK(sv)) /* Use the standard password, then. */
5240             sv_setpv(sv, pwent->pw_passwd);
5241 #   endif
5242
5243 #   ifndef INCOMPLETE_TAINTS
5244         /* passwd is tainted because user himself can diddle with it.
5245          * admittedly not much and in a very limited way, but nevertheless. */
5246         SvTAINTED_on(sv);
5247 #   endif
5248
5249 #   if Uid_t_sign <= 0
5250         mPUSHi(pwent->pw_uid);
5251 #   else
5252         mPUSHu(pwent->pw_uid);
5253 #   endif
5254
5255 #   if Uid_t_sign <= 0
5256         mPUSHi(pwent->pw_gid);
5257 #   else
5258         mPUSHu(pwent->pw_gid);
5259 #   endif
5260         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5261          * because of the poor interface of the Perl getpw*(),
5262          * not because there's some standard/convention saying so.
5263          * A better interface would have been to return a hash,
5264          * but we are accursed by our history, alas. --jhi.  */
5265 #   ifdef PWCHANGE
5266         mPUSHi(pwent->pw_change);
5267 #   else
5268 #       ifdef PWQUOTA
5269         mPUSHi(pwent->pw_quota);
5270 #       else
5271 #           ifdef PWAGE
5272         mPUSHs(newSVpv(pwent->pw_age, 0));
5273 #           else
5274         /* I think that you can never get this compiled, but just in case.  */
5275         PUSHs(sv_mortalcopy(&PL_sv_no));
5276 #           endif
5277 #       endif
5278 #   endif
5279
5280         /* pw_class and pw_comment are mutually exclusive--.
5281          * see the above note for pw_change, pw_quota, and pw_age. */
5282 #   ifdef PWCLASS
5283         mPUSHs(newSVpv(pwent->pw_class, 0));
5284 #   else
5285 #       ifdef PWCOMMENT
5286         mPUSHs(newSVpv(pwent->pw_comment, 0));
5287 #       else
5288         /* I think that you can never get this compiled, but just in case.  */
5289         PUSHs(sv_mortalcopy(&PL_sv_no));
5290 #       endif
5291 #   endif
5292
5293 #   ifdef PWGECOS
5294         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5295 #   else
5296         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5297 #   endif
5298 #   ifndef INCOMPLETE_TAINTS
5299         /* pw_gecos is tainted because user himself can diddle with it. */
5300         SvTAINTED_on(sv);
5301 #   endif
5302
5303         mPUSHs(newSVpv(pwent->pw_dir, 0));
5304
5305         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5306 #   ifndef INCOMPLETE_TAINTS
5307         /* pw_shell is tainted because user himself can diddle with it. */
5308         SvTAINTED_on(sv);
5309 #   endif
5310
5311 #   ifdef PWEXPIRE
5312         mPUSHi(pwent->pw_expire);
5313 #   endif
5314     }
5315     RETURN;
5316 #else
5317     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5318 #endif
5319 }
5320
5321 PP(pp_ggrent)
5322 {
5323 #ifdef HAS_GROUP
5324     dVAR; dSP;
5325     const I32 which = PL_op->op_type;
5326     const struct group *grent;
5327
5328     if (which == OP_GGRNAM) {
5329         const char* const name = POPpbytex;
5330         grent = (const struct group *)getgrnam(name);
5331     }
5332     else if (which == OP_GGRGID) {
5333         const Gid_t gid = POPi;
5334         grent = (const struct group *)getgrgid(gid);
5335     }
5336     else
5337 #ifdef HAS_GETGRENT
5338         grent = (struct group *)getgrent();
5339 #else
5340         DIE(aTHX_ PL_no_func, "getgrent");
5341 #endif
5342
5343     EXTEND(SP, 4);
5344     if (GIMME != G_ARRAY) {
5345         SV * const sv = sv_newmortal();
5346
5347         PUSHs(sv);
5348         if (grent) {
5349             if (which == OP_GGRNAM)
5350 #if Gid_t_sign <= 0
5351                 sv_setiv(sv, (IV)grent->gr_gid);
5352 #else
5353                 sv_setuv(sv, (UV)grent->gr_gid);
5354 #endif
5355             else
5356                 sv_setpv(sv, grent->gr_name);
5357         }
5358         RETURN;
5359     }
5360
5361     if (grent) {
5362         mPUSHs(newSVpv(grent->gr_name, 0));
5363
5364 #ifdef GRPASSWD
5365         mPUSHs(newSVpv(grent->gr_passwd, 0));
5366 #else
5367         PUSHs(sv_mortalcopy(&PL_sv_no));
5368 #endif
5369
5370 #if Gid_t_sign <= 0
5371         mPUSHi(grent->gr_gid);
5372 #else
5373         mPUSHu(grent->gr_gid);
5374 #endif
5375
5376 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5377         /* In UNICOS/mk (_CRAYMPP) the multithreading
5378          * versions (getgrnam_r, getgrgid_r)
5379          * seem to return an illegal pointer
5380          * as the group members list, gr_mem.
5381          * getgrent() doesn't even have a _r version
5382          * but the gr_mem is poisonous anyway.
5383          * So yes, you cannot get the list of group
5384          * members if building multithreaded in UNICOS/mk. */
5385         PUSHs(space_join_names_mortal(grent->gr_mem));
5386 #endif
5387     }
5388
5389     RETURN;
5390 #else
5391     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5392 #endif
5393 }
5394
5395 PP(pp_getlogin)
5396 {
5397 #ifdef HAS_GETLOGIN
5398     dVAR; dSP; dTARGET;
5399     char *tmps;
5400     EXTEND(SP, 1);
5401     if (!(tmps = PerlProc_getlogin()))
5402         RETPUSHUNDEF;
5403     sv_setpv_mg(TARG, tmps);
5404     PUSHs(TARG);
5405     RETURN;
5406 #else
5407     DIE(aTHX_ PL_no_func, "getlogin");
5408 #endif
5409 }
5410
5411 /* Miscellaneous. */
5412
5413 PP(pp_syscall)
5414 {
5415 #ifdef HAS_SYSCALL
5416     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5417     register I32 items = SP - MARK;
5418     unsigned long a[20];
5419     register I32 i = 0;
5420     I32 retval = -1;
5421
5422     if (PL_tainting) {
5423         while (++MARK <= SP) {
5424             if (SvTAINTED(*MARK)) {
5425                 TAINT;
5426                 break;
5427             }
5428         }
5429         MARK = ORIGMARK;
5430         TAINT_PROPER("syscall");
5431     }
5432
5433     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5434      * or where sizeof(long) != sizeof(char*).  But such machines will
5435      * not likely have syscall implemented either, so who cares?
5436      */
5437     while (++MARK <= SP) {
5438         if (SvNIOK(*MARK) || !i)
5439             a[i++] = SvIV(*MARK);
5440         else if (*MARK == &PL_sv_undef)
5441             a[i++] = 0;
5442         else
5443             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5444         if (i > 15)
5445             break;
5446     }
5447     switch (items) {
5448     default:
5449         DIE(aTHX_ "Too many args to syscall");
5450     case 0:
5451         DIE(aTHX_ "Too few args to syscall");
5452     case 1:
5453         retval = syscall(a[0]);
5454         break;
5455     case 2:
5456         retval = syscall(a[0],a[1]);
5457         break;
5458     case 3:
5459         retval = syscall(a[0],a[1],a[2]);
5460         break;
5461     case 4:
5462         retval = syscall(a[0],a[1],a[2],a[3]);
5463         break;
5464     case 5:
5465         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5466         break;
5467     case 6:
5468         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5469         break;
5470     case 7:
5471         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5472         break;
5473     case 8:
5474         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5475         break;
5476 #ifdef atarist
5477     case 9:
5478         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5479         break;
5480     case 10:
5481         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5482         break;
5483     case 11:
5484         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5485           a[10]);
5486         break;
5487     case 12:
5488         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5489           a[10],a[11]);
5490         break;
5491     case 13:
5492         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5493           a[10],a[11],a[12]);
5494         break;
5495     case 14:
5496         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5497           a[10],a[11],a[12],a[13]);
5498         break;
5499 #endif /* atarist */
5500     }
5501     SP = ORIGMARK;
5502     PUSHi(retval);
5503     RETURN;
5504 #else
5505     DIE(aTHX_ PL_no_func, "syscall");
5506 #endif
5507 }
5508
5509 #ifdef FCNTL_EMULATE_FLOCK
5510
5511 /*  XXX Emulate flock() with fcntl().
5512     What's really needed is a good file locking module.
5513 */
5514
5515 static int
5516 fcntl_emulate_flock(int fd, int operation)
5517 {
5518     int res;
5519     struct flock flock;
5520
5521     switch (operation & ~LOCK_NB) {
5522     case LOCK_SH:
5523         flock.l_type = F_RDLCK;
5524         break;
5525     case LOCK_EX:
5526         flock.l_type = F_WRLCK;
5527         break;
5528     case LOCK_UN:
5529         flock.l_type = F_UNLCK;
5530         break;
5531     default:
5532         errno = EINVAL;
5533         return -1;
5534     }
5535     flock.l_whence = SEEK_SET;
5536     flock.l_start = flock.l_len = (Off_t)0;
5537
5538     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5539     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5540         errno = EWOULDBLOCK;
5541     return res;
5542 }
5543
5544 #endif /* FCNTL_EMULATE_FLOCK */
5545
5546 #ifdef LOCKF_EMULATE_FLOCK
5547
5548 /*  XXX Emulate flock() with lockf().  This is just to increase
5549     portability of scripts.  The calls are not completely
5550     interchangeable.  What's really needed is a good file
5551     locking module.
5552 */
5553
5554 /*  The lockf() constants might have been defined in <unistd.h>.
5555     Unfortunately, <unistd.h> causes troubles on some mixed
5556     (BSD/POSIX) systems, such as SunOS 4.1.3.
5557
5558    Further, the lockf() constants aren't POSIX, so they might not be
5559    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5560    just stick in the SVID values and be done with it.  Sigh.
5561 */
5562
5563 # ifndef F_ULOCK
5564 #  define F_ULOCK       0       /* Unlock a previously locked region */
5565 # endif
5566 # ifndef F_LOCK
5567 #  define F_LOCK        1       /* Lock a region for exclusive use */
5568 # endif
5569 # ifndef F_TLOCK
5570 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5571 # endif
5572 # ifndef F_TEST
5573 #  define F_TEST        3       /* Test a region for other processes locks */
5574 # endif
5575
5576 static int
5577 lockf_emulate_flock(int fd, int operation)
5578 {
5579     int i;
5580     Off_t pos;
5581     dSAVE_ERRNO;
5582
5583     /* flock locks entire file so for lockf we need to do the same      */
5584     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5585     if (pos > 0)        /* is seekable and needs to be repositioned     */
5586         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5587             pos = -1;   /* seek failed, so don't seek back afterwards   */
5588     RESTORE_ERRNO;
5589
5590     switch (operation) {
5591
5592         /* LOCK_SH - get a shared lock */
5593         case LOCK_SH:
5594         /* LOCK_EX - get an exclusive lock */
5595         case LOCK_EX:
5596             i = lockf (fd, F_LOCK, 0);
5597             break;
5598
5599         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5600         case LOCK_SH|LOCK_NB:
5601         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5602         case LOCK_EX|LOCK_NB:
5603             i = lockf (fd, F_TLOCK, 0);
5604             if (i == -1)
5605                 if ((errno == EAGAIN) || (errno == EACCES))
5606                     errno = EWOULDBLOCK;
5607             break;
5608
5609         /* LOCK_UN - unlock (non-blocking is a no-op) */
5610         case LOCK_UN:
5611         case LOCK_UN|LOCK_NB:
5612             i = lockf (fd, F_ULOCK, 0);
5613             break;
5614
5615         /* Default - can't decipher operation */
5616         default:
5617             i = -1;
5618             errno = EINVAL;
5619             break;
5620     }
5621
5622     if (pos > 0)      /* need to restore position of the handle */
5623         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5624
5625     return (i);
5626 }
5627
5628 #endif /* LOCKF_EMULATE_FLOCK */
5629
5630 /*
5631  * Local variables:
5632  * c-indentation-style: bsd
5633  * c-basic-offset: 4
5634  * indent-tabs-mode: t
5635  * End:
5636  *
5637  * ex: set ts=8 sts=4 sw=4 noet:
5638  */