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