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