pp_sys.c

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