pp_sys.c

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