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