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