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