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