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