pp_sys.c

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