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