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                 XPUSHs(sv_2mortal(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 = sv_2mortal(newSVpvs("\000"));
 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 = sv_2mortal(newSVpvs("Warning: something's wrong"));
 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 = sv_2mortal(newSVpvs("Died"));
 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                XPUSHs(sv_2mortal(newSViv(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 = sv_2mortal(newSVpvs("AnyDBM_File"));
 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         PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
 957     else
 958         PUSHs(sv_2mortal(newSVuv(O_RDWR)));
 959     PUSHs(right);
 960     PUTBACK;
 961     call_sv((SV*)GvCV(gv), G_SCALAR);
 962     SPAGAIN;
 963
 964     if (!sv_isobject(TOPs)) {
 965         SP--;
 966         PUSHMARK(SP);
 967         PUSHs(sv);
 968         PUSHs(left);
 969         PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
 970         PUSHs(right);
 971         PUTBACK;
 972         call_sv((SV*)GvCV(gv), G_SCALAR);
 973         SPAGAIN;
 974     }
 975
 976     if (sv_isobject(TOPs)) {
 977         sv_unmagic((SV *) hv, PERL_MAGIC_tied);
 978         sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
 979     }
 980     LEAVE;
 981     RETURN;
 982 }
 983
 984 PP(pp_sselect)
 985 {
 986 #ifdef HAS_SELECT
 987     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         PUSHs(sv_2mortal(newSVnv(value)));
1141     }
1142     RETURN;
1143 #else
1144     DIE(aTHX_ "select not implemented");
1145 #endif
1146 }
1147
1148 void
1149 Perl_setdefout(pTHX_ GV *gv)
1150 {
1151     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             XPUSHs(sv_2mortal(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             XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2104 #else
2105             XPUSHs(sv_2mortal(newSViv(offset)));
2106 #endif
2107             XPUSHs(sv_2mortal(newSViv(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             PUSHs(sv_2mortal(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         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2877         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2878         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2879         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2880 #if Uid_t_size > IVSIZE
2881         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2882 #else
2883 #   if Uid_t_sign <= 0
2884         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2885 #   else
2886         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2887 #   endif
2888 #endif
2889 #if Gid_t_size > IVSIZE
2890         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2891 #else
2892 #   if Gid_t_sign <= 0
2893         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2894 #   else
2895         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2896 #   endif
2897 #endif
2898 #ifdef USE_STAT_RDEV
2899         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2900 #else
2901         PUSHs(sv_2mortal(newSVpvs("")));
2902 #endif
2903 #if Off_t_size > IVSIZE
2904         PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2905 #else
2906         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2907 #endif
2908 #ifdef BIG_TIME
2909         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2910         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2911         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2912 #else
2913         PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2914         PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2915         PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
2916 #endif
2917 #ifdef USE_STAT_BLOCKS
2918         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2919         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2920 #else
2921         PUSHs(sv_2mortal(newSVpvs("")));
2922         PUSHs(sv_2mortal(newSVpvs("")));
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
3003     case OP_FTEEXEC:
3004 #ifdef PERL_EFF_ACCESS
3005         access_mode = W_OK;
3006 #else
3007         use_access = 0;
3008 #endif
3009         stat_mode = S_IXUSR;
3010         effective = TRUE;
3011         break;
3012     }
3013
3014     if (use_access) {
3015 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3016         const char *name = POPpx;
3017         if (effective) {
3018 #  ifdef PERL_EFF_ACCESS
3019             result = PERL_EFF_ACCESS(name, access_mode);
3020 #  else
3021             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3022                 OP_NAME(PL_op));
3023 #  endif
3024         }
3025         else {
3026 #  ifdef HAS_ACCESS
3027             result = access(name, access_mode);
3028 #  else
3029             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3030 #  endif
3031         }
3032         if (result == 0)
3033             RETPUSHYES;
3034         if (result < 0)
3035             RETPUSHUNDEF;
3036         RETPUSHNO;
3037 #endif
3038     }
3039
3040     result = my_stat();
3041     SPAGAIN;
3042     if (result < 0)
3043         RETPUSHUNDEF;
3044     if (cando(stat_mode, effective, &PL_statcache))
3045         RETPUSHYES;
3046     RETPUSHNO;
3047 }
3048
3049 PP(pp_ftis)
3050 {
3051     dVAR;
3052     I32 result;
3053     const int op_type = PL_op->op_type;
3054     dSP;
3055     STACKED_FTEST_CHECK;
3056     result = my_stat();
3057     SPAGAIN;
3058     if (result < 0)
3059         RETPUSHUNDEF;
3060     if (op_type == OP_FTIS)
3061         RETPUSHYES;
3062     {
3063         /* You can't dTARGET inside OP_FTIS, because you'll get
3064            "panic: pad_sv po" - the op is not flagged to have a target.  */
3065         dTARGET;
3066         switch (op_type) {
3067         case OP_FTSIZE:
3068 #if Off_t_size > IVSIZE
3069             PUSHn(PL_statcache.st_size);
3070 #else
3071             PUSHi(PL_statcache.st_size);
3072 #endif
3073             break;
3074         case OP_FTMTIME:
3075             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3076             break;
3077         case OP_FTATIME:
3078             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3079             break;
3080         case OP_FTCTIME:
3081             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3082             break;
3083         }
3084     }
3085     RETURN;
3086 }
3087
3088 PP(pp_ftrowned)
3089 {
3090     dVAR;
3091     I32 result;
3092     dSP;
3093
3094     /* I believe that all these three are likely to be defined on most every
3095        system these days.  */
3096 #ifndef S_ISUID
3097     if(PL_op->op_type == OP_FTSUID)
3098         RETPUSHNO;
3099 #endif
3100 #ifndef S_ISGID
3101     if(PL_op->op_type == OP_FTSGID)
3102         RETPUSHNO;
3103 #endif
3104 #ifndef S_ISVTX
3105     if(PL_op->op_type == OP_FTSVTX)
3106         RETPUSHNO;
3107 #endif
3108
3109     STACKED_FTEST_CHECK;
3110     result = my_stat();
3111     SPAGAIN;
3112     if (result < 0)
3113         RETPUSHUNDEF;
3114     switch (PL_op->op_type) {
3115     case OP_FTROWNED:
3116         if (PL_statcache.st_uid == PL_uid)
3117             RETPUSHYES;
3118         break;
3119     case OP_FTEOWNED:
3120         if (PL_statcache.st_uid == PL_euid)
3121             RETPUSHYES;
3122         break;
3123     case OP_FTZERO:
3124         if (PL_statcache.st_size == 0)
3125             RETPUSHYES;
3126         break;
3127     case OP_FTSOCK:
3128         if (S_ISSOCK(PL_statcache.st_mode))
3129             RETPUSHYES;
3130         break;
3131     case OP_FTCHR:
3132         if (S_ISCHR(PL_statcache.st_mode))
3133             RETPUSHYES;
3134         break;
3135     case OP_FTBLK:
3136         if (S_ISBLK(PL_statcache.st_mode))
3137             RETPUSHYES;
3138         break;
3139     case OP_FTFILE:
3140         if (S_ISREG(PL_statcache.st_mode))
3141             RETPUSHYES;
3142         break;
3143     case OP_FTDIR:
3144         if (S_ISDIR(PL_statcache.st_mode))
3145             RETPUSHYES;
3146         break;
3147     case OP_FTPIPE:
3148         if (S_ISFIFO(PL_statcache.st_mode))
3149             RETPUSHYES;
3150         break;
3151 #ifdef S_ISUID
3152     case OP_FTSUID:
3153         if (PL_statcache.st_mode & S_ISUID)
3154             RETPUSHYES;
3155         break;
3156 #endif
3157 #ifdef S_ISGID
3158     case OP_FTSGID:
3159         if (PL_statcache.st_mode & S_ISGID)
3160             RETPUSHYES;
3161         break;
3162 #endif
3163 #ifdef S_ISVTX
3164     case OP_FTSVTX:
3165         if (PL_statcache.st_mode & S_ISVTX)
3166             RETPUSHYES;
3167         break;
3168 #endif
3169     }
3170     RETPUSHNO;
3171 }
3172
3173 PP(pp_ftlink)
3174 {
3175     dVAR;
3176     I32 result = my_lstat();
3177     dSP;
3178     if (result < 0)
3179         RETPUSHUNDEF;
3180     if (S_ISLNK(PL_statcache.st_mode))
3181         RETPUSHYES;
3182     RETPUSHNO;
3183 }
3184
3185 PP(pp_fttty)
3186 {
3187     dVAR;
3188     dSP;
3189     int fd;
3190     GV *gv;
3191     SV *tmpsv = NULL;
3192
3193     STACKED_FTEST_CHECK;
3194
3195     if (PL_op->op_flags & OPf_REF)
3196         gv = cGVOP_gv;
3197     else if (isGV(TOPs))
3198         gv = (GV*)POPs;
3199     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3200         gv = (GV*)SvRV(POPs);
3201     else
3202         gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3203
3204     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3205         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3206     else if (tmpsv && SvOK(tmpsv)) {
3207         const char *tmps = SvPV_nolen_const(tmpsv);
3208         if (isDIGIT(*tmps))
3209             fd = atoi(tmps);
3210         else
3211             RETPUSHUNDEF;
3212     }
3213     else
3214         RETPUSHUNDEF;
3215     if (PerlLIO_isatty(fd))
3216         RETPUSHYES;
3217     RETPUSHNO;
3218 }
3219
3220 #if defined(atarist) /* this will work with atariST. Configure will
3221                         make guesses for other systems. */
3222 # define FILE_base(f) ((f)->_base)
3223 # define FILE_ptr(f) ((f)->_ptr)
3224 # define FILE_cnt(f) ((f)->_cnt)
3225 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3226 #endif
3227
3228 PP(pp_fttext)
3229 {
3230     dVAR;
3231     dSP;
3232     I32 i;
3233     I32 len;
3234     I32 odd = 0;
3235     STDCHAR tbuf[512];
3236     register STDCHAR *s;
3237     register IO *io;
3238     register SV *sv;
3239     GV *gv;
3240     PerlIO *fp;
3241
3242     STACKED_FTEST_CHECK;
3243
3244     if (PL_op->op_flags & OPf_REF)
3245         gv = cGVOP_gv;
3246     else if (isGV(TOPs))
3247         gv = (GV*)POPs;
3248     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3249         gv = (GV*)SvRV(POPs);
3250     else
3251         gv = NULL;
3252
3253     if (gv) {
3254         EXTEND(SP, 1);
3255         if (gv == PL_defgv) {
3256             if (PL_statgv)
3257                 io = GvIO(PL_statgv);
3258             else {
3259                 sv = PL_statname;
3260                 goto really_filename;
3261             }
3262         }
3263         else {
3264             PL_statgv = gv;
3265             PL_laststatval = -1;
3266             sv_setpvn(PL_statname, "", 0);
3267             io = GvIO(PL_statgv);
3268         }
3269         if (io && IoIFP(io)) {
3270             if (! PerlIO_has_base(IoIFP(io)))
3271                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3272             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3273             if (PL_laststatval < 0)
3274                 RETPUSHUNDEF;
3275             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3276                 if (PL_op->op_type == OP_FTTEXT)
3277                     RETPUSHNO;
3278                 else
3279                     RETPUSHYES;
3280             }
3281             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3282                 i = PerlIO_getc(IoIFP(io));
3283                 if (i != EOF)
3284                     (void)PerlIO_ungetc(IoIFP(io),i);
3285             }
3286             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3287                 RETPUSHYES;
3288             len = PerlIO_get_bufsiz(IoIFP(io));
3289             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3290             /* sfio can have large buffers - limit to 512 */
3291             if (len > 512)
3292                 len = 512;
3293         }
3294         else {
3295             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3296                 gv = cGVOP_gv;
3297                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3298             }
3299             SETERRNO(EBADF,RMS_IFI);
3300             RETPUSHUNDEF;
3301         }
3302     }
3303     else {
3304         sv = POPs;
3305       really_filename:
3306         PL_statgv = NULL;
3307         PL_laststype = OP_STAT;
3308         sv_setpv(PL_statname, SvPV_nolen_const(sv));
3309         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3310             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3311                                                '\n'))
3312                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3313             RETPUSHUNDEF;
3314         }
3315         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3316         if (PL_laststatval < 0) {
3317             (void)PerlIO_close(fp);
3318             RETPUSHUNDEF;
3319         }
3320         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3321         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3322         (void)PerlIO_close(fp);
3323         if (len <= 0) {
3324             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3325                 RETPUSHNO;              /* special case NFS directories */
3326             RETPUSHYES;         /* null file is anything */
3327         }
3328         s = tbuf;
3329     }
3330
3331     /* now scan s to look for textiness */
3332     /*   XXX ASCII dependent code */
3333
3334 #if defined(DOSISH) || defined(USEMYBINMODE)
3335     /* ignore trailing ^Z on short files */
3336     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3337         --len;
3338 #endif
3339
3340     for (i = 0; i < len; i++, s++) {
3341         if (!*s) {                      /* null never allowed in text */
3342             odd += len;
3343             break;
3344         }
3345 #ifdef EBCDIC
3346         else if (!(isPRINT(*s) || isSPACE(*s)))
3347             odd++;
3348 #else
3349         else if (*s & 128) {
3350 #ifdef USE_LOCALE
3351             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3352                 continue;
3353 #endif
3354             /* utf8 characters don't count as odd */
3355             if (UTF8_IS_START(*s)) {
3356                 int ulen = UTF8SKIP(s);
3357                 if (ulen < len - i) {
3358                     int j;
3359                     for (j = 1; j < ulen; j++) {
3360                         if (!UTF8_IS_CONTINUATION(s[j]))
3361                             goto not_utf8;
3362                     }
3363                     --ulen;     /* loop does extra increment */
3364                     s += ulen;
3365                     i += ulen;
3366                     continue;
3367                 }
3368             }
3369           not_utf8:
3370             odd++;
3371         }
3372         else if (*s < 32 &&
3373           *s != '\n' && *s != '\r' && *s != '\b' &&
3374           *s != '\t' && *s != '\f' && *s != 27)
3375             odd++;
3376 #endif
3377     }
3378
3379     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3380         RETPUSHNO;
3381     else
3382         RETPUSHYES;
3383 }
3384
3385 /* File calls. */
3386
3387 PP(pp_chdir)
3388 {
3389     dVAR; dSP; dTARGET;
3390     const char *tmps = NULL;
3391     GV *gv = NULL;
3392
3393     if( MAXARG == 1 ) {
3394         SV * const sv = POPs;
3395         if (PL_op->op_flags & OPf_SPECIAL) {
3396             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3397         }
3398         else if (SvTYPE(sv) == SVt_PVGV) {
3399             gv = (GV*)sv;
3400         }
3401         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3402             gv = (GV*)SvRV(sv);
3403         }
3404         else {
3405             tmps = SvPV_nolen_const(sv);
3406         }
3407     }
3408
3409     if( !gv && (!tmps || !*tmps) ) {
3410         HV * const table = GvHVn(PL_envgv);
3411         SV **svp;
3412
3413         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3414              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3415 #ifdef VMS
3416              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3417 #endif
3418            )
3419         {
3420             if( MAXARG == 1 )
3421                 deprecate("chdir('') or chdir(undef) as chdir()");
3422             tmps = SvPV_nolen_const(*svp);
3423         }
3424         else {
3425             PUSHi(0);
3426             TAINT_PROPER("chdir");
3427             RETURN;
3428         }
3429     }
3430
3431     TAINT_PROPER("chdir");
3432     if (gv) {
3433 #ifdef HAS_FCHDIR
3434         IO* const io = GvIO(gv);
3435         if (io) {
3436             if (IoDIRP(io)) {
3437                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3438             } else if (IoIFP(io)) {
3439                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3440             }
3441             else {
3442                 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3443                     report_evil_fh(gv, io, PL_op->op_type);
3444                 SETERRNO(EBADF, RMS_IFI);
3445                 PUSHi(0);
3446             }
3447         }
3448         else {
3449             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3450                 report_evil_fh(gv, io, PL_op->op_type);
3451             SETERRNO(EBADF,RMS_IFI);
3452             PUSHi(0);
3453         }
3454 #else
3455         DIE(aTHX_ PL_no_func, "fchdir");
3456 #endif
3457     }
3458     else
3459         PUSHi( PerlDir_chdir(tmps) >= 0 );
3460 #ifdef VMS
3461     /* Clear the DEFAULT element of ENV so we'll get the new value
3462      * in the future. */
3463     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3464 #endif
3465     RETURN;
3466 }
3467
3468 PP(pp_chown)
3469 {
3470     dVAR; dSP; dMARK; dTARGET;
3471     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3472
3473     SP = MARK;
3474     XPUSHi(value);
3475     RETURN;
3476 }
3477
3478 PP(pp_chroot)
3479 {
3480 #ifdef HAS_CHROOT
3481     dVAR; dSP; dTARGET;
3482     char * const tmps = POPpx;
3483     TAINT_PROPER("chroot");
3484     PUSHi( chroot(tmps) >= 0 );
3485     RETURN;
3486 #else
3487     DIE(aTHX_ PL_no_func, "chroot");
3488 #endif
3489 }
3490
3491 PP(pp_rename)
3492 {
3493     dVAR; dSP; dTARGET;
3494     int anum;
3495     const char * const tmps2 = POPpconstx;
3496     const char * const tmps = SvPV_nolen_const(TOPs);
3497     TAINT_PROPER("rename");
3498 #ifdef HAS_RENAME
3499     anum = PerlLIO_rename(tmps, tmps2);
3500 #else
3501     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3502         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3503             anum = 1;
3504         else {
3505             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3506                 (void)UNLINK(tmps2);
3507             if (!(anum = link(tmps, tmps2)))
3508                 anum = UNLINK(tmps);
3509         }
3510     }
3511 #endif
3512     SETi( anum >= 0 );
3513     RETURN;
3514 }
3515
3516 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3517 PP(pp_link)
3518 {
3519     dVAR; dSP; dTARGET;
3520     const int op_type = PL_op->op_type;
3521     int result;
3522
3523 #  ifndef HAS_LINK
3524     if (op_type == OP_LINK)
3525         DIE(aTHX_ PL_no_func, "link");
3526 #  endif
3527 #  ifndef HAS_SYMLINK
3528     if (op_type == OP_SYMLINK)
3529         DIE(aTHX_ PL_no_func, "symlink");
3530 #  endif
3531
3532     {
3533         const char * const tmps2 = POPpconstx;
3534         const char * const tmps = SvPV_nolen_const(TOPs);
3535         TAINT_PROPER(PL_op_desc[op_type]);
3536         result =
3537 #  if defined(HAS_LINK)
3538 #    if defined(HAS_SYMLINK)
3539             /* Both present - need to choose which.  */
3540             (op_type == OP_LINK) ?
3541             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3542 #    else
3543     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3544         PerlLIO_link(tmps, tmps2);
3545 #    endif
3546 #  else
3547 #    if defined(HAS_SYMLINK)
3548     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3549         symlink(tmps, tmps2);
3550 #    endif
3551 #  endif
3552     }
3553
3554     SETi( result >= 0 );
3555     RETURN;
3556 }
3557 #else
3558 PP(pp_link)
3559 {
3560     /* Have neither.  */
3561     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3562 }
3563 #endif
3564
3565 PP(pp_readlink)
3566 {
3567     dVAR;
3568     dSP;
3569 #ifdef HAS_SYMLINK
3570     dTARGET;
3571     const char *tmps;
3572     char buf[MAXPATHLEN];
3573     int len;
3574
3575 #ifndef INCOMPLETE_TAINTS
3576     TAINT;
3577 #endif
3578     tmps = POPpconstx;
3579     len = readlink(tmps, buf, sizeof(buf) - 1);
3580     EXTEND(SP, 1);
3581     if (len < 0)
3582         RETPUSHUNDEF;
3583     PUSHp(buf, len);
3584     RETURN;
3585 #else
3586     EXTEND(SP, 1);
3587     RETSETUNDEF;                /* just pretend it's a normal file */
3588 #endif
3589 }
3590
3591 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3592 STATIC int
3593 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3594 {
3595     char * const save_filename = filename;
3596     char *cmdline;
3597     char *s;
3598     PerlIO *myfp;
3599     int anum = 1;
3600     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3601
3602     Newx(cmdline, size, char);
3603     my_strlcpy(cmdline, cmd, size);
3604     my_strlcat(cmdline, " ", size);
3605     for (s = cmdline + strlen(cmdline); *filename; ) {
3606         *s++ = '\\';
3607         *s++ = *filename++;
3608     }
3609     if (s - cmdline < size)
3610         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3611     myfp = PerlProc_popen(cmdline, "r");
3612     Safefree(cmdline);
3613
3614     if (myfp) {
3615         SV * const tmpsv = sv_newmortal();
3616         /* Need to save/restore 'PL_rs' ?? */
3617         s = sv_gets(tmpsv, myfp, 0);
3618         (void)PerlProc_pclose(myfp);
3619         if (s != NULL) {
3620             int e;
3621             for (e = 1;
3622 #ifdef HAS_SYS_ERRLIST
3623                  e <= sys_nerr
3624 #endif
3625                  ; e++)
3626             {
3627                 /* you don't see this */
3628                 const char * const errmsg =
3629 #ifdef HAS_SYS_ERRLIST
3630                     sys_errlist[e]
3631 #else
3632                     strerror(e)
3633 #endif
3634                     ;
3635                 if (!errmsg)
3636                     break;
3637                 if (instr(s, errmsg)) {
3638                     SETERRNO(e,0);
3639                     return 0;
3640                 }
3641             }
3642             SETERRNO(0,0);
3643 #ifndef EACCES
3644 #define EACCES EPERM
3645 #endif
3646             if (instr(s, "cannot make"))
3647                 SETERRNO(EEXIST,RMS_FEX);
3648             else if (instr(s, "existing file"))
3649                 SETERRNO(EEXIST,RMS_FEX);
3650             else if (instr(s, "ile exists"))
3651                 SETERRNO(EEXIST,RMS_FEX);
3652             else if (instr(s, "non-exist"))
3653                 SETERRNO(ENOENT,RMS_FNF);
3654             else if (instr(s, "does not exist"))
3655                 SETERRNO(ENOENT,RMS_FNF);
3656             else if (instr(s, "not empty"))
3657                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3658             else if (instr(s, "cannot access"))
3659                 SETERRNO(EACCES,RMS_PRV);
3660             else
3661                 SETERRNO(EPERM,RMS_PRV);
3662             return 0;
3663         }
3664         else {  /* some mkdirs return no failure indication */
3665             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3666             if (PL_op->op_type == OP_RMDIR)
3667                 anum = !anum;
3668             if (anum)
3669                 SETERRNO(0,0);
3670             else
3671                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3672         }
3673         return anum;
3674     }
3675     else
3676         return 0;
3677 }
3678 #endif
3679
3680 /* This macro removes trailing slashes from a directory name.
3681  * Different operating and file systems take differently to
3682  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3683  * any number of trailing slashes should be allowed.
3684  * Thusly we snip them away so that even non-conforming
3685  * systems are happy.
3686  * We should probably do this "filtering" for all
3687  * the functions that expect (potentially) directory names:
3688  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3689  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3690
3691 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3692     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3693         do { \
3694             (len)--; \
3695         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3696         (tmps) = savepvn((tmps), (len)); \
3697         (copy) = TRUE; \
3698     }
3699
3700 PP(pp_mkdir)
3701 {
3702     dVAR; dSP; dTARGET;
3703     STRLEN len;
3704     const char *tmps;
3705     bool copy = FALSE;
3706     const int mode = (MAXARG > 1) ? POPi : 0777;
3707
3708     TRIMSLASHES(tmps,len,copy);
3709
3710     TAINT_PROPER("mkdir");
3711 #ifdef HAS_MKDIR
3712     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3713 #else
3714     {
3715     int oldumask;
3716     SETi( dooneliner("mkdir", tmps) );
3717     oldumask = PerlLIO_umask(0);
3718     PerlLIO_umask(oldumask);
3719     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3720     }
3721 #endif
3722     if (copy)
3723         Safefree(tmps);
3724     RETURN;
3725 }
3726
3727 PP(pp_rmdir)
3728 {
3729     dVAR; dSP; dTARGET;
3730     STRLEN len;
3731     const char *tmps;
3732     bool copy = FALSE;
3733
3734     TRIMSLASHES(tmps,len,copy);
3735     TAINT_PROPER("rmdir");
3736 #ifdef HAS_RMDIR
3737     SETi( PerlDir_rmdir(tmps) >= 0 );
3738 #else
3739     SETi( dooneliner("rmdir", tmps) );
3740 #endif
3741     if (copy)
3742         Safefree(tmps);
3743     RETURN;
3744 }
3745
3746 /* Directory calls. */
3747
3748 PP(pp_open_dir)
3749 {
3750 #if defined(Direntry_t) && defined(HAS_READDIR)
3751     dVAR; dSP;
3752     const char * const dirname = POPpconstx;
3753     GV * const gv = (GV*)POPs;
3754     register IO * const io = GvIOn(gv);
3755
3756     if (!io)
3757         goto nope;
3758
3759     if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3760         Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3761                 "Opening filehandle %s also as a directory", GvENAME(gv));
3762     if (IoDIRP(io))
3763         PerlDir_close(IoDIRP(io));
3764     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3765         goto nope;
3766
3767     RETPUSHYES;
3768 nope:
3769     if (!errno)
3770         SETERRNO(EBADF,RMS_DIR);
3771     RETPUSHUNDEF;
3772 #else
3773     DIE(aTHX_ PL_no_dir_func, "opendir");
3774 #endif
3775 }
3776
3777 PP(pp_readdir)
3778 {
3779 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3780     DIE(aTHX_ PL_no_dir_func, "readdir");
3781 #else
3782 #if !defined(I_DIRENT) && !defined(VMS)
3783     Direntry_t *readdir (DIR *);
3784 #endif
3785     dVAR;
3786     dSP;
3787
3788     SV *sv;
3789     const I32 gimme = GIMME;
3790     GV * const gv = (GV *)POPs;
3791     register const Direntry_t *dp;
3792     register IO * const io = GvIOn(gv);
3793
3794     if (!io || !IoDIRP(io)) {
3795         if(ckWARN(WARN_IO)) {
3796             Perl_warner(aTHX_ packWARN(WARN_IO),
3797                 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3798         }
3799         goto nope;
3800     }
3801
3802     do {
3803         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3804         if (!dp)
3805             break;
3806 #ifdef DIRNAMLEN
3807         sv = newSVpvn(dp->d_name, dp->d_namlen);
3808 #else
3809         sv = newSVpv(dp->d_name, 0);
3810 #endif
3811 #ifndef INCOMPLETE_TAINTS
3812         if (!(IoFLAGS(io) & IOf_UNTAINT))
3813             SvTAINTED_on(sv);
3814 #endif
3815         XPUSHs(sv_2mortal(sv));
3816     } while (gimme == G_ARRAY);
3817
3818     if (!dp && gimme != G_ARRAY)
3819         goto nope;
3820
3821     RETURN;
3822
3823 nope:
3824     if (!errno)
3825         SETERRNO(EBADF,RMS_ISI);
3826     if (GIMME == G_ARRAY)
3827         RETURN;
3828     else
3829         RETPUSHUNDEF;
3830 #endif
3831 }
3832
3833 PP(pp_telldir)
3834 {
3835 #if defined(HAS_TELLDIR) || defined(telldir)
3836     dVAR; dSP; dTARGET;
3837  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3838  /* XXX netbsd still seemed to.
3839     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3840     --JHI 1999-Feb-02 */
3841 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3842     long telldir (DIR *);
3843 # endif
3844     GV * const gv = (GV*)POPs;
3845     register IO * const io = GvIOn(gv);
3846
3847     if (!io || !IoDIRP(io)) {
3848         if(ckWARN(WARN_IO)) {
3849             Perl_warner(aTHX_ packWARN(WARN_IO),
3850                 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3851         }
3852         goto nope;
3853     }
3854
3855     PUSHi( PerlDir_tell(IoDIRP(io)) );
3856     RETURN;
3857 nope:
3858     if (!errno)
3859         SETERRNO(EBADF,RMS_ISI);
3860     RETPUSHUNDEF;
3861 #else
3862     DIE(aTHX_ PL_no_dir_func, "telldir");
3863 #endif
3864 }
3865
3866 PP(pp_seekdir)
3867 {
3868 #if defined(HAS_SEEKDIR) || defined(seekdir)
3869     dVAR; dSP;
3870     const long along = POPl;
3871     GV * const gv = (GV*)POPs;
3872     register IO * const io = GvIOn(gv);
3873
3874     if (!io || !IoDIRP(io)) {
3875         if(ckWARN(WARN_IO)) {
3876             Perl_warner(aTHX_ packWARN(WARN_IO),
3877                 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3878         }
3879         goto nope;
3880     }
3881     (void)PerlDir_seek(IoDIRP(io), along);
3882
3883     RETPUSHYES;
3884 nope:
3885     if (!errno)
3886         SETERRNO(EBADF,RMS_ISI);
3887     RETPUSHUNDEF;
3888 #else
3889     DIE(aTHX_ PL_no_dir_func, "seekdir");
3890 #endif
3891 }
3892
3893 PP(pp_rewinddir)
3894 {
3895 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3896     dVAR; dSP;
3897     GV * const gv = (GV*)POPs;
3898     register IO * const io = GvIOn(gv);
3899
3900     if (!io || !IoDIRP(io)) {
3901         if(ckWARN(WARN_IO)) {
3902             Perl_warner(aTHX_ packWARN(WARN_IO),
3903                 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3904         }
3905         goto nope;
3906     }
3907     (void)PerlDir_rewind(IoDIRP(io));
3908     RETPUSHYES;
3909 nope:
3910     if (!errno)
3911         SETERRNO(EBADF,RMS_ISI);
3912     RETPUSHUNDEF;
3913 #else
3914     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3915 #endif
3916 }
3917
3918 PP(pp_closedir)
3919 {
3920 #if defined(Direntry_t) && defined(HAS_READDIR)
3921     dVAR; dSP;
3922     GV * const gv = (GV*)POPs;
3923     register IO * const io = GvIOn(gv);
3924
3925     if (!io || !IoDIRP(io)) {
3926         if(ckWARN(WARN_IO)) {
3927             Perl_warner(aTHX_ packWARN(WARN_IO),
3928                 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3929         }
3930         goto nope;
3931     }
3932 #ifdef VOID_CLOSEDIR
3933     PerlDir_close(IoDIRP(io));
3934 #else
3935     if (PerlDir_close(IoDIRP(io)) < 0) {
3936         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3937         goto nope;
3938     }
3939 #endif
3940     IoDIRP(io) = 0;
3941
3942     RETPUSHYES;
3943 nope:
3944     if (!errno)
3945         SETERRNO(EBADF,RMS_IFI);
3946     RETPUSHUNDEF;
3947 #else
3948     DIE(aTHX_ PL_no_dir_func, "closedir");
3949 #endif
3950 }
3951
3952 /* Process control. */
3953
3954 PP(pp_fork)
3955 {
3956 #ifdef HAS_FORK
3957     dVAR; dSP; dTARGET;
3958     Pid_t childpid;
3959
3960     EXTEND(SP, 1);
3961     PERL_FLUSHALL_FOR_CHILD;
3962     childpid = PerlProc_fork();
3963     if (childpid < 0)
3964         RETSETUNDEF;
3965     if (!childpid) {
3966         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3967         if (tmpgv) {
3968             SvREADONLY_off(GvSV(tmpgv));
3969             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3970             SvREADONLY_on(GvSV(tmpgv));
3971         }
3972 #ifdef THREADS_HAVE_PIDS
3973         PL_ppid = (IV)getppid();
3974 #endif
3975 #ifdef PERL_USES_PL_PIDSTATUS
3976         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3977 #endif
3978     }
3979     PUSHi(childpid);
3980     RETURN;
3981 #else
3982 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3983     dSP; dTARGET;
3984     Pid_t childpid;
3985
3986     EXTEND(SP, 1);
3987     PERL_FLUSHALL_FOR_CHILD;
3988     childpid = PerlProc_fork();
3989     if (childpid == -1)
3990         RETSETUNDEF;
3991     PUSHi(childpid);
3992     RETURN;
3993 #  else
3994     DIE(aTHX_ PL_no_func, "fork");
3995 #  endif
3996 #endif
3997 }
3998
3999 PP(pp_wait)
4000 {
4001 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4002     dVAR; dSP; dTARGET;
4003     Pid_t childpid;
4004     int argflags;
4005
4006     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4007         childpid = wait4pid(-1, &argflags, 0);
4008     else {
4009         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4010                errno == EINTR) {
4011           PERL_ASYNC_CHECK();
4012         }
4013     }
4014 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4015     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4016     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4017 #  else
4018     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4019 #  endif
4020     XPUSHi(childpid);
4021     RETURN;
4022 #else
4023     DIE(aTHX_ PL_no_func, "wait");
4024 #endif
4025 }
4026
4027 PP(pp_waitpid)
4028 {
4029 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4030     dVAR; dSP; dTARGET;
4031     const int optype = POPi;
4032     const Pid_t pid = TOPi;
4033     Pid_t result;
4034     int argflags;
4035
4036     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4037         result = wait4pid(pid, &argflags, optype);
4038     else {
4039         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4040                errno == EINTR) {
4041           PERL_ASYNC_CHECK();
4042         }
4043     }
4044 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4045     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4046     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4047 #  else
4048     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4049 #  endif
4050     SETi(result);
4051     RETURN;
4052 #else
4053     DIE(aTHX_ PL_no_func, "waitpid");
4054 #endif
4055 }
4056
4057 PP(pp_system)
4058 {
4059     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4060 #if defined(__LIBCATAMOUNT__)
4061     PL_statusvalue = -1;
4062     SP = ORIGMARK;
4063     XPUSHi(-1);
4064 #else
4065     I32 value;
4066     int result;
4067
4068     if (PL_tainting) {
4069         TAINT_ENV();
4070         while (++MARK <= SP) {
4071             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4072             if (PL_tainted)
4073                 break;
4074         }
4075         MARK = ORIGMARK;
4076         TAINT_PROPER("system");
4077     }
4078     PERL_FLUSHALL_FOR_CHILD;
4079 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4080     {
4081         Pid_t childpid;
4082         int pp[2];
4083         I32 did_pipes = 0;
4084
4085         if (PerlProc_pipe(pp) >= 0)
4086             did_pipes = 1;
4087         while ((childpid = PerlProc_fork()) == -1) {
4088             if (errno != EAGAIN) {
4089                 value = -1;
4090                 SP = ORIGMARK;
4091                 XPUSHi(value);
4092                 if (did_pipes) {
4093                     PerlLIO_close(pp[0]);
4094                     PerlLIO_close(pp[1]);
4095                 }
4096                 RETURN;
4097             }
4098             sleep(5);
4099         }
4100         if (childpid > 0) {
4101             Sigsave_t ihand,qhand; /* place to save signals during system() */
4102             int status;
4103
4104             if (did_pipes)
4105                 PerlLIO_close(pp[1]);
4106 #ifndef PERL_MICRO
4107             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4108             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4109 #endif
4110             do {
4111                 result = wait4pid(childpid, &status, 0);
4112             } while (result == -1 && errno == EINTR);
4113 #ifndef PERL_MICRO
4114             (void)rsignal_restore(SIGINT, &ihand);
4115             (void)rsignal_restore(SIGQUIT, &qhand);
4116 #endif
4117             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4118             do_execfree();      /* free any memory child malloced on fork */
4119             SP = ORIGMARK;
4120             if (did_pipes) {
4121                 int errkid;
4122                 unsigned n = 0;
4123                 SSize_t n1;
4124
4125                 while (n < sizeof(int)) {
4126                     n1 = PerlLIO_read(pp[0],
4127                                       (void*)(((char*)&errkid)+n),
4128                                       (sizeof(int)) - n);
4129                     if (n1 <= 0)
4130                         break;
4131                     n += n1;
4132                 }
4133                 PerlLIO_close(pp[0]);
4134                 if (n) {                        /* Error */
4135                     if (n != sizeof(int))
4136                         DIE(aTHX_ "panic: kid popen errno read");
4137                     errno = errkid;             /* Propagate errno from kid */
4138                     STATUS_NATIVE_CHILD_SET(-1);
4139                 }
4140             }
4141             XPUSHi(STATUS_CURRENT);
4142             RETURN;
4143         }
4144         if (did_pipes) {
4145             PerlLIO_close(pp[0]);
4146 #if defined(HAS_FCNTL) && defined(F_SETFD)
4147             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4148 #endif
4149         }
4150         if (PL_op->op_flags & OPf_STACKED) {
4151             SV * const really = *++MARK;
4152             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4153         }
4154         else if (SP - MARK != 1)
4155             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4156         else {
4157             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4158         }
4159         PerlProc__exit(-1);
4160     }
4161 #else /* ! FORK or VMS or OS/2 */
4162     PL_statusvalue = 0;
4163     result = 0;
4164     if (PL_op->op_flags & OPf_STACKED) {
4165         SV * const really = *++MARK;
4166 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4167         value = (I32)do_aspawn(really, MARK, SP);
4168 #  else
4169         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4170 #  endif
4171     }
4172     else if (SP - MARK != 1) {
4173 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4174         value = (I32)do_aspawn(NULL, MARK, SP);
4175 #  else
4176         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4177 #  endif
4178     }
4179     else {
4180         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4181     }
4182     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4183         result = 1;
4184     STATUS_NATIVE_CHILD_SET(value);
4185     do_execfree();
4186     SP = ORIGMARK;
4187     XPUSHi(result ? value : STATUS_CURRENT);
4188 #endif /* !FORK or VMS or OS/2 */
4189 #endif
4190     RETURN;
4191 }
4192
4193 PP(pp_exec)
4194 {
4195     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4196     I32 value;
4197
4198     if (PL_tainting) {
4199         TAINT_ENV();
4200         while (++MARK <= SP) {
4201             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4202             if (PL_tainted)
4203                 break;
4204         }
4205         MARK = ORIGMARK;
4206         TAINT_PROPER("exec");
4207     }
4208     PERL_FLUSHALL_FOR_CHILD;
4209     if (PL_op->op_flags & OPf_STACKED) {
4210         SV * const really = *++MARK;
4211         value = (I32)do_aexec(really, MARK, SP);
4212     }
4213     else if (SP - MARK != 1)
4214 #ifdef VMS
4215         value = (I32)vms_do_aexec(NULL, MARK, SP);
4216 #else
4217 #  ifdef __OPEN_VM
4218         {
4219            (void ) do_aspawn(NULL, MARK, SP);
4220            value = 0;
4221         }
4222 #  else
4223         value = (I32)do_aexec(NULL, MARK, SP);
4224 #  endif
4225 #endif
4226     else {
4227 #ifdef VMS
4228         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4229 #else
4230 #  ifdef __OPEN_VM
4231         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4232         value = 0;
4233 #  else
4234         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4235 #  endif
4236 #endif
4237     }
4238
4239     SP = ORIGMARK;
4240     XPUSHi(value);
4241     RETURN;
4242 }
4243
4244 PP(pp_getppid)
4245 {
4246 #ifdef HAS_GETPPID
4247     dVAR; dSP; dTARGET;
4248 #   ifdef THREADS_HAVE_PIDS
4249     if (PL_ppid != 1 && getppid() == 1)
4250         /* maybe the parent process has died. Refresh ppid cache */
4251         PL_ppid = 1;
4252     XPUSHi( PL_ppid );
4253 #   else
4254     XPUSHi( getppid() );
4255 #   endif
4256     RETURN;
4257 #else
4258     DIE(aTHX_ PL_no_func, "getppid");
4259 #endif
4260 }
4261
4262 PP(pp_getpgrp)
4263 {
4264 #ifdef HAS_GETPGRP
4265     dVAR; dSP; dTARGET;
4266     Pid_t pgrp;
4267     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4268
4269 #ifdef BSD_GETPGRP
4270     pgrp = (I32)BSD_GETPGRP(pid);
4271 #else
4272     if (pid != 0 && pid != PerlProc_getpid())
4273         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4274     pgrp = getpgrp();
4275 #endif
4276     XPUSHi(pgrp);
4277     RETURN;
4278 #else
4279     DIE(aTHX_ PL_no_func, "getpgrp()");
4280 #endif
4281 }
4282
4283 PP(pp_setpgrp)
4284 {
4285 #ifdef HAS_SETPGRP
4286     dVAR; dSP; dTARGET;
4287     Pid_t pgrp;
4288     Pid_t pid;
4289     if (MAXARG < 2) {
4290         pgrp = 0;
4291         pid = 0;
4292     }
4293     else {
4294         pgrp = POPi;
4295         pid = TOPi;
4296     }
4297
4298     TAINT_PROPER("setpgrp");
4299 #ifdef BSD_SETPGRP
4300     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4301 #else
4302     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4303         || (pid != 0 && pid != PerlProc_getpid()))
4304     {
4305         DIE(aTHX_ "setpgrp can't take arguments");
4306     }
4307     SETi( setpgrp() >= 0 );
4308 #endif /* USE_BSDPGRP */
4309     RETURN;
4310 #else
4311     DIE(aTHX_ PL_no_func, "setpgrp()");
4312 #endif
4313 }
4314
4315 PP(pp_getpriority)
4316 {
4317 #ifdef HAS_GETPRIORITY
4318     dVAR; dSP; dTARGET;
4319     const int who = POPi;
4320     const int which = TOPi;
4321     SETi( getpriority(which, who) );
4322     RETURN;
4323 #else
4324     DIE(aTHX_ PL_no_func, "getpriority()");
4325 #endif
4326 }
4327
4328 PP(pp_setpriority)
4329 {
4330 #ifdef HAS_SETPRIORITY
4331     dVAR; dSP; dTARGET;
4332     const int niceval = POPi;
4333     const int who = POPi;
4334     const int which = TOPi;
4335     TAINT_PROPER("setpriority");
4336     SETi( setpriority(which, who, niceval) >= 0 );
4337     RETURN;
4338 #else
4339     DIE(aTHX_ PL_no_func, "setpriority()");
4340 #endif
4341 }
4342
4343 /* Time calls. */
4344
4345 PP(pp_time)
4346 {
4347     dVAR; dSP; dTARGET;
4348 #ifdef BIG_TIME
4349     XPUSHn( time(NULL) );
4350 #else
4351     XPUSHi( time(NULL) );
4352 #endif
4353     RETURN;
4354 }
4355
4356 PP(pp_tms)
4357 {
4358 #ifdef HAS_TIMES
4359     dVAR;
4360     dSP;
4361     EXTEND(SP, 4);
4362 #ifndef VMS
4363     (void)PerlProc_times(&PL_timesbuf);
4364 #else
4365     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4366                                                    /* struct tms, though same data   */
4367                                                    /* is returned.                   */
4368 #endif
4369
4370     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4371     if (GIMME == G_ARRAY) {
4372         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4373         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4374         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4375     }
4376     RETURN;
4377 #else
4378 #   ifdef PERL_MICRO
4379     dSP;
4380     PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4381     EXTEND(SP, 4);
4382     if (GIMME == G_ARRAY) {
4383          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4384          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4385          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4386     }
4387     RETURN;
4388 #   else
4389     DIE(aTHX_ "times not implemented");
4390 #   endif
4391 #endif /* HAS_TIMES */
4392 }
4393
4394 #ifdef LOCALTIME_EDGECASE_BROKEN
4395 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4396 {
4397     auto time_t     T;
4398     auto struct tm *P;
4399
4400     /* No workarounds in the valid range */
4401     if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4402         return (localtime (tp));
4403
4404     /* This edge case is to workaround the undefined behaviour, where the
4405      * TIMEZONE makes the time go beyond the defined range.
4406      * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4407      * If there is a negative offset in TZ, like MET-1METDST, some broken
4408      * implementations of localtime () (like AIX 5.2) barf with bogus
4409      * return values:
4410      * 0x7fffffff gmtime               2038-01-19 03:14:07
4411      * 0x7fffffff localtime            1901-12-13 21:45:51
4412      * 0x7fffffff mylocaltime          2038-01-19 04:14:07
4413      * 0x3c19137f gmtime               2001-12-13 20:45:51
4414      * 0x3c19137f localtime            2001-12-13 21:45:51
4415      * 0x3c19137f mylocaltime          2001-12-13 21:45:51
4416      * Given that legal timezones are typically between GMT-12 and GMT+12
4417      * we turn back the clock 23 hours before calling the localtime
4418      * function, and add those to the return value. This will never cause
4419      * day wrapping problems, since the edge case is Tue Jan *19*
4420      */
4421     T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4422     P = localtime (&T);
4423     P->tm_hour += 23;
4424     if (P->tm_hour >= 24) {
4425         P->tm_hour -= 24;
4426         P->tm_mday++;   /* 18  -> 19  */
4427         P->tm_wday++;   /* Mon -> Tue */
4428         P->tm_yday++;   /* 18  -> 19  */
4429     }
4430     return (P);
4431 } /* S_my_localtime */
4432 #endif
4433
4434 PP(pp_gmtime)
4435 {
4436     dVAR;
4437     dSP;
4438     Time_t when;
4439     const struct tm *tmbuf;
4440     static const char * const dayname[] =
4441         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4442     static const char * const monname[] =
4443         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4444          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4445
4446     if (MAXARG < 1)
4447         (void)time(&when);
4448     else
4449 #ifdef BIG_TIME
4450         when = (Time_t)SvNVx(POPs);
4451 #else
4452         when = (Time_t)SvIVx(POPs);
4453 #endif
4454
4455     if (PL_op->op_type == OP_LOCALTIME)
4456 #ifdef LOCALTIME_EDGECASE_BROKEN
4457         tmbuf = S_my_localtime(aTHX_ &when);
4458 #else
4459         tmbuf = localtime(&when);
4460 #endif
4461     else
4462         tmbuf = gmtime(&when);
4463
4464     if (GIMME != G_ARRAY) {
4465         SV *tsv;
4466         EXTEND(SP, 1);
4467         EXTEND_MORTAL(1);
4468         if (!tmbuf)
4469             RETPUSHUNDEF;
4470         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4471                             dayname[tmbuf->tm_wday],
4472                             monname[tmbuf->tm_mon],
4473                             tmbuf->tm_mday,
4474                             tmbuf->tm_hour,
4475                             tmbuf->tm_min,
4476                             tmbuf->tm_sec,
4477                             tmbuf->tm_year + 1900);
4478         PUSHs(sv_2mortal(tsv));
4479     }
4480     else if (tmbuf) {
4481         EXTEND(SP, 9);
4482         EXTEND_MORTAL(9);
4483         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4484         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4485         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4486         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4487         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4488         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4489         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4490         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4491         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4492     }
4493     RETURN;
4494 }
4495
4496 PP(pp_alarm)
4497 {
4498 #ifdef HAS_ALARM
4499     dVAR; dSP; dTARGET;
4500     int anum;
4501     anum = POPi;
4502     anum = alarm((unsigned int)anum);
4503     EXTEND(SP, 1);
4504     if (anum < 0)
4505         RETPUSHUNDEF;
4506     PUSHi(anum);
4507     RETURN;
4508 #else
4509     DIE(aTHX_ PL_no_func, "alarm");
4510 #endif
4511 }
4512
4513 PP(pp_sleep)
4514 {
4515     dVAR; dSP; dTARGET;
4516     I32 duration;
4517     Time_t lasttime;
4518     Time_t when;
4519
4520     (void)time(&lasttime);
4521     if (MAXARG < 1)
4522         PerlProc_pause();
4523     else {
4524         duration = POPi;
4525         PerlProc_sleep((unsigned int)duration);
4526     }
4527     (void)time(&when);
4528     XPUSHi(when - lasttime);
4529     RETURN;
4530 }
4531
4532 /* Shared memory. */
4533 /* Merged with some message passing. */
4534
4535 PP(pp_shmwrite)
4536 {
4537 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4538     dVAR; dSP; dMARK; dTARGET;
4539     const int op_type = PL_op->op_type;
4540     I32 value;
4541
4542     switch (op_type) {
4543     case OP_MSGSND:
4544         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4545         break;
4546     case OP_MSGRCV:
4547         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4548         break;
4549     case OP_SEMOP:
4550         value = (I32)(do_semop(MARK, SP) >= 0);
4551         break;
4552     default:
4553         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4554         break;
4555     }
4556
4557     SP = MARK;
4558     PUSHi(value);
4559     RETURN;
4560 #else
4561     return pp_semget();
4562 #endif
4563 }
4564
4565 /* Semaphores. */
4566
4567 PP(pp_semget)
4568 {
4569 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4570     dVAR; dSP; dMARK; dTARGET;
4571     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4572     SP = MARK;
4573     if (anum == -1)
4574         RETPUSHUNDEF;
4575     PUSHi(anum);
4576     RETURN;
4577 #else
4578     DIE(aTHX_ "System V IPC is not implemented on this machine");
4579 #endif
4580 }
4581
4582 PP(pp_semctl)
4583 {
4584 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4585     dVAR; dSP; dMARK; dTARGET;
4586     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4587     SP = MARK;
4588     if (anum == -1)
4589         RETSETUNDEF;
4590     if (anum != 0) {
4591         PUSHi(anum);
4592     }
4593     else {
4594         PUSHp(zero_but_true, ZBTLEN);
4595     }
4596     RETURN;
4597 #else
4598     return pp_semget();
4599 #endif
4600 }
4601
4602 /* I can't const this further without getting warnings about the types of
4603    various arrays passed in from structures.  */
4604 static SV *
4605 S_space_join_names_mortal(pTHX_ char *const *array)
4606 {
4607     SV *target;
4608
4609     if (array && *array) {
4610         target = sv_2mortal(newSVpvs(""));
4611         while (1) {
4612             sv_catpv(target, *array);
4613             if (!*++array)
4614                 break;
4615             sv_catpvs(target, " ");
4616         }
4617     } else {
4618         target = sv_mortalcopy(&PL_sv_no);
4619     }
4620     return target;
4621 }
4622
4623 /* Get system info. */
4624
4625 PP(pp_ghostent)
4626 {
4627 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4628     dVAR; dSP;
4629     I32 which = PL_op->op_type;
4630     register char **elem;
4631     register SV *sv;
4632 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4633     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4634     struct hostent *gethostbyname(Netdb_name_t);
4635     struct hostent *gethostent(void);
4636 #endif
4637     struct hostent *hent;
4638     unsigned long len;
4639
4640     EXTEND(SP, 10);
4641     if (which == OP_GHBYNAME) {
4642 #ifdef HAS_GETHOSTBYNAME
4643         const char* const name = POPpbytex;
4644         hent = PerlSock_gethostbyname(name);
4645 #else
4646         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4647 #endif
4648     }
4649     else if (which == OP_GHBYADDR) {
4650 #ifdef HAS_GETHOSTBYADDR
4651         const int addrtype = POPi;
4652         SV * const addrsv = POPs;
4653         STRLEN addrlen;
4654         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4655
4656         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4657 #else
4658         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4659 #endif
4660     }
4661     else
4662 #ifdef HAS_GETHOSTENT
4663         hent = PerlSock_gethostent();
4664 #else
4665         DIE(aTHX_ PL_no_sock_func, "gethostent");
4666 #endif
4667
4668 #ifdef HOST_NOT_FOUND
4669         if (!hent) {
4670 #ifdef USE_REENTRANT_API
4671 #   ifdef USE_GETHOSTENT_ERRNO
4672             h_errno = PL_reentrant_buffer->_gethostent_errno;
4673 #   endif
4674 #endif
4675             STATUS_UNIX_SET(h_errno);
4676         }
4677 #endif
4678
4679     if (GIMME != G_ARRAY) {
4680         PUSHs(sv = sv_newmortal());
4681         if (hent) {
4682             if (which == OP_GHBYNAME) {
4683                 if (hent->h_addr)
4684                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4685             }
4686             else
4687                 sv_setpv(sv, (char*)hent->h_name);
4688         }
4689         RETURN;
4690     }
4691
4692     if (hent) {
4693         PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4694         PUSHs(space_join_names_mortal(hent->h_aliases));
4695         PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4696         len = hent->h_length;
4697         PUSHs(sv_2mortal(newSViv((IV)len)));
4698 #ifdef h_addr
4699         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4700             XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4701         }
4702 #else
4703         if (hent->h_addr)
4704             PUSHs(newSVpvn(hent->h_addr, len));
4705         else
4706             PUSHs(sv_mortalcopy(&PL_sv_no));
4707 #endif /* h_addr */
4708     }
4709     RETURN;
4710 #else
4711     DIE(aTHX_ PL_no_sock_func, "gethostent");
4712 #endif
4713 }
4714
4715 PP(pp_gnetent)
4716 {
4717 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4718     dVAR; dSP;
4719     I32 which = PL_op->op_type;
4720     register SV *sv;
4721 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4722     struct netent *getnetbyaddr(Netdb_net_t, int);
4723     struct netent *getnetbyname(Netdb_name_t);
4724     struct netent *getnetent(void);
4725 #endif
4726     struct netent *nent;
4727
4728     if (which == OP_GNBYNAME){
4729 #ifdef HAS_GETNETBYNAME
4730         const char * const name = POPpbytex;
4731         nent = PerlSock_getnetbyname(name);
4732 #else
4733         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4734 #endif
4735     }
4736     else if (which == OP_GNBYADDR) {
4737 #ifdef HAS_GETNETBYADDR
4738         const int addrtype = POPi;
4739         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4740         nent = PerlSock_getnetbyaddr(addr, addrtype);
4741 #else
4742         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4743 #endif
4744     }
4745     else
4746 #ifdef HAS_GETNETENT
4747         nent = PerlSock_getnetent();
4748 #else
4749         DIE(aTHX_ PL_no_sock_func, "getnetent");
4750 #endif
4751
4752 #ifdef HOST_NOT_FOUND
4753         if (!nent) {
4754 #ifdef USE_REENTRANT_API
4755 #   ifdef USE_GETNETENT_ERRNO
4756              h_errno = PL_reentrant_buffer->_getnetent_errno;
4757 #   endif
4758 #endif
4759             STATUS_UNIX_SET(h_errno);
4760         }
4761 #endif
4762
4763     EXTEND(SP, 4);
4764     if (GIMME != G_ARRAY) {
4765         PUSHs(sv = sv_newmortal());
4766         if (nent) {
4767             if (which == OP_GNBYNAME)
4768                 sv_setiv(sv, (IV)nent->n_net);
4769             else
4770                 sv_setpv(sv, nent->n_name);
4771         }
4772         RETURN;
4773     }
4774
4775     if (nent) {
4776         PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4777         PUSHs(space_join_names_mortal(nent->n_aliases));
4778         PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4779         PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4780     }
4781
4782     RETURN;
4783 #else
4784     DIE(aTHX_ PL_no_sock_func, "getnetent");
4785 #endif
4786 }
4787
4788 PP(pp_gprotoent)
4789 {
4790 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4791     dVAR; dSP;
4792     I32 which = PL_op->op_type;
4793     register SV *sv;
4794 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4795     struct protoent *getprotobyname(Netdb_name_t);
4796     struct protoent *getprotobynumber(int);
4797     struct protoent *getprotoent(void);
4798 #endif
4799     struct protoent *pent;
4800
4801     if (which == OP_GPBYNAME) {
4802 #ifdef HAS_GETPROTOBYNAME
4803         const char* const name = POPpbytex;
4804         pent = PerlSock_getprotobyname(name);
4805 #else
4806         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4807 #endif
4808     }
4809     else if (which == OP_GPBYNUMBER) {
4810 #ifdef HAS_GETPROTOBYNUMBER
4811         const int number = POPi;
4812         pent = PerlSock_getprotobynumber(number);
4813 #else
4814         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4815 #endif
4816     }
4817     else
4818 #ifdef HAS_GETPROTOENT
4819         pent = PerlSock_getprotoent();
4820 #else
4821         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4822 #endif
4823
4824     EXTEND(SP, 3);
4825     if (GIMME != G_ARRAY) {
4826         PUSHs(sv = sv_newmortal());
4827         if (pent) {
4828             if (which == OP_GPBYNAME)
4829                 sv_setiv(sv, (IV)pent->p_proto);
4830             else
4831                 sv_setpv(sv, pent->p_name);
4832         }
4833         RETURN;
4834     }
4835
4836     if (pent) {
4837         PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4838         PUSHs(space_join_names_mortal(pent->p_aliases));
4839         PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4840     }
4841
4842     RETURN;
4843 #else
4844     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4845 #endif
4846 }
4847
4848 PP(pp_gservent)
4849 {
4850 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4851     dVAR; dSP;
4852     I32 which = PL_op->op_type;
4853     register SV *sv;
4854 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4855     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4856     struct servent *getservbyport(int, Netdb_name_t);
4857     struct servent *getservent(void);
4858 #endif
4859     struct servent *sent;
4860
4861     if (which == OP_GSBYNAME) {
4862 #ifdef HAS_GETSERVBYNAME
4863         const char * const proto = POPpbytex;
4864         const char * const name = POPpbytex;
4865         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4866 #else
4867         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4868 #endif
4869     }
4870     else if (which == OP_GSBYPORT) {
4871 #ifdef HAS_GETSERVBYPORT
4872         const char * const proto = POPpbytex;
4873         unsigned short port = (unsigned short)POPu;
4874 #ifdef HAS_HTONS
4875         port = PerlSock_htons(port);
4876 #endif
4877         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4878 #else
4879         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4880 #endif
4881     }
4882     else
4883 #ifdef HAS_GETSERVENT
4884         sent = PerlSock_getservent();
4885 #else
4886         DIE(aTHX_ PL_no_sock_func, "getservent");
4887 #endif
4888
4889     EXTEND(SP, 4);
4890     if (GIMME != G_ARRAY) {
4891         PUSHs(sv = sv_newmortal());
4892         if (sent) {
4893             if (which == OP_GSBYNAME) {
4894 #ifdef HAS_NTOHS
4895                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4896 #else
4897                 sv_setiv(sv, (IV)(sent->s_port));
4898 #endif
4899             }
4900             else
4901                 sv_setpv(sv, sent->s_name);
4902         }
4903         RETURN;
4904     }
4905
4906     if (sent) {
4907         PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4908         PUSHs(space_join_names_mortal(sent->s_aliases));
4909 #ifdef HAS_NTOHS
4910         PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4911 #else
4912         PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4913 #endif
4914         PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4915     }
4916
4917     RETURN;
4918 #else
4919     DIE(aTHX_ PL_no_sock_func, "getservent");
4920 #endif
4921 }
4922
4923 PP(pp_shostent)
4924 {
4925 #ifdef HAS_SETHOSTENT
4926     dVAR; dSP;
4927     PerlSock_sethostent(TOPi);
4928     RETSETYES;
4929 #else
4930     DIE(aTHX_ PL_no_sock_func, "sethostent");
4931 #endif
4932 }
4933
4934 PP(pp_snetent)
4935 {
4936 #ifdef HAS_SETNETENT
4937     dVAR; dSP;
4938     PerlSock_setnetent(TOPi);
4939     RETSETYES;
4940 #else
4941     DIE(aTHX_ PL_no_sock_func, "setnetent");
4942 #endif
4943 }
4944
4945 PP(pp_sprotoent)
4946 {
4947 #ifdef HAS_SETPROTOENT
4948     dVAR; dSP;
4949     PerlSock_setprotoent(TOPi);
4950     RETSETYES;
4951 #else
4952     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4953 #endif
4954 }
4955
4956 PP(pp_sservent)
4957 {
4958 #ifdef HAS_SETSERVENT
4959     dVAR; dSP;
4960     PerlSock_setservent(TOPi);
4961     RETSETYES;
4962 #else
4963     DIE(aTHX_ PL_no_sock_func, "setservent");
4964 #endif
4965 }
4966
4967 PP(pp_ehostent)
4968 {
4969 #ifdef HAS_ENDHOSTENT
4970     dVAR; dSP;
4971     PerlSock_endhostent();
4972     EXTEND(SP,1);
4973     RETPUSHYES;
4974 #else
4975     DIE(aTHX_ PL_no_sock_func, "endhostent");
4976 #endif
4977 }
4978
4979 PP(pp_enetent)
4980 {
4981 #ifdef HAS_ENDNETENT
4982     dVAR; dSP;
4983     PerlSock_endnetent();
4984     EXTEND(SP,1);
4985     RETPUSHYES;
4986 #else
4987     DIE(aTHX_ PL_no_sock_func, "endnetent");
4988 #endif
4989 }
4990
4991 PP(pp_eprotoent)
4992 {
4993 #ifdef HAS_ENDPROTOENT
4994     dVAR; dSP;
4995     PerlSock_endprotoent();
4996     EXTEND(SP,1);
4997     RETPUSHYES;
4998 #else
4999     DIE(aTHX_ PL_no_sock_func, "endprotoent");
5000 #endif
5001 }
5002
5003 PP(pp_eservent)
5004 {
5005 #ifdef HAS_ENDSERVENT
5006     dVAR; dSP;
5007     PerlSock_endservent();
5008     EXTEND(SP,1);
5009     RETPUSHYES;
5010 #else
5011     DIE(aTHX_ PL_no_sock_func, "endservent");
5012 #endif
5013 }
5014
5015 PP(pp_gpwent)
5016 {
5017 #ifdef HAS_PASSWD
5018     dVAR; dSP;
5019     I32 which = PL_op->op_type;
5020     register SV *sv;
5021     struct passwd *pwent  = NULL;
5022     /*
5023      * We currently support only the SysV getsp* shadow password interface.
5024      * The interface is declared in <shadow.h> and often one needs to link
5025      * with -lsecurity or some such.
5026      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5027      * (and SCO?)
5028      *
5029      * AIX getpwnam() is clever enough to return the encrypted password
5030      * only if the caller (euid?) is root.
5031      *
5032      * There are at least three other shadow password APIs.  Many platforms
5033      * seem to contain more than one interface for accessing the shadow
5034      * password databases, possibly for compatibility reasons.
5035      * The getsp*() is by far he simplest one, the other two interfaces
5036      * are much more complicated, but also very similar to each other.
5037      *
5038      * <sys/types.h>
5039      * <sys/security.h>
5040      * <prot.h>
5041      * struct pr_passwd *getprpw*();
5042      * The password is in
5043      * char getprpw*(...).ufld.fd_encrypt[]
5044      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5045      *
5046      * <sys/types.h>
5047      * <sys/security.h>
5048      * <prot.h>
5049      * struct es_passwd *getespw*();
5050      * The password is in
5051      * char *(getespw*(...).ufld.fd_encrypt)
5052      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5053      *
5054      * <userpw.h> (AIX)
5055      * struct userpw *getuserpw();
5056      * The password is in
5057      * char *(getuserpw(...)).spw_upw_passwd
5058      * (but the de facto standard getpwnam() should work okay)
5059      *
5060      * Mention I_PROT here so that Configure probes for it.
5061      *
5062      * In HP-UX for getprpw*() the manual page claims that one should include
5063      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5064      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5065      * and pp_sys.c already includes <shadow.h> if there is such.
5066      *
5067      * Note that <sys/security.h> is already probed for, but currently
5068      * it is only included in special cases.
5069      *
5070      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5071      * be preferred interface, even though also the getprpw*() interface
5072      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5073      * One also needs to call set_auth_parameters() in main() before
5074      * doing anything else, whether one is using getespw*() or getprpw*().
5075      *
5076      * Note that accessing the shadow databases can be magnitudes
5077      * slower than accessing the standard databases.
5078      *
5079      * --jhi
5080      */
5081
5082 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5083     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5084      * the pw_comment is left uninitialized. */
5085     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5086 #   endif
5087
5088     switch (which) {
5089     case OP_GPWNAM:
5090       {
5091         const char* const name = POPpbytex;
5092         pwent  = getpwnam(name);
5093       }
5094       break;
5095     case OP_GPWUID:
5096       {
5097         Uid_t uid = POPi;
5098         pwent = getpwuid(uid);
5099       }
5100         break;
5101     case OP_GPWENT:
5102 #   ifdef HAS_GETPWENT
5103         pwent  = getpwent();
5104 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5105         if (pwent) pwent = getpwnam(pwent->pw_name);
5106 #endif
5107 #   else
5108         DIE(aTHX_ PL_no_func, "getpwent");
5109 #   endif
5110         break;
5111     }
5112
5113     EXTEND(SP, 10);
5114     if (GIMME != G_ARRAY) {
5115         PUSHs(sv = sv_newmortal());
5116         if (pwent) {
5117             if (which == OP_GPWNAM)
5118 #   if Uid_t_sign <= 0
5119                 sv_setiv(sv, (IV)pwent->pw_uid);
5120 #   else
5121                 sv_setuv(sv, (UV)pwent->pw_uid);
5122 #   endif
5123             else
5124                 sv_setpv(sv, pwent->pw_name);
5125         }
5126         RETURN;
5127     }
5128
5129     if (pwent) {
5130         PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5131
5132         PUSHs(sv = sv_2mortal(newSViv(0)));
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         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5177 #   else
5178         PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5179 #   endif
5180
5181 #   if Uid_t_sign <= 0
5182         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5183 #   else
5184         PUSHs(sv_2mortal(newSVuv((UV)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         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5193 #   else
5194 #       ifdef PWQUOTA
5195         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5196 #       else
5197 #           ifdef PWAGE
5198         PUSHs(sv_2mortal(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         PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5210 #   else
5211 #       ifdef PWCOMMENT
5212         PUSHs(sv_2mortal(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         PUSHs(sv_2mortal(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         PUSHs(sv_2mortal(newSViv((IV)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         PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5307
5308 #ifdef GRPASSWD
5309         PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5310 #else
5311         PUSHs(sv_mortalcopy(&PL_sv_no));
5312 #endif
5313
5314         PUSHs(sv_2mortal(newSViv((IV)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  */