pp_sys.c

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