pp_sys.c

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