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                     sv_setpvn(GvSV(gv), "-", 1);
2016                     SvSETMAGIC(GvSV(gv));
2017                 }
2018                 else if (!nextargv(gv))
2019                     RETPUSHYES;
2020             }
2021         }
2022         else
2023             gv = PL_last_in_gv;                 /* eof */
2024     }
2025     else
2026         gv = PL_last_in_gv = (GV*)POPs;         /* eof(FH) */
2027
2028     if (gv) {
2029         IO * const io = GvIO(gv);
2030         MAGIC * mg;
2031         if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2032             PUSHMARK(SP);
2033             XPUSHs(SvTIED_obj((SV*)io, mg));
2034             PUTBACK;
2035             ENTER;
2036             call_method("EOF", G_SCALAR);
2037             LEAVE;
2038             SPAGAIN;
2039             RETURN;
2040         }
2041     }
2042
2043     PUSHs(boolSV(!gv || do_eof(gv)));
2044     RETURN;
2045 }
2046
2047 PP(pp_tell)
2048 {
2049     dVAR; dSP; dTARGET;
2050     GV *gv;
2051     IO *io;
2052
2053     if (MAXARG != 0)
2054         PL_last_in_gv = (GV*)POPs;
2055     gv = PL_last_in_gv;
2056
2057     if (gv && (io = GvIO(gv))) {
2058         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2059         if (mg) {
2060             PUSHMARK(SP);
2061             XPUSHs(SvTIED_obj((SV*)io, mg));
2062             PUTBACK;
2063             ENTER;
2064             call_method("TELL", G_SCALAR);
2065             LEAVE;
2066             SPAGAIN;
2067             RETURN;
2068         }
2069     }
2070
2071 #if LSEEKSIZE > IVSIZE
2072     PUSHn( do_tell(gv) );
2073 #else
2074     PUSHi( do_tell(gv) );
2075 #endif
2076     RETURN;
2077 }
2078
2079 PP(pp_sysseek)
2080 {
2081     dVAR; dSP;
2082     const int whence = POPi;
2083 #if LSEEKSIZE > IVSIZE
2084     const Off_t offset = (Off_t)SvNVx(POPs);
2085 #else
2086     const Off_t offset = (Off_t)SvIVx(POPs);
2087 #endif
2088
2089     GV * const gv = PL_last_in_gv = (GV*)POPs;
2090     IO *io;
2091
2092     if (gv && (io = GvIO(gv))) {
2093         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2094         if (mg) {
2095             PUSHMARK(SP);
2096             XPUSHs(SvTIED_obj((SV*)io, mg));
2097 #if LSEEKSIZE > IVSIZE
2098             XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2099 #else
2100             XPUSHs(sv_2mortal(newSViv(offset)));
2101 #endif
2102             XPUSHs(sv_2mortal(newSViv(whence)));
2103             PUTBACK;
2104             ENTER;
2105             call_method("SEEK", G_SCALAR);
2106             LEAVE;
2107             SPAGAIN;
2108             RETURN;
2109         }
2110     }
2111
2112     if (PL_op->op_type == OP_SEEK)
2113         PUSHs(boolSV(do_seek(gv, offset, whence)));
2114     else {
2115         const Off_t sought = do_sysseek(gv, offset, whence);
2116         if (sought < 0)
2117             PUSHs(&PL_sv_undef);
2118         else {
2119             SV* const sv = sought ?
2120 #if LSEEKSIZE > IVSIZE
2121                 newSVnv((NV)sought)
2122 #else
2123                 newSViv(sought)
2124 #endif
2125                 : newSVpvn(zero_but_true, ZBTLEN);
2126             PUSHs(sv_2mortal(sv));
2127         }
2128     }
2129     RETURN;
2130 }
2131
2132 PP(pp_truncate)
2133 {
2134     dVAR;
2135     dSP;
2136     /* There seems to be no consensus on the length type of truncate()
2137      * and ftruncate(), both off_t and size_t have supporters. In
2138      * general one would think that when using large files, off_t is
2139      * at least as wide as size_t, so using an off_t should be okay. */
2140     /* XXX Configure probe for the length type of *truncate() needed XXX */
2141     Off_t len;
2142
2143 #if Off_t_size > IVSIZE
2144     len = (Off_t)POPn;
2145 #else
2146     len = (Off_t)POPi;
2147 #endif
2148     /* Checking for length < 0 is problematic as the type might or
2149      * might not be signed: if it is not, clever compilers will moan. */
2150     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2151     SETERRNO(0,0);
2152     {
2153         int result = 1;
2154         GV *tmpgv;
2155         IO *io;
2156
2157         if (PL_op->op_flags & OPf_SPECIAL) {
2158             tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2159
2160         do_ftruncate_gv:
2161             if (!GvIO(tmpgv))
2162                 result = 0;
2163             else {
2164                 PerlIO *fp;
2165                 io = GvIOp(tmpgv);
2166             do_ftruncate_io:
2167                 TAINT_PROPER("truncate");
2168                 if (!(fp = IoIFP(io))) {
2169                     result = 0;
2170                 }
2171                 else {
2172                     PerlIO_flush(fp);
2173 #ifdef HAS_TRUNCATE
2174                     if (ftruncate(PerlIO_fileno(fp), len) < 0)
2175 #else
2176                     if (my_chsize(PerlIO_fileno(fp), len) < 0)
2177 #endif
2178                         result = 0;
2179                 }
2180             }
2181         }
2182         else {
2183             SV * const sv = POPs;
2184             const char *name;
2185
2186             if (SvTYPE(sv) == SVt_PVGV) {
2187                 tmpgv = (GV*)sv;                /* *main::FRED for example */
2188                 goto do_ftruncate_gv;
2189             }
2190             else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2191                 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2192                 goto do_ftruncate_gv;
2193             }
2194             else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2195                 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2196                 goto do_ftruncate_io;
2197             }
2198
2199             name = SvPV_nolen_const(sv);
2200             TAINT_PROPER("truncate");
2201 #ifdef HAS_TRUNCATE
2202             if (truncate(name, len) < 0)
2203                 result = 0;
2204 #else
2205             {
2206                 const int tmpfd = PerlLIO_open(name, O_RDWR);
2207
2208                 if (tmpfd < 0)
2209                     result = 0;
2210                 else {
2211                     if (my_chsize(tmpfd, len) < 0)
2212                         result = 0;
2213                     PerlLIO_close(tmpfd);
2214                 }
2215             }
2216 #endif
2217         }
2218
2219         if (result)
2220             RETPUSHYES;
2221         if (!errno)
2222             SETERRNO(EBADF,RMS_IFI);
2223         RETPUSHUNDEF;
2224     }
2225 }
2226
2227 PP(pp_ioctl)
2228 {
2229     dVAR; dSP; dTARGET;
2230     SV * const argsv = POPs;
2231     const unsigned int func = POPu;
2232     const int optype = PL_op->op_type;
2233     GV * const gv = (GV*)POPs;
2234     IO * const io = gv ? GvIOn(gv) : NULL;
2235     char *s;
2236     IV retval;
2237
2238     if (!io || !argsv || !IoIFP(io)) {
2239         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2240             report_evil_fh(gv, io, PL_op->op_type);
2241         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2242         RETPUSHUNDEF;
2243     }
2244
2245     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2246         STRLEN len;
2247         STRLEN need;
2248         s = SvPV_force(argsv, len);
2249         need = IOCPARM_LEN(func);
2250         if (len < need) {
2251             s = Sv_Grow(argsv, need + 1);
2252             SvCUR_set(argsv, need);
2253         }
2254
2255         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2256     }
2257     else {
2258         retval = SvIV(argsv);
2259         s = INT2PTR(char*,retval);              /* ouch */
2260     }
2261
2262     TAINT_PROPER(PL_op_desc[optype]);
2263
2264     if (optype == OP_IOCTL)
2265 #ifdef HAS_IOCTL
2266         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2267 #else
2268         DIE(aTHX_ "ioctl is not implemented");
2269 #endif
2270     else
2271 #ifndef HAS_FCNTL
2272       DIE(aTHX_ "fcntl is not implemented");
2273 #else
2274 #if defined(OS2) && defined(__EMX__)
2275         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2276 #else
2277         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2278 #endif
2279 #endif
2280
2281 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2282     if (SvPOK(argsv)) {
2283         if (s[SvCUR(argsv)] != 17)
2284             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2285                 OP_NAME(PL_op));
2286         s[SvCUR(argsv)] = 0;            /* put our null back */
2287         SvSETMAGIC(argsv);              /* Assume it has changed */
2288     }
2289
2290     if (retval == -1)
2291         RETPUSHUNDEF;
2292     if (retval != 0) {
2293         PUSHi(retval);
2294     }
2295     else {
2296         PUSHp(zero_but_true, ZBTLEN);
2297     }
2298 #endif
2299     RETURN;
2300 }
2301
2302 PP(pp_flock)
2303 {
2304 #ifdef FLOCK
2305     dVAR; dSP; dTARGET;
2306     I32 value;
2307     IO *io = NULL;
2308     PerlIO *fp;
2309     const int argtype = POPi;
2310     GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2311
2312     if (gv && (io = GvIO(gv)))
2313         fp = IoIFP(io);
2314     else {
2315         fp = NULL;
2316         io = NULL;
2317     }
2318     /* XXX Looks to me like io is always NULL at this point */
2319     if (fp) {
2320         (void)PerlIO_flush(fp);
2321         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2322     }
2323     else {
2324         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2325             report_evil_fh(gv, io, PL_op->op_type);
2326         value = 0;
2327         SETERRNO(EBADF,RMS_IFI);
2328     }
2329     PUSHi(value);
2330     RETURN;
2331 #else
2332     DIE(aTHX_ PL_no_func, "flock()");
2333 #endif
2334 }
2335
2336 /* Sockets. */
2337
2338 PP(pp_socket)
2339 {
2340 #ifdef HAS_SOCKET
2341     dVAR; dSP;
2342     const int protocol = POPi;
2343     const int type = POPi;
2344     const int domain = POPi;
2345     GV * const gv = (GV*)POPs;
2346     register IO * const io = gv ? GvIOn(gv) : NULL;
2347     int fd;
2348
2349     if (!gv || !io) {
2350         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2351             report_evil_fh(gv, io, PL_op->op_type);
2352         if (io && IoIFP(io))
2353             do_close(gv, FALSE);
2354         SETERRNO(EBADF,LIB_INVARG);
2355         RETPUSHUNDEF;
2356     }
2357
2358     if (IoIFP(io))
2359         do_close(gv, FALSE);
2360
2361     TAINT_PROPER("socket");
2362     fd = PerlSock_socket(domain, type, protocol);
2363     if (fd < 0)
2364         RETPUSHUNDEF;
2365     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2366     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2367     IoTYPE(io) = IoTYPE_SOCKET;
2368     if (!IoIFP(io) || !IoOFP(io)) {
2369         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2370         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2371         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2372         RETPUSHUNDEF;
2373     }
2374 #if defined(HAS_FCNTL) && defined(F_SETFD)
2375     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2376 #endif
2377
2378 #ifdef EPOC
2379     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2380 #endif
2381
2382     RETPUSHYES;
2383 #else
2384     DIE(aTHX_ PL_no_sock_func, "socket");
2385 #endif
2386 }
2387
2388 PP(pp_sockpair)
2389 {
2390 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2391     dVAR; dSP;
2392     const int protocol = POPi;
2393     const int type = POPi;
2394     const int domain = POPi;
2395     GV * const gv2 = (GV*)POPs;
2396     GV * const gv1 = (GV*)POPs;
2397     register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2398     register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2399     int fd[2];
2400
2401     if (!gv1 || !gv2 || !io1 || !io2) {
2402         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2403             if (!gv1 || !io1)
2404                 report_evil_fh(gv1, io1, PL_op->op_type);
2405             if (!gv2 || !io2)
2406                 report_evil_fh(gv1, io2, PL_op->op_type);
2407         }
2408         if (io1 && IoIFP(io1))
2409             do_close(gv1, FALSE);
2410         if (io2 && IoIFP(io2))
2411             do_close(gv2, FALSE);
2412         RETPUSHUNDEF;
2413     }
2414
2415     if (IoIFP(io1))
2416         do_close(gv1, FALSE);
2417     if (IoIFP(io2))
2418         do_close(gv2, FALSE);
2419
2420     TAINT_PROPER("socketpair");
2421     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2422         RETPUSHUNDEF;
2423     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2424     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2425     IoTYPE(io1) = IoTYPE_SOCKET;
2426     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2427     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2428     IoTYPE(io2) = IoTYPE_SOCKET;
2429     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2430         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2431         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2432         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2433         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2434         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2435         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2436         RETPUSHUNDEF;
2437     }
2438 #if defined(HAS_FCNTL) && defined(F_SETFD)
2439     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2440     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2441 #endif
2442
2443     RETPUSHYES;
2444 #else
2445     DIE(aTHX_ PL_no_sock_func, "socketpair");
2446 #endif
2447 }
2448
2449 PP(pp_bind)
2450 {
2451 #ifdef HAS_SOCKET
2452     dVAR; dSP;
2453     SV * const addrsv = POPs;
2454     /* OK, so on what platform does bind modify addr?  */
2455     const char *addr;
2456     GV * const gv = (GV*)POPs;
2457     register IO * const io = GvIOn(gv);
2458     STRLEN len;
2459
2460     if (!io || !IoIFP(io))
2461         goto nuts;
2462
2463     addr = SvPV_const(addrsv, len);
2464     TAINT_PROPER("bind");
2465     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2466         RETPUSHYES;
2467     else
2468         RETPUSHUNDEF;
2469
2470 nuts:
2471     if (ckWARN(WARN_CLOSED))
2472         report_evil_fh(gv, io, PL_op->op_type);
2473     SETERRNO(EBADF,SS_IVCHAN);
2474     RETPUSHUNDEF;
2475 #else
2476     DIE(aTHX_ PL_no_sock_func, "bind");
2477 #endif
2478 }
2479
2480 PP(pp_connect)
2481 {
2482 #ifdef HAS_SOCKET
2483     dVAR; dSP;
2484     SV * const addrsv = POPs;
2485     GV * const gv = (GV*)POPs;
2486     register IO * const io = GvIOn(gv);
2487     const char *addr;
2488     STRLEN len;
2489
2490     if (!io || !IoIFP(io))
2491         goto nuts;
2492
2493     addr = SvPV_const(addrsv, len);
2494     TAINT_PROPER("connect");
2495     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2496         RETPUSHYES;
2497     else
2498         RETPUSHUNDEF;
2499
2500 nuts:
2501     if (ckWARN(WARN_CLOSED))
2502         report_evil_fh(gv, io, PL_op->op_type);
2503     SETERRNO(EBADF,SS_IVCHAN);
2504     RETPUSHUNDEF;
2505 #else
2506     DIE(aTHX_ PL_no_sock_func, "connect");
2507 #endif
2508 }
2509
2510 PP(pp_listen)
2511 {
2512 #ifdef HAS_SOCKET
2513     dVAR; dSP;
2514     const int backlog = POPi;
2515     GV * const gv = (GV*)POPs;
2516     register IO * const io = gv ? GvIOn(gv) : NULL;
2517
2518     if (!gv || !io || !IoIFP(io))
2519         goto nuts;
2520
2521     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2522         RETPUSHYES;
2523     else
2524         RETPUSHUNDEF;
2525
2526 nuts:
2527     if (ckWARN(WARN_CLOSED))
2528         report_evil_fh(gv, io, PL_op->op_type);
2529     SETERRNO(EBADF,SS_IVCHAN);
2530     RETPUSHUNDEF;
2531 #else
2532     DIE(aTHX_ PL_no_sock_func, "listen");
2533 #endif
2534 }
2535
2536 PP(pp_accept)
2537 {
2538 #ifdef HAS_SOCKET
2539     dVAR; dSP; dTARGET;
2540     register IO *nstio;
2541     register IO *gstio;
2542     char namebuf[MAXPATHLEN];
2543 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2544     Sock_size_t len = sizeof (struct sockaddr_in);
2545 #else
2546     Sock_size_t len = sizeof namebuf;
2547 #endif
2548     GV * const ggv = (GV*)POPs;
2549     GV * const ngv = (GV*)POPs;
2550     int fd;
2551
2552     if (!ngv)
2553         goto badexit;
2554     if (!ggv)
2555         goto nuts;
2556
2557     gstio = GvIO(ggv);
2558     if (!gstio || !IoIFP(gstio))
2559         goto nuts;
2560
2561     nstio = GvIOn(ngv);
2562     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2563 #if defined(OEMVS)
2564     if (len == 0) {
2565         /* Some platforms indicate zero length when an AF_UNIX client is
2566          * not bound. Simulate a non-zero-length sockaddr structure in
2567          * this case. */
2568         namebuf[0] = 0;        /* sun_len */
2569         namebuf[1] = AF_UNIX;  /* sun_family */
2570         len = 2;
2571     }
2572 #endif
2573
2574     if (fd < 0)
2575         goto badexit;
2576     if (IoIFP(nstio))
2577         do_close(ngv, FALSE);
2578     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2579     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2580     IoTYPE(nstio) = IoTYPE_SOCKET;
2581     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2582         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2583         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2584         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2585         goto badexit;
2586     }
2587 #if defined(HAS_FCNTL) && defined(F_SETFD)
2588     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2589 #endif
2590
2591 #ifdef EPOC
2592     len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2593     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2594 #endif
2595 #ifdef __SCO_VERSION__
2596     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2597 #endif
2598
2599     PUSHp(namebuf, len);
2600     RETURN;
2601
2602 nuts:
2603     if (ckWARN(WARN_CLOSED))
2604         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2605     SETERRNO(EBADF,SS_IVCHAN);
2606
2607 badexit:
2608     RETPUSHUNDEF;
2609
2610 #else
2611     DIE(aTHX_ PL_no_sock_func, "accept");
2612 #endif
2613 }
2614
2615 PP(pp_shutdown)
2616 {
2617 #ifdef HAS_SOCKET
2618     dVAR; dSP; dTARGET;
2619     const int how = POPi;
2620     GV * const gv = (GV*)POPs;
2621     register IO * const io = GvIOn(gv);
2622
2623     if (!io || !IoIFP(io))
2624         goto nuts;
2625
2626     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2627     RETURN;
2628
2629 nuts:
2630     if (ckWARN(WARN_CLOSED))
2631         report_evil_fh(gv, io, PL_op->op_type);
2632     SETERRNO(EBADF,SS_IVCHAN);
2633     RETPUSHUNDEF;
2634 #else
2635     DIE(aTHX_ PL_no_sock_func, "shutdown");
2636 #endif
2637 }
2638
2639 PP(pp_ssockopt)
2640 {
2641 #ifdef HAS_SOCKET
2642     dVAR; dSP;
2643     const int optype = PL_op->op_type;
2644     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2645     const unsigned int optname = (unsigned int) POPi;
2646     const unsigned int lvl = (unsigned int) POPi;
2647     GV * const gv = (GV*)POPs;
2648     register IO * const io = GvIOn(gv);
2649     int fd;
2650     Sock_size_t len;
2651
2652     if (!io || !IoIFP(io))
2653         goto nuts;
2654
2655     fd = PerlIO_fileno(IoIFP(io));
2656     switch (optype) {
2657     case OP_GSOCKOPT:
2658         SvGROW(sv, 257);
2659         (void)SvPOK_only(sv);
2660         SvCUR_set(sv,256);
2661         *SvEND(sv) ='\0';
2662         len = SvCUR(sv);
2663         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2664             goto nuts2;
2665         SvCUR_set(sv, len);
2666         *SvEND(sv) ='\0';
2667         PUSHs(sv);
2668         break;
2669     case OP_SSOCKOPT: {
2670 #if defined(__SYMBIAN32__)
2671 # define SETSOCKOPT_OPTION_VALUE_T void *
2672 #else
2673 # define SETSOCKOPT_OPTION_VALUE_T const char *
2674 #endif
2675         /* XXX TODO: We need to have a proper type (a Configure probe,
2676          * etc.) for what the C headers think of the third argument of
2677          * setsockopt(), the option_value read-only buffer: is it
2678          * a "char *", or a "void *", const or not.  Some compilers
2679          * don't take kindly to e.g. assuming that "char *" implicitly
2680          * promotes to a "void *", or to explicitly promoting/demoting
2681          * consts to non/vice versa.  The "const void *" is the SUS
2682          * definition, but that does not fly everywhere for the above
2683          * reasons. */
2684             SETSOCKOPT_OPTION_VALUE_T buf;
2685             int aint;
2686             if (SvPOKp(sv)) {
2687                 STRLEN l;
2688                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2689                 len = l;
2690             }
2691             else {
2692                 aint = (int)SvIV(sv);
2693                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2694                 len = sizeof(int);
2695             }
2696             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2697                 goto nuts2;
2698             PUSHs(&PL_sv_yes);
2699         }
2700         break;
2701     }
2702     RETURN;
2703
2704 nuts:
2705     if (ckWARN(WARN_CLOSED))
2706         report_evil_fh(gv, io, optype);
2707     SETERRNO(EBADF,SS_IVCHAN);
2708 nuts2:
2709     RETPUSHUNDEF;
2710
2711 #else
2712     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2713 #endif
2714 }
2715
2716 PP(pp_getpeername)
2717 {
2718 #ifdef HAS_SOCKET
2719     dVAR; dSP;
2720     const int optype = PL_op->op_type;
2721     GV * const gv = (GV*)POPs;
2722     register IO * const io = GvIOn(gv);
2723     Sock_size_t len;
2724     SV *sv;
2725     int fd;
2726
2727     if (!io || !IoIFP(io))
2728         goto nuts;
2729
2730     sv = sv_2mortal(newSV(257));
2731     (void)SvPOK_only(sv);
2732     len = 256;
2733     SvCUR_set(sv, len);
2734     *SvEND(sv) ='\0';
2735     fd = PerlIO_fileno(IoIFP(io));
2736     switch (optype) {
2737     case OP_GETSOCKNAME:
2738         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2739             goto nuts2;
2740         break;
2741     case OP_GETPEERNAME:
2742         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2743             goto nuts2;
2744 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2745         {
2746             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";
2747             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2748             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2749                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2750                         sizeof(u_short) + sizeof(struct in_addr))) {
2751                 goto nuts2;
2752             }
2753         }
2754 #endif
2755         break;
2756     }
2757 #ifdef BOGUS_GETNAME_RETURN
2758     /* Interactive Unix, getpeername() and getsockname()
2759       does not return valid namelen */
2760     if (len == BOGUS_GETNAME_RETURN)
2761         len = sizeof(struct sockaddr);
2762 #endif
2763     SvCUR_set(sv, len);
2764     *SvEND(sv) ='\0';
2765     PUSHs(sv);
2766     RETURN;
2767
2768 nuts:
2769     if (ckWARN(WARN_CLOSED))
2770         report_evil_fh(gv, io, optype);
2771     SETERRNO(EBADF,SS_IVCHAN);
2772 nuts2:
2773     RETPUSHUNDEF;
2774
2775 #else
2776     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2777 #endif
2778 }
2779
2780 /* Stat calls. */
2781
2782 PP(pp_stat)
2783 {
2784     dVAR;
2785     dSP;
2786     GV *gv = NULL;
2787     IO *io;
2788     I32 gimme;
2789     I32 max = 13;
2790
2791     if (PL_op->op_flags & OPf_REF) {
2792         gv = cGVOP_gv;
2793         if (PL_op->op_type == OP_LSTAT) {
2794             if (gv != PL_defgv) {
2795             do_fstat_warning_check:
2796                 if (ckWARN(WARN_IO))
2797                     Perl_warner(aTHX_ packWARN(WARN_IO),
2798                         "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2799             } else if (PL_laststype != OP_LSTAT)
2800                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2801         }
2802
2803       do_fstat:
2804         if (gv != PL_defgv) {
2805             PL_laststype = OP_STAT;
2806             PL_statgv = gv;
2807             sv_setpvn(PL_statname, "", 0);
2808             if(gv) {
2809                 io = GvIO(gv);
2810                 do_fstat_have_io:
2811                 if (io) {
2812                     if (IoIFP(io)) {
2813                         PL_laststatval =
2814                             PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2815                     } else if (IoDIRP(io)) {
2816                         PL_laststatval =
2817                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2818                     } else {
2819                         PL_laststatval = -1;
2820                     }
2821                 }
2822             }
2823         }
2824
2825         if (PL_laststatval < 0) {
2826             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2827                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2828             max = 0;
2829         }
2830     }
2831     else {
2832         SV* const sv = POPs;
2833         if (SvTYPE(sv) == SVt_PVGV) {
2834             gv = (GV*)sv;
2835             goto do_fstat;
2836         } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2837             gv = (GV*)SvRV(sv);
2838             if (PL_op->op_type == OP_LSTAT)
2839                 goto do_fstat_warning_check;
2840             goto do_fstat;
2841         } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2842             io = (IO*)SvRV(sv);
2843             if (PL_op->op_type == OP_LSTAT)
2844                 goto do_fstat_warning_check;
2845             goto do_fstat_have_io;
2846         }
2847
2848         sv_setpv(PL_statname, SvPV_nolen_const(sv));
2849         PL_statgv = NULL;
2850         PL_laststype = PL_op->op_type;
2851         if (PL_op->op_type == OP_LSTAT)
2852             PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2853         else
2854             PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2855         if (PL_laststatval < 0) {
2856             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2857                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2858             max = 0;
2859         }
2860     }
2861
2862     gimme = GIMME_V;
2863     if (gimme != G_ARRAY) {
2864         if (gimme != G_VOID)
2865             XPUSHs(boolSV(max));
2866         RETURN;
2867     }
2868     if (max) {
2869         EXTEND(SP, max);
2870         EXTEND_MORTAL(max);
2871         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2872         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2873         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2874         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2875 #if Uid_t_size > IVSIZE
2876         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2877 #else
2878 #   if Uid_t_sign <= 0
2879         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2880 #   else
2881         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2882 #   endif
2883 #endif
2884 #if Gid_t_size > IVSIZE
2885         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2886 #else
2887 #   if Gid_t_sign <= 0
2888         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2889 #   else
2890         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2891 #   endif
2892 #endif
2893 #ifdef USE_STAT_RDEV
2894         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2895 #else
2896         PUSHs(sv_2mortal(newSVpvs("")));
2897 #endif
2898 #if Off_t_size > IVSIZE
2899         PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2900 #else
2901         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2902 #endif
2903 #ifdef BIG_TIME
2904         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2905         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2906         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2907 #else
2908         PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2909         PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2910         PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
2911 #endif
2912 #ifdef USE_STAT_BLOCKS
2913         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2914         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2915 #else
2916         PUSHs(sv_2mortal(newSVpvs("")));
2917         PUSHs(sv_2mortal(newSVpvs("")));
2918 #endif
2919     }
2920     RETURN;
2921 }
2922
2923 /* This macro is used by the stacked filetest operators :
2924  * if the previous filetest failed, short-circuit and pass its value.
2925  * Else, discard it from the stack and continue. --rgs
2926  */
2927 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2928         if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2929         else { (void)POPs; PUTBACK; } \
2930     }
2931
2932 PP(pp_ftrread)
2933 {
2934     dVAR;
2935     I32 result;
2936     /* Not const, because things tweak this below. Not bool, because there's
2937        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2938 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2939     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2940     /* Giving some sort of initial value silences compilers.  */
2941 #  ifdef R_OK
2942     int access_mode = R_OK;
2943 #  else
2944     int access_mode = 0;
2945 #  endif
2946 #else
2947     /* access_mode is never used, but leaving use_access in makes the
2948        conditional compiling below much clearer.  */
2949     I32 use_access = 0;
2950 #endif
2951     int stat_mode = S_IRUSR;
2952
2953     bool effective = FALSE;
2954     dSP;
2955
2956     STACKED_FTEST_CHECK;
2957
2958     switch (PL_op->op_type) {
2959     case OP_FTRREAD:
2960 #if !(defined(HAS_ACCESS) && defined(R_OK))
2961         use_access = 0;
2962 #endif
2963         break;
2964
2965     case OP_FTRWRITE:
2966 #if defined(HAS_ACCESS) && defined(W_OK)
2967         access_mode = W_OK;
2968 #else
2969         use_access = 0;
2970 #endif
2971         stat_mode = S_IWUSR;
2972         break;
2973
2974     case OP_FTREXEC:
2975 #if defined(HAS_ACCESS) && defined(X_OK)
2976         access_mode = X_OK;
2977 #else
2978         use_access = 0;
2979 #endif
2980         stat_mode = S_IXUSR;
2981         break;
2982
2983     case OP_FTEWRITE:
2984 #ifdef PERL_EFF_ACCESS
2985         access_mode = W_OK;
2986 #endif
2987         stat_mode = S_IWUSR;
2988         /* Fall through  */
2989
2990     case OP_FTEREAD:
2991 #ifndef PERL_EFF_ACCESS
2992         use_access = 0;
2993 #endif
2994         effective = TRUE;
2995         break;
2996
2997
2998     case OP_FTEEXEC:
2999 #ifdef PERL_EFF_ACCESS
3000         access_mode = W_OK;
3001 #else
3002         use_access = 0;
3003 #endif
3004         stat_mode = S_IXUSR;
3005         effective = TRUE;
3006         break;
3007     }
3008
3009     if (use_access) {
3010 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3011         const char *name = POPpx;
3012         if (effective) {
3013 #  ifdef PERL_EFF_ACCESS
3014             result = PERL_EFF_ACCESS(name, access_mode);
3015 #  else
3016             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3017                 OP_NAME(PL_op));
3018 #  endif
3019         }
3020         else {
3021 #  ifdef HAS_ACCESS
3022             result = access(name, access_mode);
3023 #  else
3024             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3025 #  endif
3026         }
3027         if (result == 0)
3028             RETPUSHYES;
3029         if (result < 0)
3030             RETPUSHUNDEF;
3031         RETPUSHNO;
3032 #endif
3033     }
3034
3035     result = my_stat();
3036     SPAGAIN;
3037     if (result < 0)
3038         RETPUSHUNDEF;
3039     if (cando(stat_mode, effective, &PL_statcache))
3040         RETPUSHYES;
3041     RETPUSHNO;
3042 }
3043
3044 PP(pp_ftis)
3045 {
3046     dVAR;
3047     I32 result;
3048     const int op_type = PL_op->op_type;
3049     dSP;
3050     STACKED_FTEST_CHECK;
3051     result = my_stat();
3052     SPAGAIN;
3053     if (result < 0)
3054         RETPUSHUNDEF;
3055     if (op_type == OP_FTIS)
3056         RETPUSHYES;
3057     {
3058         /* You can't dTARGET inside OP_FTIS, because you'll get
3059            "panic: pad_sv po" - the op is not flagged to have a target.  */
3060         dTARGET;
3061         switch (op_type) {
3062         case OP_FTSIZE:
3063 #if Off_t_size > IVSIZE
3064             PUSHn(PL_statcache.st_size);
3065 #else
3066             PUSHi(PL_statcache.st_size);
3067 #endif
3068             break;
3069         case OP_FTMTIME:
3070             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3071             break;
3072         case OP_FTATIME:
3073             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3074             break;
3075         case OP_FTCTIME:
3076             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3077             break;
3078         }
3079     }
3080     RETURN;
3081 }
3082
3083 PP(pp_ftrowned)
3084 {
3085     dVAR;
3086     I32 result;
3087     dSP;
3088
3089     /* I believe that all these three are likely to be defined on most every
3090        system these days.  */
3091 #ifndef S_ISUID
3092     if(PL_op->op_type == OP_FTSUID)
3093         RETPUSHNO;
3094 #endif
3095 #ifndef S_ISGID
3096     if(PL_op->op_type == OP_FTSGID)
3097         RETPUSHNO;
3098 #endif
3099 #ifndef S_ISVTX
3100     if(PL_op->op_type == OP_FTSVTX)
3101         RETPUSHNO;
3102 #endif
3103
3104     STACKED_FTEST_CHECK;
3105     result = my_stat();
3106     SPAGAIN;
3107     if (result < 0)
3108         RETPUSHUNDEF;
3109     switch (PL_op->op_type) {
3110     case OP_FTROWNED:
3111         if (PL_statcache.st_uid == PL_uid)
3112             RETPUSHYES;
3113         break;
3114     case OP_FTEOWNED:
3115         if (PL_statcache.st_uid == PL_euid)
3116             RETPUSHYES;
3117         break;
3118     case OP_FTZERO:
3119         if (PL_statcache.st_size == 0)
3120             RETPUSHYES;
3121         break;
3122     case OP_FTSOCK:
3123         if (S_ISSOCK(PL_statcache.st_mode))
3124             RETPUSHYES;
3125         break;
3126     case OP_FTCHR:
3127         if (S_ISCHR(PL_statcache.st_mode))
3128             RETPUSHYES;
3129         break;
3130     case OP_FTBLK:
3131         if (S_ISBLK(PL_statcache.st_mode))
3132             RETPUSHYES;
3133         break;
3134     case OP_FTFILE:
3135         if (S_ISREG(PL_statcache.st_mode))
3136             RETPUSHYES;
3137         break;
3138     case OP_FTDIR:
3139         if (S_ISDIR(PL_statcache.st_mode))
3140             RETPUSHYES;
3141         break;
3142     case OP_FTPIPE:
3143         if (S_ISFIFO(PL_statcache.st_mode))
3144             RETPUSHYES;
3145         break;
3146 #ifdef S_ISUID
3147     case OP_FTSUID:
3148         if (PL_statcache.st_mode & S_ISUID)
3149             RETPUSHYES;
3150         break;
3151 #endif
3152 #ifdef S_ISGID
3153     case OP_FTSGID:
3154         if (PL_statcache.st_mode & S_ISGID)
3155             RETPUSHYES;
3156         break;
3157 #endif
3158 #ifdef S_ISVTX
3159     case OP_FTSVTX:
3160         if (PL_statcache.st_mode & S_ISVTX)
3161             RETPUSHYES;
3162         break;
3163 #endif
3164     }
3165     RETPUSHNO;
3166 }
3167
3168 PP(pp_ftlink)
3169 {
3170     dVAR;
3171     I32 result = my_lstat();
3172     dSP;
3173     if (result < 0)
3174         RETPUSHUNDEF;
3175     if (S_ISLNK(PL_statcache.st_mode))
3176         RETPUSHYES;
3177     RETPUSHNO;
3178 }
3179
3180 PP(pp_fttty)
3181 {
3182     dVAR;
3183     dSP;
3184     int fd;
3185     GV *gv;
3186     SV *tmpsv = NULL;
3187
3188     STACKED_FTEST_CHECK;
3189
3190     if (PL_op->op_flags & OPf_REF)
3191         gv = cGVOP_gv;
3192     else if (isGV(TOPs))
3193         gv = (GV*)POPs;
3194     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3195         gv = (GV*)SvRV(POPs);
3196     else
3197         gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3198
3199     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3200         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3201     else if (tmpsv && SvOK(tmpsv)) {
3202         const char *tmps = SvPV_nolen_const(tmpsv);
3203         if (isDIGIT(*tmps))
3204             fd = atoi(tmps);
3205         else
3206             RETPUSHUNDEF;
3207     }
3208     else
3209         RETPUSHUNDEF;
3210     if (PerlLIO_isatty(fd))
3211         RETPUSHYES;
3212     RETPUSHNO;
3213 }
3214
3215 #if defined(atarist) /* this will work with atariST. Configure will
3216                         make guesses for other systems. */
3217 # define FILE_base(f) ((f)->_base)
3218 # define FILE_ptr(f) ((f)->_ptr)
3219 # define FILE_cnt(f) ((f)->_cnt)
3220 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3221 #endif
3222
3223 PP(pp_fttext)
3224 {
3225     dVAR;
3226     dSP;
3227     I32 i;
3228     I32 len;
3229     I32 odd = 0;
3230     STDCHAR tbuf[512];
3231     register STDCHAR *s;
3232     register IO *io;
3233     register SV *sv;
3234     GV *gv;
3235     PerlIO *fp;
3236
3237     STACKED_FTEST_CHECK;
3238
3239     if (PL_op->op_flags & OPf_REF)
3240         gv = cGVOP_gv;
3241     else if (isGV(TOPs))
3242         gv = (GV*)POPs;
3243     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3244         gv = (GV*)SvRV(POPs);
3245     else
3246         gv = NULL;
3247
3248     if (gv) {
3249         EXTEND(SP, 1);
3250         if (gv == PL_defgv) {
3251             if (PL_statgv)
3252                 io = GvIO(PL_statgv);
3253             else {
3254                 sv = PL_statname;
3255                 goto really_filename;
3256             }
3257         }
3258         else {
3259             PL_statgv = gv;
3260             PL_laststatval = -1;
3261             sv_setpvn(PL_statname, "", 0);
3262             io = GvIO(PL_statgv);
3263         }
3264         if (io && IoIFP(io)) {
3265             if (! PerlIO_has_base(IoIFP(io)))
3266                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3267             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3268             if (PL_laststatval < 0)
3269                 RETPUSHUNDEF;
3270             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3271                 if (PL_op->op_type == OP_FTTEXT)
3272                     RETPUSHNO;
3273                 else
3274                     RETPUSHYES;
3275             }
3276             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3277                 i = PerlIO_getc(IoIFP(io));
3278                 if (i != EOF)
3279                     (void)PerlIO_ungetc(IoIFP(io),i);
3280             }
3281             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3282                 RETPUSHYES;
3283             len = PerlIO_get_bufsiz(IoIFP(io));
3284             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3285             /* sfio can have large buffers - limit to 512 */
3286             if (len > 512)
3287                 len = 512;
3288         }
3289         else {
3290             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3291                 gv = cGVOP_gv;
3292                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3293             }
3294             SETERRNO(EBADF,RMS_IFI);
3295             RETPUSHUNDEF;
3296         }
3297     }
3298     else {
3299         sv = POPs;
3300       really_filename:
3301         PL_statgv = NULL;
3302         PL_laststype = OP_STAT;
3303         sv_setpv(PL_statname, SvPV_nolen_const(sv));
3304         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3305             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3306                                                '\n'))
3307                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3308             RETPUSHUNDEF;
3309         }
3310         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3311         if (PL_laststatval < 0) {
3312             (void)PerlIO_close(fp);
3313             RETPUSHUNDEF;
3314         }
3315         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3316         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3317         (void)PerlIO_close(fp);
3318         if (len <= 0) {
3319             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3320                 RETPUSHNO;              /* special case NFS directories */
3321             RETPUSHYES;         /* null file is anything */
3322         }
3323         s = tbuf;
3324     }
3325
3326     /* now scan s to look for textiness */
3327     /*   XXX ASCII dependent code */
3328
3329 #if defined(DOSISH) || defined(USEMYBINMODE)
3330     /* ignore trailing ^Z on short files */
3331     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3332         --len;
3333 #endif
3334
3335     for (i = 0; i < len; i++, s++) {
3336         if (!*s) {                      /* null never allowed in text */
3337             odd += len;
3338             break;
3339         }
3340 #ifdef EBCDIC
3341         else if (!(isPRINT(*s) || isSPACE(*s)))
3342             odd++;
3343 #else
3344         else if (*s & 128) {
3345 #ifdef USE_LOCALE
3346             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3347                 continue;
3348 #endif
3349             /* utf8 characters don't count as odd */
3350             if (UTF8_IS_START(*s)) {
3351                 int ulen = UTF8SKIP(s);
3352                 if (ulen < len - i) {
3353                     int j;
3354                     for (j = 1; j < ulen; j++) {
3355                         if (!UTF8_IS_CONTINUATION(s[j]))
3356                             goto not_utf8;
3357                     }
3358                     --ulen;     /* loop does extra increment */
3359                     s += ulen;
3360                     i += ulen;
3361                     continue;
3362                 }
3363             }
3364           not_utf8:
3365             odd++;
3366         }
3367         else if (*s < 32 &&
3368           *s != '\n' && *s != '\r' && *s != '\b' &&
3369           *s != '\t' && *s != '\f' && *s != 27)
3370             odd++;
3371 #endif
3372     }
3373
3374     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3375         RETPUSHNO;
3376     else
3377         RETPUSHYES;
3378 }
3379
3380 /* File calls. */
3381
3382 PP(pp_chdir)
3383 {
3384     dVAR; dSP; dTARGET;
3385     const char *tmps = NULL;
3386     GV *gv = NULL;
3387
3388     if( MAXARG == 1 ) {
3389         SV * const sv = POPs;
3390         if (PL_op->op_flags & OPf_SPECIAL) {
3391             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3392         }
3393         else if (SvTYPE(sv) == SVt_PVGV) {
3394             gv = (GV*)sv;
3395         }
3396         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3397             gv = (GV*)SvRV(sv);
3398         }
3399         else {
3400             tmps = SvPV_nolen_const(sv);
3401         }
3402     }
3403
3404     if( !gv && (!tmps || !*tmps) ) {
3405         HV * const table = GvHVn(PL_envgv);
3406         SV **svp;
3407
3408         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3409              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3410 #ifdef VMS
3411              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3412 #endif
3413            )
3414         {
3415             if( MAXARG == 1 )
3416                 deprecate("chdir('') or chdir(undef) as chdir()");
3417             tmps = SvPV_nolen_const(*svp);
3418         }
3419         else {
3420             PUSHi(0);
3421             TAINT_PROPER("chdir");
3422             RETURN;
3423         }
3424     }
3425
3426     TAINT_PROPER("chdir");
3427     if (gv) {
3428 #ifdef HAS_FCHDIR
3429         IO* const io = GvIO(gv);
3430         if (io) {
3431             if (IoDIRP(io)) {
3432                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3433             } else if (IoIFP(io)) {
3434                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3435             }
3436             else {
3437                 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3438                     report_evil_fh(gv, io, PL_op->op_type);
3439                 SETERRNO(EBADF, RMS_IFI);
3440                 PUSHi(0);
3441             }
3442         }
3443         else {
3444             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3445                 report_evil_fh(gv, io, PL_op->op_type);
3446             SETERRNO(EBADF,RMS_IFI);
3447             PUSHi(0);
3448         }
3449 #else
3450         DIE(aTHX_ PL_no_func, "fchdir");
3451 #endif
3452     }
3453     else
3454         PUSHi( PerlDir_chdir(tmps) >= 0 );
3455 #ifdef VMS
3456     /* Clear the DEFAULT element of ENV so we'll get the new value
3457      * in the future. */
3458     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3459 #endif
3460     RETURN;
3461 }
3462
3463 PP(pp_chown)
3464 {
3465     dVAR; dSP; dMARK; dTARGET;
3466     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3467
3468     SP = MARK;
3469     XPUSHi(value);
3470     RETURN;
3471 }
3472
3473 PP(pp_chroot)
3474 {
3475 #ifdef HAS_CHROOT
3476     dVAR; dSP; dTARGET;
3477     char * const tmps = POPpx;
3478     TAINT_PROPER("chroot");
3479     PUSHi( chroot(tmps) >= 0 );
3480     RETURN;
3481 #else
3482     DIE(aTHX_ PL_no_func, "chroot");
3483 #endif
3484 }
3485
3486 PP(pp_rename)
3487 {
3488     dVAR; dSP; dTARGET;
3489     int anum;
3490     const char * const tmps2 = POPpconstx;
3491     const char * const tmps = SvPV_nolen_const(TOPs);
3492     TAINT_PROPER("rename");
3493 #ifdef HAS_RENAME
3494     anum = PerlLIO_rename(tmps, tmps2);
3495 #else
3496     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3497         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3498             anum = 1;
3499         else {
3500             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3501                 (void)UNLINK(tmps2);
3502             if (!(anum = link(tmps, tmps2)))
3503                 anum = UNLINK(tmps);
3504         }
3505     }
3506 #endif
3507     SETi( anum >= 0 );
3508     RETURN;
3509 }
3510
3511 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3512 PP(pp_link)
3513 {
3514     dVAR; dSP; dTARGET;
3515     const int op_type = PL_op->op_type;
3516     int result;
3517
3518 #  ifndef HAS_LINK
3519     if (op_type == OP_LINK)
3520         DIE(aTHX_ PL_no_func, "link");
3521 #  endif
3522 #  ifndef HAS_SYMLINK
3523     if (op_type == OP_SYMLINK)
3524         DIE(aTHX_ PL_no_func, "symlink");
3525 #  endif
3526
3527     {
3528         const char * const tmps2 = POPpconstx;
3529         const char * const tmps = SvPV_nolen_const(TOPs);
3530         TAINT_PROPER(PL_op_desc[op_type]);
3531         result =
3532 #  if defined(HAS_LINK)
3533 #    if defined(HAS_SYMLINK)
3534             /* Both present - need to choose which.  */
3535             (op_type == OP_LINK) ?
3536             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3537 #    else
3538     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3539         PerlLIO_link(tmps, tmps2);
3540 #    endif
3541 #  else
3542 #    if defined(HAS_SYMLINK)
3543     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3544         symlink(tmps, tmps2);
3545 #    endif
3546 #  endif
3547     }
3548
3549     SETi( result >= 0 );
3550     RETURN;
3551 }
3552 #else
3553 PP(pp_link)
3554 {
3555     /* Have neither.  */
3556     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3557 }
3558 #endif
3559
3560 PP(pp_readlink)
3561 {
3562     dVAR;
3563     dSP;
3564 #ifdef HAS_SYMLINK
3565     dTARGET;
3566     const char *tmps;
3567     char buf[MAXPATHLEN];
3568     int len;
3569
3570 #ifndef INCOMPLETE_TAINTS
3571     TAINT;
3572 #endif
3573     tmps = POPpconstx;
3574     len = readlink(tmps, buf, sizeof(buf) - 1);
3575     EXTEND(SP, 1);
3576     if (len < 0)
3577         RETPUSHUNDEF;
3578     PUSHp(buf, len);
3579     RETURN;
3580 #else
3581     EXTEND(SP, 1);
3582     RETSETUNDEF;                /* just pretend it's a normal file */
3583 #endif
3584 }
3585
3586 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3587 STATIC int
3588 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3589 {
3590     char * const save_filename = filename;
3591     char *cmdline;
3592     char *s;
3593     PerlIO *myfp;
3594     int anum = 1;
3595     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3596
3597     Newx(cmdline, size, char);
3598     my_strlcpy(cmdline, cmd, size);
3599     my_strlcat(cmdline, " ", size);
3600     for (s = cmdline + strlen(cmdline); *filename; ) {
3601         *s++ = '\\';
3602         *s++ = *filename++;
3603     }
3604     if (s - cmdline < size)
3605         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3606     myfp = PerlProc_popen(cmdline, "r");
3607     Safefree(cmdline);
3608
3609     if (myfp) {
3610         SV * const tmpsv = sv_newmortal();
3611         /* Need to save/restore 'PL_rs' ?? */
3612         s = sv_gets(tmpsv, myfp, 0);
3613         (void)PerlProc_pclose(myfp);
3614         if (s != NULL) {
3615             int e;
3616             for (e = 1;
3617 #ifdef HAS_SYS_ERRLIST
3618                  e <= sys_nerr
3619 #endif
3620                  ; e++)
3621             {
3622                 /* you don't see this */
3623                 const char * const errmsg =
3624 #ifdef HAS_SYS_ERRLIST
3625                     sys_errlist[e]
3626 #else
3627                     strerror(e)
3628 #endif
3629                     ;
3630                 if (!errmsg)
3631                     break;
3632                 if (instr(s, errmsg)) {
3633                     SETERRNO(e,0);
3634                     return 0;
3635                 }
3636             }
3637             SETERRNO(0,0);
3638 #ifndef EACCES
3639 #define EACCES EPERM
3640 #endif
3641             if (instr(s, "cannot make"))
3642                 SETERRNO(EEXIST,RMS_FEX);
3643             else if (instr(s, "existing file"))
3644                 SETERRNO(EEXIST,RMS_FEX);
3645             else if (instr(s, "ile exists"))
3646                 SETERRNO(EEXIST,RMS_FEX);
3647             else if (instr(s, "non-exist"))
3648                 SETERRNO(ENOENT,RMS_FNF);
3649             else if (instr(s, "does not exist"))
3650                 SETERRNO(ENOENT,RMS_FNF);
3651             else if (instr(s, "not empty"))
3652                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3653             else if (instr(s, "cannot access"))
3654                 SETERRNO(EACCES,RMS_PRV);
3655             else
3656                 SETERRNO(EPERM,RMS_PRV);
3657             return 0;
3658         }
3659         else {  /* some mkdirs return no failure indication */
3660             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3661             if (PL_op->op_type == OP_RMDIR)
3662                 anum = !anum;
3663             if (anum)
3664                 SETERRNO(0,0);
3665             else
3666                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3667         }
3668         return anum;
3669     }
3670     else
3671         return 0;
3672 }
3673 #endif
3674
3675 /* This macro removes trailing slashes from a directory name.
3676  * Different operating and file systems take differently to
3677  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3678  * any number of trailing slashes should be allowed.
3679  * Thusly we snip them away so that even non-conforming
3680  * systems are happy.
3681  * We should probably do this "filtering" for all
3682  * the functions that expect (potentially) directory names:
3683  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3684  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3685
3686 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3687     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3688         do { \
3689             (len)--; \
3690         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3691         (tmps) = savepvn((tmps), (len)); \
3692         (copy) = TRUE; \
3693     }
3694
3695 PP(pp_mkdir)
3696 {
3697     dVAR; dSP; dTARGET;
3698     STRLEN len;
3699     const char *tmps;
3700     bool copy = FALSE;
3701     const int mode = (MAXARG > 1) ? POPi : 0777;
3702
3703     TRIMSLASHES(tmps,len,copy);
3704
3705     TAINT_PROPER("mkdir");
3706 #ifdef HAS_MKDIR
3707     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3708 #else
3709     {
3710     int oldumask;
3711     SETi( dooneliner("mkdir", tmps) );
3712     oldumask = PerlLIO_umask(0);
3713     PerlLIO_umask(oldumask);
3714     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3715     }
3716 #endif
3717     if (copy)
3718         Safefree(tmps);
3719     RETURN;
3720 }
3721
3722 PP(pp_rmdir)
3723 {
3724     dVAR; dSP; dTARGET;
3725     STRLEN len;
3726     const char *tmps;
3727     bool copy = FALSE;
3728
3729     TRIMSLASHES(tmps,len,copy);
3730     TAINT_PROPER("rmdir");
3731 #ifdef HAS_RMDIR
3732     SETi( PerlDir_rmdir(tmps) >= 0 );
3733 #else
3734     SETi( dooneliner("rmdir", tmps) );
3735 #endif
3736     if (copy)
3737         Safefree(tmps);
3738     RETURN;
3739 }
3740
3741 /* Directory calls. */
3742
3743 PP(pp_open_dir)
3744 {
3745 #if defined(Direntry_t) && defined(HAS_READDIR)
3746     dVAR; dSP;
3747     const char * const dirname = POPpconstx;
3748     GV * const gv = (GV*)POPs;
3749     register IO * const io = GvIOn(gv);
3750
3751     if (!io)
3752         goto nope;
3753
3754     if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3755         Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3756                 "Opening filehandle %s also as a directory", GvENAME(gv));
3757     if (IoDIRP(io))
3758         PerlDir_close(IoDIRP(io));
3759     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3760         goto nope;
3761
3762     RETPUSHYES;
3763 nope:
3764     if (!errno)
3765         SETERRNO(EBADF,RMS_DIR);
3766     RETPUSHUNDEF;
3767 #else
3768     DIE(aTHX_ PL_no_dir_func, "opendir");
3769 #endif
3770 }
3771
3772 PP(pp_readdir)
3773 {
3774 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3775     DIE(aTHX_ PL_no_dir_func, "readdir");
3776 #else
3777 #if !defined(I_DIRENT) && !defined(VMS)
3778     Direntry_t *readdir (DIR *);
3779 #endif
3780     dVAR;
3781     dSP;
3782
3783     SV *sv;
3784     const I32 gimme = GIMME;
3785     GV * const gv = (GV *)POPs;
3786     register const Direntry_t *dp;
3787     register IO * const io = GvIOn(gv);
3788
3789     if (!io || !IoDIRP(io)) {
3790         if(ckWARN(WARN_IO)) {
3791             Perl_warner(aTHX_ packWARN(WARN_IO),
3792                 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3793         }
3794         goto nope;
3795     }
3796
3797     do {
3798         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3799         if (!dp)
3800             break;
3801 #ifdef DIRNAMLEN
3802         sv = newSVpvn(dp->d_name, dp->d_namlen);
3803 #else
3804         sv = newSVpv(dp->d_name, 0);
3805 #endif
3806 #ifndef INCOMPLETE_TAINTS
3807         if (!(IoFLAGS(io) & IOf_UNTAINT))
3808             SvTAINTED_on(sv);
3809 #endif
3810         XPUSHs(sv_2mortal(sv));
3811     } while (gimme == G_ARRAY);
3812
3813     if (!dp && gimme != G_ARRAY)
3814         goto nope;
3815
3816     RETURN;
3817
3818 nope:
3819     if (!errno)
3820         SETERRNO(EBADF,RMS_ISI);
3821     if (GIMME == G_ARRAY)
3822         RETURN;
3823     else
3824         RETPUSHUNDEF;
3825 #endif
3826 }
3827
3828 PP(pp_telldir)
3829 {
3830 #if defined(HAS_TELLDIR) || defined(telldir)
3831     dVAR; dSP; dTARGET;
3832  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3833  /* XXX netbsd still seemed to.
3834     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3835     --JHI 1999-Feb-02 */
3836 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3837     long telldir (DIR *);
3838 # endif
3839     GV * const gv = (GV*)POPs;
3840     register IO * const io = GvIOn(gv);
3841
3842     if (!io || !IoDIRP(io)) {
3843         if(ckWARN(WARN_IO)) {
3844             Perl_warner(aTHX_ packWARN(WARN_IO),
3845                 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3846         }
3847         goto nope;
3848     }
3849
3850     PUSHi( PerlDir_tell(IoDIRP(io)) );
3851     RETURN;
3852 nope:
3853     if (!errno)
3854         SETERRNO(EBADF,RMS_ISI);
3855     RETPUSHUNDEF;
3856 #else
3857     DIE(aTHX_ PL_no_dir_func, "telldir");
3858 #endif
3859 }
3860
3861 PP(pp_seekdir)
3862 {
3863 #if defined(HAS_SEEKDIR) || defined(seekdir)
3864     dVAR; dSP;
3865     const long along = POPl;
3866     GV * const gv = (GV*)POPs;
3867     register IO * const io = GvIOn(gv);
3868
3869     if (!io || !IoDIRP(io)) {
3870         if(ckWARN(WARN_IO)) {
3871             Perl_warner(aTHX_ packWARN(WARN_IO),
3872                 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3873         }
3874         goto nope;
3875     }
3876     (void)PerlDir_seek(IoDIRP(io), along);
3877
3878     RETPUSHYES;
3879 nope:
3880     if (!errno)
3881         SETERRNO(EBADF,RMS_ISI);
3882     RETPUSHUNDEF;
3883 #else
3884     DIE(aTHX_ PL_no_dir_func, "seekdir");
3885 #endif
3886 }
3887
3888 PP(pp_rewinddir)
3889 {
3890 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3891     dVAR; dSP;
3892     GV * const gv = (GV*)POPs;
3893     register IO * const io = GvIOn(gv);
3894
3895     if (!io || !IoDIRP(io)) {
3896         if(ckWARN(WARN_IO)) {
3897             Perl_warner(aTHX_ packWARN(WARN_IO),
3898                 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3899         }
3900         goto nope;
3901     }
3902     (void)PerlDir_rewind(IoDIRP(io));
3903     RETPUSHYES;
3904 nope:
3905     if (!errno)
3906         SETERRNO(EBADF,RMS_ISI);
3907     RETPUSHUNDEF;
3908 #else
3909     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3910 #endif
3911 }
3912
3913 PP(pp_closedir)
3914 {
3915 #if defined(Direntry_t) && defined(HAS_READDIR)
3916     dVAR; dSP;
3917     GV * const gv = (GV*)POPs;
3918     register IO * const io = GvIOn(gv);
3919
3920     if (!io || !IoDIRP(io)) {
3921         if(ckWARN(WARN_IO)) {
3922             Perl_warner(aTHX_ packWARN(WARN_IO),
3923                 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3924         }
3925         goto nope;
3926     }
3927 #ifdef VOID_CLOSEDIR
3928     PerlDir_close(IoDIRP(io));
3929 #else
3930     if (PerlDir_close(IoDIRP(io)) < 0) {
3931         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3932         goto nope;
3933     }
3934 #endif
3935     IoDIRP(io) = 0;
3936
3937     RETPUSHYES;
3938 nope:
3939     if (!errno)
3940         SETERRNO(EBADF,RMS_IFI);
3941     RETPUSHUNDEF;
3942 #else
3943     DIE(aTHX_ PL_no_dir_func, "closedir");
3944 #endif
3945 }
3946
3947 /* Process control. */
3948
3949 PP(pp_fork)
3950 {
3951 #ifdef HAS_FORK
3952     dVAR; dSP; dTARGET;
3953     Pid_t childpid;
3954
3955     EXTEND(SP, 1);
3956     PERL_FLUSHALL_FOR_CHILD;
3957     childpid = PerlProc_fork();
3958     if (childpid < 0)
3959         RETSETUNDEF;
3960     if (!childpid) {
3961         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3962         if (tmpgv) {
3963             SvREADONLY_off(GvSV(tmpgv));
3964             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3965             SvREADONLY_on(GvSV(tmpgv));
3966         }
3967 #ifdef THREADS_HAVE_PIDS
3968         PL_ppid = (IV)getppid();
3969 #endif
3970 #ifdef PERL_USES_PL_PIDSTATUS
3971         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3972 #endif
3973     }
3974     PUSHi(childpid);
3975     RETURN;
3976 #else
3977 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3978     dSP; dTARGET;
3979     Pid_t childpid;
3980
3981     EXTEND(SP, 1);
3982     PERL_FLUSHALL_FOR_CHILD;
3983     childpid = PerlProc_fork();
3984     if (childpid == -1)
3985         RETSETUNDEF;
3986     PUSHi(childpid);
3987     RETURN;
3988 #  else
3989     DIE(aTHX_ PL_no_func, "fork");
3990 #  endif
3991 #endif
3992 }
3993
3994 PP(pp_wait)
3995 {
3996 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
3997     dVAR; dSP; dTARGET;
3998     Pid_t childpid;
3999     int argflags;
4000
4001     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4002         childpid = wait4pid(-1, &argflags, 0);
4003     else {
4004         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4005                errno == EINTR) {
4006           PERL_ASYNC_CHECK();
4007         }
4008     }
4009 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4010     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4011     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4012 #  else
4013     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4014 #  endif
4015     XPUSHi(childpid);
4016     RETURN;
4017 #else
4018     DIE(aTHX_ PL_no_func, "wait");
4019 #endif
4020 }
4021
4022 PP(pp_waitpid)
4023 {
4024 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4025     dVAR; dSP; dTARGET;
4026     const int optype = POPi;
4027     const Pid_t pid = TOPi;
4028     Pid_t result;
4029     int argflags;
4030
4031     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4032         result = wait4pid(pid, &argflags, optype);
4033     else {
4034         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4035                errno == EINTR) {
4036           PERL_ASYNC_CHECK();
4037         }
4038     }
4039 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4040     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4041     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4042 #  else
4043     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4044 #  endif
4045     SETi(result);
4046     RETURN;
4047 #else
4048     DIE(aTHX_ PL_no_func, "waitpid");
4049 #endif
4050 }
4051
4052 PP(pp_system)
4053 {
4054     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4055 #if defined(__LIBCATAMOUNT__)
4056     PL_statusvalue = -1;
4057     SP = ORIGMARK;
4058     XPUSHi(-1);
4059 #else
4060     I32 value;
4061     int result;
4062
4063     if (PL_tainting) {
4064         TAINT_ENV();
4065         while (++MARK <= SP) {
4066             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4067             if (PL_tainted)
4068                 break;
4069         }
4070         MARK = ORIGMARK;
4071         TAINT_PROPER("system");
4072     }
4073     PERL_FLUSHALL_FOR_CHILD;
4074 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4075     {
4076         Pid_t childpid;
4077         int pp[2];
4078         I32 did_pipes = 0;
4079
4080         if (PerlProc_pipe(pp) >= 0)
4081             did_pipes = 1;
4082         while ((childpid = PerlProc_fork()) == -1) {
4083             if (errno != EAGAIN) {
4084                 value = -1;
4085                 SP = ORIGMARK;
4086                 XPUSHi(value);
4087                 if (did_pipes) {
4088                     PerlLIO_close(pp[0]);
4089                     PerlLIO_close(pp[1]);
4090                 }
4091                 RETURN;
4092             }
4093             sleep(5);
4094         }
4095         if (childpid > 0) {
4096             Sigsave_t ihand,qhand; /* place to save signals during system() */
4097             int status;
4098
4099             if (did_pipes)
4100                 PerlLIO_close(pp[1]);
4101 #ifndef PERL_MICRO
4102             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4103             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4104 #endif
4105             do {
4106                 result = wait4pid(childpid, &status, 0);
4107             } while (result == -1 && errno == EINTR);
4108 #ifndef PERL_MICRO
4109             (void)rsignal_restore(SIGINT, &ihand);
4110             (void)rsignal_restore(SIGQUIT, &qhand);
4111 #endif
4112             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4113             do_execfree();      /* free any memory child malloced on fork */
4114             SP = ORIGMARK;
4115             if (did_pipes) {
4116                 int errkid;
4117                 unsigned n = 0;
4118                 SSize_t n1;
4119
4120                 while (n < sizeof(int)) {
4121                     n1 = PerlLIO_read(pp[0],
4122                                       (void*)(((char*)&errkid)+n),
4123                                       (sizeof(int)) - n);
4124                     if (n1 <= 0)
4125                         break;
4126                     n += n1;
4127                 }
4128                 PerlLIO_close(pp[0]);
4129                 if (n) {                        /* Error */
4130                     if (n != sizeof(int))
4131                         DIE(aTHX_ "panic: kid popen errno read");
4132                     errno = errkid;             /* Propagate errno from kid */
4133                     STATUS_NATIVE_CHILD_SET(-1);
4134                 }
4135             }
4136             XPUSHi(STATUS_CURRENT);
4137             RETURN;
4138         }
4139         if (did_pipes) {
4140             PerlLIO_close(pp[0]);
4141 #if defined(HAS_FCNTL) && defined(F_SETFD)
4142             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4143 #endif
4144         }
4145         if (PL_op->op_flags & OPf_STACKED) {
4146             SV * const really = *++MARK;
4147             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4148         }
4149         else if (SP - MARK != 1)
4150             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4151         else {
4152             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4153         }
4154         PerlProc__exit(-1);
4155     }
4156 #else /* ! FORK or VMS or OS/2 */
4157     PL_statusvalue = 0;
4158     result = 0;
4159     if (PL_op->op_flags & OPf_STACKED) {
4160         SV * const really = *++MARK;
4161 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4162         value = (I32)do_aspawn(really, MARK, SP);
4163 #  else
4164         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4165 #  endif
4166     }
4167     else if (SP - MARK != 1) {
4168 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4169         value = (I32)do_aspawn(NULL, MARK, SP);
4170 #  else
4171         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4172 #  endif
4173     }
4174     else {
4175         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4176     }
4177     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4178         result = 1;
4179     STATUS_NATIVE_CHILD_SET(value);
4180     do_execfree();
4181     SP = ORIGMARK;
4182     XPUSHi(result ? value : STATUS_CURRENT);
4183 #endif /* !FORK or VMS or OS/2 */
4184 #endif
4185     RETURN;
4186 }
4187
4188 PP(pp_exec)
4189 {
4190     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4191     I32 value;
4192
4193     if (PL_tainting) {
4194         TAINT_ENV();
4195         while (++MARK <= SP) {
4196             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4197             if (PL_tainted)
4198                 break;
4199         }
4200         MARK = ORIGMARK;
4201         TAINT_PROPER("exec");
4202     }
4203     PERL_FLUSHALL_FOR_CHILD;
4204     if (PL_op->op_flags & OPf_STACKED) {
4205         SV * const really = *++MARK;
4206         value = (I32)do_aexec(really, MARK, SP);
4207     }
4208     else if (SP - MARK != 1)
4209 #ifdef VMS
4210         value = (I32)vms_do_aexec(NULL, MARK, SP);
4211 #else
4212 #  ifdef __OPEN_VM
4213         {
4214            (void ) do_aspawn(NULL, MARK, SP);
4215            value = 0;
4216         }
4217 #  else
4218         value = (I32)do_aexec(NULL, MARK, SP);
4219 #  endif
4220 #endif
4221     else {
4222 #ifdef VMS
4223         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4224 #else
4225 #  ifdef __OPEN_VM
4226         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4227         value = 0;
4228 #  else
4229         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4230 #  endif
4231 #endif
4232     }
4233
4234     SP = ORIGMARK;
4235     XPUSHi(value);
4236     RETURN;
4237 }
4238
4239 PP(pp_getppid)
4240 {
4241 #ifdef HAS_GETPPID
4242     dVAR; dSP; dTARGET;
4243 #   ifdef THREADS_HAVE_PIDS
4244     if (PL_ppid != 1 && getppid() == 1)
4245         /* maybe the parent process has died. Refresh ppid cache */
4246         PL_ppid = 1;
4247     XPUSHi( PL_ppid );
4248 #   else
4249     XPUSHi( getppid() );
4250 #   endif
4251     RETURN;
4252 #else
4253     DIE(aTHX_ PL_no_func, "getppid");
4254 #endif
4255 }
4256
4257 PP(pp_getpgrp)
4258 {
4259 #ifdef HAS_GETPGRP
4260     dVAR; dSP; dTARGET;
4261     Pid_t pgrp;
4262     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4263
4264 #ifdef BSD_GETPGRP
4265     pgrp = (I32)BSD_GETPGRP(pid);
4266 #else
4267     if (pid != 0 && pid != PerlProc_getpid())
4268         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4269     pgrp = getpgrp();
4270 #endif
4271     XPUSHi(pgrp);
4272     RETURN;
4273 #else
4274     DIE(aTHX_ PL_no_func, "getpgrp()");
4275 #endif
4276 }
4277
4278 PP(pp_setpgrp)
4279 {
4280 #ifdef HAS_SETPGRP
4281     dVAR; dSP; dTARGET;
4282     Pid_t pgrp;
4283     Pid_t pid;
4284     if (MAXARG < 2) {
4285         pgrp = 0;
4286         pid = 0;
4287     }
4288     else {
4289         pgrp = POPi;
4290         pid = TOPi;
4291     }
4292
4293     TAINT_PROPER("setpgrp");
4294 #ifdef BSD_SETPGRP
4295     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4296 #else
4297     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4298         || (pid != 0 && pid != PerlProc_getpid()))
4299     {
4300         DIE(aTHX_ "setpgrp can't take arguments");
4301     }
4302     SETi( setpgrp() >= 0 );
4303 #endif /* USE_BSDPGRP */
4304     RETURN;
4305 #else
4306     DIE(aTHX_ PL_no_func, "setpgrp()");
4307 #endif
4308 }
4309
4310 PP(pp_getpriority)
4311 {
4312 #ifdef HAS_GETPRIORITY
4313     dVAR; dSP; dTARGET;
4314     const int who = POPi;
4315     const int which = TOPi;
4316     SETi( getpriority(which, who) );
4317     RETURN;
4318 #else
4319     DIE(aTHX_ PL_no_func, "getpriority()");
4320 #endif
4321 }
4322
4323 PP(pp_setpriority)
4324 {
4325 #ifdef HAS_SETPRIORITY
4326     dVAR; dSP; dTARGET;
4327     const int niceval = POPi;
4328     const int who = POPi;
4329     const int which = TOPi;
4330     TAINT_PROPER("setpriority");
4331     SETi( setpriority(which, who, niceval) >= 0 );
4332     RETURN;
4333 #else
4334     DIE(aTHX_ PL_no_func, "setpriority()");
4335 #endif
4336 }
4337
4338 /* Time calls. */
4339
4340 PP(pp_time)
4341 {
4342     dVAR; dSP; dTARGET;
4343 #ifdef BIG_TIME
4344     XPUSHn( time(NULL) );
4345 #else
4346     XPUSHi( time(NULL) );
4347 #endif
4348     RETURN;
4349 }
4350
4351 PP(pp_tms)
4352 {
4353 #ifdef HAS_TIMES
4354     dVAR;
4355     dSP;
4356     EXTEND(SP, 4);
4357 #ifndef VMS
4358     (void)PerlProc_times(&PL_timesbuf);
4359 #else
4360     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4361                                                    /* struct tms, though same data   */
4362                                                    /* is returned.                   */
4363 #endif
4364
4365     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4366     if (GIMME == G_ARRAY) {
4367         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4368         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4369         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4370     }
4371     RETURN;
4372 #else
4373 #   ifdef PERL_MICRO
4374     dSP;
4375     PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4376     EXTEND(SP, 4);
4377     if (GIMME == G_ARRAY) {
4378          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4379          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4380          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4381     }
4382     RETURN;
4383 #   else
4384     DIE(aTHX_ "times not implemented");
4385 #   endif
4386 #endif /* HAS_TIMES */
4387 }
4388
4389 #ifdef LOCALTIME_EDGECASE_BROKEN
4390 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4391 {
4392     auto time_t     T;
4393     auto struct tm *P;
4394
4395     /* No workarounds in the valid range */
4396     if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4397         return (localtime (tp));
4398
4399     /* This edge case is to workaround the undefined behaviour, where the
4400      * TIMEZONE makes the time go beyond the defined range.
4401      * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4402      * If there is a negative offset in TZ, like MET-1METDST, some broken
4403      * implementations of localtime () (like AIX 5.2) barf with bogus
4404      * return values:
4405      * 0x7fffffff gmtime               2038-01-19 03:14:07
4406      * 0x7fffffff localtime            1901-12-13 21:45:51
4407      * 0x7fffffff mylocaltime          2038-01-19 04:14:07
4408      * 0x3c19137f gmtime               2001-12-13 20:45:51
4409      * 0x3c19137f localtime            2001-12-13 21:45:51
4410      * 0x3c19137f mylocaltime          2001-12-13 21:45:51
4411      * Given that legal timezones are typically between GMT-12 and GMT+12
4412      * we turn back the clock 23 hours before calling the localtime
4413      * function, and add those to the return value. This will never cause
4414      * day wrapping problems, since the edge case is Tue Jan *19*
4415      */
4416     T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4417     P = localtime (&T);
4418     P->tm_hour += 23;
4419     if (P->tm_hour >= 24) {
4420         P->tm_hour -= 24;
4421         P->tm_mday++;   /* 18  -> 19  */
4422         P->tm_wday++;   /* Mon -> Tue */
4423         P->tm_yday++;   /* 18  -> 19  */
4424     }
4425     return (P);
4426 } /* S_my_localtime */
4427 #endif
4428
4429 PP(pp_gmtime)
4430 {
4431     dVAR;
4432     dSP;
4433     Time_t when;
4434     const struct tm *tmbuf;
4435     static const char * const dayname[] =
4436         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4437     static const char * const monname[] =
4438         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4439          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4440
4441     if (MAXARG < 1)
4442         (void)time(&when);
4443     else
4444 #ifdef BIG_TIME
4445         when = (Time_t)SvNVx(POPs);
4446 #else
4447         when = (Time_t)SvIVx(POPs);
4448 #endif
4449
4450     if (PL_op->op_type == OP_LOCALTIME)
4451 #ifdef LOCALTIME_EDGECASE_BROKEN
4452         tmbuf = S_my_localtime(aTHX_ &when);
4453 #else
4454         tmbuf = localtime(&when);
4455 #endif
4456     else
4457         tmbuf = gmtime(&when);
4458
4459     if (GIMME != G_ARRAY) {
4460         SV *tsv;
4461         EXTEND(SP, 1);
4462         EXTEND_MORTAL(1);
4463         if (!tmbuf)
4464             RETPUSHUNDEF;
4465         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4466                             dayname[tmbuf->tm_wday],
4467                             monname[tmbuf->tm_mon],
4468                             tmbuf->tm_mday,
4469                             tmbuf->tm_hour,
4470                             tmbuf->tm_min,
4471                             tmbuf->tm_sec,
4472                             tmbuf->tm_year + 1900);
4473         PUSHs(sv_2mortal(tsv));
4474     }
4475     else if (tmbuf) {
4476         EXTEND(SP, 9);
4477         EXTEND_MORTAL(9);
4478         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4479         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4480         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4481         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4482         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4483         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4484         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4485         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4486         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4487     }
4488     RETURN;
4489 }
4490
4491 PP(pp_alarm)
4492 {
4493 #ifdef HAS_ALARM
4494     dVAR; dSP; dTARGET;
4495     int anum;
4496     anum = POPi;
4497     anum = alarm((unsigned int)anum);
4498     EXTEND(SP, 1);
4499     if (anum < 0)
4500         RETPUSHUNDEF;
4501     PUSHi(anum);
4502     RETURN;
4503 #else
4504     DIE(aTHX_ PL_no_func, "alarm");
4505 #endif
4506 }
4507
4508 PP(pp_sleep)
4509 {
4510     dVAR; dSP; dTARGET;
4511     I32 duration;
4512     Time_t lasttime;
4513     Time_t when;
4514
4515     (void)time(&lasttime);
4516     if (MAXARG < 1)
4517         PerlProc_pause();
4518     else {
4519         duration = POPi;
4520         PerlProc_sleep((unsigned int)duration);
4521     }
4522     (void)time(&when);
4523     XPUSHi(when - lasttime);
4524     RETURN;
4525 }
4526
4527 /* Shared memory. */
4528 /* Merged with some message passing. */
4529
4530 PP(pp_shmwrite)
4531 {
4532 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4533     dVAR; dSP; dMARK; dTARGET;
4534     const int op_type = PL_op->op_type;
4535     I32 value;
4536
4537     switch (op_type) {
4538     case OP_MSGSND:
4539         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4540         break;
4541     case OP_MSGRCV:
4542         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4543         break;
4544     case OP_SEMOP:
4545         value = (I32)(do_semop(MARK, SP) >= 0);
4546         break;
4547     default:
4548         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4549         break;
4550     }
4551
4552     SP = MARK;
4553     PUSHi(value);
4554     RETURN;
4555 #else
4556     return pp_semget();
4557 #endif
4558 }
4559
4560 /* Semaphores. */
4561
4562 PP(pp_semget)
4563 {
4564 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4565     dVAR; dSP; dMARK; dTARGET;
4566     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4567     SP = MARK;
4568     if (anum == -1)
4569         RETPUSHUNDEF;
4570     PUSHi(anum);
4571     RETURN;
4572 #else
4573     DIE(aTHX_ "System V IPC is not implemented on this machine");
4574 #endif
4575 }
4576
4577 PP(pp_semctl)
4578 {
4579 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4580     dVAR; dSP; dMARK; dTARGET;
4581     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4582     SP = MARK;
4583     if (anum == -1)
4584         RETSETUNDEF;
4585     if (anum != 0) {
4586         PUSHi(anum);
4587     }
4588     else {
4589         PUSHp(zero_but_true, ZBTLEN);
4590     }
4591     RETURN;
4592 #else
4593     return pp_semget();
4594 #endif
4595 }
4596
4597 /* I can't const this further without getting warnings about the types of
4598    various arrays passed in from structures.  */
4599 static SV *
4600 S_space_join_names_mortal(pTHX_ char *const *array)
4601 {
4602     SV *target;
4603
4604     if (array && *array) {
4605         target = sv_2mortal(newSVpvs(""));
4606         while (1) {
4607             sv_catpv(target, *array);
4608             if (!*++array)
4609                 break;
4610             sv_catpvs(target, " ");
4611         }
4612     } else {
4613         target = sv_mortalcopy(&PL_sv_no);
4614     }
4615     return target;
4616 }
4617
4618 /* Get system info. */
4619
4620 PP(pp_ghostent)
4621 {
4622 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4623     dVAR; dSP;
4624     I32 which = PL_op->op_type;
4625     register char **elem;
4626     register SV *sv;
4627 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4628     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4629     struct hostent *gethostbyname(Netdb_name_t);
4630     struct hostent *gethostent(void);
4631 #endif
4632     struct hostent *hent;
4633     unsigned long len;
4634
4635     EXTEND(SP, 10);
4636     if (which == OP_GHBYNAME) {
4637 #ifdef HAS_GETHOSTBYNAME
4638         const char* const name = POPpbytex;
4639         hent = PerlSock_gethostbyname(name);
4640 #else
4641         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4642 #endif
4643     }
4644     else if (which == OP_GHBYADDR) {
4645 #ifdef HAS_GETHOSTBYADDR
4646         const int addrtype = POPi;
4647         SV * const addrsv = POPs;
4648         STRLEN addrlen;
4649         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4650
4651         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4652 #else
4653         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4654 #endif
4655     }
4656     else
4657 #ifdef HAS_GETHOSTENT
4658         hent = PerlSock_gethostent();
4659 #else
4660         DIE(aTHX_ PL_no_sock_func, "gethostent");
4661 #endif
4662
4663 #ifdef HOST_NOT_FOUND
4664         if (!hent) {
4665 #ifdef USE_REENTRANT_API
4666 #   ifdef USE_GETHOSTENT_ERRNO
4667             h_errno = PL_reentrant_buffer->_gethostent_errno;
4668 #   endif
4669 #endif
4670             STATUS_UNIX_SET(h_errno);
4671         }
4672 #endif
4673
4674     if (GIMME != G_ARRAY) {
4675         PUSHs(sv = sv_newmortal());
4676         if (hent) {
4677             if (which == OP_GHBYNAME) {
4678                 if (hent->h_addr)
4679                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4680             }
4681             else
4682                 sv_setpv(sv, (char*)hent->h_name);
4683         }
4684         RETURN;
4685     }
4686
4687     if (hent) {
4688         PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4689         PUSHs(space_join_names_mortal(hent->h_aliases));
4690         PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4691         len = hent->h_length;
4692         PUSHs(sv_2mortal(newSViv((IV)len)));
4693 #ifdef h_addr
4694         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4695             XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4696         }
4697 #else
4698         if (hent->h_addr)
4699             PUSHs(newSVpvn(hent->h_addr, len));
4700         else
4701             PUSHs(sv_mortalcopy(&PL_sv_no));
4702 #endif /* h_addr */
4703     }
4704     RETURN;
4705 #else
4706     DIE(aTHX_ PL_no_sock_func, "gethostent");
4707 #endif
4708 }
4709
4710 PP(pp_gnetent)
4711 {
4712 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4713     dVAR; dSP;
4714     I32 which = PL_op->op_type;
4715     register SV *sv;
4716 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4717     struct netent *getnetbyaddr(Netdb_net_t, int);
4718     struct netent *getnetbyname(Netdb_name_t);
4719     struct netent *getnetent(void);
4720 #endif
4721     struct netent *nent;
4722
4723     if (which == OP_GNBYNAME){
4724 #ifdef HAS_GETNETBYNAME
4725         const char * const name = POPpbytex;
4726         nent = PerlSock_getnetbyname(name);
4727 #else
4728         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4729 #endif
4730     }
4731     else if (which == OP_GNBYADDR) {
4732 #ifdef HAS_GETNETBYADDR
4733         const int addrtype = POPi;
4734         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4735         nent = PerlSock_getnetbyaddr(addr, addrtype);
4736 #else
4737         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4738 #endif
4739     }
4740     else
4741 #ifdef HAS_GETNETENT
4742         nent = PerlSock_getnetent();
4743 #else
4744         DIE(aTHX_ PL_no_sock_func, "getnetent");
4745 #endif
4746
4747 #ifdef HOST_NOT_FOUND
4748         if (!nent) {
4749 #ifdef USE_REENTRANT_API
4750 #   ifdef USE_GETNETENT_ERRNO
4751              h_errno = PL_reentrant_buffer->_getnetent_errno;
4752 #   endif
4753 #endif
4754             STATUS_UNIX_SET(h_errno);
4755         }
4756 #endif
4757
4758     EXTEND(SP, 4);
4759     if (GIMME != G_ARRAY) {
4760         PUSHs(sv = sv_newmortal());
4761         if (nent) {
4762             if (which == OP_GNBYNAME)
4763                 sv_setiv(sv, (IV)nent->n_net);
4764             else
4765                 sv_setpv(sv, nent->n_name);
4766         }
4767         RETURN;
4768     }
4769
4770     if (nent) {
4771         PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4772         PUSHs(space_join_names_mortal(nent->n_aliases));
4773         PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4774         PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4775     }
4776
4777     RETURN;
4778 #else
4779     DIE(aTHX_ PL_no_sock_func, "getnetent");
4780 #endif
4781 }
4782
4783 PP(pp_gprotoent)
4784 {
4785 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4786     dVAR; dSP;
4787     I32 which = PL_op->op_type;
4788     register SV *sv;
4789 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4790     struct protoent *getprotobyname(Netdb_name_t);
4791     struct protoent *getprotobynumber(int);
4792     struct protoent *getprotoent(void);
4793 #endif
4794     struct protoent *pent;
4795
4796     if (which == OP_GPBYNAME) {
4797 #ifdef HAS_GETPROTOBYNAME
4798         const char* const name = POPpbytex;
4799         pent = PerlSock_getprotobyname(name);
4800 #else
4801         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4802 #endif
4803     }
4804     else if (which == OP_GPBYNUMBER) {
4805 #ifdef HAS_GETPROTOBYNUMBER
4806         const int number = POPi;
4807         pent = PerlSock_getprotobynumber(number);
4808 #else
4809         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4810 #endif
4811     }
4812     else
4813 #ifdef HAS_GETPROTOENT
4814         pent = PerlSock_getprotoent();
4815 #else
4816         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4817 #endif
4818
4819     EXTEND(SP, 3);
4820     if (GIMME != G_ARRAY) {
4821         PUSHs(sv = sv_newmortal());
4822         if (pent) {
4823             if (which == OP_GPBYNAME)
4824                 sv_setiv(sv, (IV)pent->p_proto);
4825             else
4826                 sv_setpv(sv, pent->p_name);
4827         }
4828         RETURN;
4829     }
4830
4831     if (pent) {
4832         PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4833         PUSHs(space_join_names_mortal(pent->p_aliases));
4834         PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4835     }
4836
4837     RETURN;
4838 #else
4839     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4840 #endif
4841 }
4842
4843 PP(pp_gservent)
4844 {
4845 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4846     dVAR; dSP;
4847     I32 which = PL_op->op_type;
4848     register SV *sv;
4849 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4850     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4851     struct servent *getservbyport(int, Netdb_name_t);
4852     struct servent *getservent(void);
4853 #endif
4854     struct servent *sent;
4855
4856     if (which == OP_GSBYNAME) {
4857 #ifdef HAS_GETSERVBYNAME
4858         const char * const proto = POPpbytex;
4859         const char * const name = POPpbytex;
4860         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4861 #else
4862         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4863 #endif
4864     }
4865     else if (which == OP_GSBYPORT) {
4866 #ifdef HAS_GETSERVBYPORT
4867         const char * const proto = POPpbytex;
4868         unsigned short port = (unsigned short)POPu;
4869 #ifdef HAS_HTONS
4870         port = PerlSock_htons(port);
4871 #endif
4872         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4873 #else
4874         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4875 #endif
4876     }
4877     else
4878 #ifdef HAS_GETSERVENT
4879         sent = PerlSock_getservent();
4880 #else
4881         DIE(aTHX_ PL_no_sock_func, "getservent");
4882 #endif
4883
4884     EXTEND(SP, 4);
4885     if (GIMME != G_ARRAY) {
4886         PUSHs(sv = sv_newmortal());
4887         if (sent) {
4888             if (which == OP_GSBYNAME) {
4889 #ifdef HAS_NTOHS
4890                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4891 #else
4892                 sv_setiv(sv, (IV)(sent->s_port));
4893 #endif
4894             }
4895             else
4896                 sv_setpv(sv, sent->s_name);
4897         }
4898         RETURN;
4899     }
4900
4901     if (sent) {
4902         PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4903         PUSHs(space_join_names_mortal(sent->s_aliases));
4904 #ifdef HAS_NTOHS
4905         PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4906 #else
4907         PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4908 #endif
4909         PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4910     }
4911
4912     RETURN;
4913 #else
4914     DIE(aTHX_ PL_no_sock_func, "getservent");
4915 #endif
4916 }
4917
4918 PP(pp_shostent)
4919 {
4920 #ifdef HAS_SETHOSTENT
4921     dVAR; dSP;
4922     PerlSock_sethostent(TOPi);
4923     RETSETYES;
4924 #else
4925     DIE(aTHX_ PL_no_sock_func, "sethostent");
4926 #endif
4927 }
4928
4929 PP(pp_snetent)
4930 {
4931 #ifdef HAS_SETNETENT
4932     dVAR; dSP;
4933     PerlSock_setnetent(TOPi);
4934     RETSETYES;
4935 #else
4936     DIE(aTHX_ PL_no_sock_func, "setnetent");
4937 #endif
4938 }
4939
4940 PP(pp_sprotoent)
4941 {
4942 #ifdef HAS_SETPROTOENT
4943     dVAR; dSP;
4944     PerlSock_setprotoent(TOPi);
4945     RETSETYES;
4946 #else
4947     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4948 #endif
4949 }
4950
4951 PP(pp_sservent)
4952 {
4953 #ifdef HAS_SETSERVENT
4954     dVAR; dSP;
4955     PerlSock_setservent(TOPi);
4956     RETSETYES;
4957 #else
4958     DIE(aTHX_ PL_no_sock_func, "setservent");
4959 #endif
4960 }
4961
4962 PP(pp_ehostent)
4963 {
4964 #ifdef HAS_ENDHOSTENT
4965     dVAR; dSP;
4966     PerlSock_endhostent();
4967     EXTEND(SP,1);
4968     RETPUSHYES;
4969 #else
4970     DIE(aTHX_ PL_no_sock_func, "endhostent");
4971 #endif
4972 }
4973
4974 PP(pp_enetent)
4975 {
4976 #ifdef HAS_ENDNETENT
4977     dVAR; dSP;
4978     PerlSock_endnetent();
4979     EXTEND(SP,1);
4980     RETPUSHYES;
4981 #else
4982     DIE(aTHX_ PL_no_sock_func, "endnetent");
4983 #endif
4984 }
4985
4986 PP(pp_eprotoent)
4987 {
4988 #ifdef HAS_ENDPROTOENT
4989     dVAR; dSP;
4990     PerlSock_endprotoent();
4991     EXTEND(SP,1);
4992     RETPUSHYES;
4993 #else
4994     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4995 #endif
4996 }
4997
4998 PP(pp_eservent)
4999 {
5000 #ifdef HAS_ENDSERVENT
5001     dVAR; dSP;
5002     PerlSock_endservent();
5003     EXTEND(SP,1);
5004     RETPUSHYES;
5005 #else
5006     DIE(aTHX_ PL_no_sock_func, "endservent");
5007 #endif
5008 }
5009
5010 PP(pp_gpwent)
5011 {
5012 #ifdef HAS_PASSWD
5013     dVAR; dSP;
5014     I32 which = PL_op->op_type;
5015     register SV *sv;
5016     struct passwd *pwent  = NULL;
5017     /*
5018      * We currently support only the SysV getsp* shadow password interface.
5019      * The interface is declared in <shadow.h> and often one needs to link
5020      * with -lsecurity or some such.
5021      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5022      * (and SCO?)
5023      *
5024      * AIX getpwnam() is clever enough to return the encrypted password
5025      * only if the caller (euid?) is root.
5026      *
5027      * There are at least three other shadow password APIs.  Many platforms
5028      * seem to contain more than one interface for accessing the shadow
5029      * password databases, possibly for compatibility reasons.
5030      * The getsp*() is by far he simplest one, the other two interfaces
5031      * are much more complicated, but also very similar to each other.
5032      *
5033      * <sys/types.h>
5034      * <sys/security.h>
5035      * <prot.h>
5036      * struct pr_passwd *getprpw*();
5037      * The password is in
5038      * char getprpw*(...).ufld.fd_encrypt[]
5039      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5040      *
5041      * <sys/types.h>
5042      * <sys/security.h>
5043      * <prot.h>
5044      * struct es_passwd *getespw*();
5045      * The password is in
5046      * char *(getespw*(...).ufld.fd_encrypt)
5047      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5048      *
5049      * <userpw.h> (AIX)
5050      * struct userpw *getuserpw();
5051      * The password is in
5052      * char *(getuserpw(...)).spw_upw_passwd
5053      * (but the de facto standard getpwnam() should work okay)
5054      *
5055      * Mention I_PROT here so that Configure probes for it.
5056      *
5057      * In HP-UX for getprpw*() the manual page claims that one should include
5058      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5059      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5060      * and pp_sys.c already includes <shadow.h> if there is such.
5061      *
5062      * Note that <sys/security.h> is already probed for, but currently
5063      * it is only included in special cases.
5064      *
5065      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5066      * be preferred interface, even though also the getprpw*() interface
5067      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5068      * One also needs to call set_auth_parameters() in main() before
5069      * doing anything else, whether one is using getespw*() or getprpw*().
5070      *
5071      * Note that accessing the shadow databases can be magnitudes
5072      * slower than accessing the standard databases.
5073      *
5074      * --jhi
5075      */
5076
5077 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5078     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5079      * the pw_comment is left uninitialized. */
5080     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5081 #   endif
5082
5083     switch (which) {
5084     case OP_GPWNAM:
5085       {
5086         const char* const name = POPpbytex;
5087         pwent  = getpwnam(name);
5088       }
5089       break;
5090     case OP_GPWUID:
5091       {
5092         Uid_t uid = POPi;
5093         pwent = getpwuid(uid);
5094       }
5095         break;
5096     case OP_GPWENT:
5097 #   ifdef HAS_GETPWENT
5098         pwent  = getpwent();
5099 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5100         if (pwent) pwent = getpwnam(pwent->pw_name);
5101 #endif
5102 #   else
5103         DIE(aTHX_ PL_no_func, "getpwent");
5104 #   endif
5105         break;
5106     }
5107
5108     EXTEND(SP, 10);
5109     if (GIMME != G_ARRAY) {
5110         PUSHs(sv = sv_newmortal());
5111         if (pwent) {
5112             if (which == OP_GPWNAM)
5113 #   if Uid_t_sign <= 0
5114                 sv_setiv(sv, (IV)pwent->pw_uid);
5115 #   else
5116                 sv_setuv(sv, (UV)pwent->pw_uid);
5117 #   endif
5118             else
5119                 sv_setpv(sv, pwent->pw_name);
5120         }
5121         RETURN;
5122     }
5123
5124     if (pwent) {
5125         PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5126
5127         PUSHs(sv = sv_2mortal(newSViv(0)));
5128         /* If we have getspnam(), we try to dig up the shadow
5129          * password.  If we are underprivileged, the shadow
5130          * interface will set the errno to EACCES or similar,
5131          * and return a null pointer.  If this happens, we will
5132          * use the dummy password (usually "*" or "x") from the
5133          * standard password database.
5134          *
5135          * In theory we could skip the shadow call completely
5136          * if euid != 0 but in practice we cannot know which
5137          * security measures are guarding the shadow databases
5138          * on a random platform.
5139          *
5140          * Resist the urge to use additional shadow interfaces.
5141          * Divert the urge to writing an extension instead.
5142          *
5143          * --jhi */
5144         /* Some AIX setups falsely(?) detect some getspnam(), which
5145          * has a different API than the Solaris/IRIX one. */
5146 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5147         {
5148             const int saverrno = errno;
5149             const struct spwd * const spwent = getspnam(pwent->pw_name);
5150                           /* Save and restore errno so that
5151                            * underprivileged attempts seem
5152                            * to have never made the unsccessful
5153                            * attempt to retrieve the shadow password. */
5154             errno = saverrno;
5155             if (spwent && spwent->sp_pwdp)
5156                 sv_setpv(sv, spwent->sp_pwdp);
5157         }
5158 #   endif
5159 #   ifdef PWPASSWD
5160         if (!SvPOK(sv)) /* Use the standard password, then. */
5161             sv_setpv(sv, pwent->pw_passwd);
5162 #   endif
5163
5164 #   ifndef INCOMPLETE_TAINTS
5165         /* passwd is tainted because user himself can diddle with it.
5166          * admittedly not much and in a very limited way, but nevertheless. */
5167         SvTAINTED_on(sv);
5168 #   endif
5169
5170 #   if Uid_t_sign <= 0
5171         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5172 #   else
5173         PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5174 #   endif
5175
5176 #   if Uid_t_sign <= 0
5177         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5178 #   else
5179         PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5180 #   endif
5181         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5182          * because of the poor interface of the Perl getpw*(),
5183          * not because there's some standard/convention saying so.
5184          * A better interface would have been to return a hash,
5185          * but we are accursed by our history, alas. --jhi.  */
5186 #   ifdef PWCHANGE
5187         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5188 #   else
5189 #       ifdef PWQUOTA
5190         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5191 #       else
5192 #           ifdef PWAGE
5193         PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5194 #           else
5195         /* I think that you can never get this compiled, but just in case.  */
5196         PUSHs(sv_mortalcopy(&PL_sv_no));
5197 #           endif
5198 #       endif
5199 #   endif
5200
5201         /* pw_class and pw_comment are mutually exclusive--.
5202          * see the above note for pw_change, pw_quota, and pw_age. */
5203 #   ifdef PWCLASS
5204         PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5205 #   else
5206 #       ifdef PWCOMMENT
5207         PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5208 #       else
5209         /* I think that you can never get this compiled, but just in case.  */
5210         PUSHs(sv_mortalcopy(&PL_sv_no));
5211 #       endif
5212 #   endif
5213
5214 #   ifdef PWGECOS
5215         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5216 #   else
5217         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5218 #   endif
5219 #   ifndef INCOMPLETE_TAINTS
5220         /* pw_gecos is tainted because user himself can diddle with it. */
5221         SvTAINTED_on(sv);
5222 #   endif
5223
5224         PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5225
5226         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5227 #   ifndef INCOMPLETE_TAINTS
5228         /* pw_shell is tainted because user himself can diddle with it. */
5229         SvTAINTED_on(sv);
5230 #   endif
5231
5232 #   ifdef PWEXPIRE
5233         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5234 #   endif
5235     }
5236     RETURN;
5237 #else
5238     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5239 #endif
5240 }
5241
5242 PP(pp_spwent)
5243 {
5244 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5245     dVAR; dSP;
5246     setpwent();
5247     RETPUSHYES;
5248 #else
5249     DIE(aTHX_ PL_no_func, "setpwent");
5250 #endif
5251 }
5252
5253 PP(pp_epwent)
5254 {
5255 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5256     dVAR; dSP;
5257     endpwent();
5258     RETPUSHYES;
5259 #else
5260     DIE(aTHX_ PL_no_func, "endpwent");
5261 #endif
5262 }
5263
5264 PP(pp_ggrent)
5265 {
5266 #ifdef HAS_GROUP
5267     dVAR; dSP;
5268     const I32 which = PL_op->op_type;
5269     const struct group *grent;
5270
5271     if (which == OP_GGRNAM) {
5272         const char* const name = POPpbytex;
5273         grent = (const struct group *)getgrnam(name);
5274     }
5275     else if (which == OP_GGRGID) {
5276         const Gid_t gid = POPi;
5277         grent = (const struct group *)getgrgid(gid);
5278     }
5279     else
5280 #ifdef HAS_GETGRENT
5281         grent = (struct group *)getgrent();
5282 #else
5283         DIE(aTHX_ PL_no_func, "getgrent");
5284 #endif
5285
5286     EXTEND(SP, 4);
5287     if (GIMME != G_ARRAY) {
5288         SV * const sv = sv_newmortal();
5289
5290         PUSHs(sv);
5291         if (grent) {
5292             if (which == OP_GGRNAM)
5293                 sv_setiv(sv, (IV)grent->gr_gid);
5294             else
5295                 sv_setpv(sv, grent->gr_name);
5296         }
5297         RETURN;
5298     }
5299
5300     if (grent) {
5301         PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5302
5303 #ifdef GRPASSWD
5304         PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5305 #else
5306         PUSHs(sv_mortalcopy(&PL_sv_no));
5307 #endif
5308
5309         PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5310
5311 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5312         /* In UNICOS/mk (_CRAYMPP) the multithreading
5313          * versions (getgrnam_r, getgrgid_r)
5314          * seem to return an illegal pointer
5315          * as the group members list, gr_mem.
5316          * getgrent() doesn't even have a _r version
5317          * but the gr_mem is poisonous anyway.
5318          * So yes, you cannot get the list of group
5319          * members if building multithreaded in UNICOS/mk. */
5320         PUSHs(space_join_names_mortal(grent->gr_mem));
5321 #endif
5322     }
5323
5324     RETURN;
5325 #else
5326     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5327 #endif
5328 }
5329
5330 PP(pp_sgrent)
5331 {
5332 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5333     dVAR; dSP;
5334     setgrent();
5335     RETPUSHYES;
5336 #else
5337     DIE(aTHX_ PL_no_func, "setgrent");
5338 #endif
5339 }
5340
5341 PP(pp_egrent)
5342 {
5343 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5344     dVAR; dSP;
5345     endgrent();
5346     RETPUSHYES;
5347 #else
5348     DIE(aTHX_ PL_no_func, "endgrent");
5349 #endif
5350 }
5351
5352 PP(pp_getlogin)
5353 {
5354 #ifdef HAS_GETLOGIN
5355     dVAR; dSP; dTARGET;
5356     char *tmps;
5357     EXTEND(SP, 1);
5358     if (!(tmps = PerlProc_getlogin()))
5359         RETPUSHUNDEF;
5360     PUSHp(tmps, strlen(tmps));
5361     RETURN;
5362 #else
5363     DIE(aTHX_ PL_no_func, "getlogin");
5364 #endif
5365 }
5366
5367 /* Miscellaneous. */
5368
5369 PP(pp_syscall)
5370 {
5371 #ifdef HAS_SYSCALL
5372     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5373     register I32 items = SP - MARK;
5374     unsigned long a[20];
5375     register I32 i = 0;
5376     I32 retval = -1;
5377
5378     if (PL_tainting) {
5379         while (++MARK <= SP) {
5380             if (SvTAINTED(*MARK)) {
5381                 TAINT;
5382                 break;
5383             }
5384         }
5385         MARK = ORIGMARK;
5386         TAINT_PROPER("syscall");
5387     }
5388
5389     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5390      * or where sizeof(long) != sizeof(char*).  But such machines will
5391      * not likely have syscall implemented either, so who cares?
5392      */
5393     while (++MARK <= SP) {
5394         if (SvNIOK(*MARK) || !i)
5395             a[i++] = SvIV(*MARK);
5396         else if (*MARK == &PL_sv_undef)
5397             a[i++] = 0;
5398         else
5399             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5400         if (i > 15)
5401             break;
5402     }
5403     switch (items) {
5404     default:
5405         DIE(aTHX_ "Too many args to syscall");
5406     case 0:
5407         DIE(aTHX_ "Too few args to syscall");
5408     case 1:
5409         retval = syscall(a[0]);
5410         break;
5411     case 2:
5412         retval = syscall(a[0],a[1]);
5413         break;
5414     case 3:
5415         retval = syscall(a[0],a[1],a[2]);
5416         break;
5417     case 4:
5418         retval = syscall(a[0],a[1],a[2],a[3]);
5419         break;
5420     case 5:
5421         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5422         break;
5423     case 6:
5424         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5425         break;
5426     case 7:
5427         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5428         break;
5429     case 8:
5430         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5431         break;
5432 #ifdef atarist
5433     case 9:
5434         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5435         break;
5436     case 10:
5437         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5438         break;
5439     case 11:
5440         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5441           a[10]);
5442         break;
5443     case 12:
5444         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5445           a[10],a[11]);
5446         break;
5447     case 13:
5448         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5449           a[10],a[11],a[12]);
5450         break;
5451     case 14:
5452         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5453           a[10],a[11],a[12],a[13]);
5454         break;
5455 #endif /* atarist */
5456     }
5457     SP = ORIGMARK;
5458     PUSHi(retval);
5459     RETURN;
5460 #else
5461     DIE(aTHX_ PL_no_func, "syscall");
5462 #endif
5463 }
5464
5465 #ifdef FCNTL_EMULATE_FLOCK
5466
5467 /*  XXX Emulate flock() with fcntl().
5468     What's really needed is a good file locking module.
5469 */
5470
5471 static int
5472 fcntl_emulate_flock(int fd, int operation)
5473 {
5474     struct flock flock;
5475
5476     switch (operation & ~LOCK_NB) {
5477     case LOCK_SH:
5478         flock.l_type = F_RDLCK;
5479         break;
5480     case LOCK_EX:
5481         flock.l_type = F_WRLCK;
5482         break;
5483     case LOCK_UN:
5484         flock.l_type = F_UNLCK;
5485         break;
5486     default:
5487         errno = EINVAL;
5488         return -1;
5489     }
5490     flock.l_whence = SEEK_SET;
5491     flock.l_start = flock.l_len = (Off_t)0;
5492
5493     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5494 }
5495
5496 #endif /* FCNTL_EMULATE_FLOCK */
5497
5498 #ifdef LOCKF_EMULATE_FLOCK
5499
5500 /*  XXX Emulate flock() with lockf().  This is just to increase
5501     portability of scripts.  The calls are not completely
5502     interchangeable.  What's really needed is a good file
5503     locking module.
5504 */
5505
5506 /*  The lockf() constants might have been defined in <unistd.h>.
5507     Unfortunately, <unistd.h> causes troubles on some mixed
5508     (BSD/POSIX) systems, such as SunOS 4.1.3.
5509
5510    Further, the lockf() constants aren't POSIX, so they might not be
5511    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5512    just stick in the SVID values and be done with it.  Sigh.
5513 */
5514
5515 # ifndef F_ULOCK
5516 #  define F_ULOCK       0       /* Unlock a previously locked region */
5517 # endif
5518 # ifndef F_LOCK
5519 #  define F_LOCK        1       /* Lock a region for exclusive use */
5520 # endif
5521 # ifndef F_TLOCK
5522 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5523 # endif
5524 # ifndef F_TEST
5525 #  define F_TEST        3       /* Test a region for other processes locks */
5526 # endif
5527
5528 static int
5529 lockf_emulate_flock(int fd, int operation)
5530 {
5531     int i;
5532     const int save_errno = errno;
5533     Off_t pos;
5534
5535     /* flock locks entire file so for lockf we need to do the same      */
5536     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5537     if (pos > 0)        /* is seekable and needs to be repositioned     */
5538         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5539             pos = -1;   /* seek failed, so don't seek back afterwards   */
5540     errno = save_errno;
5541
5542     switch (operation) {
5543
5544         /* LOCK_SH - get a shared lock */
5545         case LOCK_SH:
5546         /* LOCK_EX - get an exclusive lock */
5547         case LOCK_EX:
5548             i = lockf (fd, F_LOCK, 0);
5549             break;
5550
5551         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5552         case LOCK_SH|LOCK_NB:
5553         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5554         case LOCK_EX|LOCK_NB:
5555             i = lockf (fd, F_TLOCK, 0);
5556             if (i == -1)
5557                 if ((errno == EAGAIN) || (errno == EACCES))
5558                     errno = EWOULDBLOCK;
5559             break;
5560
5561         /* LOCK_UN - unlock (non-blocking is a no-op) */
5562         case LOCK_UN:
5563         case LOCK_UN|LOCK_NB:
5564             i = lockf (fd, F_ULOCK, 0);
5565             break;
5566
5567         /* Default - can't decipher operation */
5568         default:
5569             i = -1;
5570             errno = EINVAL;
5571             break;
5572     }
5573
5574     if (pos > 0)      /* need to restore position of the handle */
5575         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5576
5577     return (i);
5578 }
5579
5580 #endif /* LOCKF_EMULATE_FLOCK */
5581
5582 /*
5583  * Local variables:
5584  * c-indentation-style: bsd
5585  * c-basic-offset: 4
5586  * indent-tabs-mode: t
5587  * End:
5588  *
5589  * ex: set ts=8 sts=4 sw=4 noet:
5590  */