pp_sys.c

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