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