pp_sys.c

   1 /*    pp_sys.c
   2  *
   3  *    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4  *    2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * But only a short way ahead its floor and the walls on either side were
  13  * cloven by a great fissure, out of which the red glare came, now leaping
  14  * up, now dying down into darkness; and all the while far below there was
  15  * a rumour and a trouble as of great engines throbbing and labouring.
  16  *
  17  *     [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
  18  */
  19
  20 /* This file contains system pp ("push/pop") functions that
  21  * execute the opcodes that make up a perl program. A typical pp function
  22  * expects to find its arguments on the stack, and usually pushes its
  23  * results onto the stack, hence the 'pp' terminology. Each OP structure
  24  * contains a pointer to the relevant pp_foo() function.
  25  *
  26  * By 'system', we mean ops which interact with the OS, such as pp_open().
  27  */
  28
  29 #include "EXTERN.h"
  30 #define PERL_IN_PP_SYS_C
  31 #include "perl.h"
  32 #include "time64.h"
  33 #include "time64.c"
  34
  35 #ifdef I_SHADOW
  36 /* Shadow password support for solaris - pdo@cs.umd.edu
  37  * Not just Solaris: at least HP-UX, IRIX, Linux.
  38  * The API is from SysV.
  39  *
  40  * There are at least two more shadow interfaces,
  41  * see the comments in pp_gpwent().
  42  *
  43  * --jhi */
  44 #   ifdef __hpux__
  45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
  46  * and another MAXINT from "perl.h" <- <sys/param.h>. */
  47 #       undef MAXINT
  48 #   endif
  49 #   include <shadow.h>
  50 #endif
  51
  52 #ifdef I_SYS_WAIT
  53 # include <sys/wait.h>
  54 #endif
  55
  56 #ifdef I_SYS_RESOURCE
  57 # include <sys/resource.h>
  58 #endif
  59
  60 #ifdef NETWARE
  61 NETDB_DEFINE_CONTEXT
  62 #endif
  63
  64 #ifdef HAS_SELECT
  65 # ifdef I_SYS_SELECT
  66 #  include <sys/select.h>
  67 # endif
  68 #endif
  69
  70 /* XXX Configure test needed.
  71    h_errno might not be a simple 'int', especially for multi-threaded
  72    applications, see "extern int errno in perl.h".  Creating such
  73    a test requires taking into account the differences between
  74    compiling multithreaded and singlethreaded ($ccflags et al).
  75    HOST_NOT_FOUND is typically defined in <netdb.h>.
  76 */
  77 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
  78 extern int h_errno;
  79 #endif
  80
  81 #ifdef HAS_PASSWD
  82 # ifdef I_PWD
  83 #  include <pwd.h>
  84 # else
  85 #  if !defined(VMS)
  86     struct passwd *getpwnam (char *);
  87     struct passwd *getpwuid (Uid_t);
  88 #  endif
  89 # endif
  90 # ifdef HAS_GETPWENT
  91 #ifndef getpwent
  92   struct passwd *getpwent (void);
  93 #elif defined (VMS) && defined (my_getpwent)
  94   struct passwd *Perl_my_getpwent (pTHX);
  95 #endif
  96 # endif
  97 #endif
  98
  99 #ifdef HAS_GROUP
 100 # ifdef I_GRP
 101 #  include <grp.h>
 102 # else
 103     struct group *getgrnam (char *);
 104     struct group *getgrgid (Gid_t);
 105 # endif
 106 # ifdef HAS_GETGRENT
 107 #ifndef getgrent
 108     struct group *getgrent (void);
 109 #endif
 110 # endif
 111 #endif
 112
 113 #ifdef I_UTIME
 114 #  if defined(_MSC_VER) || defined(__MINGW32__)
 115 #    include <sys/utime.h>
 116 #  else
 117 #    include <utime.h>
 118 #  endif
 119 #endif
 120
 121 #ifdef HAS_CHSIZE
 122 # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
 123 #   undef my_chsize
 124 # endif
 125 # define my_chsize PerlLIO_chsize
 126 #else
 127 # ifdef HAS_TRUNCATE
 128 #   define my_chsize PerlLIO_chsize
 129 # else
 130 I32 my_chsize(int fd, Off_t length);
 131 # endif
 132 #endif
 133
 134 #ifdef HAS_FLOCK
 135 #  define FLOCK flock
 136 #else /* no flock() */
 137
 138    /* fcntl.h might not have been included, even if it exists, because
 139       the current Configure only sets I_FCNTL if it's needed to pick up
 140       the *_OK constants.  Make sure it has been included before testing
 141       the fcntl() locking constants. */
 142 #  if defined(HAS_FCNTL) && !defined(I_FCNTL)
 143 #    include <fcntl.h>
 144 #  endif
 145
 146 #  if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
 147 #    define FLOCK fcntl_emulate_flock
 148 #    define FCNTL_EMULATE_FLOCK
 149 #  else /* no flock() or fcntl(F_SETLK,...) */
 150 #    ifdef HAS_LOCKF
 151 #      define FLOCK lockf_emulate_flock
 152 #      define LOCKF_EMULATE_FLOCK
 153 #    endif /* lockf */
 154 #  endif /* no flock() or fcntl(F_SETLK,...) */
 155
 156 #  ifdef FLOCK
 157      static int FLOCK (int, int);
 158
 159     /*
 160      * These are the flock() constants.  Since this sytems doesn't have
 161      * flock(), the values of the constants are probably not available.
 162      */
 163 #    ifndef LOCK_SH
 164 #      define LOCK_SH 1
 165 #    endif
 166 #    ifndef LOCK_EX
 167 #      define LOCK_EX 2
 168 #    endif
 169 #    ifndef LOCK_NB
 170 #      define LOCK_NB 4
 171 #    endif
 172 #    ifndef LOCK_UN
 173 #      define LOCK_UN 8
 174 #    endif
 175 #  endif /* emulating flock() */
 176
 177 #endif /* no flock() */
 178
 179 #define ZBTLEN 10
 180 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
 181
 182 #if defined(I_SYS_ACCESS) && !defined(R_OK)
 183 #  include <sys/access.h>
 184 #endif
 185
 186 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
 187 #  define FD_CLOEXEC 1          /* NeXT needs this */
 188 #endif
 189
 190 #include "reentr.h"
 191
 192 #ifdef __Lynx__
 193 /* Missing protos on LynxOS */
 194 void sethostent(int);
 195 void endhostent(void);
 196 void setnetent(int);
 197 void endnetent(void);
 198 void setprotoent(int);
 199 void endprotoent(void);
 200 void setservent(int);
 201 void endservent(void);
 202 #endif
 203
 204 #undef PERL_EFF_ACCESS  /* EFFective uid/gid ACCESS */
 205
 206 /* F_OK unused: if stat() cannot find it... */
 207
 208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
 209     /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
 210 #   define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
 211 #endif
 212
 213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
 214 #   ifdef I_SYS_SECURITY
 215 #       include <sys/security.h>
 216 #   endif
 217 #   ifdef ACC_SELF
 218         /* HP SecureWare */
 219 #       define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
 220 #   else
 221         /* SCO */
 222 #       define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
 223 #   endif
 224 #endif
 225
 226 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
 227     /* AIX */
 228 #   define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
 229 #endif
 230
 231
 232 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS)    \
 233     && (defined(HAS_SETREUID) || defined(HAS_SETRESUID)         \
 234         || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
 235 /* The Hard Way. */
 236 STATIC int
 237 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
 238 {
 239     const Uid_t ruid = getuid();
 240     const Uid_t euid = geteuid();
 241     const Gid_t rgid = getgid();
 242     const Gid_t egid = getegid();
 243     int res;
 244
 245 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
 246     Perl_croak(aTHX_ "switching effective uid is not implemented");
 247 #else
 248 #ifdef HAS_SETREUID
 249     if (setreuid(euid, ruid))
 250 #else
 251 #ifdef HAS_SETRESUID
 252     if (setresuid(euid, ruid, (Uid_t)-1))
 253 #endif
 254 #endif
 255         Perl_croak(aTHX_ "entering effective uid failed");
 256 #endif
 257
 258 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
 259     Perl_croak(aTHX_ "switching effective gid is not implemented");
 260 #else
 261 #ifdef HAS_SETREGID
 262     if (setregid(egid, rgid))
 263 #else
 264 #ifdef HAS_SETRESGID
 265     if (setresgid(egid, rgid, (Gid_t)-1))
 266 #endif
 267 #endif
 268         Perl_croak(aTHX_ "entering effective gid failed");
 269 #endif
 270
 271     res = access(path, mode);
 272
 273 #ifdef HAS_SETREUID
 274     if (setreuid(ruid, euid))
 275 #else
 276 #ifdef HAS_SETRESUID
 277     if (setresuid(ruid, euid, (Uid_t)-1))
 278 #endif
 279 #endif
 280         Perl_croak(aTHX_ "leaving effective uid failed");
 281
 282 #ifdef HAS_SETREGID
 283     if (setregid(rgid, egid))
 284 #else
 285 #ifdef HAS_SETRESGID
 286     if (setresgid(rgid, egid, (Gid_t)-1))
 287 #endif
 288 #endif
 289         Perl_croak(aTHX_ "leaving effective gid failed");
 290
 291     return res;
 292 }
 293 #   define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
 294 #endif
 295
 296 PP(pp_backtick)
 297 {
 298     dVAR; dSP; dTARGET;
 299     PerlIO *fp;
 300     const char * const tmps = POPpconstx;
 301     const I32 gimme = GIMME_V;
 302     const char *mode = "r";
 303
 304     TAINT_PROPER("``");
 305     if (PL_op->op_private & OPpOPEN_IN_RAW)
 306         mode = "rb";
 307     else if (PL_op->op_private & OPpOPEN_IN_CRLF)
 308         mode = "rt";
 309     fp = PerlProc_popen(tmps, mode);
 310     if (fp) {
 311         const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
 312         if (type && *type)
 313             PerlIO_apply_layers(aTHX_ fp,mode,type);
 314
 315         if (gimme == G_VOID) {
 316             char tmpbuf[256];
 317             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
 318                 NOOP;
 319         }
 320         else if (gimme == G_SCALAR) {
 321             ENTER_with_name("backtick");
 322             SAVESPTR(PL_rs);
 323             PL_rs = &PL_sv_undef;
 324             sv_setpvs(TARG, "");        /* note that this preserves previous buffer */
 325             while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
 326                 NOOP;
 327             LEAVE_with_name("backtick");
 328             XPUSHs(TARG);
 329             SvTAINTED_on(TARG);
 330         }
 331         else {
 332             for (;;) {
 333                 SV * const sv = newSV(79);
 334                 if (sv_gets(sv, fp, 0) == NULL) {
 335                     SvREFCNT_dec(sv);
 336                     break;
 337                 }
 338                 mXPUSHs(sv);
 339                 if (SvLEN(sv) - SvCUR(sv) > 20) {
 340                     SvPV_shrink_to_cur(sv);
 341                 }
 342                 SvTAINTED_on(sv);
 343             }
 344         }
 345         STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
 346         TAINT;          /* "I believe that this is not gratuitous!" */
 347     }
 348     else {
 349         STATUS_NATIVE_CHILD_SET(-1);
 350         if (gimme == G_SCALAR)
 351             RETPUSHUNDEF;
 352     }
 353
 354     RETURN;
 355 }
 356
 357 PP(pp_glob)
 358 {
 359     dVAR;
 360     OP *result;
 361     dSP;
 362     /* make a copy of the pattern, to ensure that magic is called once
 363      * and only once */
 364     TOPm1s = sv_2mortal(newSVsv(TOPm1s));
 365
 366     tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
 367
 368     if (PL_op->op_flags & OPf_SPECIAL) {
 369         /* call Perl-level glob function instead. Stack args are:
 370          * MARK, wildcard, csh_glob context index
 371          * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
 372          * */
 373         return NORMAL;
 374     }
 375     /* stack args are: wildcard, gv(_GEN_n) */
 376
 377
 378     /* Note that we only ever get here if File::Glob fails to load
 379      * without at the same time croaking, for some reason, or if
 380      * perl was built with PERL_EXTERNAL_GLOB */
 381
 382     ENTER_with_name("glob");
 383
 384 #ifndef VMS
 385     if (PL_tainting) {
 386         /*
 387          * The external globbing program may use things we can't control,
 388          * so for security reasons we must assume the worst.
 389          */
 390         TAINT;
 391         taint_proper(PL_no_security, "glob");
 392     }
 393 #endif /* !VMS */
 394
 395     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
 396     PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
 397
 398     SAVESPTR(PL_rs);            /* This is not permanent, either. */
 399     PL_rs = newSVpvs_flags("\000", SVs_TEMP);
 400 #ifndef DOSISH
 401 #ifndef CSH
 402     *SvPVX(PL_rs) = '\n';
 403 #endif  /* !CSH */
 404 #endif  /* !DOSISH */
 405
 406     result = do_readline();
 407     LEAVE_with_name("glob");
 408     return result;
 409 }
 410
 411 PP(pp_rcatline)
 412 {
 413     dVAR;
 414     PL_last_in_gv = cGVOP_gv;
 415     return do_readline();
 416 }
 417
 418 PP(pp_warn)
 419 {
 420     dVAR; dSP; dMARK;
 421     SV *exsv;
 422     STRLEN len;
 423     if (SP - MARK > 1) {
 424         dTARGET;
 425         do_join(TARG, &PL_sv_no, MARK, SP);
 426         exsv = TARG;
 427         SP = MARK + 1;
 428     }
 429     else if (SP == MARK) {
 430         exsv = &PL_sv_no;
 431         EXTEND(SP, 1);
 432         SP = MARK + 1;
 433     }
 434     else {
 435         exsv = TOPs;
 436     }
 437
 438     if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
 439         /* well-formed exception supplied */
 440     }
 441     else if (SvROK(ERRSV)) {
 442         exsv = ERRSV;
 443     }
 444     else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
 445         exsv = sv_mortalcopy(ERRSV);
 446         sv_catpvs(exsv, "\t...caught");
 447     }
 448     else {
 449         exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
 450     }
 451     if (SvROK(exsv) && !PL_warnhook)
 452          Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
 453     else warn_sv(exsv);
 454     RETSETYES;
 455 }
 456
 457 PP(pp_die)
 458 {
 459     dVAR; dSP; dMARK;
 460     SV *exsv;
 461     STRLEN len;
 462 #ifdef VMS
 463     VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
 464 #endif
 465     if (SP - MARK != 1) {
 466         dTARGET;
 467         do_join(TARG, &PL_sv_no, MARK, SP);
 468         exsv = TARG;
 469         SP = MARK + 1;
 470     }
 471     else {
 472         exsv = TOPs;
 473     }
 474
 475     if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
 476         /* well-formed exception supplied */
 477     }
 478     else if (SvROK(ERRSV)) {
 479         exsv = ERRSV;
 480         if (sv_isobject(exsv)) {
 481             HV * const stash = SvSTASH(SvRV(exsv));
 482             GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
 483             if (gv) {
 484                 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
 485                 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
 486                 EXTEND(SP, 3);
 487                 PUSHMARK(SP);
 488                 PUSHs(exsv);
 489                 PUSHs(file);
 490                 PUSHs(line);
 491                 PUTBACK;
 492                 call_sv(MUTABLE_SV(GvCV(gv)),
 493                         G_SCALAR|G_EVAL|G_KEEPERR);
 494                 exsv = sv_mortalcopy(*PL_stack_sp--);
 495             }
 496         }
 497     }
 498     else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
 499         exsv = sv_mortalcopy(ERRSV);
 500         sv_catpvs(exsv, "\t...propagated");
 501     }
 502     else {
 503         exsv = newSVpvs_flags("Died", SVs_TEMP);
 504     }
 505     return die_sv(exsv);
 506 }
 507
 508 /* I/O. */
 509
 510 OP *
 511 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
 512                  const MAGIC *const mg, const U32 flags, U32 argc, ...)
 513 {
 514     SV **orig_sp = sp;
 515     I32 ret_args;
 516
 517     PERL_ARGS_ASSERT_TIED_METHOD;
 518
 519     /* Ensure that our flag bits do not overlap.  */
 520     assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
 521     assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
 522     assert((TIED_METHOD_SAY & G_WANT) == 0);
 523
 524     PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
 525     PUSHSTACKi(PERLSI_MAGIC);
 526     EXTEND(SP, argc+1); /* object + args */
 527     PUSHMARK(sp);
 528     PUSHs(SvTIED_obj(sv, mg));
 529     if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
 530         Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
 531         sp += argc;
 532     }
 533     else if (argc) {
 534         const U32 mortalize_not_needed
 535             = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
 536         va_list args;
 537         va_start(args, argc);
 538         do {
 539             SV *const arg = va_arg(args, SV *);
 540             if(mortalize_not_needed)
 541                 PUSHs(arg);
 542             else
 543                 mPUSHs(arg);
 544         } while (--argc);
 545         va_end(args);
 546     }
 547
 548     PUTBACK;
 549     ENTER_with_name("call_tied_method");
 550     if (flags & TIED_METHOD_SAY) {
 551         /* local $\ = "\n" */
 552         SAVEGENERICSV(PL_ors_sv);
 553         PL_ors_sv = newSVpvs("\n");
 554     }
 555     ret_args = call_method(methname, flags & G_WANT);
 556     SPAGAIN;
 557     orig_sp = sp;
 558     POPSTACK;
 559     SPAGAIN;
 560     if (ret_args) { /* copy results back to original stack */
 561         EXTEND(sp, ret_args);
 562         Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
 563         sp += ret_args;
 564         PUTBACK;
 565     }
 566     LEAVE_with_name("call_tied_method");
 567     return NORMAL;
 568 }
 569
 570 #define tied_method0(a,b,c,d)           \
 571     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
 572 #define tied_method1(a,b,c,d,e)         \
 573     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
 574 #define tied_method2(a,b,c,d,e,f)       \
 575     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
 576
 577 PP(pp_open)
 578 {
 579     dVAR; dSP;
 580     dMARK; dORIGMARK;
 581     dTARGET;
 582     SV *sv;
 583     IO *io;
 584     const char *tmps;
 585     STRLEN len;
 586     bool  ok;
 587
 588     GV * const gv = MUTABLE_GV(*++MARK);
 589
 590     if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
 591         DIE(aTHX_ PL_no_usym, "filehandle");
 592
 593     if ((io = GvIOp(gv))) {
 594         const MAGIC *mg;
 595         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 596
 597         if (IoDIRP(io))
 598             Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
 599                              "Opening dirhandle %s also as a file",
 600                              GvENAME(gv));
 601
 602         mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 603         if (mg) {
 604             /* Method's args are same as ours ... */
 605             /* ... except handle is replaced by the object */
 606             return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
 607                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
 608                                     sp - mark);
 609         }
 610     }
 611
 612     if (MARK < SP) {
 613         sv = *++MARK;
 614     }
 615     else {
 616         sv = GvSVn(gv);
 617     }
 618
 619     tmps = SvPV_const(sv, len);
 620     ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
 621     SP = ORIGMARK;
 622     if (ok)
 623         PUSHi( (I32)PL_forkprocess );
 624     else if (PL_forkprocess == 0)               /* we are a new child */
 625         PUSHi(0);
 626     else
 627         RETPUSHUNDEF;
 628     RETURN;
 629 }
 630
 631 PP(pp_close)
 632 {
 633     dVAR; dSP;
 634     GV * const gv =
 635         MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
 636
 637     if (MAXARG == 0)
 638         EXTEND(SP, 1);
 639
 640     if (gv) {
 641         IO * const io = GvIO(gv);
 642         if (io) {
 643             const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 644             if (mg) {
 645                 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
 646             }
 647         }
 648     }
 649     PUSHs(boolSV(do_close(gv, TRUE)));
 650     RETURN;
 651 }
 652
 653 PP(pp_pipe_op)
 654 {
 655 #ifdef HAS_PIPE
 656     dVAR;
 657     dSP;
 658     register IO *rstio;
 659     register IO *wstio;
 660     int fd[2];
 661
 662     GV * const wgv = MUTABLE_GV(POPs);
 663     GV * const rgv = MUTABLE_GV(POPs);
 664
 665     if (!rgv || !wgv)
 666         goto badexit;
 667
 668     if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
 669         DIE(aTHX_ PL_no_usym, "filehandle");
 670     rstio = GvIOn(rgv);
 671     wstio = GvIOn(wgv);
 672
 673     if (IoIFP(rstio))
 674         do_close(rgv, FALSE);
 675     if (IoIFP(wstio))
 676         do_close(wgv, FALSE);
 677
 678     if (PerlProc_pipe(fd) < 0)
 679         goto badexit;
 680
 681     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
 682     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
 683     IoOFP(rstio) = IoIFP(rstio);
 684     IoIFP(wstio) = IoOFP(wstio);
 685     IoTYPE(rstio) = IoTYPE_RDONLY;
 686     IoTYPE(wstio) = IoTYPE_WRONLY;
 687
 688     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 689         if (IoIFP(rstio))
 690             PerlIO_close(IoIFP(rstio));
 691         else
 692             PerlLIO_close(fd[0]);
 693         if (IoOFP(wstio))
 694             PerlIO_close(IoOFP(wstio));
 695         else
 696             PerlLIO_close(fd[1]);
 697         goto badexit;
 698     }
 699 #if defined(HAS_FCNTL) && defined(F_SETFD)
 700     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
 701     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
 702 #endif
 703     RETPUSHYES;
 704
 705 badexit:
 706     RETPUSHUNDEF;
 707 #else
 708     DIE(aTHX_ PL_no_func, "pipe");
 709 #endif
 710 }
 711
 712 PP(pp_fileno)
 713 {
 714     dVAR; dSP; dTARGET;
 715     GV *gv;
 716     IO *io;
 717     PerlIO *fp;
 718     const MAGIC *mg;
 719
 720     if (MAXARG < 1)
 721         RETPUSHUNDEF;
 722     gv = MUTABLE_GV(POPs);
 723     io = GvIO(gv);
 724
 725     if (io
 726         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 727     {
 728         return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
 729     }
 730
 731     if (!io || !(fp = IoIFP(io))) {
 732         /* Can't do this because people seem to do things like
 733            defined(fileno($foo)) to check whether $foo is a valid fh.
 734
 735            report_evil_fh(gv);
 736             */
 737         RETPUSHUNDEF;
 738     }
 739
 740     PUSHi(PerlIO_fileno(fp));
 741     RETURN;
 742 }
 743
 744 PP(pp_umask)
 745 {
 746     dVAR;
 747     dSP;
 748 #ifdef HAS_UMASK
 749     dTARGET;
 750     Mode_t anum;
 751
 752     if (MAXARG < 1 || (!TOPs && !POPs)) {
 753         anum = PerlLIO_umask(022);
 754         /* setting it to 022 between the two calls to umask avoids
 755          * to have a window where the umask is set to 0 -- meaning
 756          * that another thread could create world-writeable files. */
 757         if (anum != 022)
 758             (void)PerlLIO_umask(anum);
 759     }
 760     else
 761         anum = PerlLIO_umask(POPi);
 762     TAINT_PROPER("umask");
 763     XPUSHi(anum);
 764 #else
 765     /* Only DIE if trying to restrict permissions on "user" (self).
 766      * Otherwise it's harmless and more useful to just return undef
 767      * since 'group' and 'other' concepts probably don't exist here. */
 768     if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
 769         DIE(aTHX_ "umask not implemented");
 770     XPUSHs(&PL_sv_undef);
 771 #endif
 772     RETURN;
 773 }
 774
 775 PP(pp_binmode)
 776 {
 777     dVAR; dSP;
 778     GV *gv;
 779     IO *io;
 780     PerlIO *fp;
 781     SV *discp = NULL;
 782
 783     if (MAXARG < 1)
 784         RETPUSHUNDEF;
 785     if (MAXARG > 1) {
 786         discp = POPs;
 787     }
 788
 789     gv = MUTABLE_GV(POPs);
 790     io = GvIO(gv);
 791
 792     if (io) {
 793         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 794         if (mg) {
 795             /* This takes advantage of the implementation of the varargs
 796                function, which I don't think that the optimiser will be able to
 797                figure out. Although, as it's a static function, in theory it
 798                could.  */
 799             return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
 800                                     G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
 801                                     discp ? 1 : 0, discp);
 802         }
 803     }
 804
 805     if (!io || !(fp = IoIFP(io))) {
 806         report_evil_fh(gv);
 807         SETERRNO(EBADF,RMS_IFI);
 808         RETPUSHUNDEF;
 809     }
 810
 811     PUTBACK;
 812     {
 813         STRLEN len = 0;
 814         const char *d = NULL;
 815         int mode;
 816         if (discp)
 817             d = SvPV_const(discp, len);
 818         mode = mode_from_discipline(d, len);
 819         if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
 820             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
 821                 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
 822                     SPAGAIN;
 823                     RETPUSHUNDEF;
 824                 }
 825             }
 826             SPAGAIN;
 827             RETPUSHYES;
 828         }
 829         else {
 830             SPAGAIN;
 831             RETPUSHUNDEF;
 832         }
 833     }
 834 }
 835
 836 PP(pp_tie)
 837 {
 838     dVAR; dSP; dMARK;
 839     HV* stash;
 840     GV *gv = NULL;
 841     SV *sv;
 842     const I32 markoff = MARK - PL_stack_base;
 843     const char *methname;
 844     int how = PERL_MAGIC_tied;
 845     U32 items;
 846     SV *varsv = *++MARK;
 847
 848     switch(SvTYPE(varsv)) {
 849         case SVt_PVHV:
 850             methname = "TIEHASH";
 851             HvEITER_set(MUTABLE_HV(varsv), 0);
 852             break;
 853         case SVt_PVAV:
 854             methname = "TIEARRAY";
 855             break;
 856         case SVt_PVGV:
 857         case SVt_PVLV:
 858             if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
 859                 methname = "TIEHANDLE";
 860                 how = PERL_MAGIC_tiedscalar;
 861                 /* For tied filehandles, we apply tiedscalar magic to the IO
 862                    slot of the GP rather than the GV itself. AMS 20010812 */
 863                 if (!GvIOp(varsv))
 864                     GvIOp(varsv) = newIO();
 865                 varsv = MUTABLE_SV(GvIOp(varsv));
 866                 break;
 867             }
 868             /* FALL THROUGH */
 869         default:
 870             methname = "TIESCALAR";
 871             how = PERL_MAGIC_tiedscalar;
 872             break;
 873     }
 874     items = SP - MARK++;
 875     if (sv_isobject(*MARK)) { /* Calls GET magic. */
 876         ENTER_with_name("call_TIE");
 877         PUSHSTACKi(PERLSI_MAGIC);
 878         PUSHMARK(SP);
 879         EXTEND(SP,(I32)items);
 880         while (items--)
 881             PUSHs(*MARK++);
 882         PUTBACK;
 883         call_method(methname, G_SCALAR);
 884     }
 885     else {
 886         /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
 887          * will attempt to invoke IO::File::TIEARRAY, with (best case) the
 888          * wrong error message, and worse case, supreme action at a distance.
 889          * (Sorry obfuscation writers. You're not going to be given this one.)
 890          */
 891         STRLEN len;
 892         const char *name = SvPV_nomg_const(*MARK, len);
 893         stash = gv_stashpvn(name, len, 0);
 894         if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 895             DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
 896                  methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
 897         }
 898         ENTER_with_name("call_TIE");
 899         PUSHSTACKi(PERLSI_MAGIC);
 900         PUSHMARK(SP);
 901         EXTEND(SP,(I32)items);
 902         while (items--)
 903             PUSHs(*MARK++);
 904         PUTBACK;
 905         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
 906     }
 907     SPAGAIN;
 908
 909     sv = TOPs;
 910     POPSTACK;
 911     if (sv_isobject(sv)) {
 912         sv_unmagic(varsv, how);
 913         /* Croak if a self-tie on an aggregate is attempted. */
 914         if (varsv == SvRV(sv) &&
 915             (SvTYPE(varsv) == SVt_PVAV ||
 916              SvTYPE(varsv) == SVt_PVHV))
 917             Perl_croak(aTHX_
 918                        "Self-ties of arrays and hashes are not supported");
 919         sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
 920     }
 921     LEAVE_with_name("call_TIE");
 922     SP = PL_stack_base + markoff;
 923     PUSHs(sv);
 924     RETURN;
 925 }
 926
 927 PP(pp_untie)
 928 {
 929     dVAR; dSP;
 930     MAGIC *mg;
 931     SV *sv = POPs;
 932     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
 933                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
 934
 935     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
 936         RETPUSHYES;
 937
 938     if ((mg = SvTIED_mg(sv, how))) {
 939         SV * const obj = SvRV(SvTIED_obj(sv, mg));
 940         if (obj) {
 941             GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
 942             CV *cv;
 943             if (gv && isGV(gv) && (cv = GvCV(gv))) {
 944                PUSHMARK(SP);
 945                PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
 946                mXPUSHi(SvREFCNT(obj) - 1);
 947                PUTBACK;
 948                ENTER_with_name("call_UNTIE");
 949                call_sv(MUTABLE_SV(cv), G_VOID);
 950                LEAVE_with_name("call_UNTIE");
 951                SPAGAIN;
 952             }
 953             else if (mg && SvREFCNT(obj) > 1) {
 954                 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
 955                                "untie attempted while %"UVuf" inner references still exist",
 956                                (UV)SvREFCNT(obj) - 1 ) ;
 957             }
 958         }
 959     }
 960     sv_unmagic(sv, how) ;
 961     RETPUSHYES;
 962 }
 963
 964 PP(pp_tied)
 965 {
 966     dVAR;
 967     dSP;
 968     const MAGIC *mg;
 969     SV *sv = POPs;
 970     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
 971                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
 972
 973     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
 974         RETPUSHUNDEF;
 975
 976     if ((mg = SvTIED_mg(sv, how))) {
 977         SV *osv = SvTIED_obj(sv, mg);
 978         if (osv == mg->mg_obj)
 979             osv = sv_mortalcopy(osv);
 980         PUSHs(osv);
 981         RETURN;
 982     }
 983     RETPUSHUNDEF;
 984 }
 985
 986 PP(pp_dbmopen)
 987 {
 988     dVAR; dSP;
 989     dPOPPOPssrl;
 990     HV* stash;
 991     GV *gv = NULL;
 992
 993     HV * const hv = MUTABLE_HV(POPs);
 994     SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
 995     stash = gv_stashsv(sv, 0);
 996     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
 997         PUTBACK;
 998         require_pv("AnyDBM_File.pm");
 999         SPAGAIN;
1000         if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1001             DIE(aTHX_ "No dbm on this machine");
1002     }
1003
1004     ENTER;
1005     PUSHMARK(SP);
1006
1007     EXTEND(SP, 5);
1008     PUSHs(sv);
1009     PUSHs(left);
1010     if (SvIV(right))
1011         mPUSHu(O_RDWR|O_CREAT);
1012     else
1013         mPUSHu(O_RDWR);
1014     PUSHs(right);
1015     PUTBACK;
1016     call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1017     SPAGAIN;
1018
1019     if (!sv_isobject(TOPs)) {
1020         SP--;
1021         PUSHMARK(SP);
1022         PUSHs(sv);
1023         PUSHs(left);
1024         mPUSHu(O_RDONLY);
1025         PUSHs(right);
1026         PUTBACK;
1027         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1028         SPAGAIN;
1029     }
1030
1031     if (sv_isobject(TOPs)) {
1032         sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1033         sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1034     }
1035     LEAVE;
1036     RETURN;
1037 }
1038
1039 PP(pp_sselect)
1040 {
1041 #ifdef HAS_SELECT
1042     dVAR; dSP; dTARGET;
1043     register I32 i;
1044     register I32 j;
1045     register char *s;
1046     register SV *sv;
1047     NV value;
1048     I32 maxlen = 0;
1049     I32 nfound;
1050     struct timeval timebuf;
1051     struct timeval *tbuf = &timebuf;
1052     I32 growsize;
1053     char *fd_sets[4];
1054 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1055         I32 masksize;
1056         I32 offset;
1057         I32 k;
1058
1059 #   if BYTEORDER & 0xf0000
1060 #       define ORDERBYTE (0x88888888 - BYTEORDER)
1061 #   else
1062 #       define ORDERBYTE (0x4444 - BYTEORDER)
1063 #   endif
1064
1065 #endif
1066
1067     SP -= 4;
1068     for (i = 1; i <= 3; i++) {
1069         SV * const sv = SP[i];
1070         if (!SvOK(sv))
1071             continue;
1072         if (SvREADONLY(sv)) {
1073             if (SvIsCOW(sv))
1074                 sv_force_normal_flags(sv, 0);
1075             if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1076                 Perl_croak_no_modify(aTHX);
1077         }
1078         if (!SvPOK(sv)) {
1079             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1080             SvPV_force_nolen(sv);       /* force string conversion */
1081         }
1082         j = SvCUR(sv);
1083         if (maxlen < j)
1084             maxlen = j;
1085     }
1086
1087 /* little endians can use vecs directly */
1088 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1089 #  ifdef NFDBITS
1090
1091 #    ifndef NBBY
1092 #     define NBBY 8
1093 #    endif
1094
1095     masksize = NFDBITS / NBBY;
1096 #  else
1097     masksize = sizeof(long);    /* documented int, everyone seems to use long */
1098 #  endif
1099     Zero(&fd_sets[0], 4, char*);
1100 #endif
1101
1102 #  if SELECT_MIN_BITS == 1
1103     growsize = sizeof(fd_set);
1104 #  else
1105 #   if defined(__GLIBC__) && defined(__FD_SETSIZE)
1106 #      undef SELECT_MIN_BITS
1107 #      define SELECT_MIN_BITS __FD_SETSIZE
1108 #   endif
1109     /* If SELECT_MIN_BITS is greater than one we most probably will want
1110      * to align the sizes with SELECT_MIN_BITS/8 because for example
1111      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1112      * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1113      * on (sets/tests/clears bits) is 32 bits.  */
1114     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1115 #  endif
1116
1117     sv = SP[4];
1118     if (SvOK(sv)) {
1119         value = SvNV(sv);
1120         if (value < 0.0)
1121             value = 0.0;
1122         timebuf.tv_sec = (long)value;
1123         value -= (NV)timebuf.tv_sec;
1124         timebuf.tv_usec = (long)(value * 1000000.0);
1125     }
1126     else
1127         tbuf = NULL;
1128
1129     for (i = 1; i <= 3; i++) {
1130         sv = SP[i];
1131         if (!SvOK(sv) || SvCUR(sv) == 0) {
1132             fd_sets[i] = 0;
1133             continue;
1134         }
1135         assert(SvPOK(sv));
1136         j = SvLEN(sv);
1137         if (j < growsize) {
1138             Sv_Grow(sv, growsize);
1139         }
1140         j = SvCUR(sv);
1141         s = SvPVX(sv) + j;
1142         while (++j <= growsize) {
1143             *s++ = '\0';
1144         }
1145
1146 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1147         s = SvPVX(sv);
1148         Newx(fd_sets[i], growsize, char);
1149         for (offset = 0; offset < growsize; offset += masksize) {
1150             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1151                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1152         }
1153 #else
1154         fd_sets[i] = SvPVX(sv);
1155 #endif
1156     }
1157
1158 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1159     /* Can't make just the (void*) conditional because that would be
1160      * cpp #if within cpp macro, and not all compilers like that. */
1161     nfound = PerlSock_select(
1162         maxlen * 8,
1163         (Select_fd_set_t) fd_sets[1],
1164         (Select_fd_set_t) fd_sets[2],
1165         (Select_fd_set_t) fd_sets[3],
1166         (void*) tbuf); /* Workaround for compiler bug. */
1167 #else
1168     nfound = PerlSock_select(
1169         maxlen * 8,
1170         (Select_fd_set_t) fd_sets[1],
1171         (Select_fd_set_t) fd_sets[2],
1172         (Select_fd_set_t) fd_sets[3],
1173         tbuf);
1174 #endif
1175     for (i = 1; i <= 3; i++) {
1176         if (fd_sets[i]) {
1177             sv = SP[i];
1178 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1179             s = SvPVX(sv);
1180             for (offset = 0; offset < growsize; offset += masksize) {
1181                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1182                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1183             }
1184             Safefree(fd_sets[i]);
1185 #endif
1186             SvSETMAGIC(sv);
1187         }
1188     }
1189
1190     PUSHi(nfound);
1191     if (GIMME == G_ARRAY && tbuf) {
1192         value = (NV)(timebuf.tv_sec) +
1193                 (NV)(timebuf.tv_usec) / 1000000.0;
1194         mPUSHn(value);
1195     }
1196     RETURN;
1197 #else
1198     DIE(aTHX_ "select not implemented");
1199 #endif
1200 }
1201
1202 /*
1203 =for apidoc setdefout
1204
1205 Sets PL_defoutgv, the default file handle for output, to the passed in
1206 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1207 count of the passed in typeglob is increased by one, and the reference count
1208 of the typeglob that PL_defoutgv points to is decreased by one.
1209
1210 =cut
1211 */
1212
1213 void
1214 Perl_setdefout(pTHX_ GV *gv)
1215 {
1216     dVAR;
1217     SvREFCNT_inc_simple_void(gv);
1218     SvREFCNT_dec(PL_defoutgv);
1219     PL_defoutgv = gv;
1220 }
1221
1222 PP(pp_select)
1223 {
1224     dVAR; dSP; dTARGET;
1225     HV *hv;
1226     GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1227     GV * egv = GvEGVx(PL_defoutgv);
1228
1229     if (!egv)
1230         egv = PL_defoutgv;
1231     hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1232     if (! hv)
1233         XPUSHs(&PL_sv_undef);
1234     else {
1235         GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1236         if (gvp && *gvp == egv) {
1237             gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1238             XPUSHTARG;
1239         }
1240         else {
1241             mXPUSHs(newRV(MUTABLE_SV(egv)));
1242         }
1243     }
1244
1245     if (newdefout) {
1246         if (!GvIO(newdefout))
1247             gv_IOadd(newdefout);
1248         setdefout(newdefout);
1249     }
1250
1251     RETURN;
1252 }
1253
1254 PP(pp_getc)
1255 {
1256     dVAR; dSP; dTARGET;
1257     GV * const gv =
1258         MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1259     IO *const io = GvIO(gv);
1260
1261     if (MAXARG == 0)
1262         EXTEND(SP, 1);
1263
1264     if (io) {
1265         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1266         if (mg) {
1267             const U32 gimme = GIMME_V;
1268             Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1269             if (gimme == G_SCALAR) {
1270                 SPAGAIN;
1271                 SvSetMagicSV_nosteal(TARG, TOPs);
1272             }
1273             return NORMAL;
1274         }
1275     }
1276     if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1277         if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1278             report_evil_fh(gv);
1279         SETERRNO(EBADF,RMS_IFI);
1280         RETPUSHUNDEF;
1281     }
1282     TAINT;
1283     sv_setpvs(TARG, " ");
1284     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1285     if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1286         /* Find out how many bytes the char needs */
1287         Size_t len = UTF8SKIP(SvPVX_const(TARG));
1288         if (len > 1) {
1289             SvGROW(TARG,len+1);
1290             len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1291             SvCUR_set(TARG,1+len);
1292         }
1293         SvUTF8_on(TARG);
1294     }
1295     PUSHTARG;
1296     RETURN;
1297 }
1298
1299 STATIC OP *
1300 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1301 {
1302     dVAR;
1303     register PERL_CONTEXT *cx;
1304     const I32 gimme = GIMME_V;
1305
1306     PERL_ARGS_ASSERT_DOFORM;
1307
1308     if (cv && CvCLONE(cv))
1309         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1310
1311     ENTER;
1312     SAVETMPS;
1313
1314     PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1315     PUSHFORMAT(cx, retop);
1316     SAVECOMPPAD();
1317     PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1318
1319     setdefout(gv);          /* locally select filehandle so $% et al work */
1320     return CvSTART(cv);
1321 }
1322
1323 PP(pp_enterwrite)
1324 {
1325     dVAR;
1326     dSP;
1327     register GV *gv;
1328     register IO *io;
1329     GV *fgv;
1330     CV *cv = NULL;
1331     SV *tmpsv = NULL;
1332
1333     if (MAXARG == 0) {
1334         gv = PL_defoutgv;
1335         EXTEND(SP, 1);
1336     }
1337     else {
1338         gv = MUTABLE_GV(POPs);
1339         if (!gv)
1340             gv = PL_defoutgv;
1341     }
1342     io = GvIO(gv);
1343     if (!io) {
1344         RETPUSHNO;
1345     }
1346     if (IoFMT_GV(io))
1347         fgv = IoFMT_GV(io);
1348     else
1349         fgv = gv;
1350
1351     if (!fgv)
1352         goto not_a_format_reference;
1353
1354     cv = GvFORM(fgv);
1355     if (!cv) {
1356         const char *name;
1357         tmpsv = sv_newmortal();
1358         gv_efullname4(tmpsv, fgv, NULL, FALSE);
1359         name = SvPV_nolen_const(tmpsv);
1360         if (name && *name)
1361             DIE(aTHX_ "Undefined format \"%s\" called", name);
1362
1363         not_a_format_reference:
1364         DIE(aTHX_ "Not a format reference");
1365     }
1366     IoFLAGS(io) &= ~IOf_DIDTOP;
1367     return doform(cv,gv,PL_op->op_next);
1368 }
1369
1370 PP(pp_leavewrite)
1371 {
1372     dVAR; dSP;
1373     GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1374     register IO * const io = GvIOp(gv);
1375     PerlIO *ofp;
1376     PerlIO *fp;
1377     SV **newsp;
1378     I32 gimme;
1379     register PERL_CONTEXT *cx;
1380     OP *retop;
1381
1382     if (!io || !(ofp = IoOFP(io)))
1383         goto forget_top;
1384
1385     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1386           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1387
1388     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1389         PL_formtarget != PL_toptarget)
1390     {
1391         GV *fgv;
1392         CV *cv;
1393         if (!IoTOP_GV(io)) {
1394             GV *topgv;
1395
1396             if (!IoTOP_NAME(io)) {
1397                 SV *topname;
1398                 if (!IoFMT_NAME(io))
1399                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1400                 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1401                 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1402                 if ((topgv && GvFORM(topgv)) ||
1403                   !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1404                     IoTOP_NAME(io) = savesvpv(topname);
1405                 else
1406                     IoTOP_NAME(io) = savepvs("top");
1407             }
1408             topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1409             if (!topgv || !GvFORM(topgv)) {
1410                 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1411                 goto forget_top;
1412             }
1413             IoTOP_GV(io) = topgv;
1414         }
1415         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1416             I32 lines = IoLINES_LEFT(io);
1417             const char *s = SvPVX_const(PL_formtarget);
1418             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1419                 goto forget_top;
1420             while (lines-- > 0) {
1421                 s = strchr(s, '\n');
1422                 if (!s)
1423                     break;
1424                 s++;
1425             }
1426             if (s) {
1427                 const STRLEN save = SvCUR(PL_formtarget);
1428                 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1429                 do_print(PL_formtarget, ofp);
1430                 SvCUR_set(PL_formtarget, save);
1431                 sv_chop(PL_formtarget, s);
1432                 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1433             }
1434         }
1435         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1436             do_print(PL_formfeed, ofp);
1437         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1438         IoPAGE(io)++;
1439         PL_formtarget = PL_toptarget;
1440         IoFLAGS(io) |= IOf_DIDTOP;
1441         fgv = IoTOP_GV(io);
1442         if (!fgv)
1443             DIE(aTHX_ "bad top format reference");
1444         cv = GvFORM(fgv);
1445         if (!cv) {
1446             SV * const sv = sv_newmortal();
1447             const char *name;
1448             gv_efullname4(sv, fgv, NULL, FALSE);
1449             name = SvPV_nolen_const(sv);
1450             if (name && *name)
1451                 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1452             else
1453                 DIE(aTHX_ "Undefined top format called");
1454         }
1455         return doform(cv, gv, PL_op);
1456     }
1457
1458   forget_top:
1459     POPBLOCK(cx,PL_curpm);
1460     POPFORMAT(cx);
1461     retop = cx->blk_sub.retop;
1462     LEAVE;
1463
1464     fp = IoOFP(io);
1465     if (!fp) {
1466         if (IoIFP(io))
1467             report_wrongway_fh(gv, '<');
1468         else
1469             report_evil_fh(gv);
1470         PUSHs(&PL_sv_no);
1471     }
1472     else {
1473         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1474             Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1475         }
1476         if (!do_print(PL_formtarget, fp))
1477             PUSHs(&PL_sv_no);
1478         else {
1479             FmLINES(PL_formtarget) = 0;
1480             SvCUR_set(PL_formtarget, 0);
1481             *SvEND(PL_formtarget) = '\0';
1482             if (IoFLAGS(io) & IOf_FLUSH)
1483                 (void)PerlIO_flush(fp);
1484             PUSHs(&PL_sv_yes);
1485         }
1486     }
1487     /* bad_ofp: */
1488     PL_formtarget = PL_bodytarget;
1489     PUTBACK;
1490     PERL_UNUSED_VAR(newsp);
1491     PERL_UNUSED_VAR(gimme);
1492     return retop;
1493 }
1494
1495 PP(pp_prtf)
1496 {
1497     dVAR; dSP; dMARK; dORIGMARK;
1498     PerlIO *fp;
1499     SV *sv;
1500
1501     GV * const gv
1502         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1503     IO *const io = GvIO(gv);
1504
1505     if (io) {
1506         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1507         if (mg) {
1508             if (MARK == ORIGMARK) {
1509                 MEXTEND(SP, 1);
1510                 ++MARK;
1511                 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1512                 ++SP;
1513             }
1514             return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1515                                     mg,
1516                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1517                                     sp - mark);
1518         }
1519     }
1520
1521     sv = newSV(0);
1522     if (!io) {
1523         report_evil_fh(gv);
1524         SETERRNO(EBADF,RMS_IFI);
1525         goto just_say_no;
1526     }
1527     else if (!(fp = IoOFP(io))) {
1528         if (IoIFP(io))
1529             report_wrongway_fh(gv, '<');
1530         else if (ckWARN(WARN_CLOSED))
1531             report_evil_fh(gv);
1532         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1533         goto just_say_no;
1534     }
1535     else {
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 && (TOPs || POPs)) ? 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 && (TOPs || POPs))
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 #if ST_INO_SIZE > IVSIZE
2840         mPUSHn(PL_statcache.st_ino);
2841 #else
2842 #   if ST_INO_SIGN <= 0
2843         mPUSHi(PL_statcache.st_ino);
2844 #   else
2845         mPUSHu(PL_statcache.st_ino);
2846 #   endif
2847 #endif
2848         mPUSHu(PL_statcache.st_mode);
2849         mPUSHu(PL_statcache.st_nlink);
2850 #if Uid_t_size > IVSIZE
2851         mPUSHn(PL_statcache.st_uid);
2852 #else
2853 #   if Uid_t_sign <= 0
2854         mPUSHi(PL_statcache.st_uid);
2855 #   else
2856         mPUSHu(PL_statcache.st_uid);
2857 #   endif
2858 #endif
2859 #if Gid_t_size > IVSIZE
2860         mPUSHn(PL_statcache.st_gid);
2861 #else
2862 #   if Gid_t_sign <= 0
2863         mPUSHi(PL_statcache.st_gid);
2864 #   else
2865         mPUSHu(PL_statcache.st_gid);
2866 #   endif
2867 #endif
2868 #ifdef USE_STAT_RDEV
2869         mPUSHi(PL_statcache.st_rdev);
2870 #else
2871         PUSHs(newSVpvs_flags("", SVs_TEMP));
2872 #endif
2873 #if Off_t_size > IVSIZE
2874         mPUSHn(PL_statcache.st_size);
2875 #else
2876         mPUSHi(PL_statcache.st_size);
2877 #endif
2878 #ifdef BIG_TIME
2879         mPUSHn(PL_statcache.st_atime);
2880         mPUSHn(PL_statcache.st_mtime);
2881         mPUSHn(PL_statcache.st_ctime);
2882 #else
2883         mPUSHi(PL_statcache.st_atime);
2884         mPUSHi(PL_statcache.st_mtime);
2885         mPUSHi(PL_statcache.st_ctime);
2886 #endif
2887 #ifdef USE_STAT_BLOCKS
2888         mPUSHu(PL_statcache.st_blksize);
2889         mPUSHu(PL_statcache.st_blocks);
2890 #else
2891         PUSHs(newSVpvs_flags("", SVs_TEMP));
2892         PUSHs(newSVpvs_flags("", SVs_TEMP));
2893 #endif
2894     }
2895     RETURN;
2896 }
2897
2898 #define tryAMAGICftest_MG(chr) STMT_START { \
2899         if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2900                 && S_try_amagic_ftest(aTHX_ chr)) \
2901             return NORMAL; \
2902     } STMT_END
2903
2904 STATIC bool
2905 S_try_amagic_ftest(pTHX_ char chr) {
2906     dVAR;
2907     dSP;
2908     SV* const arg = TOPs;
2909
2910     assert(chr != '?');
2911     SvGETMAGIC(arg);
2912
2913     if ((PL_op->op_flags & OPf_KIDS)
2914             && SvAMAGIC(TOPs))
2915     {
2916         const char tmpchr = chr;
2917         SV * const tmpsv = amagic_call(arg,
2918                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2919                                 ftest_amg, AMGf_unary);
2920
2921         if (!tmpsv)
2922             return FALSE;
2923
2924         SPAGAIN;
2925
2926         if (PL_op->op_private & OPpFT_STACKING) {
2927             if (SvTRUE(tmpsv))
2928                 /* leave the object alone */
2929                 return TRUE;
2930         }
2931
2932         SETs(tmpsv);
2933         PUTBACK;
2934         return TRUE;
2935     }
2936     return FALSE;
2937 }
2938
2939
2940 /* This macro is used by the stacked filetest operators :
2941  * if the previous filetest failed, short-circuit and pass its value.
2942  * Else, discard it from the stack and continue. --rgs
2943  */
2944 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2945         if (!SvTRUE(TOPs)) { RETURN; } \
2946         else { (void)POPs; PUTBACK; } \
2947     }
2948
2949 PP(pp_ftrread)
2950 {
2951     dVAR;
2952     I32 result;
2953     /* Not const, because things tweak this below. Not bool, because there's
2954        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2955 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2956     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2957     /* Giving some sort of initial value silences compilers.  */
2958 #  ifdef R_OK
2959     int access_mode = R_OK;
2960 #  else
2961     int access_mode = 0;
2962 #  endif
2963 #else
2964     /* access_mode is never used, but leaving use_access in makes the
2965        conditional compiling below much clearer.  */
2966     I32 use_access = 0;
2967 #endif
2968     Mode_t stat_mode = S_IRUSR;
2969
2970     bool effective = FALSE;
2971     char opchar = '?';
2972     dSP;
2973
2974     switch (PL_op->op_type) {
2975     case OP_FTRREAD:    opchar = 'R'; break;
2976     case OP_FTRWRITE:   opchar = 'W'; break;
2977     case OP_FTREXEC:    opchar = 'X'; break;
2978     case OP_FTEREAD:    opchar = 'r'; break;
2979     case OP_FTEWRITE:   opchar = 'w'; break;
2980     case OP_FTEEXEC:    opchar = 'x'; break;
2981     }
2982     tryAMAGICftest_MG(opchar);
2983
2984     STACKED_FTEST_CHECK;
2985
2986     switch (PL_op->op_type) {
2987     case OP_FTRREAD:
2988 #if !(defined(HAS_ACCESS) && defined(R_OK))
2989         use_access = 0;
2990 #endif
2991         break;
2992
2993     case OP_FTRWRITE:
2994 #if defined(HAS_ACCESS) && defined(W_OK)
2995         access_mode = W_OK;
2996 #else
2997         use_access = 0;
2998 #endif
2999         stat_mode = S_IWUSR;
3000         break;
3001
3002     case OP_FTREXEC:
3003 #if defined(HAS_ACCESS) && defined(X_OK)
3004         access_mode = X_OK;
3005 #else
3006         use_access = 0;
3007 #endif
3008         stat_mode = S_IXUSR;
3009         break;
3010
3011     case OP_FTEWRITE:
3012 #ifdef PERL_EFF_ACCESS
3013         access_mode = W_OK;
3014 #endif
3015         stat_mode = S_IWUSR;
3016         /* fall through */
3017
3018     case OP_FTEREAD:
3019 #ifndef PERL_EFF_ACCESS
3020         use_access = 0;
3021 #endif
3022         effective = TRUE;
3023         break;
3024
3025     case OP_FTEEXEC:
3026 #ifdef PERL_EFF_ACCESS
3027         access_mode = X_OK;
3028 #else
3029         use_access = 0;
3030 #endif
3031         stat_mode = S_IXUSR;
3032         effective = TRUE;
3033         break;
3034     }
3035
3036     if (use_access) {
3037 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3038         const char *name = POPpx;
3039         if (effective) {
3040 #  ifdef PERL_EFF_ACCESS
3041             result = PERL_EFF_ACCESS(name, access_mode);
3042 #  else
3043             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3044                 OP_NAME(PL_op));
3045 #  endif
3046         }
3047         else {
3048 #  ifdef HAS_ACCESS
3049             result = access(name, access_mode);
3050 #  else
3051             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3052 #  endif
3053         }
3054         if (result == 0)
3055             RETPUSHYES;
3056         if (result < 0)
3057             RETPUSHUNDEF;
3058         RETPUSHNO;
3059 #endif
3060     }
3061
3062     result = my_stat_flags(0);
3063     SPAGAIN;
3064     if (result < 0)
3065         RETPUSHUNDEF;
3066     if (cando(stat_mode, effective, &PL_statcache))
3067         RETPUSHYES;
3068     RETPUSHNO;
3069 }
3070
3071 PP(pp_ftis)
3072 {
3073     dVAR;
3074     I32 result;
3075     const int op_type = PL_op->op_type;
3076     char opchar = '?';
3077     dSP;
3078
3079     switch (op_type) {
3080     case OP_FTIS:       opchar = 'e'; break;
3081     case OP_FTSIZE:     opchar = 's'; break;
3082     case OP_FTMTIME:    opchar = 'M'; break;
3083     case OP_FTCTIME:    opchar = 'C'; break;
3084     case OP_FTATIME:    opchar = 'A'; break;
3085     }
3086     tryAMAGICftest_MG(opchar);
3087
3088     STACKED_FTEST_CHECK;
3089
3090     result = my_stat_flags(0);
3091     SPAGAIN;
3092     if (result < 0)
3093         RETPUSHUNDEF;
3094     if (op_type == OP_FTIS)
3095         RETPUSHYES;
3096     {
3097         /* You can't dTARGET inside OP_FTIS, because you'll get
3098            "panic: pad_sv po" - the op is not flagged to have a target.  */
3099         dTARGET;
3100         switch (op_type) {
3101         case OP_FTSIZE:
3102 #if Off_t_size > IVSIZE
3103             PUSHn(PL_statcache.st_size);
3104 #else
3105             PUSHi(PL_statcache.st_size);
3106 #endif
3107             break;
3108         case OP_FTMTIME:
3109             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3110             break;
3111         case OP_FTATIME:
3112             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3113             break;
3114         case OP_FTCTIME:
3115             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3116             break;
3117         }
3118     }
3119     RETURN;
3120 }
3121
3122 PP(pp_ftrowned)
3123 {
3124     dVAR;
3125     I32 result;
3126     char opchar = '?';
3127     dSP;
3128
3129     switch (PL_op->op_type) {
3130     case OP_FTROWNED:   opchar = 'O'; break;
3131     case OP_FTEOWNED:   opchar = 'o'; break;
3132     case OP_FTZERO:     opchar = 'z'; break;
3133     case OP_FTSOCK:     opchar = 'S'; break;
3134     case OP_FTCHR:      opchar = 'c'; break;
3135     case OP_FTBLK:      opchar = 'b'; break;
3136     case OP_FTFILE:     opchar = 'f'; break;
3137     case OP_FTDIR:      opchar = 'd'; break;
3138     case OP_FTPIPE:     opchar = 'p'; break;
3139     case OP_FTSUID:     opchar = 'u'; break;
3140     case OP_FTSGID:     opchar = 'g'; break;
3141     case OP_FTSVTX:     opchar = 'k'; break;
3142     }
3143     tryAMAGICftest_MG(opchar);
3144
3145     STACKED_FTEST_CHECK;
3146
3147     /* I believe that all these three are likely to be defined on most every
3148        system these days.  */
3149 #ifndef S_ISUID
3150     if(PL_op->op_type == OP_FTSUID) {
3151         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3152             (void) POPs;
3153         RETPUSHNO;
3154     }
3155 #endif
3156 #ifndef S_ISGID
3157     if(PL_op->op_type == OP_FTSGID) {
3158         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3159             (void) POPs;
3160         RETPUSHNO;
3161     }
3162 #endif
3163 #ifndef S_ISVTX
3164     if(PL_op->op_type == OP_FTSVTX) {
3165         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3166             (void) POPs;
3167         RETPUSHNO;
3168     }
3169 #endif
3170
3171     result = my_stat_flags(0);
3172     SPAGAIN;
3173     if (result < 0)
3174         RETPUSHUNDEF;
3175     switch (PL_op->op_type) {
3176     case OP_FTROWNED:
3177         if (PL_statcache.st_uid == PL_uid)
3178             RETPUSHYES;
3179         break;
3180     case OP_FTEOWNED:
3181         if (PL_statcache.st_uid == PL_euid)
3182             RETPUSHYES;
3183         break;
3184     case OP_FTZERO:
3185         if (PL_statcache.st_size == 0)
3186             RETPUSHYES;
3187         break;
3188     case OP_FTSOCK:
3189         if (S_ISSOCK(PL_statcache.st_mode))
3190             RETPUSHYES;
3191         break;
3192     case OP_FTCHR:
3193         if (S_ISCHR(PL_statcache.st_mode))
3194             RETPUSHYES;
3195         break;
3196     case OP_FTBLK:
3197         if (S_ISBLK(PL_statcache.st_mode))
3198             RETPUSHYES;
3199         break;
3200     case OP_FTFILE:
3201         if (S_ISREG(PL_statcache.st_mode))
3202             RETPUSHYES;
3203         break;
3204     case OP_FTDIR:
3205         if (S_ISDIR(PL_statcache.st_mode))
3206             RETPUSHYES;
3207         break;
3208     case OP_FTPIPE:
3209         if (S_ISFIFO(PL_statcache.st_mode))
3210             RETPUSHYES;
3211         break;
3212 #ifdef S_ISUID
3213     case OP_FTSUID:
3214         if (PL_statcache.st_mode & S_ISUID)
3215             RETPUSHYES;
3216         break;
3217 #endif
3218 #ifdef S_ISGID
3219     case OP_FTSGID:
3220         if (PL_statcache.st_mode & S_ISGID)
3221             RETPUSHYES;
3222         break;
3223 #endif
3224 #ifdef S_ISVTX
3225     case OP_FTSVTX:
3226         if (PL_statcache.st_mode & S_ISVTX)
3227             RETPUSHYES;
3228         break;
3229 #endif
3230     }
3231     RETPUSHNO;
3232 }
3233
3234 PP(pp_ftlink)
3235 {
3236     dVAR;
3237     dSP;
3238     I32 result;
3239
3240     tryAMAGICftest_MG('l');
3241     result = my_lstat_flags(0);
3242     SPAGAIN;
3243
3244     if (result < 0)
3245         RETPUSHUNDEF;
3246     if (S_ISLNK(PL_statcache.st_mode))
3247         RETPUSHYES;
3248     RETPUSHNO;
3249 }
3250
3251 PP(pp_fttty)
3252 {
3253     dVAR;
3254     dSP;
3255     int fd;
3256     GV *gv;
3257     SV *tmpsv = NULL;
3258     char *name = NULL;
3259     STRLEN namelen;
3260
3261     tryAMAGICftest_MG('t');
3262
3263     STACKED_FTEST_CHECK;
3264
3265     if (PL_op->op_flags & OPf_REF)
3266         gv = cGVOP_gv;
3267     else if (isGV_with_GP(TOPs))
3268         gv = MUTABLE_GV(POPs);
3269     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3270         gv = MUTABLE_GV(SvRV(POPs));
3271     else {
3272         tmpsv = POPs;
3273         name = SvPV_nomg(tmpsv, namelen);
3274         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3275     }
3276
3277     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3278         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3279     else if (tmpsv && SvOK(tmpsv)) {
3280         if (isDIGIT(*name))
3281             fd = atoi(name);
3282         else
3283             RETPUSHUNDEF;
3284     }
3285     else
3286         RETPUSHUNDEF;
3287     if (PerlLIO_isatty(fd))
3288         RETPUSHYES;
3289     RETPUSHNO;
3290 }
3291
3292 #if defined(atarist) /* this will work with atariST. Configure will
3293                         make guesses for other systems. */
3294 # define FILE_base(f) ((f)->_base)
3295 # define FILE_ptr(f) ((f)->_ptr)
3296 # define FILE_cnt(f) ((f)->_cnt)
3297 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3298 #endif
3299
3300 PP(pp_fttext)
3301 {
3302     dVAR;
3303     dSP;
3304     I32 i;
3305     I32 len;
3306     I32 odd = 0;
3307     STDCHAR tbuf[512];
3308     register STDCHAR *s;
3309     register IO *io;
3310     register SV *sv;
3311     GV *gv;
3312     PerlIO *fp;
3313
3314     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3315
3316     STACKED_FTEST_CHECK;
3317
3318     if (PL_op->op_flags & OPf_REF)
3319         gv = cGVOP_gv;
3320     else if (isGV_with_GP(TOPs))
3321         gv = MUTABLE_GV(POPs);
3322     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3323         gv = MUTABLE_GV(SvRV(POPs));
3324     else
3325         gv = NULL;
3326
3327     if (gv) {
3328         EXTEND(SP, 1);
3329         if (gv == PL_defgv) {
3330             if (PL_statgv)
3331                 io = GvIO(PL_statgv);
3332             else {
3333                 sv = PL_statname;
3334                 goto really_filename;
3335             }
3336         }
3337         else {
3338             PL_statgv = gv;
3339             PL_laststatval = -1;
3340             sv_setpvs(PL_statname, "");
3341             io = GvIO(PL_statgv);
3342         }
3343         if (io && IoIFP(io)) {
3344             if (! PerlIO_has_base(IoIFP(io)))
3345                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3346             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3347             if (PL_laststatval < 0)
3348                 RETPUSHUNDEF;
3349             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3350                 if (PL_op->op_type == OP_FTTEXT)
3351                     RETPUSHNO;
3352                 else
3353                     RETPUSHYES;
3354             }
3355             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3356                 i = PerlIO_getc(IoIFP(io));
3357                 if (i != EOF)
3358                     (void)PerlIO_ungetc(IoIFP(io),i);
3359             }
3360             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3361                 RETPUSHYES;
3362             len = PerlIO_get_bufsiz(IoIFP(io));
3363             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3364             /* sfio can have large buffers - limit to 512 */
3365             if (len > 512)
3366                 len = 512;
3367         }
3368         else {
3369             report_evil_fh(cGVOP_gv);
3370             SETERRNO(EBADF,RMS_IFI);
3371             RETPUSHUNDEF;
3372         }
3373     }
3374     else {
3375         sv = POPs;
3376       really_filename:
3377         PL_statgv = NULL;
3378         PL_laststype = OP_STAT;
3379         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3380         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3381             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3382                                                '\n'))
3383                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3384             RETPUSHUNDEF;
3385         }
3386         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3387         if (PL_laststatval < 0) {
3388             (void)PerlIO_close(fp);
3389             RETPUSHUNDEF;
3390         }
3391         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3392         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3393         (void)PerlIO_close(fp);
3394         if (len <= 0) {
3395             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3396                 RETPUSHNO;              /* special case NFS directories */
3397             RETPUSHYES;         /* null file is anything */
3398         }
3399         s = tbuf;
3400     }
3401
3402     /* now scan s to look for textiness */
3403     /*   XXX ASCII dependent code */
3404
3405 #if defined(DOSISH) || defined(USEMYBINMODE)
3406     /* ignore trailing ^Z on short files */
3407     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3408         --len;
3409 #endif
3410
3411     for (i = 0; i < len; i++, s++) {
3412         if (!*s) {                      /* null never allowed in text */
3413             odd += len;
3414             break;
3415         }
3416 #ifdef EBCDIC
3417         else if (!(isPRINT(*s) || isSPACE(*s)))
3418             odd++;
3419 #else
3420         else if (*s & 128) {
3421 #ifdef USE_LOCALE
3422             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3423                 continue;
3424 #endif
3425             /* utf8 characters don't count as odd */
3426             if (UTF8_IS_START(*s)) {
3427                 int ulen = UTF8SKIP(s);
3428                 if (ulen < len - i) {
3429                     int j;
3430                     for (j = 1; j < ulen; j++) {
3431                         if (!UTF8_IS_CONTINUATION(s[j]))
3432                             goto not_utf8;
3433                     }
3434                     --ulen;     /* loop does extra increment */
3435                     s += ulen;
3436                     i += ulen;
3437                     continue;
3438                 }
3439             }
3440           not_utf8:
3441             odd++;
3442         }
3443         else if (*s < 32 &&
3444           *s != '\n' && *s != '\r' && *s != '\b' &&
3445           *s != '\t' && *s != '\f' && *s != 27)
3446             odd++;
3447 #endif
3448     }
3449
3450     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3451         RETPUSHNO;
3452     else
3453         RETPUSHYES;
3454 }
3455
3456 /* File calls. */
3457
3458 PP(pp_chdir)
3459 {
3460     dVAR; dSP; dTARGET;
3461     const char *tmps = NULL;
3462     GV *gv = NULL;
3463
3464     if( MAXARG == 1 ) {
3465         SV * const sv = POPs;
3466         if (PL_op->op_flags & OPf_SPECIAL) {
3467             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3468         }
3469         else if (SvGETMAGIC(sv), isGV_with_GP(sv)) {
3470             gv = MUTABLE_GV(sv);
3471         }
3472         else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3473             gv = MUTABLE_GV(SvRV(sv));
3474         }
3475         else {
3476             tmps = SvPV_nomg_const_nolen(sv);
3477         }
3478     }
3479
3480     if( !gv && (!tmps || !*tmps) ) {
3481         HV * const table = GvHVn(PL_envgv);
3482         SV **svp;
3483
3484         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3485              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3486 #ifdef VMS
3487              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3488 #endif
3489            )
3490         {
3491             if( MAXARG == 1 )
3492                 deprecate("chdir('') or chdir(undef) as chdir()");
3493             tmps = SvPV_nolen_const(*svp);
3494         }
3495         else {
3496             PUSHi(0);
3497             TAINT_PROPER("chdir");
3498             RETURN;
3499         }
3500     }
3501
3502     TAINT_PROPER("chdir");
3503     if (gv) {
3504 #ifdef HAS_FCHDIR
3505         IO* const io = GvIO(gv);
3506         if (io) {
3507             if (IoDIRP(io)) {
3508                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3509             } else if (IoIFP(io)) {
3510                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3511             }
3512             else {
3513                 report_evil_fh(gv);
3514                 SETERRNO(EBADF, RMS_IFI);
3515                 PUSHi(0);
3516             }
3517         }
3518         else {
3519             report_evil_fh(gv);
3520             SETERRNO(EBADF,RMS_IFI);
3521             PUSHi(0);
3522         }
3523 #else
3524         DIE(aTHX_ PL_no_func, "fchdir");
3525 #endif
3526     }
3527     else
3528         PUSHi( PerlDir_chdir(tmps) >= 0 );
3529 #ifdef VMS
3530     /* Clear the DEFAULT element of ENV so we'll get the new value
3531      * in the future. */
3532     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3533 #endif
3534     RETURN;
3535 }
3536
3537 PP(pp_chown)
3538 {
3539     dVAR; dSP; dMARK; dTARGET;
3540     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3541
3542     SP = MARK;
3543     XPUSHi(value);
3544     RETURN;
3545 }
3546
3547 PP(pp_chroot)
3548 {
3549 #ifdef HAS_CHROOT
3550     dVAR; dSP; dTARGET;
3551     char * const tmps = POPpx;
3552     TAINT_PROPER("chroot");
3553     PUSHi( chroot(tmps) >= 0 );
3554     RETURN;
3555 #else
3556     DIE(aTHX_ PL_no_func, "chroot");
3557 #endif
3558 }
3559
3560 PP(pp_rename)
3561 {
3562     dVAR; dSP; dTARGET;
3563     int anum;
3564     const char * const tmps2 = POPpconstx;
3565     const char * const tmps = SvPV_nolen_const(TOPs);
3566     TAINT_PROPER("rename");
3567 #ifdef HAS_RENAME
3568     anum = PerlLIO_rename(tmps, tmps2);
3569 #else
3570     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3571         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3572             anum = 1;
3573         else {
3574             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3575                 (void)UNLINK(tmps2);
3576             if (!(anum = link(tmps, tmps2)))
3577                 anum = UNLINK(tmps);
3578         }
3579     }
3580 #endif
3581     SETi( anum >= 0 );
3582     RETURN;
3583 }
3584
3585 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3586 PP(pp_link)
3587 {
3588     dVAR; dSP; dTARGET;
3589     const int op_type = PL_op->op_type;
3590     int result;
3591
3592 #  ifndef HAS_LINK
3593     if (op_type == OP_LINK)
3594         DIE(aTHX_ PL_no_func, "link");
3595 #  endif
3596 #  ifndef HAS_SYMLINK
3597     if (op_type == OP_SYMLINK)
3598         DIE(aTHX_ PL_no_func, "symlink");
3599 #  endif
3600
3601     {
3602         const char * const tmps2 = POPpconstx;
3603         const char * const tmps = SvPV_nolen_const(TOPs);
3604         TAINT_PROPER(PL_op_desc[op_type]);
3605         result =
3606 #  if defined(HAS_LINK)
3607 #    if defined(HAS_SYMLINK)
3608             /* Both present - need to choose which.  */
3609             (op_type == OP_LINK) ?
3610             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3611 #    else
3612     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3613         PerlLIO_link(tmps, tmps2);
3614 #    endif
3615 #  else
3616 #    if defined(HAS_SYMLINK)
3617     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3618         symlink(tmps, tmps2);
3619 #    endif
3620 #  endif
3621     }
3622
3623     SETi( result >= 0 );
3624     RETURN;
3625 }
3626 #else
3627 PP(pp_link)
3628 {
3629     /* Have neither.  */
3630     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3631 }
3632 #endif
3633
3634 PP(pp_readlink)
3635 {
3636     dVAR;
3637     dSP;
3638 #ifdef HAS_SYMLINK
3639     dTARGET;
3640     const char *tmps;
3641     char buf[MAXPATHLEN];
3642     int len;
3643
3644 #ifndef INCOMPLETE_TAINTS
3645     TAINT;
3646 #endif
3647     tmps = POPpconstx;
3648     len = readlink(tmps, buf, sizeof(buf) - 1);
3649     if (len < 0)
3650         RETPUSHUNDEF;
3651     PUSHp(buf, len);
3652     RETURN;
3653 #else
3654     EXTEND(SP, 1);
3655     RETSETUNDEF;                /* just pretend it's a normal file */
3656 #endif
3657 }
3658
3659 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3660 STATIC int
3661 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3662 {
3663     char * const save_filename = filename;
3664     char *cmdline;
3665     char *s;
3666     PerlIO *myfp;
3667     int anum = 1;
3668     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3669
3670     PERL_ARGS_ASSERT_DOONELINER;
3671
3672     Newx(cmdline, size, char);
3673     my_strlcpy(cmdline, cmd, size);
3674     my_strlcat(cmdline, " ", size);
3675     for (s = cmdline + strlen(cmdline); *filename; ) {
3676         *s++ = '\\';
3677         *s++ = *filename++;
3678     }
3679     if (s - cmdline < size)
3680         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3681     myfp = PerlProc_popen(cmdline, "r");
3682     Safefree(cmdline);
3683
3684     if (myfp) {
3685         SV * const tmpsv = sv_newmortal();
3686         /* Need to save/restore 'PL_rs' ?? */
3687         s = sv_gets(tmpsv, myfp, 0);
3688         (void)PerlProc_pclose(myfp);
3689         if (s != NULL) {
3690             int e;
3691             for (e = 1;
3692 #ifdef HAS_SYS_ERRLIST
3693                  e <= sys_nerr
3694 #endif
3695                  ; e++)
3696             {
3697                 /* you don't see this */
3698                 const char * const errmsg =
3699 #ifdef HAS_SYS_ERRLIST
3700                     sys_errlist[e]
3701 #else
3702                     strerror(e)
3703 #endif
3704                     ;
3705                 if (!errmsg)
3706                     break;
3707                 if (instr(s, errmsg)) {
3708                     SETERRNO(e,0);
3709                     return 0;
3710                 }
3711             }
3712             SETERRNO(0,0);
3713 #ifndef EACCES
3714 #define EACCES EPERM
3715 #endif
3716             if (instr(s, "cannot make"))
3717                 SETERRNO(EEXIST,RMS_FEX);
3718             else if (instr(s, "existing file"))
3719                 SETERRNO(EEXIST,RMS_FEX);
3720             else if (instr(s, "ile exists"))
3721                 SETERRNO(EEXIST,RMS_FEX);
3722             else if (instr(s, "non-exist"))
3723                 SETERRNO(ENOENT,RMS_FNF);
3724             else if (instr(s, "does not exist"))
3725                 SETERRNO(ENOENT,RMS_FNF);
3726             else if (instr(s, "not empty"))
3727                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3728             else if (instr(s, "cannot access"))
3729                 SETERRNO(EACCES,RMS_PRV);
3730             else
3731                 SETERRNO(EPERM,RMS_PRV);
3732             return 0;
3733         }
3734         else {  /* some mkdirs return no failure indication */
3735             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3736             if (PL_op->op_type == OP_RMDIR)
3737                 anum = !anum;
3738             if (anum)
3739                 SETERRNO(0,0);
3740             else
3741                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3742         }
3743         return anum;
3744     }
3745     else
3746         return 0;
3747 }
3748 #endif
3749
3750 /* This macro removes trailing slashes from a directory name.
3751  * Different operating and file systems take differently to
3752  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3753  * any number of trailing slashes should be allowed.
3754  * Thusly we snip them away so that even non-conforming
3755  * systems are happy.
3756  * We should probably do this "filtering" for all
3757  * the functions that expect (potentially) directory names:
3758  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3759  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3760
3761 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3762     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3763         do { \
3764             (len)--; \
3765         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3766         (tmps) = savepvn((tmps), (len)); \
3767         (copy) = TRUE; \
3768     }
3769
3770 PP(pp_mkdir)
3771 {
3772     dVAR; dSP; dTARGET;
3773     STRLEN len;
3774     const char *tmps;
3775     bool copy = FALSE;
3776     const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3777
3778     TRIMSLASHES(tmps,len,copy);
3779
3780     TAINT_PROPER("mkdir");
3781 #ifdef HAS_MKDIR
3782     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3783 #else
3784     {
3785     int oldumask;
3786     SETi( dooneliner("mkdir", tmps) );
3787     oldumask = PerlLIO_umask(0);
3788     PerlLIO_umask(oldumask);
3789     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3790     }
3791 #endif
3792     if (copy)
3793         Safefree(tmps);
3794     RETURN;
3795 }
3796
3797 PP(pp_rmdir)
3798 {
3799     dVAR; dSP; dTARGET;
3800     STRLEN len;
3801     const char *tmps;
3802     bool copy = FALSE;
3803
3804     TRIMSLASHES(tmps,len,copy);
3805     TAINT_PROPER("rmdir");
3806 #ifdef HAS_RMDIR
3807     SETi( PerlDir_rmdir(tmps) >= 0 );
3808 #else
3809     SETi( dooneliner("rmdir", tmps) );
3810 #endif
3811     if (copy)
3812         Safefree(tmps);
3813     RETURN;
3814 }
3815
3816 /* Directory calls. */
3817
3818 PP(pp_open_dir)
3819 {
3820 #if defined(Direntry_t) && defined(HAS_READDIR)
3821     dVAR; dSP;
3822     const char * const dirname = POPpconstx;
3823     GV * const gv = MUTABLE_GV(POPs);
3824     register IO * const io = GvIOn(gv);
3825
3826     if (!io)
3827         goto nope;
3828
3829     if ((IoIFP(io) || IoOFP(io)))
3830         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3831                          "Opening filehandle %s also as a directory",
3832                          GvENAME(gv));
3833     if (IoDIRP(io))
3834         PerlDir_close(IoDIRP(io));
3835     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3836         goto nope;
3837
3838     RETPUSHYES;
3839 nope:
3840     if (!errno)
3841         SETERRNO(EBADF,RMS_DIR);
3842     RETPUSHUNDEF;
3843 #else
3844     DIE(aTHX_ PL_no_dir_func, "opendir");
3845 #endif
3846 }
3847
3848 PP(pp_readdir)
3849 {
3850 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3851     DIE(aTHX_ PL_no_dir_func, "readdir");
3852 #else
3853 #if !defined(I_DIRENT) && !defined(VMS)
3854     Direntry_t *readdir (DIR *);
3855 #endif
3856     dVAR;
3857     dSP;
3858
3859     SV *sv;
3860     const I32 gimme = GIMME;
3861     GV * const gv = MUTABLE_GV(POPs);
3862     register const Direntry_t *dp;
3863     register IO * const io = GvIOn(gv);
3864
3865     if (!io || !IoDIRP(io)) {
3866         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3867                        "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3868         goto nope;
3869     }
3870
3871     do {
3872         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3873         if (!dp)
3874             break;
3875 #ifdef DIRNAMLEN
3876         sv = newSVpvn(dp->d_name, dp->d_namlen);
3877 #else
3878         sv = newSVpv(dp->d_name, 0);
3879 #endif
3880 #ifndef INCOMPLETE_TAINTS
3881         if (!(IoFLAGS(io) & IOf_UNTAINT))
3882             SvTAINTED_on(sv);
3883 #endif
3884         mXPUSHs(sv);
3885     } while (gimme == G_ARRAY);
3886
3887     if (!dp && gimme != G_ARRAY)
3888         goto nope;
3889
3890     RETURN;
3891
3892 nope:
3893     if (!errno)
3894         SETERRNO(EBADF,RMS_ISI);
3895     if (GIMME == G_ARRAY)
3896         RETURN;
3897     else
3898         RETPUSHUNDEF;
3899 #endif
3900 }
3901
3902 PP(pp_telldir)
3903 {
3904 #if defined(HAS_TELLDIR) || defined(telldir)
3905     dVAR; dSP; dTARGET;
3906  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3907  /* XXX netbsd still seemed to.
3908     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3909     --JHI 1999-Feb-02 */
3910 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3911     long telldir (DIR *);
3912 # endif
3913     GV * const gv = MUTABLE_GV(POPs);
3914     register IO * const io = GvIOn(gv);
3915
3916     if (!io || !IoDIRP(io)) {
3917         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3918                        "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3919         goto nope;
3920     }
3921
3922     PUSHi( PerlDir_tell(IoDIRP(io)) );
3923     RETURN;
3924 nope:
3925     if (!errno)
3926         SETERRNO(EBADF,RMS_ISI);
3927     RETPUSHUNDEF;
3928 #else
3929     DIE(aTHX_ PL_no_dir_func, "telldir");
3930 #endif
3931 }
3932
3933 PP(pp_seekdir)
3934 {
3935 #if defined(HAS_SEEKDIR) || defined(seekdir)
3936     dVAR; dSP;
3937     const long along = POPl;
3938     GV * const gv = MUTABLE_GV(POPs);
3939     register IO * const io = GvIOn(gv);
3940
3941     if (!io || !IoDIRP(io)) {
3942         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3943                        "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3944         goto nope;
3945     }
3946     (void)PerlDir_seek(IoDIRP(io), along);
3947
3948     RETPUSHYES;
3949 nope:
3950     if (!errno)
3951         SETERRNO(EBADF,RMS_ISI);
3952     RETPUSHUNDEF;
3953 #else
3954     DIE(aTHX_ PL_no_dir_func, "seekdir");
3955 #endif
3956 }
3957
3958 PP(pp_rewinddir)
3959 {
3960 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3961     dVAR; dSP;
3962     GV * const gv = MUTABLE_GV(POPs);
3963     register IO * const io = GvIOn(gv);
3964
3965     if (!io || !IoDIRP(io)) {
3966         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3967                        "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3968         goto nope;
3969     }
3970     (void)PerlDir_rewind(IoDIRP(io));
3971     RETPUSHYES;
3972 nope:
3973     if (!errno)
3974         SETERRNO(EBADF,RMS_ISI);
3975     RETPUSHUNDEF;
3976 #else
3977     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3978 #endif
3979 }
3980
3981 PP(pp_closedir)
3982 {
3983 #if defined(Direntry_t) && defined(HAS_READDIR)
3984     dVAR; dSP;
3985     GV * const gv = MUTABLE_GV(POPs);
3986     register IO * const io = GvIOn(gv);
3987
3988     if (!io || !IoDIRP(io)) {
3989         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3990                        "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3991         goto nope;
3992     }
3993 #ifdef VOID_CLOSEDIR
3994     PerlDir_close(IoDIRP(io));
3995 #else
3996     if (PerlDir_close(IoDIRP(io)) < 0) {
3997         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3998         goto nope;
3999     }
4000 #endif
4001     IoDIRP(io) = 0;
4002
4003     RETPUSHYES;
4004 nope:
4005     if (!errno)
4006         SETERRNO(EBADF,RMS_IFI);
4007     RETPUSHUNDEF;
4008 #else
4009     DIE(aTHX_ PL_no_dir_func, "closedir");
4010 #endif
4011 }
4012
4013 /* Process control. */
4014
4015 PP(pp_fork)
4016 {
4017 #ifdef HAS_FORK
4018     dVAR; dSP; dTARGET;
4019     Pid_t childpid;
4020
4021     EXTEND(SP, 1);
4022     PERL_FLUSHALL_FOR_CHILD;
4023     childpid = PerlProc_fork();
4024     if (childpid < 0)
4025         RETSETUNDEF;
4026     if (!childpid) {
4027 #ifdef THREADS_HAVE_PIDS
4028         PL_ppid = (IV)getppid();
4029 #endif
4030 #ifdef PERL_USES_PL_PIDSTATUS
4031         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4032 #endif
4033     }
4034     PUSHi(childpid);
4035     RETURN;
4036 #else
4037 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4038     dSP; dTARGET;
4039     Pid_t childpid;
4040
4041     EXTEND(SP, 1);
4042     PERL_FLUSHALL_FOR_CHILD;
4043     childpid = PerlProc_fork();
4044     if (childpid == -1)
4045         RETSETUNDEF;
4046     PUSHi(childpid);
4047     RETURN;
4048 #  else
4049     DIE(aTHX_ PL_no_func, "fork");
4050 #  endif
4051 #endif
4052 }
4053
4054 PP(pp_wait)
4055 {
4056 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4057     dVAR; dSP; dTARGET;
4058     Pid_t childpid;
4059     int argflags;
4060
4061     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4062         childpid = wait4pid(-1, &argflags, 0);
4063     else {
4064         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4065                errno == EINTR) {
4066           PERL_ASYNC_CHECK();
4067         }
4068     }
4069 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4070     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4071     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4072 #  else
4073     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4074 #  endif
4075     XPUSHi(childpid);
4076     RETURN;
4077 #else
4078     DIE(aTHX_ PL_no_func, "wait");
4079 #endif
4080 }
4081
4082 PP(pp_waitpid)
4083 {
4084 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4085     dVAR; dSP; dTARGET;
4086     const int optype = POPi;
4087     const Pid_t pid = TOPi;
4088     Pid_t result;
4089     int argflags;
4090
4091     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4092         result = wait4pid(pid, &argflags, optype);
4093     else {
4094         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4095                errno == EINTR) {
4096           PERL_ASYNC_CHECK();
4097         }
4098     }
4099 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4100     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4101     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4102 #  else
4103     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4104 #  endif
4105     SETi(result);
4106     RETURN;
4107 #else
4108     DIE(aTHX_ PL_no_func, "waitpid");
4109 #endif
4110 }
4111
4112 PP(pp_system)
4113 {
4114     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4115 #if defined(__LIBCATAMOUNT__)
4116     PL_statusvalue = -1;
4117     SP = ORIGMARK;
4118     XPUSHi(-1);
4119 #else
4120     I32 value;
4121     int result;
4122
4123     if (PL_tainting) {
4124         TAINT_ENV();
4125         while (++MARK <= SP) {
4126             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4127             if (PL_tainted)
4128                 break;
4129         }
4130         MARK = ORIGMARK;
4131         TAINT_PROPER("system");
4132     }
4133     PERL_FLUSHALL_FOR_CHILD;
4134 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4135     {
4136         Pid_t childpid;
4137         int pp[2];
4138         I32 did_pipes = 0;
4139
4140         if (PerlProc_pipe(pp) >= 0)
4141             did_pipes = 1;
4142         while ((childpid = PerlProc_fork()) == -1) {
4143             if (errno != EAGAIN) {
4144                 value = -1;
4145                 SP = ORIGMARK;
4146                 XPUSHi(value);
4147                 if (did_pipes) {
4148                     PerlLIO_close(pp[0]);
4149                     PerlLIO_close(pp[1]);
4150                 }
4151                 RETURN;
4152             }
4153             sleep(5);
4154         }
4155         if (childpid > 0) {
4156             Sigsave_t ihand,qhand; /* place to save signals during system() */
4157             int status;
4158
4159             if (did_pipes)
4160                 PerlLIO_close(pp[1]);
4161 #ifndef PERL_MICRO
4162             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4163             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4164 #endif
4165             do {
4166                 result = wait4pid(childpid, &status, 0);
4167             } while (result == -1 && errno == EINTR);
4168 #ifndef PERL_MICRO
4169             (void)rsignal_restore(SIGINT, &ihand);
4170             (void)rsignal_restore(SIGQUIT, &qhand);
4171 #endif
4172             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4173             do_execfree();      /* free any memory child malloced on fork */
4174             SP = ORIGMARK;
4175             if (did_pipes) {
4176                 int errkid;
4177                 unsigned n = 0;
4178                 SSize_t n1;
4179
4180                 while (n < sizeof(int)) {
4181                     n1 = PerlLIO_read(pp[0],
4182                                       (void*)(((char*)&errkid)+n),
4183                                       (sizeof(int)) - n);
4184                     if (n1 <= 0)
4185                         break;
4186                     n += n1;
4187                 }
4188                 PerlLIO_close(pp[0]);
4189                 if (n) {                        /* Error */
4190                     if (n != sizeof(int))
4191                         DIE(aTHX_ "panic: kid popen errno read");
4192                     errno = errkid;             /* Propagate errno from kid */
4193                     STATUS_NATIVE_CHILD_SET(-1);
4194                 }
4195             }
4196             XPUSHi(STATUS_CURRENT);
4197             RETURN;
4198         }
4199         if (did_pipes) {
4200             PerlLIO_close(pp[0]);
4201 #if defined(HAS_FCNTL) && defined(F_SETFD)
4202             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4203 #endif
4204         }
4205         if (PL_op->op_flags & OPf_STACKED) {
4206             SV * const really = *++MARK;
4207             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4208         }
4209         else if (SP - MARK != 1)
4210             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4211         else {
4212             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4213         }
4214         PerlProc__exit(-1);
4215     }
4216 #else /* ! FORK or VMS or OS/2 */
4217     PL_statusvalue = 0;
4218     result = 0;
4219     if (PL_op->op_flags & OPf_STACKED) {
4220         SV * const really = *++MARK;
4221 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4222         value = (I32)do_aspawn(really, MARK, SP);
4223 #  else
4224         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4225 #  endif
4226     }
4227     else if (SP - MARK != 1) {
4228 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4229         value = (I32)do_aspawn(NULL, MARK, SP);
4230 #  else
4231         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4232 #  endif
4233     }
4234     else {
4235         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4236     }
4237     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4238         result = 1;
4239     STATUS_NATIVE_CHILD_SET(value);
4240     do_execfree();
4241     SP = ORIGMARK;
4242     XPUSHi(result ? value : STATUS_CURRENT);
4243 #endif /* !FORK or VMS or OS/2 */
4244 #endif
4245     RETURN;
4246 }
4247
4248 PP(pp_exec)
4249 {
4250     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4251     I32 value;
4252
4253     if (PL_tainting) {
4254         TAINT_ENV();
4255         while (++MARK <= SP) {
4256             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4257             if (PL_tainted)
4258                 break;
4259         }
4260         MARK = ORIGMARK;
4261         TAINT_PROPER("exec");
4262     }
4263     PERL_FLUSHALL_FOR_CHILD;
4264     if (PL_op->op_flags & OPf_STACKED) {
4265         SV * const really = *++MARK;
4266         value = (I32)do_aexec(really, MARK, SP);
4267     }
4268     else if (SP - MARK != 1)
4269 #ifdef VMS
4270         value = (I32)vms_do_aexec(NULL, MARK, SP);
4271 #else
4272 #  ifdef __OPEN_VM
4273         {
4274            (void ) do_aspawn(NULL, MARK, SP);
4275            value = 0;
4276         }
4277 #  else
4278         value = (I32)do_aexec(NULL, MARK, SP);
4279 #  endif
4280 #endif
4281     else {
4282 #ifdef VMS
4283         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4284 #else
4285 #  ifdef __OPEN_VM
4286         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4287         value = 0;
4288 #  else
4289         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4290 #  endif
4291 #endif
4292     }
4293
4294     SP = ORIGMARK;
4295     XPUSHi(value);
4296     RETURN;
4297 }
4298
4299 PP(pp_getppid)
4300 {
4301 #ifdef HAS_GETPPID
4302     dVAR; dSP; dTARGET;
4303 #   ifdef THREADS_HAVE_PIDS
4304     if (PL_ppid != 1 && getppid() == 1)
4305         /* maybe the parent process has died. Refresh ppid cache */
4306         PL_ppid = 1;
4307     XPUSHi( PL_ppid );
4308 #   else
4309     XPUSHi( getppid() );
4310 #   endif
4311     RETURN;
4312 #else
4313     DIE(aTHX_ PL_no_func, "getppid");
4314 #endif
4315 }
4316
4317 PP(pp_getpgrp)
4318 {
4319 #ifdef HAS_GETPGRP
4320     dVAR; dSP; dTARGET;
4321     Pid_t pgrp;
4322     const Pid_t pid =
4323         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4324
4325 #ifdef BSD_GETPGRP
4326     pgrp = (I32)BSD_GETPGRP(pid);
4327 #else
4328     if (pid != 0 && pid != PerlProc_getpid())
4329         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4330     pgrp = getpgrp();
4331 #endif
4332     XPUSHi(pgrp);
4333     RETURN;
4334 #else
4335     DIE(aTHX_ PL_no_func, "getpgrp()");
4336 #endif
4337 }
4338
4339 PP(pp_setpgrp)
4340 {
4341 #ifdef HAS_SETPGRP
4342     dVAR; dSP; dTARGET;
4343     Pid_t pgrp;
4344     Pid_t pid;
4345     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4346     if (MAXARG > 0) pid = TOPs && TOPi;
4347     else {
4348         pid = 0;
4349         XPUSHi(-1);
4350     }
4351
4352     TAINT_PROPER("setpgrp");
4353 #ifdef BSD_SETPGRP
4354     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4355 #else
4356     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4357         || (pid != 0 && pid != PerlProc_getpid()))
4358     {
4359         DIE(aTHX_ "setpgrp can't take arguments");
4360     }
4361     SETi( setpgrp() >= 0 );
4362 #endif /* USE_BSDPGRP */
4363     RETURN;
4364 #else
4365     DIE(aTHX_ PL_no_func, "setpgrp()");
4366 #endif
4367 }
4368
4369 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4370 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4371 #else
4372 #  define PRIORITY_WHICH_T(which) which
4373 #endif
4374
4375 PP(pp_getpriority)
4376 {
4377 #ifdef HAS_GETPRIORITY
4378     dVAR; dSP; dTARGET;
4379     const int who = POPi;
4380     const int which = TOPi;
4381     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4382     RETURN;
4383 #else
4384     DIE(aTHX_ PL_no_func, "getpriority()");
4385 #endif
4386 }
4387
4388 PP(pp_setpriority)
4389 {
4390 #ifdef HAS_SETPRIORITY
4391     dVAR; dSP; dTARGET;
4392     const int niceval = POPi;
4393     const int who = POPi;
4394     const int which = TOPi;
4395     TAINT_PROPER("setpriority");
4396     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4397     RETURN;
4398 #else
4399     DIE(aTHX_ PL_no_func, "setpriority()");
4400 #endif
4401 }
4402
4403 #undef PRIORITY_WHICH_T
4404
4405 /* Time calls. */
4406
4407 PP(pp_time)
4408 {
4409     dVAR; dSP; dTARGET;
4410 #ifdef BIG_TIME
4411     XPUSHn( time(NULL) );
4412 #else
4413     XPUSHi( time(NULL) );
4414 #endif
4415     RETURN;
4416 }
4417
4418 PP(pp_tms)
4419 {
4420 #ifdef HAS_TIMES
4421     dVAR;
4422     dSP;
4423     EXTEND(SP, 4);
4424 #ifndef VMS
4425     (void)PerlProc_times(&PL_timesbuf);
4426 #else
4427     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4428                                                    /* struct tms, though same data   */
4429                                                    /* is returned.                   */
4430 #endif
4431
4432     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4433     if (GIMME == G_ARRAY) {
4434         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4435         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4436         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4437     }
4438     RETURN;
4439 #else
4440 #   ifdef PERL_MICRO
4441     dSP;
4442     mPUSHn(0.0);
4443     EXTEND(SP, 4);
4444     if (GIMME == G_ARRAY) {
4445          mPUSHn(0.0);
4446          mPUSHn(0.0);
4447          mPUSHn(0.0);
4448     }
4449     RETURN;
4450 #   else
4451     DIE(aTHX_ "times not implemented");
4452 #   endif
4453 #endif /* HAS_TIMES */
4454 }
4455
4456 /* The 32 bit int year limits the times we can represent to these
4457    boundaries with a few days wiggle room to account for time zone
4458    offsets
4459 */
4460 /* Sat Jan  3 00:00:00 -2147481748 */
4461 #define TIME_LOWER_BOUND -67768100567755200.0
4462 /* Sun Dec 29 12:00:00  2147483647 */
4463 #define TIME_UPPER_BOUND  67767976233316800.0
4464
4465 PP(pp_gmtime)
4466 {
4467     dVAR;
4468     dSP;
4469     Time64_T when;
4470     struct TM tmbuf;
4471     struct TM *err;
4472     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4473     static const char * const dayname[] =
4474         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4475     static const char * const monname[] =
4476         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4477          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4478
4479     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4480         time_t now;
4481         (void)time(&now);
4482         when = (Time64_T)now;
4483     }
4484     else {
4485         NV input = Perl_floor(POPn);
4486         when = (Time64_T)input;
4487         if (when != input) {
4488             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4489                            "%s(%.0" NVff ") too large", opname, input);
4490         }
4491     }
4492
4493     if ( TIME_LOWER_BOUND > when ) {
4494         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4495                        "%s(%.0" NVff ") too small", opname, when);
4496         err = NULL;
4497     }
4498     else if( when > TIME_UPPER_BOUND ) {
4499         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4500                        "%s(%.0" NVff ") too large", opname, when);
4501         err = NULL;
4502     }
4503     else {
4504         if (PL_op->op_type == OP_LOCALTIME)
4505             err = S_localtime64_r(&when, &tmbuf);
4506         else
4507             err = S_gmtime64_r(&when, &tmbuf);
4508     }
4509
4510     if (err == NULL) {
4511         /* XXX %lld broken for quads */
4512         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4513                        "%s(%.0" NVff ") failed", opname, when);
4514     }
4515
4516     if (GIMME != G_ARRAY) {     /* scalar context */
4517         SV *tsv;
4518         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4519         double year = (double)tmbuf.tm_year + 1900;
4520
4521         EXTEND(SP, 1);
4522         EXTEND_MORTAL(1);
4523         if (err == NULL)
4524             RETPUSHUNDEF;
4525
4526         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4527                             dayname[tmbuf.tm_wday],
4528                             monname[tmbuf.tm_mon],
4529                             tmbuf.tm_mday,
4530                             tmbuf.tm_hour,
4531                             tmbuf.tm_min,
4532                             tmbuf.tm_sec,
4533                             year);
4534         mPUSHs(tsv);
4535     }
4536     else {                      /* list context */
4537         if ( err == NULL )
4538             RETURN;
4539
4540         EXTEND(SP, 9);
4541         EXTEND_MORTAL(9);
4542         mPUSHi(tmbuf.tm_sec);
4543         mPUSHi(tmbuf.tm_min);
4544         mPUSHi(tmbuf.tm_hour);
4545         mPUSHi(tmbuf.tm_mday);
4546         mPUSHi(tmbuf.tm_mon);
4547         mPUSHn(tmbuf.tm_year);
4548         mPUSHi(tmbuf.tm_wday);
4549         mPUSHi(tmbuf.tm_yday);
4550         mPUSHi(tmbuf.tm_isdst);
4551     }
4552     RETURN;
4553 }
4554
4555 PP(pp_alarm)
4556 {
4557 #ifdef HAS_ALARM
4558     dVAR; dSP; dTARGET;
4559     int anum;
4560     anum = POPi;
4561     anum = alarm((unsigned int)anum);
4562     if (anum < 0)
4563         RETPUSHUNDEF;
4564     PUSHi(anum);
4565     RETURN;
4566 #else
4567     DIE(aTHX_ PL_no_func, "alarm");
4568 #endif
4569 }
4570
4571 PP(pp_sleep)
4572 {
4573     dVAR; dSP; dTARGET;
4574     I32 duration;
4575     Time_t lasttime;
4576     Time_t when;
4577
4578     (void)time(&lasttime);
4579     if (MAXARG < 1 || (!TOPs && !POPs))
4580         PerlProc_pause();
4581     else {
4582         duration = POPi;
4583         PerlProc_sleep((unsigned int)duration);
4584     }
4585     (void)time(&when);
4586     XPUSHi(when - lasttime);
4587     RETURN;
4588 }
4589
4590 /* Shared memory. */
4591 /* Merged with some message passing. */
4592
4593 PP(pp_shmwrite)
4594 {
4595 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4596     dVAR; dSP; dMARK; dTARGET;
4597     const int op_type = PL_op->op_type;
4598     I32 value;
4599
4600     switch (op_type) {
4601     case OP_MSGSND:
4602         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4603         break;
4604     case OP_MSGRCV:
4605         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4606         break;
4607     case OP_SEMOP:
4608         value = (I32)(do_semop(MARK, SP) >= 0);
4609         break;
4610     default:
4611         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4612         break;
4613     }
4614
4615     SP = MARK;
4616     PUSHi(value);
4617     RETURN;
4618 #else
4619     return Perl_pp_semget(aTHX);
4620 #endif
4621 }
4622
4623 /* Semaphores. */
4624
4625 PP(pp_semget)
4626 {
4627 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4628     dVAR; dSP; dMARK; dTARGET;
4629     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4630     SP = MARK;
4631     if (anum == -1)
4632         RETPUSHUNDEF;
4633     PUSHi(anum);
4634     RETURN;
4635 #else
4636     DIE(aTHX_ "System V IPC is not implemented on this machine");
4637 #endif
4638 }
4639
4640 PP(pp_semctl)
4641 {
4642 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4643     dVAR; dSP; dMARK; dTARGET;
4644     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4645     SP = MARK;
4646     if (anum == -1)
4647         RETSETUNDEF;
4648     if (anum != 0) {
4649         PUSHi(anum);
4650     }
4651     else {
4652         PUSHp(zero_but_true, ZBTLEN);
4653     }
4654     RETURN;
4655 #else
4656     return Perl_pp_semget(aTHX);
4657 #endif
4658 }
4659
4660 /* I can't const this further without getting warnings about the types of
4661    various arrays passed in from structures.  */
4662 static SV *
4663 S_space_join_names_mortal(pTHX_ char *const *array)
4664 {
4665     SV *target;
4666
4667     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4668
4669     if (array && *array) {
4670         target = newSVpvs_flags("", SVs_TEMP);
4671         while (1) {
4672             sv_catpv(target, *array);
4673             if (!*++array)
4674                 break;
4675             sv_catpvs(target, " ");
4676         }
4677     } else {
4678         target = sv_mortalcopy(&PL_sv_no);
4679     }
4680     return target;
4681 }
4682
4683 /* Get system info. */
4684
4685 PP(pp_ghostent)
4686 {
4687 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4688     dVAR; dSP;
4689     I32 which = PL_op->op_type;
4690     register char **elem;
4691     register SV *sv;
4692 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4693     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4694     struct hostent *gethostbyname(Netdb_name_t);
4695     struct hostent *gethostent(void);
4696 #endif
4697     struct hostent *hent = NULL;
4698     unsigned long len;
4699
4700     EXTEND(SP, 10);
4701     if (which == OP_GHBYNAME) {
4702 #ifdef HAS_GETHOSTBYNAME
4703         const char* const name = POPpbytex;
4704         hent = PerlSock_gethostbyname(name);
4705 #else
4706         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4707 #endif
4708     }
4709     else if (which == OP_GHBYADDR) {
4710 #ifdef HAS_GETHOSTBYADDR
4711         const int addrtype = POPi;
4712         SV * const addrsv = POPs;
4713         STRLEN addrlen;
4714         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4715
4716         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4717 #else
4718         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4719 #endif
4720     }
4721     else
4722 #ifdef HAS_GETHOSTENT
4723         hent = PerlSock_gethostent();
4724 #else
4725         DIE(aTHX_ PL_no_sock_func, "gethostent");
4726 #endif
4727
4728 #ifdef HOST_NOT_FOUND
4729         if (!hent) {
4730 #ifdef USE_REENTRANT_API
4731 #   ifdef USE_GETHOSTENT_ERRNO
4732             h_errno = PL_reentrant_buffer->_gethostent_errno;
4733 #   endif
4734 #endif
4735             STATUS_UNIX_SET(h_errno);
4736         }
4737 #endif
4738
4739     if (GIMME != G_ARRAY) {
4740         PUSHs(sv = sv_newmortal());
4741         if (hent) {
4742             if (which == OP_GHBYNAME) {
4743                 if (hent->h_addr)
4744                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4745             }
4746             else
4747                 sv_setpv(sv, (char*)hent->h_name);
4748         }
4749         RETURN;
4750     }
4751
4752     if (hent) {
4753         mPUSHs(newSVpv((char*)hent->h_name, 0));
4754         PUSHs(space_join_names_mortal(hent->h_aliases));
4755         mPUSHi(hent->h_addrtype);
4756         len = hent->h_length;
4757         mPUSHi(len);
4758 #ifdef h_addr
4759         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4760             mXPUSHp(*elem, len);
4761         }
4762 #else
4763         if (hent->h_addr)
4764             mPUSHp(hent->h_addr, len);
4765         else
4766             PUSHs(sv_mortalcopy(&PL_sv_no));
4767 #endif /* h_addr */
4768     }
4769     RETURN;
4770 #else
4771     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4772 #endif
4773 }
4774
4775 PP(pp_gnetent)
4776 {
4777 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4778     dVAR; dSP;
4779     I32 which = PL_op->op_type;
4780     register SV *sv;
4781 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4782     struct netent *getnetbyaddr(Netdb_net_t, int);
4783     struct netent *getnetbyname(Netdb_name_t);
4784     struct netent *getnetent(void);
4785 #endif
4786     struct netent *nent;
4787
4788     if (which == OP_GNBYNAME){
4789 #ifdef HAS_GETNETBYNAME
4790         const char * const name = POPpbytex;
4791         nent = PerlSock_getnetbyname(name);
4792 #else
4793         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4794 #endif
4795     }
4796     else if (which == OP_GNBYADDR) {
4797 #ifdef HAS_GETNETBYADDR
4798         const int addrtype = POPi;
4799         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4800         nent = PerlSock_getnetbyaddr(addr, addrtype);
4801 #else
4802         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4803 #endif
4804     }
4805     else
4806 #ifdef HAS_GETNETENT
4807         nent = PerlSock_getnetent();
4808 #else
4809         DIE(aTHX_ PL_no_sock_func, "getnetent");
4810 #endif
4811
4812 #ifdef HOST_NOT_FOUND
4813         if (!nent) {
4814 #ifdef USE_REENTRANT_API
4815 #   ifdef USE_GETNETENT_ERRNO
4816              h_errno = PL_reentrant_buffer->_getnetent_errno;
4817 #   endif
4818 #endif
4819             STATUS_UNIX_SET(h_errno);
4820         }
4821 #endif
4822
4823     EXTEND(SP, 4);
4824     if (GIMME != G_ARRAY) {
4825         PUSHs(sv = sv_newmortal());
4826         if (nent) {
4827             if (which == OP_GNBYNAME)
4828                 sv_setiv(sv, (IV)nent->n_net);
4829             else
4830                 sv_setpv(sv, nent->n_name);
4831         }
4832         RETURN;
4833     }
4834
4835     if (nent) {
4836         mPUSHs(newSVpv(nent->n_name, 0));
4837         PUSHs(space_join_names_mortal(nent->n_aliases));
4838         mPUSHi(nent->n_addrtype);
4839         mPUSHi(nent->n_net);
4840     }
4841
4842     RETURN;
4843 #else
4844     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4845 #endif
4846 }
4847
4848 PP(pp_gprotoent)
4849 {
4850 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4851     dVAR; dSP;
4852     I32 which = PL_op->op_type;
4853     register SV *sv;
4854 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4855     struct protoent *getprotobyname(Netdb_name_t);
4856     struct protoent *getprotobynumber(int);
4857     struct protoent *getprotoent(void);
4858 #endif
4859     struct protoent *pent;
4860
4861     if (which == OP_GPBYNAME) {
4862 #ifdef HAS_GETPROTOBYNAME
4863         const char* const name = POPpbytex;
4864         pent = PerlSock_getprotobyname(name);
4865 #else
4866         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4867 #endif
4868     }
4869     else if (which == OP_GPBYNUMBER) {
4870 #ifdef HAS_GETPROTOBYNUMBER
4871         const int number = POPi;
4872         pent = PerlSock_getprotobynumber(number);
4873 #else
4874         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4875 #endif
4876     }
4877     else
4878 #ifdef HAS_GETPROTOENT
4879         pent = PerlSock_getprotoent();
4880 #else
4881         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4882 #endif
4883
4884     EXTEND(SP, 3);
4885     if (GIMME != G_ARRAY) {
4886         PUSHs(sv = sv_newmortal());
4887         if (pent) {
4888             if (which == OP_GPBYNAME)
4889                 sv_setiv(sv, (IV)pent->p_proto);
4890             else
4891                 sv_setpv(sv, pent->p_name);
4892         }
4893         RETURN;
4894     }
4895
4896     if (pent) {
4897         mPUSHs(newSVpv(pent->p_name, 0));
4898         PUSHs(space_join_names_mortal(pent->p_aliases));
4899         mPUSHi(pent->p_proto);
4900     }
4901
4902     RETURN;
4903 #else
4904     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4905 #endif
4906 }
4907
4908 PP(pp_gservent)
4909 {
4910 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4911     dVAR; dSP;
4912     I32 which = PL_op->op_type;
4913     register SV *sv;
4914 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4915     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4916     struct servent *getservbyport(int, Netdb_name_t);
4917     struct servent *getservent(void);
4918 #endif
4919     struct servent *sent;
4920
4921     if (which == OP_GSBYNAME) {
4922 #ifdef HAS_GETSERVBYNAME
4923         const char * const proto = POPpbytex;
4924         const char * const name = POPpbytex;
4925         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4926 #else
4927         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4928 #endif
4929     }
4930     else if (which == OP_GSBYPORT) {
4931 #ifdef HAS_GETSERVBYPORT
4932         const char * const proto = POPpbytex;
4933         unsigned short port = (unsigned short)POPu;
4934 #ifdef HAS_HTONS
4935         port = PerlSock_htons(port);
4936 #endif
4937         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4938 #else
4939         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4940 #endif
4941     }
4942     else
4943 #ifdef HAS_GETSERVENT
4944         sent = PerlSock_getservent();
4945 #else
4946         DIE(aTHX_ PL_no_sock_func, "getservent");
4947 #endif
4948
4949     EXTEND(SP, 4);
4950     if (GIMME != G_ARRAY) {
4951         PUSHs(sv = sv_newmortal());
4952         if (sent) {
4953             if (which == OP_GSBYNAME) {
4954 #ifdef HAS_NTOHS
4955                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4956 #else
4957                 sv_setiv(sv, (IV)(sent->s_port));
4958 #endif
4959             }
4960             else
4961                 sv_setpv(sv, sent->s_name);
4962         }
4963         RETURN;
4964     }
4965
4966     if (sent) {
4967         mPUSHs(newSVpv(sent->s_name, 0));
4968         PUSHs(space_join_names_mortal(sent->s_aliases));
4969 #ifdef HAS_NTOHS
4970         mPUSHi(PerlSock_ntohs(sent->s_port));
4971 #else
4972         mPUSHi(sent->s_port);
4973 #endif
4974         mPUSHs(newSVpv(sent->s_proto, 0));
4975     }
4976
4977     RETURN;
4978 #else
4979     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4980 #endif
4981 }
4982
4983 PP(pp_shostent)
4984 {
4985     dVAR; dSP;
4986     const int stayopen = TOPi;
4987     switch(PL_op->op_type) {
4988     case OP_SHOSTENT:
4989 #ifdef HAS_SETHOSTENT
4990         PerlSock_sethostent(stayopen);
4991 #else
4992         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4993 #endif
4994         break;
4995 #ifdef HAS_SETNETENT
4996     case OP_SNETENT:
4997         PerlSock_setnetent(stayopen);
4998 #else
4999         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5000 #endif
5001         break;
5002     case OP_SPROTOENT:
5003 #ifdef HAS_SETPROTOENT
5004         PerlSock_setprotoent(stayopen);
5005 #else
5006         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5007 #endif
5008         break;
5009     case OP_SSERVENT:
5010 #ifdef HAS_SETSERVENT
5011         PerlSock_setservent(stayopen);
5012 #else
5013         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5014 #endif
5015         break;
5016     }
5017     RETSETYES;
5018 }
5019
5020 PP(pp_ehostent)
5021 {
5022     dVAR; dSP;
5023     switch(PL_op->op_type) {
5024     case OP_EHOSTENT:
5025 #ifdef HAS_ENDHOSTENT
5026         PerlSock_endhostent();
5027 #else
5028         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5029 #endif
5030         break;
5031     case OP_ENETENT:
5032 #ifdef HAS_ENDNETENT
5033         PerlSock_endnetent();
5034 #else
5035         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5036 #endif
5037         break;
5038     case OP_EPROTOENT:
5039 #ifdef HAS_ENDPROTOENT
5040         PerlSock_endprotoent();
5041 #else
5042         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5043 #endif
5044         break;
5045     case OP_ESERVENT:
5046 #ifdef HAS_ENDSERVENT
5047         PerlSock_endservent();
5048 #else
5049         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5050 #endif
5051         break;
5052     case OP_SGRENT:
5053 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5054         setgrent();
5055 #else
5056         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5057 #endif
5058         break;
5059     case OP_EGRENT:
5060 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5061         endgrent();
5062 #else
5063         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5064 #endif
5065         break;
5066     case OP_SPWENT:
5067 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5068         setpwent();
5069 #else
5070         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5071 #endif
5072         break;
5073     case OP_EPWENT:
5074 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5075         endpwent();
5076 #else
5077         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5078 #endif
5079         break;
5080     }
5081     EXTEND(SP,1);
5082     RETPUSHYES;
5083 }
5084
5085 PP(pp_gpwent)
5086 {
5087 #ifdef HAS_PASSWD
5088     dVAR; dSP;
5089     I32 which = PL_op->op_type;
5090     register SV *sv;
5091     struct passwd *pwent  = NULL;
5092     /*
5093      * We currently support only the SysV getsp* shadow password interface.
5094      * The interface is declared in <shadow.h> and often one needs to link
5095      * with -lsecurity or some such.
5096      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5097      * (and SCO?)
5098      *
5099      * AIX getpwnam() is clever enough to return the encrypted password
5100      * only if the caller (euid?) is root.
5101      *
5102      * There are at least three other shadow password APIs.  Many platforms
5103      * seem to contain more than one interface for accessing the shadow
5104      * password databases, possibly for compatibility reasons.
5105      * The getsp*() is by far he simplest one, the other two interfaces
5106      * are much more complicated, but also very similar to each other.
5107      *
5108      * <sys/types.h>
5109      * <sys/security.h>
5110      * <prot.h>
5111      * struct pr_passwd *getprpw*();
5112      * The password is in
5113      * char getprpw*(...).ufld.fd_encrypt[]
5114      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5115      *
5116      * <sys/types.h>
5117      * <sys/security.h>
5118      * <prot.h>
5119      * struct es_passwd *getespw*();
5120      * The password is in
5121      * char *(getespw*(...).ufld.fd_encrypt)
5122      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5123      *
5124      * <userpw.h> (AIX)
5125      * struct userpw *getuserpw();
5126      * The password is in
5127      * char *(getuserpw(...)).spw_upw_passwd
5128      * (but the de facto standard getpwnam() should work okay)
5129      *
5130      * Mention I_PROT here so that Configure probes for it.
5131      *
5132      * In HP-UX for getprpw*() the manual page claims that one should include
5133      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5134      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5135      * and pp_sys.c already includes <shadow.h> if there is such.
5136      *
5137      * Note that <sys/security.h> is already probed for, but currently
5138      * it is only included in special cases.
5139      *
5140      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5141      * be preferred interface, even though also the getprpw*() interface
5142      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5143      * One also needs to call set_auth_parameters() in main() before
5144      * doing anything else, whether one is using getespw*() or getprpw*().
5145      *
5146      * Note that accessing the shadow databases can be magnitudes
5147      * slower than accessing the standard databases.
5148      *
5149      * --jhi
5150      */
5151
5152 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5153     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5154      * the pw_comment is left uninitialized. */
5155     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5156 #   endif
5157
5158     switch (which) {
5159     case OP_GPWNAM:
5160       {
5161         const char* const name = POPpbytex;
5162         pwent  = getpwnam(name);
5163       }
5164       break;
5165     case OP_GPWUID:
5166       {
5167         Uid_t uid = POPi;
5168         pwent = getpwuid(uid);
5169       }
5170         break;
5171     case OP_GPWENT:
5172 #   ifdef HAS_GETPWENT
5173         pwent  = getpwent();
5174 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5175         if (pwent) pwent = getpwnam(pwent->pw_name);
5176 #endif
5177 #   else
5178         DIE(aTHX_ PL_no_func, "getpwent");
5179 #   endif
5180         break;
5181     }
5182
5183     EXTEND(SP, 10);
5184     if (GIMME != G_ARRAY) {
5185         PUSHs(sv = sv_newmortal());
5186         if (pwent) {
5187             if (which == OP_GPWNAM)
5188 #   if Uid_t_sign <= 0
5189                 sv_setiv(sv, (IV)pwent->pw_uid);
5190 #   else
5191                 sv_setuv(sv, (UV)pwent->pw_uid);
5192 #   endif
5193             else
5194                 sv_setpv(sv, pwent->pw_name);
5195         }
5196         RETURN;
5197     }
5198
5199     if (pwent) {
5200         mPUSHs(newSVpv(pwent->pw_name, 0));
5201
5202         sv = newSViv(0);
5203         mPUSHs(sv);
5204         /* If we have getspnam(), we try to dig up the shadow
5205          * password.  If we are underprivileged, the shadow
5206          * interface will set the errno to EACCES or similar,
5207          * and return a null pointer.  If this happens, we will
5208          * use the dummy password (usually "*" or "x") from the
5209          * standard password database.
5210          *
5211          * In theory we could skip the shadow call completely
5212          * if euid != 0 but in practice we cannot know which
5213          * security measures are guarding the shadow databases
5214          * on a random platform.
5215          *
5216          * Resist the urge to use additional shadow interfaces.
5217          * Divert the urge to writing an extension instead.
5218          *
5219          * --jhi */
5220         /* Some AIX setups falsely(?) detect some getspnam(), which
5221          * has a different API than the Solaris/IRIX one. */
5222 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5223         {
5224             dSAVE_ERRNO;
5225             const struct spwd * const spwent = getspnam(pwent->pw_name);
5226                           /* Save and restore errno so that
5227                            * underprivileged attempts seem
5228                            * to have never made the unsuccessful
5229                            * attempt to retrieve the shadow password. */
5230             RESTORE_ERRNO;
5231             if (spwent && spwent->sp_pwdp)
5232                 sv_setpv(sv, spwent->sp_pwdp);
5233         }
5234 #   endif
5235 #   ifdef PWPASSWD
5236         if (!SvPOK(sv)) /* Use the standard password, then. */
5237             sv_setpv(sv, pwent->pw_passwd);
5238 #   endif
5239
5240 #   ifndef INCOMPLETE_TAINTS
5241         /* passwd is tainted because user himself can diddle with it.
5242          * admittedly not much and in a very limited way, but nevertheless. */
5243         SvTAINTED_on(sv);
5244 #   endif
5245
5246 #   if Uid_t_sign <= 0
5247         mPUSHi(pwent->pw_uid);
5248 #   else
5249         mPUSHu(pwent->pw_uid);
5250 #   endif
5251
5252 #   if Uid_t_sign <= 0
5253         mPUSHi(pwent->pw_gid);
5254 #   else
5255         mPUSHu(pwent->pw_gid);
5256 #   endif
5257         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5258          * because of the poor interface of the Perl getpw*(),
5259          * not because there's some standard/convention saying so.
5260          * A better interface would have been to return a hash,
5261          * but we are accursed by our history, alas. --jhi.  */
5262 #   ifdef PWCHANGE
5263         mPUSHi(pwent->pw_change);
5264 #   else
5265 #       ifdef PWQUOTA
5266         mPUSHi(pwent->pw_quota);
5267 #       else
5268 #           ifdef PWAGE
5269         mPUSHs(newSVpv(pwent->pw_age, 0));
5270 #           else
5271         /* I think that you can never get this compiled, but just in case.  */
5272         PUSHs(sv_mortalcopy(&PL_sv_no));
5273 #           endif
5274 #       endif
5275 #   endif
5276
5277         /* pw_class and pw_comment are mutually exclusive--.
5278          * see the above note for pw_change, pw_quota, and pw_age. */
5279 #   ifdef PWCLASS
5280         mPUSHs(newSVpv(pwent->pw_class, 0));
5281 #   else
5282 #       ifdef PWCOMMENT
5283         mPUSHs(newSVpv(pwent->pw_comment, 0));
5284 #       else
5285         /* I think that you can never get this compiled, but just in case.  */
5286         PUSHs(sv_mortalcopy(&PL_sv_no));
5287 #       endif
5288 #   endif
5289
5290 #   ifdef PWGECOS
5291         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5292 #   else
5293         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5294 #   endif
5295 #   ifndef INCOMPLETE_TAINTS
5296         /* pw_gecos is tainted because user himself can diddle with it. */
5297         SvTAINTED_on(sv);
5298 #   endif
5299
5300         mPUSHs(newSVpv(pwent->pw_dir, 0));
5301
5302         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5303 #   ifndef INCOMPLETE_TAINTS
5304         /* pw_shell is tainted because user himself can diddle with it. */
5305         SvTAINTED_on(sv);
5306 #   endif
5307
5308 #   ifdef PWEXPIRE
5309         mPUSHi(pwent->pw_expire);
5310 #   endif
5311     }
5312     RETURN;
5313 #else
5314     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5315 #endif
5316 }
5317
5318 PP(pp_ggrent)
5319 {
5320 #ifdef HAS_GROUP
5321     dVAR; dSP;
5322     const I32 which = PL_op->op_type;
5323     const struct group *grent;
5324
5325     if (which == OP_GGRNAM) {
5326         const char* const name = POPpbytex;
5327         grent = (const struct group *)getgrnam(name);
5328     }
5329     else if (which == OP_GGRGID) {
5330         const Gid_t gid = POPi;
5331         grent = (const struct group *)getgrgid(gid);
5332     }
5333     else
5334 #ifdef HAS_GETGRENT
5335         grent = (struct group *)getgrent();
5336 #else
5337         DIE(aTHX_ PL_no_func, "getgrent");
5338 #endif
5339
5340     EXTEND(SP, 4);
5341     if (GIMME != G_ARRAY) {
5342         SV * const sv = sv_newmortal();
5343
5344         PUSHs(sv);
5345         if (grent) {
5346             if (which == OP_GGRNAM)
5347 #if Gid_t_sign <= 0
5348                 sv_setiv(sv, (IV)grent->gr_gid);
5349 #else
5350                 sv_setuv(sv, (UV)grent->gr_gid);
5351 #endif
5352             else
5353                 sv_setpv(sv, grent->gr_name);
5354         }
5355         RETURN;
5356     }
5357
5358     if (grent) {
5359         mPUSHs(newSVpv(grent->gr_name, 0));
5360
5361 #ifdef GRPASSWD
5362         mPUSHs(newSVpv(grent->gr_passwd, 0));
5363 #else
5364         PUSHs(sv_mortalcopy(&PL_sv_no));
5365 #endif
5366
5367 #if Gid_t_sign <= 0
5368         mPUSHi(grent->gr_gid);
5369 #else
5370         mPUSHu(grent->gr_gid);
5371 #endif
5372
5373 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5374         /* In UNICOS/mk (_CRAYMPP) the multithreading
5375          * versions (getgrnam_r, getgrgid_r)
5376          * seem to return an illegal pointer
5377          * as the group members list, gr_mem.
5378          * getgrent() doesn't even have a _r version
5379          * but the gr_mem is poisonous anyway.
5380          * So yes, you cannot get the list of group
5381          * members if building multithreaded in UNICOS/mk. */
5382         PUSHs(space_join_names_mortal(grent->gr_mem));
5383 #endif
5384     }
5385
5386     RETURN;
5387 #else
5388     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5389 #endif
5390 }
5391
5392 PP(pp_getlogin)
5393 {
5394 #ifdef HAS_GETLOGIN
5395     dVAR; dSP; dTARGET;
5396     char *tmps;
5397     EXTEND(SP, 1);
5398     if (!(tmps = PerlProc_getlogin()))
5399         RETPUSHUNDEF;
5400     sv_setpv_mg(TARG, tmps);
5401     PUSHs(TARG);
5402     RETURN;
5403 #else
5404     DIE(aTHX_ PL_no_func, "getlogin");
5405 #endif
5406 }
5407
5408 /* Miscellaneous. */
5409
5410 PP(pp_syscall)
5411 {
5412 #ifdef HAS_SYSCALL
5413     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5414     register I32 items = SP - MARK;
5415     unsigned long a[20];
5416     register I32 i = 0;
5417     I32 retval = -1;
5418
5419     if (PL_tainting) {
5420         while (++MARK <= SP) {
5421             if (SvTAINTED(*MARK)) {
5422                 TAINT;
5423                 break;
5424             }
5425         }
5426         MARK = ORIGMARK;
5427         TAINT_PROPER("syscall");
5428     }
5429
5430     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5431      * or where sizeof(long) != sizeof(char*).  But such machines will
5432      * not likely have syscall implemented either, so who cares?
5433      */
5434     while (++MARK <= SP) {
5435         if (SvNIOK(*MARK) || !i)
5436             a[i++] = SvIV(*MARK);
5437         else if (*MARK == &PL_sv_undef)
5438             a[i++] = 0;
5439         else
5440             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5441         if (i > 15)
5442             break;
5443     }
5444     switch (items) {
5445     default:
5446         DIE(aTHX_ "Too many args to syscall");
5447     case 0:
5448         DIE(aTHX_ "Too few args to syscall");
5449     case 1:
5450         retval = syscall(a[0]);
5451         break;
5452     case 2:
5453         retval = syscall(a[0],a[1]);
5454         break;
5455     case 3:
5456         retval = syscall(a[0],a[1],a[2]);
5457         break;
5458     case 4:
5459         retval = syscall(a[0],a[1],a[2],a[3]);
5460         break;
5461     case 5:
5462         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5463         break;
5464     case 6:
5465         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5466         break;
5467     case 7:
5468         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5469         break;
5470     case 8:
5471         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5472         break;
5473 #ifdef atarist
5474     case 9:
5475         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5476         break;
5477     case 10:
5478         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5479         break;
5480     case 11:
5481         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5482           a[10]);
5483         break;
5484     case 12:
5485         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5486           a[10],a[11]);
5487         break;
5488     case 13:
5489         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5490           a[10],a[11],a[12]);
5491         break;
5492     case 14:
5493         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5494           a[10],a[11],a[12],a[13]);
5495         break;
5496 #endif /* atarist */
5497     }
5498     SP = ORIGMARK;
5499     PUSHi(retval);
5500     RETURN;
5501 #else
5502     DIE(aTHX_ PL_no_func, "syscall");
5503 #endif
5504 }
5505
5506 #ifdef FCNTL_EMULATE_FLOCK
5507
5508 /*  XXX Emulate flock() with fcntl().
5509     What's really needed is a good file locking module.
5510 */
5511
5512 static int
5513 fcntl_emulate_flock(int fd, int operation)
5514 {
5515     int res;
5516     struct flock flock;
5517
5518     switch (operation & ~LOCK_NB) {
5519     case LOCK_SH:
5520         flock.l_type = F_RDLCK;
5521         break;
5522     case LOCK_EX:
5523         flock.l_type = F_WRLCK;
5524         break;
5525     case LOCK_UN:
5526         flock.l_type = F_UNLCK;
5527         break;
5528     default:
5529         errno = EINVAL;
5530         return -1;
5531     }
5532     flock.l_whence = SEEK_SET;
5533     flock.l_start = flock.l_len = (Off_t)0;
5534
5535     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5536     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5537         errno = EWOULDBLOCK;
5538     return res;
5539 }
5540
5541 #endif /* FCNTL_EMULATE_FLOCK */
5542
5543 #ifdef LOCKF_EMULATE_FLOCK
5544
5545 /*  XXX Emulate flock() with lockf().  This is just to increase
5546     portability of scripts.  The calls are not completely
5547     interchangeable.  What's really needed is a good file
5548     locking module.
5549 */
5550
5551 /*  The lockf() constants might have been defined in <unistd.h>.
5552     Unfortunately, <unistd.h> causes troubles on some mixed
5553     (BSD/POSIX) systems, such as SunOS 4.1.3.
5554
5555    Further, the lockf() constants aren't POSIX, so they might not be
5556    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5557    just stick in the SVID values and be done with it.  Sigh.
5558 */
5559
5560 # ifndef F_ULOCK
5561 #  define F_ULOCK       0       /* Unlock a previously locked region */
5562 # endif
5563 # ifndef F_LOCK
5564 #  define F_LOCK        1       /* Lock a region for exclusive use */
5565 # endif
5566 # ifndef F_TLOCK
5567 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5568 # endif
5569 # ifndef F_TEST
5570 #  define F_TEST        3       /* Test a region for other processes locks */
5571 # endif
5572
5573 static int
5574 lockf_emulate_flock(int fd, int operation)
5575 {
5576     int i;
5577     Off_t pos;
5578     dSAVE_ERRNO;
5579
5580     /* flock locks entire file so for lockf we need to do the same      */
5581     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5582     if (pos > 0)        /* is seekable and needs to be repositioned     */
5583         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5584             pos = -1;   /* seek failed, so don't seek back afterwards   */
5585     RESTORE_ERRNO;
5586
5587     switch (operation) {
5588
5589         /* LOCK_SH - get a shared lock */
5590         case LOCK_SH:
5591         /* LOCK_EX - get an exclusive lock */
5592         case LOCK_EX:
5593             i = lockf (fd, F_LOCK, 0);
5594             break;
5595
5596         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5597         case LOCK_SH|LOCK_NB:
5598         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5599         case LOCK_EX|LOCK_NB:
5600             i = lockf (fd, F_TLOCK, 0);
5601             if (i == -1)
5602                 if ((errno == EAGAIN) || (errno == EACCES))
5603                     errno = EWOULDBLOCK;
5604             break;
5605
5606         /* LOCK_UN - unlock (non-blocking is a no-op) */
5607         case LOCK_UN:
5608         case LOCK_UN|LOCK_NB:
5609             i = lockf (fd, F_ULOCK, 0);
5610             break;
5611
5612         /* Default - can't decipher operation */
5613         default:
5614             i = -1;
5615             errno = EINVAL;
5616             break;
5617     }
5618
5619     if (pos > 0)      /* need to restore position of the handle */
5620         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5621
5622     return (i);
5623 }
5624
5625 #endif /* LOCKF_EMULATE_FLOCK */
5626
5627 /*
5628  * Local variables:
5629  * c-indentation-style: bsd
5630  * c-basic-offset: 4
5631  * indent-tabs-mode: t
5632  * End:
5633  *
5634  * ex: set ts=8 sts=4 sw=4 noet:
5635  */