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