pp_sys.c

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