pp_sys.c

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