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