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     char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4406     static const char * const dayname[] =
4407         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4408     static const char * const monname[] =
4409         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4410          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4411
4412     if (MAXARG < 1) {
4413         time_t now;
4414         (void)time(&now);
4415         when = (Time64_T)now;
4416     }
4417     else {
4418         /* XXX POPq uses an SvIV so it won't work with 32 bit integer scalars
4419            using a double causes an unfortunate loss of accuracy on high numbers.
4420            What we really need is an SvQV.
4421         */
4422         double input = POPn;
4423         when = (Time64_T)input;
4424         if( when != input ) {
4425             Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4426                         "%s(%.0f) too large", opname, input);
4427         }
4428     }
4429
4430     if (PL_op->op_type == OP_LOCALTIME)
4431         err = localtime64_r(&when, &tmbuf);
4432     else
4433         err = gmtime64_r(&when, &tmbuf);
4434
4435     if( err == NULL ) {
4436         /* XXX %lld broken for quads */
4437         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4438                     "%s(%.0f) failed", opname, (double)when);
4439     }
4440
4441     if (GIMME != G_ARRAY) {     /* scalar context */
4442         SV *tsv;
4443         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4444         double year = (double)tmbuf.tm_year + 1900;
4445
4446         EXTEND(SP, 1);
4447         EXTEND_MORTAL(1);
4448         if (err == NULL)
4449             RETPUSHUNDEF;
4450
4451         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4452                             dayname[tmbuf.tm_wday],
4453                             monname[tmbuf.tm_mon],
4454                             tmbuf.tm_mday,
4455                             tmbuf.tm_hour,
4456                             tmbuf.tm_min,
4457                             tmbuf.tm_sec,
4458                             year);
4459         mPUSHs(tsv);
4460     }
4461     else {                      /* list context */
4462         if ( err == NULL )
4463             RETURN;
4464
4465         EXTEND(SP, 9);
4466         EXTEND_MORTAL(9);
4467         mPUSHi(tmbuf.tm_sec);
4468         mPUSHi(tmbuf.tm_min);
4469         mPUSHi(tmbuf.tm_hour);
4470         mPUSHi(tmbuf.tm_mday);
4471         mPUSHi(tmbuf.tm_mon);
4472         mPUSHn(tmbuf.tm_year);
4473         mPUSHi(tmbuf.tm_wday);
4474         mPUSHi(tmbuf.tm_yday);
4475         mPUSHi(tmbuf.tm_isdst);
4476     }
4477     RETURN;
4478 }
4479
4480 PP(pp_alarm)
4481 {
4482 #ifdef HAS_ALARM
4483     dVAR; dSP; dTARGET;
4484     int anum;
4485     anum = POPi;
4486     anum = alarm((unsigned int)anum);
4487     EXTEND(SP, 1);
4488     if (anum < 0)
4489         RETPUSHUNDEF;
4490     PUSHi(anum);
4491     RETURN;
4492 #else
4493     DIE(aTHX_ PL_no_func, "alarm");
4494 #endif
4495 }
4496
4497 PP(pp_sleep)
4498 {
4499     dVAR; dSP; dTARGET;
4500     I32 duration;
4501     Time_t lasttime;
4502     Time_t when;
4503
4504     (void)time(&lasttime);
4505     if (MAXARG < 1)
4506         PerlProc_pause();
4507     else {
4508         duration = POPi;
4509         PerlProc_sleep((unsigned int)duration);
4510     }
4511     (void)time(&when);
4512     XPUSHi(when - lasttime);
4513     RETURN;
4514 }
4515
4516 /* Shared memory. */
4517 /* Merged with some message passing. */
4518
4519 PP(pp_shmwrite)
4520 {
4521 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4522     dVAR; dSP; dMARK; dTARGET;
4523     const int op_type = PL_op->op_type;
4524     I32 value;
4525
4526     switch (op_type) {
4527     case OP_MSGSND:
4528         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4529         break;
4530     case OP_MSGRCV:
4531         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4532         break;
4533     case OP_SEMOP:
4534         value = (I32)(do_semop(MARK, SP) >= 0);
4535         break;
4536     default:
4537         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4538         break;
4539     }
4540
4541     SP = MARK;
4542     PUSHi(value);
4543     RETURN;
4544 #else
4545     return pp_semget();
4546 #endif
4547 }
4548
4549 /* Semaphores. */
4550
4551 PP(pp_semget)
4552 {
4553 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4554     dVAR; dSP; dMARK; dTARGET;
4555     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4556     SP = MARK;
4557     if (anum == -1)
4558         RETPUSHUNDEF;
4559     PUSHi(anum);
4560     RETURN;
4561 #else
4562     DIE(aTHX_ "System V IPC is not implemented on this machine");
4563 #endif
4564 }
4565
4566 PP(pp_semctl)
4567 {
4568 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4569     dVAR; dSP; dMARK; dTARGET;
4570     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4571     SP = MARK;
4572     if (anum == -1)
4573         RETSETUNDEF;
4574     if (anum != 0) {
4575         PUSHi(anum);
4576     }
4577     else {
4578         PUSHp(zero_but_true, ZBTLEN);
4579     }
4580     RETURN;
4581 #else
4582     return pp_semget();
4583 #endif
4584 }
4585
4586 /* I can't const this further without getting warnings about the types of
4587    various arrays passed in from structures.  */
4588 static SV *
4589 S_space_join_names_mortal(pTHX_ char *const *array)
4590 {
4591     SV *target;
4592
4593     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4594
4595     if (array && *array) {
4596         target = newSVpvs_flags("", SVs_TEMP);
4597         while (1) {
4598             sv_catpv(target, *array);
4599             if (!*++array)
4600                 break;
4601             sv_catpvs(target, " ");
4602         }
4603     } else {
4604         target = sv_mortalcopy(&PL_sv_no);
4605     }
4606     return target;
4607 }
4608
4609 /* Get system info. */
4610
4611 PP(pp_ghostent)
4612 {
4613 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4614     dVAR; dSP;
4615     I32 which = PL_op->op_type;
4616     register char **elem;
4617     register SV *sv;
4618 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4619     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4620     struct hostent *gethostbyname(Netdb_name_t);
4621     struct hostent *gethostent(void);
4622 #endif
4623     struct hostent *hent;
4624     unsigned long len;
4625
4626     EXTEND(SP, 10);
4627     if (which == OP_GHBYNAME) {
4628 #ifdef HAS_GETHOSTBYNAME
4629         const char* const name = POPpbytex;
4630         hent = PerlSock_gethostbyname(name);
4631 #else
4632         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4633 #endif
4634     }
4635     else if (which == OP_GHBYADDR) {
4636 #ifdef HAS_GETHOSTBYADDR
4637         const int addrtype = POPi;
4638         SV * const addrsv = POPs;
4639         STRLEN addrlen;
4640         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4641
4642         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4643 #else
4644         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4645 #endif
4646     }
4647     else
4648 #ifdef HAS_GETHOSTENT
4649         hent = PerlSock_gethostent();
4650 #else
4651         DIE(aTHX_ PL_no_sock_func, "gethostent");
4652 #endif
4653
4654 #ifdef HOST_NOT_FOUND
4655         if (!hent) {
4656 #ifdef USE_REENTRANT_API
4657 #   ifdef USE_GETHOSTENT_ERRNO
4658             h_errno = PL_reentrant_buffer->_gethostent_errno;
4659 #   endif
4660 #endif
4661             STATUS_UNIX_SET(h_errno);
4662         }
4663 #endif
4664
4665     if (GIMME != G_ARRAY) {
4666         PUSHs(sv = sv_newmortal());
4667         if (hent) {
4668             if (which == OP_GHBYNAME) {
4669                 if (hent->h_addr)
4670                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4671             }
4672             else
4673                 sv_setpv(sv, (char*)hent->h_name);
4674         }
4675         RETURN;
4676     }
4677
4678     if (hent) {
4679         mPUSHs(newSVpv((char*)hent->h_name, 0));
4680         PUSHs(space_join_names_mortal(hent->h_aliases));
4681         mPUSHi(hent->h_addrtype);
4682         len = hent->h_length;
4683         mPUSHi(len);
4684 #ifdef h_addr
4685         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4686             mXPUSHp(*elem, len);
4687         }
4688 #else
4689         if (hent->h_addr)
4690             mPUSHp(hent->h_addr, len);
4691         else
4692             PUSHs(sv_mortalcopy(&PL_sv_no));
4693 #endif /* h_addr */
4694     }
4695     RETURN;
4696 #else
4697     DIE(aTHX_ PL_no_sock_func, "gethostent");
4698 #endif
4699 }
4700
4701 PP(pp_gnetent)
4702 {
4703 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4704     dVAR; dSP;
4705     I32 which = PL_op->op_type;
4706     register SV *sv;
4707 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4708     struct netent *getnetbyaddr(Netdb_net_t, int);
4709     struct netent *getnetbyname(Netdb_name_t);
4710     struct netent *getnetent(void);
4711 #endif
4712     struct netent *nent;
4713
4714     if (which == OP_GNBYNAME){
4715 #ifdef HAS_GETNETBYNAME
4716         const char * const name = POPpbytex;
4717         nent = PerlSock_getnetbyname(name);
4718 #else
4719         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4720 #endif
4721     }
4722     else if (which == OP_GNBYADDR) {
4723 #ifdef HAS_GETNETBYADDR
4724         const int addrtype = POPi;
4725         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4726         nent = PerlSock_getnetbyaddr(addr, addrtype);
4727 #else
4728         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4729 #endif
4730     }
4731     else
4732 #ifdef HAS_GETNETENT
4733         nent = PerlSock_getnetent();
4734 #else
4735         DIE(aTHX_ PL_no_sock_func, "getnetent");
4736 #endif
4737
4738 #ifdef HOST_NOT_FOUND
4739         if (!nent) {
4740 #ifdef USE_REENTRANT_API
4741 #   ifdef USE_GETNETENT_ERRNO
4742              h_errno = PL_reentrant_buffer->_getnetent_errno;
4743 #   endif
4744 #endif
4745             STATUS_UNIX_SET(h_errno);
4746         }
4747 #endif
4748
4749     EXTEND(SP, 4);
4750     if (GIMME != G_ARRAY) {
4751         PUSHs(sv = sv_newmortal());
4752         if (nent) {
4753             if (which == OP_GNBYNAME)
4754                 sv_setiv(sv, (IV)nent->n_net);
4755             else
4756                 sv_setpv(sv, nent->n_name);
4757         }
4758         RETURN;
4759     }
4760
4761     if (nent) {
4762         mPUSHs(newSVpv(nent->n_name, 0));
4763         PUSHs(space_join_names_mortal(nent->n_aliases));
4764         mPUSHi(nent->n_addrtype);
4765         mPUSHi(nent->n_net);
4766     }
4767
4768     RETURN;
4769 #else
4770     DIE(aTHX_ PL_no_sock_func, "getnetent");
4771 #endif
4772 }
4773
4774 PP(pp_gprotoent)
4775 {
4776 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4777     dVAR; dSP;
4778     I32 which = PL_op->op_type;
4779     register SV *sv;
4780 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4781     struct protoent *getprotobyname(Netdb_name_t);
4782     struct protoent *getprotobynumber(int);
4783     struct protoent *getprotoent(void);
4784 #endif
4785     struct protoent *pent;
4786
4787     if (which == OP_GPBYNAME) {
4788 #ifdef HAS_GETPROTOBYNAME
4789         const char* const name = POPpbytex;
4790         pent = PerlSock_getprotobyname(name);
4791 #else
4792         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4793 #endif
4794     }
4795     else if (which == OP_GPBYNUMBER) {
4796 #ifdef HAS_GETPROTOBYNUMBER
4797         const int number = POPi;
4798         pent = PerlSock_getprotobynumber(number);
4799 #else
4800         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4801 #endif
4802     }
4803     else
4804 #ifdef HAS_GETPROTOENT
4805         pent = PerlSock_getprotoent();
4806 #else
4807         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4808 #endif
4809
4810     EXTEND(SP, 3);
4811     if (GIMME != G_ARRAY) {
4812         PUSHs(sv = sv_newmortal());
4813         if (pent) {
4814             if (which == OP_GPBYNAME)
4815                 sv_setiv(sv, (IV)pent->p_proto);
4816             else
4817                 sv_setpv(sv, pent->p_name);
4818         }
4819         RETURN;
4820     }
4821
4822     if (pent) {
4823         mPUSHs(newSVpv(pent->p_name, 0));
4824         PUSHs(space_join_names_mortal(pent->p_aliases));
4825         mPUSHi(pent->p_proto);
4826     }
4827
4828     RETURN;
4829 #else
4830     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4831 #endif
4832 }
4833
4834 PP(pp_gservent)
4835 {
4836 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4837     dVAR; dSP;
4838     I32 which = PL_op->op_type;
4839     register SV *sv;
4840 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4841     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4842     struct servent *getservbyport(int, Netdb_name_t);
4843     struct servent *getservent(void);
4844 #endif
4845     struct servent *sent;
4846
4847     if (which == OP_GSBYNAME) {
4848 #ifdef HAS_GETSERVBYNAME
4849         const char * const proto = POPpbytex;
4850         const char * const name = POPpbytex;
4851         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4852 #else
4853         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4854 #endif
4855     }
4856     else if (which == OP_GSBYPORT) {
4857 #ifdef HAS_GETSERVBYPORT
4858         const char * const proto = POPpbytex;
4859         unsigned short port = (unsigned short)POPu;
4860 #ifdef HAS_HTONS
4861         port = PerlSock_htons(port);
4862 #endif
4863         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4864 #else
4865         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4866 #endif
4867     }
4868     else
4869 #ifdef HAS_GETSERVENT
4870         sent = PerlSock_getservent();
4871 #else
4872         DIE(aTHX_ PL_no_sock_func, "getservent");
4873 #endif
4874
4875     EXTEND(SP, 4);
4876     if (GIMME != G_ARRAY) {
4877         PUSHs(sv = sv_newmortal());
4878         if (sent) {
4879             if (which == OP_GSBYNAME) {
4880 #ifdef HAS_NTOHS
4881                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4882 #else
4883                 sv_setiv(sv, (IV)(sent->s_port));
4884 #endif
4885             }
4886             else
4887                 sv_setpv(sv, sent->s_name);
4888         }
4889         RETURN;
4890     }
4891
4892     if (sent) {
4893         mPUSHs(newSVpv(sent->s_name, 0));
4894         PUSHs(space_join_names_mortal(sent->s_aliases));
4895 #ifdef HAS_NTOHS
4896         mPUSHi(PerlSock_ntohs(sent->s_port));
4897 #else
4898         mPUSHi(sent->s_port);
4899 #endif
4900         mPUSHs(newSVpv(sent->s_proto, 0));
4901     }
4902
4903     RETURN;
4904 #else
4905     DIE(aTHX_ PL_no_sock_func, "getservent");
4906 #endif
4907 }
4908
4909 PP(pp_shostent)
4910 {
4911 #ifdef HAS_SETHOSTENT
4912     dVAR; dSP;
4913     PerlSock_sethostent(TOPi);
4914     RETSETYES;
4915 #else
4916     DIE(aTHX_ PL_no_sock_func, "sethostent");
4917 #endif
4918 }
4919
4920 PP(pp_snetent)
4921 {
4922 #ifdef HAS_SETNETENT
4923     dVAR; dSP;
4924     (void)PerlSock_setnetent(TOPi);
4925     RETSETYES;
4926 #else
4927     DIE(aTHX_ PL_no_sock_func, "setnetent");
4928 #endif
4929 }
4930
4931 PP(pp_sprotoent)
4932 {
4933 #ifdef HAS_SETPROTOENT
4934     dVAR; dSP;
4935     (void)PerlSock_setprotoent(TOPi);
4936     RETSETYES;
4937 #else
4938     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4939 #endif
4940 }
4941
4942 PP(pp_sservent)
4943 {
4944 #ifdef HAS_SETSERVENT
4945     dVAR; dSP;
4946     (void)PerlSock_setservent(TOPi);
4947     RETSETYES;
4948 #else
4949     DIE(aTHX_ PL_no_sock_func, "setservent");
4950 #endif
4951 }
4952
4953 PP(pp_ehostent)
4954 {
4955 #ifdef HAS_ENDHOSTENT
4956     dVAR; dSP;
4957     PerlSock_endhostent();
4958     EXTEND(SP,1);
4959     RETPUSHYES;
4960 #else
4961     DIE(aTHX_ PL_no_sock_func, "endhostent");
4962 #endif
4963 }
4964
4965 PP(pp_enetent)
4966 {
4967 #ifdef HAS_ENDNETENT
4968     dVAR; dSP;
4969     PerlSock_endnetent();
4970     EXTEND(SP,1);
4971     RETPUSHYES;
4972 #else
4973     DIE(aTHX_ PL_no_sock_func, "endnetent");
4974 #endif
4975 }
4976
4977 PP(pp_eprotoent)
4978 {
4979 #ifdef HAS_ENDPROTOENT
4980     dVAR; dSP;
4981     PerlSock_endprotoent();
4982     EXTEND(SP,1);
4983     RETPUSHYES;
4984 #else
4985     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4986 #endif
4987 }
4988
4989 PP(pp_eservent)
4990 {
4991 #ifdef HAS_ENDSERVENT
4992     dVAR; dSP;
4993     PerlSock_endservent();
4994     EXTEND(SP,1);
4995     RETPUSHYES;
4996 #else
4997     DIE(aTHX_ PL_no_sock_func, "endservent");
4998 #endif
4999 }
5000
5001 PP(pp_gpwent)
5002 {
5003 #ifdef HAS_PASSWD
5004     dVAR; dSP;
5005     I32 which = PL_op->op_type;
5006     register SV *sv;
5007     struct passwd *pwent  = NULL;
5008     /*
5009      * We currently support only the SysV getsp* shadow password interface.
5010      * The interface is declared in <shadow.h> and often one needs to link
5011      * with -lsecurity or some such.
5012      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5013      * (and SCO?)
5014      *
5015      * AIX getpwnam() is clever enough to return the encrypted password
5016      * only if the caller (euid?) is root.
5017      *
5018      * There are at least three other shadow password APIs.  Many platforms
5019      * seem to contain more than one interface for accessing the shadow
5020      * password databases, possibly for compatibility reasons.
5021      * The getsp*() is by far he simplest one, the other two interfaces
5022      * are much more complicated, but also very similar to each other.
5023      *
5024      * <sys/types.h>
5025      * <sys/security.h>
5026      * <prot.h>
5027      * struct pr_passwd *getprpw*();
5028      * The password is in
5029      * char getprpw*(...).ufld.fd_encrypt[]
5030      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5031      *
5032      * <sys/types.h>
5033      * <sys/security.h>
5034      * <prot.h>
5035      * struct es_passwd *getespw*();
5036      * The password is in
5037      * char *(getespw*(...).ufld.fd_encrypt)
5038      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5039      *
5040      * <userpw.h> (AIX)
5041      * struct userpw *getuserpw();
5042      * The password is in
5043      * char *(getuserpw(...)).spw_upw_passwd
5044      * (but the de facto standard getpwnam() should work okay)
5045      *
5046      * Mention I_PROT here so that Configure probes for it.
5047      *
5048      * In HP-UX for getprpw*() the manual page claims that one should include
5049      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5050      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5051      * and pp_sys.c already includes <shadow.h> if there is such.
5052      *
5053      * Note that <sys/security.h> is already probed for, but currently
5054      * it is only included in special cases.
5055      *
5056      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5057      * be preferred interface, even though also the getprpw*() interface
5058      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5059      * One also needs to call set_auth_parameters() in main() before
5060      * doing anything else, whether one is using getespw*() or getprpw*().
5061      *
5062      * Note that accessing the shadow databases can be magnitudes
5063      * slower than accessing the standard databases.
5064      *
5065      * --jhi
5066      */
5067
5068 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5069     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5070      * the pw_comment is left uninitialized. */
5071     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5072 #   endif
5073
5074     switch (which) {
5075     case OP_GPWNAM:
5076       {
5077         const char* const name = POPpbytex;
5078         pwent  = getpwnam(name);
5079       }
5080       break;
5081     case OP_GPWUID:
5082       {
5083         Uid_t uid = POPi;
5084         pwent = getpwuid(uid);
5085       }
5086         break;
5087     case OP_GPWENT:
5088 #   ifdef HAS_GETPWENT
5089         pwent  = getpwent();
5090 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5091         if (pwent) pwent = getpwnam(pwent->pw_name);
5092 #endif
5093 #   else
5094         DIE(aTHX_ PL_no_func, "getpwent");
5095 #   endif
5096         break;
5097     }
5098
5099     EXTEND(SP, 10);
5100     if (GIMME != G_ARRAY) {
5101         PUSHs(sv = sv_newmortal());
5102         if (pwent) {
5103             if (which == OP_GPWNAM)
5104 #   if Uid_t_sign <= 0
5105                 sv_setiv(sv, (IV)pwent->pw_uid);
5106 #   else
5107                 sv_setuv(sv, (UV)pwent->pw_uid);
5108 #   endif
5109             else
5110                 sv_setpv(sv, pwent->pw_name);
5111         }
5112         RETURN;
5113     }
5114
5115     if (pwent) {
5116         mPUSHs(newSVpv(pwent->pw_name, 0));
5117
5118         sv = newSViv(0);
5119         mPUSHs(sv);
5120         /* If we have getspnam(), we try to dig up the shadow
5121          * password.  If we are underprivileged, the shadow
5122          * interface will set the errno to EACCES or similar,
5123          * and return a null pointer.  If this happens, we will
5124          * use the dummy password (usually "*" or "x") from the
5125          * standard password database.
5126          *
5127          * In theory we could skip the shadow call completely
5128          * if euid != 0 but in practice we cannot know which
5129          * security measures are guarding the shadow databases
5130          * on a random platform.
5131          *
5132          * Resist the urge to use additional shadow interfaces.
5133          * Divert the urge to writing an extension instead.
5134          *
5135          * --jhi */
5136         /* Some AIX setups falsely(?) detect some getspnam(), which
5137          * has a different API than the Solaris/IRIX one. */
5138 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5139         {
5140             const int saverrno = errno;
5141             const struct spwd * const spwent = getspnam(pwent->pw_name);
5142                           /* Save and restore errno so that
5143                            * underprivileged attempts seem
5144                            * to have never made the unsccessful
5145                            * attempt to retrieve the shadow password. */
5146             errno = saverrno;
5147             if (spwent && spwent->sp_pwdp)
5148                 sv_setpv(sv, spwent->sp_pwdp);
5149         }
5150 #   endif
5151 #   ifdef PWPASSWD
5152         if (!SvPOK(sv)) /* Use the standard password, then. */
5153             sv_setpv(sv, pwent->pw_passwd);
5154 #   endif
5155
5156 #   ifndef INCOMPLETE_TAINTS
5157         /* passwd is tainted because user himself can diddle with it.
5158          * admittedly not much and in a very limited way, but nevertheless. */
5159         SvTAINTED_on(sv);
5160 #   endif
5161
5162 #   if Uid_t_sign <= 0
5163         mPUSHi(pwent->pw_uid);
5164 #   else
5165         mPUSHu(pwent->pw_uid);
5166 #   endif
5167
5168 #   if Uid_t_sign <= 0
5169         mPUSHi(pwent->pw_gid);
5170 #   else
5171         mPUSHu(pwent->pw_gid);
5172 #   endif
5173         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5174          * because of the poor interface of the Perl getpw*(),
5175          * not because there's some standard/convention saying so.
5176          * A better interface would have been to return a hash,
5177          * but we are accursed by our history, alas. --jhi.  */
5178 #   ifdef PWCHANGE
5179         mPUSHi(pwent->pw_change);
5180 #   else
5181 #       ifdef PWQUOTA
5182         mPUSHi(pwent->pw_quota);
5183 #       else
5184 #           ifdef PWAGE
5185         mPUSHs(newSVpv(pwent->pw_age, 0));
5186 #           else
5187         /* I think that you can never get this compiled, but just in case.  */
5188         PUSHs(sv_mortalcopy(&PL_sv_no));
5189 #           endif
5190 #       endif
5191 #   endif
5192
5193         /* pw_class and pw_comment are mutually exclusive--.
5194          * see the above note for pw_change, pw_quota, and pw_age. */
5195 #   ifdef PWCLASS
5196         mPUSHs(newSVpv(pwent->pw_class, 0));
5197 #   else
5198 #       ifdef PWCOMMENT
5199         mPUSHs(newSVpv(pwent->pw_comment, 0));
5200 #       else
5201         /* I think that you can never get this compiled, but just in case.  */
5202         PUSHs(sv_mortalcopy(&PL_sv_no));
5203 #       endif
5204 #   endif
5205
5206 #   ifdef PWGECOS
5207         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5208 #   else
5209         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5210 #   endif
5211 #   ifndef INCOMPLETE_TAINTS
5212         /* pw_gecos is tainted because user himself can diddle with it. */
5213         SvTAINTED_on(sv);
5214 #   endif
5215
5216         mPUSHs(newSVpv(pwent->pw_dir, 0));
5217
5218         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5219 #   ifndef INCOMPLETE_TAINTS
5220         /* pw_shell is tainted because user himself can diddle with it. */
5221         SvTAINTED_on(sv);
5222 #   endif
5223
5224 #   ifdef PWEXPIRE
5225         mPUSHi(pwent->pw_expire);
5226 #   endif
5227     }
5228     RETURN;
5229 #else
5230     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5231 #endif
5232 }
5233
5234 PP(pp_spwent)
5235 {
5236 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5237     dVAR; dSP;
5238     setpwent();
5239     RETPUSHYES;
5240 #else
5241     DIE(aTHX_ PL_no_func, "setpwent");
5242 #endif
5243 }
5244
5245 PP(pp_epwent)
5246 {
5247 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5248     dVAR; dSP;
5249     endpwent();
5250     RETPUSHYES;
5251 #else
5252     DIE(aTHX_ PL_no_func, "endpwent");
5253 #endif
5254 }
5255
5256 PP(pp_ggrent)
5257 {
5258 #ifdef HAS_GROUP
5259     dVAR; dSP;
5260     const I32 which = PL_op->op_type;
5261     const struct group *grent;
5262
5263     if (which == OP_GGRNAM) {
5264         const char* const name = POPpbytex;
5265         grent = (const struct group *)getgrnam(name);
5266     }
5267     else if (which == OP_GGRGID) {
5268         const Gid_t gid = POPi;
5269         grent = (const struct group *)getgrgid(gid);
5270     }
5271     else
5272 #ifdef HAS_GETGRENT
5273         grent = (struct group *)getgrent();
5274 #else
5275         DIE(aTHX_ PL_no_func, "getgrent");
5276 #endif
5277
5278     EXTEND(SP, 4);
5279     if (GIMME != G_ARRAY) {
5280         SV * const sv = sv_newmortal();
5281
5282         PUSHs(sv);
5283         if (grent) {
5284             if (which == OP_GGRNAM)
5285                 sv_setiv(sv, (IV)grent->gr_gid);
5286             else
5287                 sv_setpv(sv, grent->gr_name);
5288         }
5289         RETURN;
5290     }
5291
5292     if (grent) {
5293         mPUSHs(newSVpv(grent->gr_name, 0));
5294
5295 #ifdef GRPASSWD
5296         mPUSHs(newSVpv(grent->gr_passwd, 0));
5297 #else
5298         PUSHs(sv_mortalcopy(&PL_sv_no));
5299 #endif
5300
5301         mPUSHi(grent->gr_gid);
5302
5303 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5304         /* In UNICOS/mk (_CRAYMPP) the multithreading
5305          * versions (getgrnam_r, getgrgid_r)
5306          * seem to return an illegal pointer
5307          * as the group members list, gr_mem.
5308          * getgrent() doesn't even have a _r version
5309          * but the gr_mem is poisonous anyway.
5310          * So yes, you cannot get the list of group
5311          * members if building multithreaded in UNICOS/mk. */
5312         PUSHs(space_join_names_mortal(grent->gr_mem));
5313 #endif
5314     }
5315
5316     RETURN;
5317 #else
5318     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5319 #endif
5320 }
5321
5322 PP(pp_sgrent)
5323 {
5324 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5325     dVAR; dSP;
5326     setgrent();
5327     RETPUSHYES;
5328 #else
5329     DIE(aTHX_ PL_no_func, "setgrent");
5330 #endif
5331 }
5332
5333 PP(pp_egrent)
5334 {
5335 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5336     dVAR; dSP;
5337     endgrent();
5338     RETPUSHYES;
5339 #else
5340     DIE(aTHX_ PL_no_func, "endgrent");
5341 #endif
5342 }
5343
5344 PP(pp_getlogin)
5345 {
5346 #ifdef HAS_GETLOGIN
5347     dVAR; dSP; dTARGET;
5348     char *tmps;
5349     EXTEND(SP, 1);
5350     if (!(tmps = PerlProc_getlogin()))
5351         RETPUSHUNDEF;
5352     PUSHp(tmps, strlen(tmps));
5353     RETURN;
5354 #else
5355     DIE(aTHX_ PL_no_func, "getlogin");
5356 #endif
5357 }
5358
5359 /* Miscellaneous. */
5360
5361 PP(pp_syscall)
5362 {
5363 #ifdef HAS_SYSCALL
5364     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5365     register I32 items = SP - MARK;
5366     unsigned long a[20];
5367     register I32 i = 0;
5368     I32 retval = -1;
5369
5370     if (PL_tainting) {
5371         while (++MARK <= SP) {
5372             if (SvTAINTED(*MARK)) {
5373                 TAINT;
5374                 break;
5375             }
5376         }
5377         MARK = ORIGMARK;
5378         TAINT_PROPER("syscall");
5379     }
5380
5381     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5382      * or where sizeof(long) != sizeof(char*).  But such machines will
5383      * not likely have syscall implemented either, so who cares?
5384      */
5385     while (++MARK <= SP) {
5386         if (SvNIOK(*MARK) || !i)
5387             a[i++] = SvIV(*MARK);
5388         else if (*MARK == &PL_sv_undef)
5389             a[i++] = 0;
5390         else
5391             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5392         if (i > 15)
5393             break;
5394     }
5395     switch (items) {
5396     default:
5397         DIE(aTHX_ "Too many args to syscall");
5398     case 0:
5399         DIE(aTHX_ "Too few args to syscall");
5400     case 1:
5401         retval = syscall(a[0]);
5402         break;
5403     case 2:
5404         retval = syscall(a[0],a[1]);
5405         break;
5406     case 3:
5407         retval = syscall(a[0],a[1],a[2]);
5408         break;
5409     case 4:
5410         retval = syscall(a[0],a[1],a[2],a[3]);
5411         break;
5412     case 5:
5413         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5414         break;
5415     case 6:
5416         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5417         break;
5418     case 7:
5419         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5420         break;
5421     case 8:
5422         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5423         break;
5424 #ifdef atarist
5425     case 9:
5426         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5427         break;
5428     case 10:
5429         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5430         break;
5431     case 11:
5432         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5433           a[10]);
5434         break;
5435     case 12:
5436         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5437           a[10],a[11]);
5438         break;
5439     case 13:
5440         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5441           a[10],a[11],a[12]);
5442         break;
5443     case 14:
5444         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5445           a[10],a[11],a[12],a[13]);
5446         break;
5447 #endif /* atarist */
5448     }
5449     SP = ORIGMARK;
5450     PUSHi(retval);
5451     RETURN;
5452 #else
5453     DIE(aTHX_ PL_no_func, "syscall");
5454 #endif
5455 }
5456
5457 #ifdef FCNTL_EMULATE_FLOCK
5458
5459 /*  XXX Emulate flock() with fcntl().
5460     What's really needed is a good file locking module.
5461 */
5462
5463 static int
5464 fcntl_emulate_flock(int fd, int operation)
5465 {
5466     struct flock flock;
5467
5468     switch (operation & ~LOCK_NB) {
5469     case LOCK_SH:
5470         flock.l_type = F_RDLCK;
5471         break;
5472     case LOCK_EX:
5473         flock.l_type = F_WRLCK;
5474         break;
5475     case LOCK_UN:
5476         flock.l_type = F_UNLCK;
5477         break;
5478     default:
5479         errno = EINVAL;
5480         return -1;
5481     }
5482     flock.l_whence = SEEK_SET;
5483     flock.l_start = flock.l_len = (Off_t)0;
5484
5485     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5486 }
5487
5488 #endif /* FCNTL_EMULATE_FLOCK */
5489
5490 #ifdef LOCKF_EMULATE_FLOCK
5491
5492 /*  XXX Emulate flock() with lockf().  This is just to increase
5493     portability of scripts.  The calls are not completely
5494     interchangeable.  What's really needed is a good file
5495     locking module.
5496 */
5497
5498 /*  The lockf() constants might have been defined in <unistd.h>.
5499     Unfortunately, <unistd.h> causes troubles on some mixed
5500     (BSD/POSIX) systems, such as SunOS 4.1.3.
5501
5502    Further, the lockf() constants aren't POSIX, so they might not be
5503    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5504    just stick in the SVID values and be done with it.  Sigh.
5505 */
5506
5507 # ifndef F_ULOCK
5508 #  define F_ULOCK       0       /* Unlock a previously locked region */
5509 # endif
5510 # ifndef F_LOCK
5511 #  define F_LOCK        1       /* Lock a region for exclusive use */
5512 # endif
5513 # ifndef F_TLOCK
5514 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5515 # endif
5516 # ifndef F_TEST
5517 #  define F_TEST        3       /* Test a region for other processes locks */
5518 # endif
5519
5520 static int
5521 lockf_emulate_flock(int fd, int operation)
5522 {
5523     int i;
5524     const int save_errno = errno;
5525     Off_t pos;
5526
5527     /* flock locks entire file so for lockf we need to do the same      */
5528     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5529     if (pos > 0)        /* is seekable and needs to be repositioned     */
5530         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5531             pos = -1;   /* seek failed, so don't seek back afterwards   */
5532     errno = save_errno;
5533
5534     switch (operation) {
5535
5536         /* LOCK_SH - get a shared lock */
5537         case LOCK_SH:
5538         /* LOCK_EX - get an exclusive lock */
5539         case LOCK_EX:
5540             i = lockf (fd, F_LOCK, 0);
5541             break;
5542
5543         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5544         case LOCK_SH|LOCK_NB:
5545         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5546         case LOCK_EX|LOCK_NB:
5547             i = lockf (fd, F_TLOCK, 0);
5548             if (i == -1)
5549                 if ((errno == EAGAIN) || (errno == EACCES))
5550                     errno = EWOULDBLOCK;
5551             break;
5552
5553         /* LOCK_UN - unlock (non-blocking is a no-op) */
5554         case LOCK_UN:
5555         case LOCK_UN|LOCK_NB:
5556             i = lockf (fd, F_ULOCK, 0);
5557             break;
5558
5559         /* Default - can't decipher operation */
5560         default:
5561             i = -1;
5562             errno = EINVAL;
5563             break;
5564     }
5565
5566     if (pos > 0)      /* need to restore position of the handle */
5567         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5568
5569     return (i);
5570 }
5571
5572 #endif /* LOCKF_EMULATE_FLOCK */
5573
5574 /*
5575  * Local variables:
5576  * c-indentation-style: bsd
5577  * c-basic-offset: 4
5578  * indent-tabs-mode: t
5579  * End:
5580  *
5581  * ex: set ts=8 sts=4 sw=4 noet:
5582  */