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