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