pp_sys.c

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