pp_sys.c

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