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