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