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 (IoDIRP(io)) {
3446 #ifdef HAS_DIRFD
3447                 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3448 #else
3449                 DIE(aTHX_ PL_no_func, "dirfd");
3450 #endif
3451             } else if (IoIFP(io)) {
3452                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3453             }
3454             else {
3455                 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3456                     report_evil_fh(gv, io, PL_op->op_type);
3457                 SETERRNO(EBADF, RMS_IFI);
3458                 PUSHi(0);
3459             }
3460         }
3461         else {
3462             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3463                 report_evil_fh(gv, io, PL_op->op_type);
3464             SETERRNO(EBADF,RMS_IFI);
3465             PUSHi(0);
3466         }
3467 #else
3468         DIE(aTHX_ PL_no_func, "fchdir");
3469 #endif
3470     }
3471     else
3472         PUSHi( PerlDir_chdir(tmps) >= 0 );
3473 #ifdef VMS
3474     /* Clear the DEFAULT element of ENV so we'll get the new value
3475      * in the future. */
3476     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3477 #endif
3478     RETURN;
3479 }
3480
3481 PP(pp_chown)
3482 {
3483     dVAR; dSP; dMARK; dTARGET;
3484     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3485
3486     SP = MARK;
3487     XPUSHi(value);
3488     RETURN;
3489 }
3490
3491 PP(pp_chroot)
3492 {
3493 #ifdef HAS_CHROOT
3494     dVAR; dSP; dTARGET;
3495     char * const tmps = POPpx;
3496     TAINT_PROPER("chroot");
3497     PUSHi( chroot(tmps) >= 0 );
3498     RETURN;
3499 #else
3500     DIE(aTHX_ PL_no_func, "chroot");
3501 #endif
3502 }
3503
3504 PP(pp_rename)
3505 {
3506     dVAR; dSP; dTARGET;
3507     int anum;
3508     const char * const tmps2 = POPpconstx;
3509     const char * const tmps = SvPV_nolen_const(TOPs);
3510     TAINT_PROPER("rename");
3511 #ifdef HAS_RENAME
3512     anum = PerlLIO_rename(tmps, tmps2);
3513 #else
3514     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3515         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3516             anum = 1;
3517         else {
3518             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3519                 (void)UNLINK(tmps2);
3520             if (!(anum = link(tmps, tmps2)))
3521                 anum = UNLINK(tmps);
3522         }
3523     }
3524 #endif
3525     SETi( anum >= 0 );
3526     RETURN;
3527 }
3528
3529 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3530 PP(pp_link)
3531 {
3532     dVAR; dSP; dTARGET;
3533     const int op_type = PL_op->op_type;
3534     int result;
3535
3536 #  ifndef HAS_LINK
3537     if (op_type == OP_LINK)
3538         DIE(aTHX_ PL_no_func, "link");
3539 #  endif
3540 #  ifndef HAS_SYMLINK
3541     if (op_type == OP_SYMLINK)
3542         DIE(aTHX_ PL_no_func, "symlink");
3543 #  endif
3544
3545     {
3546         const char * const tmps2 = POPpconstx;
3547         const char * const tmps = SvPV_nolen_const(TOPs);
3548         TAINT_PROPER(PL_op_desc[op_type]);
3549         result =
3550 #  if defined(HAS_LINK)
3551 #    if defined(HAS_SYMLINK)
3552             /* Both present - need to choose which.  */
3553             (op_type == OP_LINK) ?
3554             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3555 #    else
3556     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3557         PerlLIO_link(tmps, tmps2);
3558 #    endif
3559 #  else
3560 #    if defined(HAS_SYMLINK)
3561     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3562         symlink(tmps, tmps2);
3563 #    endif
3564 #  endif
3565     }
3566
3567     SETi( result >= 0 );
3568     RETURN;
3569 }
3570 #else
3571 PP(pp_link)
3572 {
3573     /* Have neither.  */
3574     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3575 }
3576 #endif
3577
3578 PP(pp_readlink)
3579 {
3580     dVAR;
3581     dSP;
3582 #ifdef HAS_SYMLINK
3583     dTARGET;
3584     const char *tmps;
3585     char buf[MAXPATHLEN];
3586     int len;
3587
3588 #ifndef INCOMPLETE_TAINTS
3589     TAINT;
3590 #endif
3591     tmps = POPpconstx;
3592     len = readlink(tmps, buf, sizeof(buf) - 1);
3593     EXTEND(SP, 1);
3594     if (len < 0)
3595         RETPUSHUNDEF;
3596     PUSHp(buf, len);
3597     RETURN;
3598 #else
3599     EXTEND(SP, 1);
3600     RETSETUNDEF;                /* just pretend it's a normal file */
3601 #endif
3602 }
3603
3604 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3605 STATIC int
3606 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3607 {
3608     char * const save_filename = filename;
3609     char *cmdline;
3610     char *s;
3611     PerlIO *myfp;
3612     int anum = 1;
3613     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3614
3615     Newx(cmdline, size, char);
3616     my_strlcpy(cmdline, cmd, size);
3617     my_strlcat(cmdline, " ", size);
3618     for (s = cmdline + strlen(cmdline); *filename; ) {
3619         *s++ = '\\';
3620         *s++ = *filename++;
3621     }
3622     if (s - cmdline < size)
3623         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3624     myfp = PerlProc_popen(cmdline, "r");
3625     Safefree(cmdline);
3626
3627     if (myfp) {
3628         SV * const tmpsv = sv_newmortal();
3629         /* Need to save/restore 'PL_rs' ?? */
3630         s = sv_gets(tmpsv, myfp, 0);
3631         (void)PerlProc_pclose(myfp);
3632         if (s != NULL) {
3633             int e;
3634             for (e = 1;
3635 #ifdef HAS_SYS_ERRLIST
3636                  e <= sys_nerr
3637 #endif
3638                  ; e++)
3639             {
3640                 /* you don't see this */
3641                 const char * const errmsg =
3642 #ifdef HAS_SYS_ERRLIST
3643                     sys_errlist[e]
3644 #else
3645                     strerror(e)
3646 #endif
3647                     ;
3648                 if (!errmsg)
3649                     break;
3650                 if (instr(s, errmsg)) {
3651                     SETERRNO(e,0);
3652                     return 0;
3653                 }
3654             }
3655             SETERRNO(0,0);
3656 #ifndef EACCES
3657 #define EACCES EPERM
3658 #endif
3659             if (instr(s, "cannot make"))
3660                 SETERRNO(EEXIST,RMS_FEX);
3661             else if (instr(s, "existing file"))
3662                 SETERRNO(EEXIST,RMS_FEX);
3663             else if (instr(s, "ile exists"))
3664                 SETERRNO(EEXIST,RMS_FEX);
3665             else if (instr(s, "non-exist"))
3666                 SETERRNO(ENOENT,RMS_FNF);
3667             else if (instr(s, "does not exist"))
3668                 SETERRNO(ENOENT,RMS_FNF);
3669             else if (instr(s, "not empty"))
3670                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3671             else if (instr(s, "cannot access"))
3672                 SETERRNO(EACCES,RMS_PRV);
3673             else
3674                 SETERRNO(EPERM,RMS_PRV);
3675             return 0;
3676         }
3677         else {  /* some mkdirs return no failure indication */
3678             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3679             if (PL_op->op_type == OP_RMDIR)
3680                 anum = !anum;
3681             if (anum)
3682                 SETERRNO(0,0);
3683             else
3684                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3685         }
3686         return anum;
3687     }
3688     else
3689         return 0;
3690 }
3691 #endif
3692
3693 /* This macro removes trailing slashes from a directory name.
3694  * Different operating and file systems take differently to
3695  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3696  * any number of trailing slashes should be allowed.
3697  * Thusly we snip them away so that even non-conforming
3698  * systems are happy.
3699  * We should probably do this "filtering" for all
3700  * the functions that expect (potentially) directory names:
3701  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3702  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3703
3704 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3705     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3706         do { \
3707             (len)--; \
3708         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3709         (tmps) = savepvn((tmps), (len)); \
3710         (copy) = TRUE; \
3711     }
3712
3713 PP(pp_mkdir)
3714 {
3715     dVAR; dSP; dTARGET;
3716     STRLEN len;
3717     const char *tmps;
3718     bool copy = FALSE;
3719     const int mode = (MAXARG > 1) ? POPi : 0777;
3720
3721     TRIMSLASHES(tmps,len,copy);
3722
3723     TAINT_PROPER("mkdir");
3724 #ifdef HAS_MKDIR
3725     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3726 #else
3727     {
3728     int oldumask;
3729     SETi( dooneliner("mkdir", tmps) );
3730     oldumask = PerlLIO_umask(0);
3731     PerlLIO_umask(oldumask);
3732     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3733     }
3734 #endif
3735     if (copy)
3736         Safefree(tmps);
3737     RETURN;
3738 }
3739
3740 PP(pp_rmdir)
3741 {
3742     dVAR; dSP; dTARGET;
3743     STRLEN len;
3744     const char *tmps;
3745     bool copy = FALSE;
3746
3747     TRIMSLASHES(tmps,len,copy);
3748     TAINT_PROPER("rmdir");
3749 #ifdef HAS_RMDIR
3750     SETi( PerlDir_rmdir(tmps) >= 0 );
3751 #else
3752     SETi( dooneliner("rmdir", tmps) );
3753 #endif
3754     if (copy)
3755         Safefree(tmps);
3756     RETURN;
3757 }
3758
3759 /* Directory calls. */
3760
3761 PP(pp_open_dir)
3762 {
3763 #if defined(Direntry_t) && defined(HAS_READDIR)
3764     dVAR; dSP;
3765     const char * const dirname = POPpconstx;
3766     GV * const gv = (GV*)POPs;
3767     register IO * const io = GvIOn(gv);
3768
3769     if (!io)
3770         goto nope;
3771
3772     if (IoDIRP(io))
3773         PerlDir_close(IoDIRP(io));
3774     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3775         goto nope;
3776
3777     RETPUSHYES;
3778 nope:
3779     if (!errno)
3780         SETERRNO(EBADF,RMS_DIR);
3781     RETPUSHUNDEF;
3782 #else
3783     DIE(aTHX_ PL_no_dir_func, "opendir");
3784 #endif
3785 }
3786
3787 PP(pp_readdir)
3788 {
3789 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3790     DIE(aTHX_ PL_no_dir_func, "readdir");
3791 #else
3792 #if !defined(I_DIRENT) && !defined(VMS)
3793     Direntry_t *readdir (DIR *);
3794 #endif
3795     dVAR;
3796     dSP;
3797
3798     SV *sv;
3799     const I32 gimme = GIMME;
3800     GV * const gv = (GV *)POPs;
3801     register const Direntry_t *dp;
3802     register IO * const io = GvIOn(gv);
3803
3804     if (!io || !IoDIRP(io)) {
3805         if(ckWARN(WARN_IO)) {
3806             Perl_warner(aTHX_ packWARN(WARN_IO),
3807                 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3808         }
3809         goto nope;
3810     }
3811
3812     do {
3813         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3814         if (!dp)
3815             break;
3816 #ifdef DIRNAMLEN
3817         sv = newSVpvn(dp->d_name, dp->d_namlen);
3818 #else
3819         sv = newSVpv(dp->d_name, 0);
3820 #endif
3821 #ifndef INCOMPLETE_TAINTS
3822         if (!(IoFLAGS(io) & IOf_UNTAINT))
3823             SvTAINTED_on(sv);
3824 #endif
3825         XPUSHs(sv_2mortal(sv));
3826     } while (gimme == G_ARRAY);
3827
3828     if (!dp && gimme != G_ARRAY)
3829         goto nope;
3830
3831     RETURN;
3832
3833 nope:
3834     if (!errno)
3835         SETERRNO(EBADF,RMS_ISI);
3836     if (GIMME == G_ARRAY)
3837         RETURN;
3838     else
3839         RETPUSHUNDEF;
3840 #endif
3841 }
3842
3843 PP(pp_telldir)
3844 {
3845 #if defined(HAS_TELLDIR) || defined(telldir)
3846     dVAR; dSP; dTARGET;
3847  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3848  /* XXX netbsd still seemed to.
3849     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3850     --JHI 1999-Feb-02 */
3851 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3852     long telldir (DIR *);
3853 # endif
3854     GV * const gv = (GV*)POPs;
3855     register IO * const io = GvIOn(gv);
3856
3857     if (!io || !IoDIRP(io)) {
3858         if(ckWARN(WARN_IO)) {
3859             Perl_warner(aTHX_ packWARN(WARN_IO),
3860                 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3861         }
3862         goto nope;
3863     }
3864
3865     PUSHi( PerlDir_tell(IoDIRP(io)) );
3866     RETURN;
3867 nope:
3868     if (!errno)
3869         SETERRNO(EBADF,RMS_ISI);
3870     RETPUSHUNDEF;
3871 #else
3872     DIE(aTHX_ PL_no_dir_func, "telldir");
3873 #endif
3874 }
3875
3876 PP(pp_seekdir)
3877 {
3878 #if defined(HAS_SEEKDIR) || defined(seekdir)
3879     dVAR; dSP;
3880     const long along = POPl;
3881     GV * const gv = (GV*)POPs;
3882     register IO * const io = GvIOn(gv);
3883
3884     if (!io || !IoDIRP(io)) {
3885         if(ckWARN(WARN_IO)) {
3886             Perl_warner(aTHX_ packWARN(WARN_IO),
3887                 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3888         }
3889         goto nope;
3890     }
3891     (void)PerlDir_seek(IoDIRP(io), along);
3892
3893     RETPUSHYES;
3894 nope:
3895     if (!errno)
3896         SETERRNO(EBADF,RMS_ISI);
3897     RETPUSHUNDEF;
3898 #else
3899     DIE(aTHX_ PL_no_dir_func, "seekdir");
3900 #endif
3901 }
3902
3903 PP(pp_rewinddir)
3904 {
3905 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3906     dVAR; dSP;
3907     GV * const gv = (GV*)POPs;
3908     register IO * const io = GvIOn(gv);
3909
3910     if (!io || !IoDIRP(io)) {
3911         if(ckWARN(WARN_IO)) {
3912             Perl_warner(aTHX_ packWARN(WARN_IO),
3913                 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3914         }
3915         goto nope;
3916     }
3917     (void)PerlDir_rewind(IoDIRP(io));
3918     RETPUSHYES;
3919 nope:
3920     if (!errno)
3921         SETERRNO(EBADF,RMS_ISI);
3922     RETPUSHUNDEF;
3923 #else
3924     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3925 #endif
3926 }
3927
3928 PP(pp_closedir)
3929 {
3930 #if defined(Direntry_t) && defined(HAS_READDIR)
3931     dVAR; dSP;
3932     GV * const gv = (GV*)POPs;
3933     register IO * const io = GvIOn(gv);
3934
3935     if (!io || !IoDIRP(io)) {
3936         if(ckWARN(WARN_IO)) {
3937             Perl_warner(aTHX_ packWARN(WARN_IO),
3938                 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3939         }
3940         goto nope;
3941     }
3942 #ifdef VOID_CLOSEDIR
3943     PerlDir_close(IoDIRP(io));
3944 #else
3945     if (PerlDir_close(IoDIRP(io)) < 0) {
3946         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3947         goto nope;
3948     }
3949 #endif
3950     IoDIRP(io) = 0;
3951
3952     RETPUSHYES;
3953 nope:
3954     if (!errno)
3955         SETERRNO(EBADF,RMS_IFI);
3956     RETPUSHUNDEF;
3957 #else
3958     DIE(aTHX_ PL_no_dir_func, "closedir");
3959 #endif
3960 }
3961
3962 /* Process control. */
3963
3964 PP(pp_fork)
3965 {
3966 #ifdef HAS_FORK
3967     dVAR; dSP; dTARGET;
3968     Pid_t childpid;
3969
3970     EXTEND(SP, 1);
3971     PERL_FLUSHALL_FOR_CHILD;
3972     childpid = PerlProc_fork();
3973     if (childpid < 0)
3974         RETSETUNDEF;
3975     if (!childpid) {
3976         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3977         if (tmpgv) {
3978             SvREADONLY_off(GvSV(tmpgv));
3979             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3980             SvREADONLY_on(GvSV(tmpgv));
3981         }
3982 #ifdef THREADS_HAVE_PIDS
3983         PL_ppid = (IV)getppid();
3984 #endif
3985 #ifdef PERL_USES_PL_PIDSTATUS
3986         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3987 #endif
3988     }
3989     PUSHi(childpid);
3990     RETURN;
3991 #else
3992 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3993     dSP; dTARGET;
3994     Pid_t childpid;
3995
3996     EXTEND(SP, 1);
3997     PERL_FLUSHALL_FOR_CHILD;
3998     childpid = PerlProc_fork();
3999     if (childpid == -1)
4000         RETSETUNDEF;
4001     PUSHi(childpid);
4002     RETURN;
4003 #  else
4004     DIE(aTHX_ PL_no_func, "fork");
4005 #  endif
4006 #endif
4007 }
4008
4009 PP(pp_wait)
4010 {
4011 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4012     dVAR; dSP; dTARGET;
4013     Pid_t childpid;
4014     int argflags;
4015
4016     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4017         childpid = wait4pid(-1, &argflags, 0);
4018     else {
4019         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4020                errno == EINTR) {
4021           PERL_ASYNC_CHECK();
4022         }
4023     }
4024 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4025     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4026     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4027 #  else
4028     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4029 #  endif
4030     XPUSHi(childpid);
4031     RETURN;
4032 #else
4033     DIE(aTHX_ PL_no_func, "wait");
4034 #endif
4035 }
4036
4037 PP(pp_waitpid)
4038 {
4039 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4040     dVAR; dSP; dTARGET;
4041     const int optype = POPi;
4042     const Pid_t pid = TOPi;
4043     Pid_t result;
4044     int argflags;
4045
4046     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4047         result = wait4pid(pid, &argflags, optype);
4048     else {
4049         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4050                errno == EINTR) {
4051           PERL_ASYNC_CHECK();
4052         }
4053     }
4054 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4055     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4056     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4057 #  else
4058     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4059 #  endif
4060     SETi(result);
4061     RETURN;
4062 #else
4063     DIE(aTHX_ PL_no_func, "waitpid");
4064 #endif
4065 }
4066
4067 PP(pp_system)
4068 {
4069     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4070     I32 value;
4071     int result;
4072
4073     if (PL_tainting) {
4074         TAINT_ENV();
4075         while (++MARK <= SP) {
4076             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4077             if (PL_tainted)
4078                 break;
4079         }
4080         MARK = ORIGMARK;
4081         TAINT_PROPER("system");
4082     }
4083     PERL_FLUSHALL_FOR_CHILD;
4084 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4085     {
4086         Pid_t childpid;
4087         int pp[2];
4088         I32 did_pipes = 0;
4089
4090         if (PerlProc_pipe(pp) >= 0)
4091             did_pipes = 1;
4092         while ((childpid = PerlProc_fork()) == -1) {
4093             if (errno != EAGAIN) {
4094                 value = -1;
4095                 SP = ORIGMARK;
4096                 XPUSHi(value);
4097                 if (did_pipes) {
4098                     PerlLIO_close(pp[0]);
4099                     PerlLIO_close(pp[1]);
4100                 }
4101                 RETURN;
4102             }
4103             sleep(5);
4104         }
4105         if (childpid > 0) {
4106             Sigsave_t ihand,qhand; /* place to save signals during system() */
4107             int status;
4108
4109             if (did_pipes)
4110                 PerlLIO_close(pp[1]);
4111 #ifndef PERL_MICRO
4112             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4113             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4114 #endif
4115             do {
4116                 result = wait4pid(childpid, &status, 0);
4117             } while (result == -1 && errno == EINTR);
4118 #ifndef PERL_MICRO
4119             (void)rsignal_restore(SIGINT, &ihand);
4120             (void)rsignal_restore(SIGQUIT, &qhand);
4121 #endif
4122             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4123             do_execfree();      /* free any memory child malloced on fork */
4124             SP = ORIGMARK;
4125             if (did_pipes) {
4126                 int errkid;
4127                 unsigned n = 0;
4128                 SSize_t n1;
4129
4130                 while (n < sizeof(int)) {
4131                     n1 = PerlLIO_read(pp[0],
4132                                       (void*)(((char*)&errkid)+n),
4133                                       (sizeof(int)) - n);
4134                     if (n1 <= 0)
4135                         break;
4136                     n += n1;
4137                 }
4138                 PerlLIO_close(pp[0]);
4139                 if (n) {                        /* Error */
4140                     if (n != sizeof(int))
4141                         DIE(aTHX_ "panic: kid popen errno read");
4142                     errno = errkid;             /* Propagate errno from kid */
4143                     STATUS_NATIVE_CHILD_SET(-1);
4144                 }
4145             }
4146             XPUSHi(STATUS_CURRENT);
4147             RETURN;
4148         }
4149         if (did_pipes) {
4150             PerlLIO_close(pp[0]);
4151 #if defined(HAS_FCNTL) && defined(F_SETFD)
4152             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4153 #endif
4154         }
4155         if (PL_op->op_flags & OPf_STACKED) {
4156             SV * const really = *++MARK;
4157             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4158         }
4159         else if (SP - MARK != 1)
4160             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4161         else {
4162             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4163         }
4164         PerlProc__exit(-1);
4165     }
4166 #else /* ! FORK or VMS or OS/2 */
4167     PL_statusvalue = 0;
4168     result = 0;
4169     if (PL_op->op_flags & OPf_STACKED) {
4170         SV * const really = *++MARK;
4171 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4172         value = (I32)do_aspawn(really, MARK, SP);
4173 #  else
4174         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4175 #  endif
4176     }
4177     else if (SP - MARK != 1) {
4178 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4179         value = (I32)do_aspawn(NULL, MARK, SP);
4180 #  else
4181         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4182 #  endif
4183     }
4184     else {
4185         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4186     }
4187     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4188         result = 1;
4189     STATUS_NATIVE_CHILD_SET(value);
4190     do_execfree();
4191     SP = ORIGMARK;
4192     XPUSHi(result ? value : STATUS_CURRENT);
4193 #endif /* !FORK or VMS */
4194     RETURN;
4195 }
4196
4197 PP(pp_exec)
4198 {
4199     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4200     I32 value;
4201
4202     if (PL_tainting) {
4203         TAINT_ENV();
4204         while (++MARK <= SP) {
4205             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4206             if (PL_tainted)
4207                 break;
4208         }
4209         MARK = ORIGMARK;
4210         TAINT_PROPER("exec");
4211     }
4212     PERL_FLUSHALL_FOR_CHILD;
4213     if (PL_op->op_flags & OPf_STACKED) {
4214         SV * const really = *++MARK;
4215         value = (I32)do_aexec(really, MARK, SP);
4216     }
4217     else if (SP - MARK != 1)
4218 #ifdef VMS
4219         value = (I32)vms_do_aexec(NULL, MARK, SP);
4220 #else
4221 #  ifdef __OPEN_VM
4222         {
4223            (void ) do_aspawn(NULL, MARK, SP);
4224            value = 0;
4225         }
4226 #  else
4227         value = (I32)do_aexec(NULL, MARK, SP);
4228 #  endif
4229 #endif
4230     else {
4231 #ifdef VMS
4232         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4233 #else
4234 #  ifdef __OPEN_VM
4235         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4236         value = 0;
4237 #  else
4238         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4239 #  endif
4240 #endif
4241     }
4242
4243     SP = ORIGMARK;
4244     XPUSHi(value);
4245     RETURN;
4246 }
4247
4248 PP(pp_getppid)
4249 {
4250 #ifdef HAS_GETPPID
4251     dVAR; dSP; dTARGET;
4252 #   ifdef THREADS_HAVE_PIDS
4253     if (PL_ppid != 1 && getppid() == 1)
4254         /* maybe the parent process has died. Refresh ppid cache */
4255         PL_ppid = 1;
4256     XPUSHi( PL_ppid );
4257 #   else
4258     XPUSHi( getppid() );
4259 #   endif
4260     RETURN;
4261 #else
4262     DIE(aTHX_ PL_no_func, "getppid");
4263 #endif
4264 }
4265
4266 PP(pp_getpgrp)
4267 {
4268 #ifdef HAS_GETPGRP
4269     dVAR; dSP; dTARGET;
4270     Pid_t pgrp;
4271     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4272
4273 #ifdef BSD_GETPGRP
4274     pgrp = (I32)BSD_GETPGRP(pid);
4275 #else
4276     if (pid != 0 && pid != PerlProc_getpid())
4277         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4278     pgrp = getpgrp();
4279 #endif
4280     XPUSHi(pgrp);
4281     RETURN;
4282 #else
4283     DIE(aTHX_ PL_no_func, "getpgrp()");
4284 #endif
4285 }
4286
4287 PP(pp_setpgrp)
4288 {
4289 #ifdef HAS_SETPGRP
4290     dVAR; dSP; dTARGET;
4291     Pid_t pgrp;
4292     Pid_t pid;
4293     if (MAXARG < 2) {
4294         pgrp = 0;
4295         pid = 0;
4296     }
4297     else {
4298         pgrp = POPi;
4299         pid = TOPi;
4300     }
4301
4302     TAINT_PROPER("setpgrp");
4303 #ifdef BSD_SETPGRP
4304     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4305 #else
4306     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4307         || (pid != 0 && pid != PerlProc_getpid()))
4308     {
4309         DIE(aTHX_ "setpgrp can't take arguments");
4310     }
4311     SETi( setpgrp() >= 0 );
4312 #endif /* USE_BSDPGRP */
4313     RETURN;
4314 #else
4315     DIE(aTHX_ PL_no_func, "setpgrp()");
4316 #endif
4317 }
4318
4319 PP(pp_getpriority)
4320 {
4321 #ifdef HAS_GETPRIORITY
4322     dVAR; dSP; dTARGET;
4323     const int who = POPi;
4324     const int which = TOPi;
4325     SETi( getpriority(which, who) );
4326     RETURN;
4327 #else
4328     DIE(aTHX_ PL_no_func, "getpriority()");
4329 #endif
4330 }
4331
4332 PP(pp_setpriority)
4333 {
4334 #ifdef HAS_SETPRIORITY
4335     dVAR; dSP; dTARGET;
4336     const int niceval = POPi;
4337     const int who = POPi;
4338     const int which = TOPi;
4339     TAINT_PROPER("setpriority");
4340     SETi( setpriority(which, who, niceval) >= 0 );
4341     RETURN;
4342 #else
4343     DIE(aTHX_ PL_no_func, "setpriority()");
4344 #endif
4345 }
4346
4347 /* Time calls. */
4348
4349 PP(pp_time)
4350 {
4351     dVAR; dSP; dTARGET;
4352 #ifdef BIG_TIME
4353     XPUSHn( time(NULL) );
4354 #else
4355     XPUSHi( time(NULL) );
4356 #endif
4357     RETURN;
4358 }
4359
4360 PP(pp_tms)
4361 {
4362 #ifdef HAS_TIMES
4363     dVAR;
4364     dSP;
4365     EXTEND(SP, 4);
4366 #ifndef VMS
4367     (void)PerlProc_times(&PL_timesbuf);
4368 #else
4369     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4370                                                    /* struct tms, though same data   */
4371                                                    /* is returned.                   */
4372 #endif
4373
4374     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4375     if (GIMME == G_ARRAY) {
4376         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4377         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4378         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4379     }
4380     RETURN;
4381 #else
4382 #   ifdef PERL_MICRO
4383     dSP;
4384     PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4385     EXTEND(SP, 4);
4386     if (GIMME == G_ARRAY) {
4387          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4388          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4389          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4390     }
4391     RETURN;
4392 #   else
4393     DIE(aTHX_ "times not implemented");
4394 #   endif
4395 #endif /* HAS_TIMES */
4396 }
4397
4398 #ifdef LOCALTIME_EDGECASE_BROKEN
4399 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4400 {
4401     auto time_t     T;
4402     auto struct tm *P;
4403
4404     /* No workarounds in the valid range */
4405     if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4406         return (localtime (tp));
4407
4408     /* This edge case is to workaround the undefined behaviour, where the
4409      * TIMEZONE makes the time go beyond the defined range.
4410      * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4411      * If there is a negative offset in TZ, like MET-1METDST, some broken
4412      * implementations of localtime () (like AIX 5.2) barf with bogus
4413      * return values:
4414      * 0x7fffffff gmtime               2038-01-19 03:14:07
4415      * 0x7fffffff localtime            1901-12-13 21:45:51
4416      * 0x7fffffff mylocaltime          2038-01-19 04:14:07
4417      * 0x3c19137f gmtime               2001-12-13 20:45:51
4418      * 0x3c19137f localtime            2001-12-13 21:45:51
4419      * 0x3c19137f mylocaltime          2001-12-13 21:45:51
4420      * Given that legal timezones are typically between GMT-12 and GMT+12
4421      * we turn back the clock 23 hours before calling the localtime
4422      * function, and add those to the return value. This will never cause
4423      * day wrapping problems, since the edge case is Tue Jan *19*
4424      */
4425     T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4426     P = localtime (&T);
4427     P->tm_hour += 23;
4428     if (P->tm_hour >= 24) {
4429         P->tm_hour -= 24;
4430         P->tm_mday++;   /* 18  -> 19  */
4431         P->tm_wday++;   /* Mon -> Tue */
4432         P->tm_yday++;   /* 18  -> 19  */
4433     }
4434     return (P);
4435 } /* S_my_localtime */
4436 #endif
4437
4438 PP(pp_gmtime)
4439 {
4440     dVAR;
4441     dSP;
4442     Time_t when;
4443     const struct tm *tmbuf;
4444     static const char * const dayname[] =
4445         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4446     static const char * const monname[] =
4447         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4448          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4449
4450     if (MAXARG < 1)
4451         (void)time(&when);
4452     else
4453 #ifdef BIG_TIME
4454         when = (Time_t)SvNVx(POPs);
4455 #else
4456         when = (Time_t)SvIVx(POPs);
4457 #endif
4458
4459     if (PL_op->op_type == OP_LOCALTIME)
4460 #ifdef LOCALTIME_EDGECASE_BROKEN
4461         tmbuf = S_my_localtime(aTHX_ &when);
4462 #else
4463         tmbuf = localtime(&when);
4464 #endif
4465     else
4466         tmbuf = gmtime(&when);
4467
4468     if (GIMME != G_ARRAY) {
4469         SV *tsv;
4470         EXTEND(SP, 1);
4471         EXTEND_MORTAL(1);
4472         if (!tmbuf)
4473             RETPUSHUNDEF;
4474         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4475                             dayname[tmbuf->tm_wday],
4476                             monname[tmbuf->tm_mon],
4477                             tmbuf->tm_mday,
4478                             tmbuf->tm_hour,
4479                             tmbuf->tm_min,
4480                             tmbuf->tm_sec,
4481                             tmbuf->tm_year + 1900);
4482         PUSHs(sv_2mortal(tsv));
4483     }
4484     else if (tmbuf) {
4485         EXTEND(SP, 9);
4486         EXTEND_MORTAL(9);
4487         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4488         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4489         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4490         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4491         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4492         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4493         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4494         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4495         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4496     }
4497     RETURN;
4498 }
4499
4500 PP(pp_alarm)
4501 {
4502 #ifdef HAS_ALARM
4503     dVAR; dSP; dTARGET;
4504     int anum;
4505     anum = POPi;
4506     anum = alarm((unsigned int)anum);
4507     EXTEND(SP, 1);
4508     if (anum < 0)
4509         RETPUSHUNDEF;
4510     PUSHi(anum);
4511     RETURN;
4512 #else
4513     DIE(aTHX_ PL_no_func, "alarm");
4514 #endif
4515 }
4516
4517 PP(pp_sleep)
4518 {
4519     dVAR; dSP; dTARGET;
4520     I32 duration;
4521     Time_t lasttime;
4522     Time_t when;
4523
4524     (void)time(&lasttime);
4525     if (MAXARG < 1)
4526         PerlProc_pause();
4527     else {
4528         duration = POPi;
4529         PerlProc_sleep((unsigned int)duration);
4530     }
4531     (void)time(&when);
4532     XPUSHi(when - lasttime);
4533     RETURN;
4534 }
4535
4536 /* Shared memory. */
4537 /* Merged with some message passing. */
4538
4539 PP(pp_shmwrite)
4540 {
4541 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4542     dVAR; dSP; dMARK; dTARGET;
4543     const int op_type = PL_op->op_type;
4544     I32 value;
4545
4546     switch (op_type) {
4547     case OP_MSGSND:
4548         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4549         break;
4550     case OP_MSGRCV:
4551         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4552         break;
4553     case OP_SEMOP:
4554         value = (I32)(do_semop(MARK, SP) >= 0);
4555         break;
4556     default:
4557         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4558         break;
4559     }
4560
4561     SP = MARK;
4562     PUSHi(value);
4563     RETURN;
4564 #else
4565     return pp_semget();
4566 #endif
4567 }
4568
4569 /* Semaphores. */
4570
4571 PP(pp_semget)
4572 {
4573 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4574     dVAR; dSP; dMARK; dTARGET;
4575     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4576     SP = MARK;
4577     if (anum == -1)
4578         RETPUSHUNDEF;
4579     PUSHi(anum);
4580     RETURN;
4581 #else
4582     DIE(aTHX_ "System V IPC is not implemented on this machine");
4583 #endif
4584 }
4585
4586 PP(pp_semctl)
4587 {
4588 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4589     dVAR; dSP; dMARK; dTARGET;
4590     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4591     SP = MARK;
4592     if (anum == -1)
4593         RETSETUNDEF;
4594     if (anum != 0) {
4595         PUSHi(anum);
4596     }
4597     else {
4598         PUSHp(zero_but_true, ZBTLEN);
4599     }
4600     RETURN;
4601 #else
4602     return pp_semget();
4603 #endif
4604 }
4605
4606 /* I can't const this further without getting warnings about the types of
4607    various arrays passed in from structures.  */
4608 static SV *
4609 S_space_join_names_mortal(pTHX_ char *const *array)
4610 {
4611     SV *target;
4612
4613     if (array && *array) {
4614         target = sv_2mortal(newSVpvs(""));
4615         while (1) {
4616             sv_catpv(target, *array);
4617             if (!*++array)
4618                 break;
4619             sv_catpvs(target, " ");
4620         }
4621     } else {
4622         target = sv_mortalcopy(&PL_sv_no);
4623     }
4624     return target;
4625 }
4626
4627 /* Get system info. */
4628
4629 PP(pp_ghostent)
4630 {
4631 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4632     dVAR; dSP;
4633     I32 which = PL_op->op_type;
4634     register char **elem;
4635     register SV *sv;
4636 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4637     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4638     struct hostent *gethostbyname(Netdb_name_t);
4639     struct hostent *gethostent(void);
4640 #endif
4641     struct hostent *hent;
4642     unsigned long len;
4643
4644     EXTEND(SP, 10);
4645     if (which == OP_GHBYNAME) {
4646 #ifdef HAS_GETHOSTBYNAME
4647         const char* const name = POPpbytex;
4648         hent = PerlSock_gethostbyname(name);
4649 #else
4650         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4651 #endif
4652     }
4653     else if (which == OP_GHBYADDR) {
4654 #ifdef HAS_GETHOSTBYADDR
4655         const int addrtype = POPi;
4656         SV * const addrsv = POPs;
4657         STRLEN addrlen;
4658         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4659
4660         hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4661 #else
4662         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4663 #endif
4664     }
4665     else
4666 #ifdef HAS_GETHOSTENT
4667         hent = PerlSock_gethostent();
4668 #else
4669         DIE(aTHX_ PL_no_sock_func, "gethostent");
4670 #endif
4671
4672 #ifdef HOST_NOT_FOUND
4673         if (!hent) {
4674 #ifdef USE_REENTRANT_API
4675 #   ifdef USE_GETHOSTENT_ERRNO
4676             h_errno = PL_reentrant_buffer->_gethostent_errno;
4677 #   endif
4678 #endif
4679             STATUS_UNIX_SET(h_errno);
4680         }
4681 #endif
4682
4683     if (GIMME != G_ARRAY) {
4684         PUSHs(sv = sv_newmortal());
4685         if (hent) {
4686             if (which == OP_GHBYNAME) {
4687                 if (hent->h_addr)
4688                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4689             }
4690             else
4691                 sv_setpv(sv, (char*)hent->h_name);
4692         }
4693         RETURN;
4694     }
4695
4696     if (hent) {
4697         PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4698         PUSHs(space_join_names_mortal(hent->h_aliases));
4699         PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4700         len = hent->h_length;
4701         PUSHs(sv_2mortal(newSViv((IV)len)));
4702 #ifdef h_addr
4703         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4704             XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4705         }
4706 #else
4707         if (hent->h_addr)
4708             PUSHs(newSVpvn(hent->h_addr, len));
4709         else
4710             PUSHs(sv_mortalcopy(&PL_sv_no));
4711 #endif /* h_addr */
4712     }
4713     RETURN;
4714 #else
4715     DIE(aTHX_ PL_no_sock_func, "gethostent");
4716 #endif
4717 }
4718
4719 PP(pp_gnetent)
4720 {
4721 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4722     dVAR; dSP;
4723     I32 which = PL_op->op_type;
4724     register SV *sv;
4725 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4726     struct netent *getnetbyaddr(Netdb_net_t, int);
4727     struct netent *getnetbyname(Netdb_name_t);
4728     struct netent *getnetent(void);
4729 #endif
4730     struct netent *nent;
4731
4732     if (which == OP_GNBYNAME){
4733 #ifdef HAS_GETNETBYNAME
4734         const char * const name = POPpbytex;
4735         nent = PerlSock_getnetbyname(name);
4736 #else
4737         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4738 #endif
4739     }
4740     else if (which == OP_GNBYADDR) {
4741 #ifdef HAS_GETNETBYADDR
4742         const int addrtype = POPi;
4743         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4744         nent = PerlSock_getnetbyaddr(addr, addrtype);
4745 #else
4746         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4747 #endif
4748     }
4749     else
4750 #ifdef HAS_GETNETENT
4751         nent = PerlSock_getnetent();
4752 #else
4753         DIE(aTHX_ PL_no_sock_func, "getnetent");
4754 #endif
4755
4756 #ifdef HOST_NOT_FOUND
4757         if (!nent) {
4758 #ifdef USE_REENTRANT_API
4759 #   ifdef USE_GETNETENT_ERRNO
4760              h_errno = PL_reentrant_buffer->_getnetent_errno;
4761 #   endif
4762 #endif
4763             STATUS_UNIX_SET(h_errno);
4764         }
4765 #endif
4766
4767     EXTEND(SP, 4);
4768     if (GIMME != G_ARRAY) {
4769         PUSHs(sv = sv_newmortal());
4770         if (nent) {
4771             if (which == OP_GNBYNAME)
4772                 sv_setiv(sv, (IV)nent->n_net);
4773             else
4774                 sv_setpv(sv, nent->n_name);
4775         }
4776         RETURN;
4777     }
4778
4779     if (nent) {
4780         PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4781         PUSHs(space_join_names_mortal(nent->n_aliases));
4782         PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4783         PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4784     }
4785
4786     RETURN;
4787 #else
4788     DIE(aTHX_ PL_no_sock_func, "getnetent");
4789 #endif
4790 }
4791
4792 PP(pp_gprotoent)
4793 {
4794 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4795     dVAR; dSP;
4796     I32 which = PL_op->op_type;
4797     register SV *sv;
4798 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4799     struct protoent *getprotobyname(Netdb_name_t);
4800     struct protoent *getprotobynumber(int);
4801     struct protoent *getprotoent(void);
4802 #endif
4803     struct protoent *pent;
4804
4805     if (which == OP_GPBYNAME) {
4806 #ifdef HAS_GETPROTOBYNAME
4807         const char* const name = POPpbytex;
4808         pent = PerlSock_getprotobyname(name);
4809 #else
4810         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4811 #endif
4812     }
4813     else if (which == OP_GPBYNUMBER) {
4814 #ifdef HAS_GETPROTOBYNUMBER
4815         const int number = POPi;
4816         pent = PerlSock_getprotobynumber(number);
4817 #else
4818         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4819 #endif
4820     }
4821     else
4822 #ifdef HAS_GETPROTOENT
4823         pent = PerlSock_getprotoent();
4824 #else
4825         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4826 #endif
4827
4828     EXTEND(SP, 3);
4829     if (GIMME != G_ARRAY) {
4830         PUSHs(sv = sv_newmortal());
4831         if (pent) {
4832             if (which == OP_GPBYNAME)
4833                 sv_setiv(sv, (IV)pent->p_proto);
4834             else
4835                 sv_setpv(sv, pent->p_name);
4836         }
4837         RETURN;
4838     }
4839
4840     if (pent) {
4841         PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4842         PUSHs(space_join_names_mortal(pent->p_aliases));
4843         PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4844     }
4845
4846     RETURN;
4847 #else
4848     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4849 #endif
4850 }
4851
4852 PP(pp_gservent)
4853 {
4854 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4855     dVAR; dSP;
4856     I32 which = PL_op->op_type;
4857     register SV *sv;
4858 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4859     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4860     struct servent *getservbyport(int, Netdb_name_t);
4861     struct servent *getservent(void);
4862 #endif
4863     struct servent *sent;
4864
4865     if (which == OP_GSBYNAME) {
4866 #ifdef HAS_GETSERVBYNAME
4867         const char * const proto = POPpbytex;
4868         const char * const name = POPpbytex;
4869         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4870 #else
4871         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4872 #endif
4873     }
4874     else if (which == OP_GSBYPORT) {
4875 #ifdef HAS_GETSERVBYPORT
4876         const char * const proto = POPpbytex;
4877         unsigned short port = (unsigned short)POPu;
4878 #ifdef HAS_HTONS
4879         port = PerlSock_htons(port);
4880 #endif
4881         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4882 #else
4883         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4884 #endif
4885     }
4886     else
4887 #ifdef HAS_GETSERVENT
4888         sent = PerlSock_getservent();
4889 #else
4890         DIE(aTHX_ PL_no_sock_func, "getservent");
4891 #endif
4892
4893     EXTEND(SP, 4);
4894     if (GIMME != G_ARRAY) {
4895         PUSHs(sv = sv_newmortal());
4896         if (sent) {
4897             if (which == OP_GSBYNAME) {
4898 #ifdef HAS_NTOHS
4899                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4900 #else
4901                 sv_setiv(sv, (IV)(sent->s_port));
4902 #endif
4903             }
4904             else
4905                 sv_setpv(sv, sent->s_name);
4906         }
4907         RETURN;
4908     }
4909
4910     if (sent) {
4911         PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4912         PUSHs(space_join_names_mortal(sent->s_aliases));
4913 #ifdef HAS_NTOHS
4914         PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4915 #else
4916         PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4917 #endif
4918         PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4919     }
4920
4921     RETURN;
4922 #else
4923     DIE(aTHX_ PL_no_sock_func, "getservent");
4924 #endif
4925 }
4926
4927 PP(pp_shostent)
4928 {
4929 #ifdef HAS_SETHOSTENT
4930     dVAR; dSP;
4931     PerlSock_sethostent(TOPi);
4932     RETSETYES;
4933 #else
4934     DIE(aTHX_ PL_no_sock_func, "sethostent");
4935 #endif
4936 }
4937
4938 PP(pp_snetent)
4939 {
4940 #ifdef HAS_SETNETENT
4941     dVAR; dSP;
4942     PerlSock_setnetent(TOPi);
4943     RETSETYES;
4944 #else
4945     DIE(aTHX_ PL_no_sock_func, "setnetent");
4946 #endif
4947 }
4948
4949 PP(pp_sprotoent)
4950 {
4951 #ifdef HAS_SETPROTOENT
4952     dVAR; dSP;
4953     PerlSock_setprotoent(TOPi);
4954     RETSETYES;
4955 #else
4956     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4957 #endif
4958 }
4959
4960 PP(pp_sservent)
4961 {
4962 #ifdef HAS_SETSERVENT
4963     dVAR; dSP;
4964     PerlSock_setservent(TOPi);
4965     RETSETYES;
4966 #else
4967     DIE(aTHX_ PL_no_sock_func, "setservent");
4968 #endif
4969 }
4970
4971 PP(pp_ehostent)
4972 {
4973 #ifdef HAS_ENDHOSTENT
4974     dVAR; dSP;
4975     PerlSock_endhostent();
4976     EXTEND(SP,1);
4977     RETPUSHYES;
4978 #else
4979     DIE(aTHX_ PL_no_sock_func, "endhostent");
4980 #endif
4981 }
4982
4983 PP(pp_enetent)
4984 {
4985 #ifdef HAS_ENDNETENT
4986     dVAR; dSP;
4987     PerlSock_endnetent();
4988     EXTEND(SP,1);
4989     RETPUSHYES;
4990 #else
4991     DIE(aTHX_ PL_no_sock_func, "endnetent");
4992 #endif
4993 }
4994
4995 PP(pp_eprotoent)
4996 {
4997 #ifdef HAS_ENDPROTOENT
4998     dVAR; dSP;
4999     PerlSock_endprotoent();
5000     EXTEND(SP,1);
5001     RETPUSHYES;
5002 #else
5003     DIE(aTHX_ PL_no_sock_func, "endprotoent");
5004 #endif
5005 }
5006
5007 PP(pp_eservent)
5008 {
5009 #ifdef HAS_ENDSERVENT
5010     dVAR; dSP;
5011     PerlSock_endservent();
5012     EXTEND(SP,1);
5013     RETPUSHYES;
5014 #else
5015     DIE(aTHX_ PL_no_sock_func, "endservent");
5016 #endif
5017 }
5018
5019 PP(pp_gpwent)
5020 {
5021 #ifdef HAS_PASSWD
5022     dVAR; dSP;
5023     I32 which = PL_op->op_type;
5024     register SV *sv;
5025     struct passwd *pwent  = NULL;
5026     /*
5027      * We currently support only the SysV getsp* shadow password interface.
5028      * The interface is declared in <shadow.h> and often one needs to link
5029      * with -lsecurity or some such.
5030      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5031      * (and SCO?)
5032      *
5033      * AIX getpwnam() is clever enough to return the encrypted password
5034      * only if the caller (euid?) is root.
5035      *
5036      * There are at least three other shadow password APIs.  Many platforms
5037      * seem to contain more than one interface for accessing the shadow
5038      * password databases, possibly for compatibility reasons.
5039      * The getsp*() is by far he simplest one, the other two interfaces
5040      * are much more complicated, but also very similar to each other.
5041      *
5042      * <sys/types.h>
5043      * <sys/security.h>
5044      * <prot.h>
5045      * struct pr_passwd *getprpw*();
5046      * The password is in
5047      * char getprpw*(...).ufld.fd_encrypt[]
5048      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5049      *
5050      * <sys/types.h>
5051      * <sys/security.h>
5052      * <prot.h>
5053      * struct es_passwd *getespw*();
5054      * The password is in
5055      * char *(getespw*(...).ufld.fd_encrypt)
5056      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5057      *
5058      * <userpw.h> (AIX)
5059      * struct userpw *getuserpw();
5060      * The password is in
5061      * char *(getuserpw(...)).spw_upw_passwd
5062      * (but the de facto standard getpwnam() should work okay)
5063      *
5064      * Mention I_PROT here so that Configure probes for it.
5065      *
5066      * In HP-UX for getprpw*() the manual page claims that one should include
5067      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5068      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5069      * and pp_sys.c already includes <shadow.h> if there is such.
5070      *
5071      * Note that <sys/security.h> is already probed for, but currently
5072      * it is only included in special cases.
5073      *
5074      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5075      * be preferred interface, even though also the getprpw*() interface
5076      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5077      * One also needs to call set_auth_parameters() in main() before
5078      * doing anything else, whether one is using getespw*() or getprpw*().
5079      *
5080      * Note that accessing the shadow databases can be magnitudes
5081      * slower than accessing the standard databases.
5082      *
5083      * --jhi
5084      */
5085
5086 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5087     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5088      * the pw_comment is left uninitialized. */
5089     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5090 #   endif
5091
5092     switch (which) {
5093     case OP_GPWNAM:
5094       {
5095         const char* const name = POPpbytex;
5096         pwent  = getpwnam(name);
5097       }
5098       break;
5099     case OP_GPWUID:
5100       {
5101         Uid_t uid = POPi;
5102         pwent = getpwuid(uid);
5103       }
5104         break;
5105     case OP_GPWENT:
5106 #   ifdef HAS_GETPWENT
5107         pwent  = getpwent();
5108 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5109         if (pwent) pwent = getpwnam(pwent->pw_name);
5110 #endif
5111 #   else
5112         DIE(aTHX_ PL_no_func, "getpwent");
5113 #   endif
5114         break;
5115     }
5116
5117     EXTEND(SP, 10);
5118     if (GIMME != G_ARRAY) {
5119         PUSHs(sv = sv_newmortal());
5120         if (pwent) {
5121             if (which == OP_GPWNAM)
5122 #   if Uid_t_sign <= 0
5123                 sv_setiv(sv, (IV)pwent->pw_uid);
5124 #   else
5125                 sv_setuv(sv, (UV)pwent->pw_uid);
5126 #   endif
5127             else
5128                 sv_setpv(sv, pwent->pw_name);
5129         }
5130         RETURN;
5131     }
5132
5133     if (pwent) {
5134         PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5135
5136         PUSHs(sv = sv_2mortal(newSViv(0)));
5137         /* If we have getspnam(), we try to dig up the shadow
5138          * password.  If we are underprivileged, the shadow
5139          * interface will set the errno to EACCES or similar,
5140          * and return a null pointer.  If this happens, we will
5141          * use the dummy password (usually "*" or "x") from the
5142          * standard password database.
5143          *
5144          * In theory we could skip the shadow call completely
5145          * if euid != 0 but in practice we cannot know which
5146          * security measures are guarding the shadow databases
5147          * on a random platform.
5148          *
5149          * Resist the urge to use additional shadow interfaces.
5150          * Divert the urge to writing an extension instead.
5151          *
5152          * --jhi */
5153         /* Some AIX setups falsely(?) detect some getspnam(), which
5154          * has a different API than the Solaris/IRIX one. */
5155 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5156         {
5157             const int saverrno = errno;
5158             const struct spwd * const spwent = getspnam(pwent->pw_name);
5159                           /* Save and restore errno so that
5160                            * underprivileged attempts seem
5161                            * to have never made the unsccessful
5162                            * attempt to retrieve the shadow password. */
5163             errno = saverrno;
5164             if (spwent && spwent->sp_pwdp)
5165                 sv_setpv(sv, spwent->sp_pwdp);
5166         }
5167 #   endif
5168 #   ifdef PWPASSWD
5169         if (!SvPOK(sv)) /* Use the standard password, then. */
5170             sv_setpv(sv, pwent->pw_passwd);
5171 #   endif
5172
5173 #   ifndef INCOMPLETE_TAINTS
5174         /* passwd is tainted because user himself can diddle with it.
5175          * admittedly not much and in a very limited way, but nevertheless. */
5176         SvTAINTED_on(sv);
5177 #   endif
5178
5179 #   if Uid_t_sign <= 0
5180         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5181 #   else
5182         PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5183 #   endif
5184
5185 #   if Uid_t_sign <= 0
5186         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5187 #   else
5188         PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5189 #   endif
5190         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5191          * because of the poor interface of the Perl getpw*(),
5192          * not because there's some standard/convention saying so.
5193          * A better interface would have been to return a hash,
5194          * but we are accursed by our history, alas. --jhi.  */
5195 #   ifdef PWCHANGE
5196         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5197 #   else
5198 #       ifdef PWQUOTA
5199         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5200 #       else
5201 #           ifdef PWAGE
5202         PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5203 #           else
5204         /* I think that you can never get this compiled, but just in case.  */
5205         PUSHs(sv_mortalcopy(&PL_sv_no));
5206 #           endif
5207 #       endif
5208 #   endif
5209
5210         /* pw_class and pw_comment are mutually exclusive--.
5211          * see the above note for pw_change, pw_quota, and pw_age. */
5212 #   ifdef PWCLASS
5213         PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5214 #   else
5215 #       ifdef PWCOMMENT
5216         PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5217 #       else
5218         /* I think that you can never get this compiled, but just in case.  */
5219         PUSHs(sv_mortalcopy(&PL_sv_no));
5220 #       endif
5221 #   endif
5222
5223 #   ifdef PWGECOS
5224         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5225 #   else
5226         PUSHs(sv_mortalcopy(&PL_sv_no));
5227 #   endif
5228 #   ifndef INCOMPLETE_TAINTS
5229         /* pw_gecos is tainted because user himself can diddle with it. */
5230         SvTAINTED_on(sv);
5231 #   endif
5232
5233         PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5234
5235         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5236 #   ifndef INCOMPLETE_TAINTS
5237         /* pw_shell is tainted because user himself can diddle with it. */
5238         SvTAINTED_on(sv);
5239 #   endif
5240
5241 #   ifdef PWEXPIRE
5242         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5243 #   endif
5244     }
5245     RETURN;
5246 #else
5247     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5248 #endif
5249 }
5250
5251 PP(pp_spwent)
5252 {
5253 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5254     dVAR; dSP;
5255     setpwent();
5256     RETPUSHYES;
5257 #else
5258     DIE(aTHX_ PL_no_func, "setpwent");
5259 #endif
5260 }
5261
5262 PP(pp_epwent)
5263 {
5264 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5265     dVAR; dSP;
5266     endpwent();
5267     RETPUSHYES;
5268 #else
5269     DIE(aTHX_ PL_no_func, "endpwent");
5270 #endif
5271 }
5272
5273 PP(pp_ggrent)
5274 {
5275 #ifdef HAS_GROUP
5276     dVAR; dSP;
5277     const I32 which = PL_op->op_type;
5278     const struct group *grent;
5279
5280     if (which == OP_GGRNAM) {
5281         const char* const name = POPpbytex;
5282         grent = (const struct group *)getgrnam(name);
5283     }
5284     else if (which == OP_GGRGID) {
5285         const Gid_t gid = POPi;
5286         grent = (const struct group *)getgrgid(gid);
5287     }
5288     else
5289 #ifdef HAS_GETGRENT
5290         grent = (struct group *)getgrent();
5291 #else
5292         DIE(aTHX_ PL_no_func, "getgrent");
5293 #endif
5294
5295     EXTEND(SP, 4);
5296     if (GIMME != G_ARRAY) {
5297         SV * const sv = sv_newmortal();
5298
5299         PUSHs(sv);
5300         if (grent) {
5301             if (which == OP_GGRNAM)
5302                 sv_setiv(sv, (IV)grent->gr_gid);
5303             else
5304                 sv_setpv(sv, grent->gr_name);
5305         }
5306         RETURN;
5307     }
5308
5309     if (grent) {
5310         PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5311
5312 #ifdef GRPASSWD
5313         PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5314 #else
5315         PUSHs(sv_mortalcopy(&PL_sv_no));
5316 #endif
5317
5318         PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5319
5320 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5321         /* In UNICOS/mk (_CRAYMPP) the multithreading
5322          * versions (getgrnam_r, getgrgid_r)
5323          * seem to return an illegal pointer
5324          * as the group members list, gr_mem.
5325          * getgrent() doesn't even have a _r version
5326          * but the gr_mem is poisonous anyway.
5327          * So yes, you cannot get the list of group
5328          * members if building multithreaded in UNICOS/mk. */
5329         PUSHs(space_join_names_mortal(grent->gr_mem));
5330 #endif
5331     }
5332
5333     RETURN;
5334 #else
5335     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5336 #endif
5337 }
5338
5339 PP(pp_sgrent)
5340 {
5341 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5342     dVAR; dSP;
5343     setgrent();
5344     RETPUSHYES;
5345 #else
5346     DIE(aTHX_ PL_no_func, "setgrent");
5347 #endif
5348 }
5349
5350 PP(pp_egrent)
5351 {
5352 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5353     dVAR; dSP;
5354     endgrent();
5355     RETPUSHYES;
5356 #else
5357     DIE(aTHX_ PL_no_func, "endgrent");
5358 #endif
5359 }
5360
5361 PP(pp_getlogin)
5362 {
5363 #ifdef HAS_GETLOGIN
5364     dVAR; dSP; dTARGET;
5365     char *tmps;
5366     EXTEND(SP, 1);
5367     if (!(tmps = PerlProc_getlogin()))
5368         RETPUSHUNDEF;
5369     PUSHp(tmps, strlen(tmps));
5370     RETURN;
5371 #else
5372     DIE(aTHX_ PL_no_func, "getlogin");
5373 #endif
5374 }
5375
5376 /* Miscellaneous. */
5377
5378 PP(pp_syscall)
5379 {
5380 #ifdef HAS_SYSCALL
5381     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5382     register I32 items = SP - MARK;
5383     unsigned long a[20];
5384     register I32 i = 0;
5385     I32 retval = -1;
5386
5387     if (PL_tainting) {
5388         while (++MARK <= SP) {
5389             if (SvTAINTED(*MARK)) {
5390                 TAINT;
5391                 break;
5392             }
5393         }
5394         MARK = ORIGMARK;
5395         TAINT_PROPER("syscall");
5396     }
5397
5398     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5399      * or where sizeof(long) != sizeof(char*).  But such machines will
5400      * not likely have syscall implemented either, so who cares?
5401      */
5402     while (++MARK <= SP) {
5403         if (SvNIOK(*MARK) || !i)
5404             a[i++] = SvIV(*MARK);
5405         else if (*MARK == &PL_sv_undef)
5406             a[i++] = 0;
5407         else
5408             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5409         if (i > 15)
5410             break;
5411     }
5412     switch (items) {
5413     default:
5414         DIE(aTHX_ "Too many args to syscall");
5415     case 0:
5416         DIE(aTHX_ "Too few args to syscall");
5417     case 1:
5418         retval = syscall(a[0]);
5419         break;
5420     case 2:
5421         retval = syscall(a[0],a[1]);
5422         break;
5423     case 3:
5424         retval = syscall(a[0],a[1],a[2]);
5425         break;
5426     case 4:
5427         retval = syscall(a[0],a[1],a[2],a[3]);
5428         break;
5429     case 5:
5430         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5431         break;
5432     case 6:
5433         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5434         break;
5435     case 7:
5436         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5437         break;
5438     case 8:
5439         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5440         break;
5441 #ifdef atarist
5442     case 9:
5443         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5444         break;
5445     case 10:
5446         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5447         break;
5448     case 11:
5449         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5450           a[10]);
5451         break;
5452     case 12:
5453         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5454           a[10],a[11]);
5455         break;
5456     case 13:
5457         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5458           a[10],a[11],a[12]);
5459         break;
5460     case 14:
5461         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5462           a[10],a[11],a[12],a[13]);
5463         break;
5464 #endif /* atarist */
5465     }
5466     SP = ORIGMARK;
5467     PUSHi(retval);
5468     RETURN;
5469 #else
5470     DIE(aTHX_ PL_no_func, "syscall");
5471 #endif
5472 }
5473
5474 #ifdef FCNTL_EMULATE_FLOCK
5475
5476 /*  XXX Emulate flock() with fcntl().
5477     What's really needed is a good file locking module.
5478 */
5479
5480 static int
5481 fcntl_emulate_flock(int fd, int operation)
5482 {
5483     struct flock flock;
5484
5485     switch (operation & ~LOCK_NB) {
5486     case LOCK_SH:
5487         flock.l_type = F_RDLCK;
5488         break;
5489     case LOCK_EX:
5490         flock.l_type = F_WRLCK;
5491         break;
5492     case LOCK_UN:
5493         flock.l_type = F_UNLCK;
5494         break;
5495     default:
5496         errno = EINVAL;
5497         return -1;
5498     }
5499     flock.l_whence = SEEK_SET;
5500     flock.l_start = flock.l_len = (Off_t)0;
5501
5502     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5503 }
5504
5505 #endif /* FCNTL_EMULATE_FLOCK */
5506
5507 #ifdef LOCKF_EMULATE_FLOCK
5508
5509 /*  XXX Emulate flock() with lockf().  This is just to increase
5510     portability of scripts.  The calls are not completely
5511     interchangeable.  What's really needed is a good file
5512     locking module.
5513 */
5514
5515 /*  The lockf() constants might have been defined in <unistd.h>.
5516     Unfortunately, <unistd.h> causes troubles on some mixed
5517     (BSD/POSIX) systems, such as SunOS 4.1.3.
5518
5519    Further, the lockf() constants aren't POSIX, so they might not be
5520    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5521    just stick in the SVID values and be done with it.  Sigh.
5522 */
5523
5524 # ifndef F_ULOCK
5525 #  define F_ULOCK       0       /* Unlock a previously locked region */
5526 # endif
5527 # ifndef F_LOCK
5528 #  define F_LOCK        1       /* Lock a region for exclusive use */
5529 # endif
5530 # ifndef F_TLOCK
5531 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5532 # endif
5533 # ifndef F_TEST
5534 #  define F_TEST        3       /* Test a region for other processes locks */
5535 # endif
5536
5537 static int
5538 lockf_emulate_flock(int fd, int operation)
5539 {
5540     int i;
5541     const int save_errno = errno;
5542     Off_t pos;
5543
5544     /* flock locks entire file so for lockf we need to do the same      */
5545     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5546     if (pos > 0)        /* is seekable and needs to be repositioned     */
5547         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5548             pos = -1;   /* seek failed, so don't seek back afterwards   */
5549     errno = save_errno;
5550
5551     switch (operation) {
5552
5553         /* LOCK_SH - get a shared lock */
5554         case LOCK_SH:
5555         /* LOCK_EX - get an exclusive lock */
5556         case LOCK_EX:
5557             i = lockf (fd, F_LOCK, 0);
5558             break;
5559
5560         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5561         case LOCK_SH|LOCK_NB:
5562         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5563         case LOCK_EX|LOCK_NB:
5564             i = lockf (fd, F_TLOCK, 0);
5565             if (i == -1)
5566                 if ((errno == EAGAIN) || (errno == EACCES))
5567                     errno = EWOULDBLOCK;
5568             break;
5569
5570         /* LOCK_UN - unlock (non-blocking is a no-op) */
5571         case LOCK_UN:
5572         case LOCK_UN|LOCK_NB:
5573             i = lockf (fd, F_ULOCK, 0);
5574             break;
5575
5576         /* Default - can't decipher operation */
5577         default:
5578             i = -1;
5579             errno = EINVAL;
5580             break;
5581     }
5582
5583     if (pos > 0)      /* need to restore position of the handle */
5584         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5585
5586     return (i);
5587 }
5588
5589 #endif /* LOCKF_EMULATE_FLOCK */
5590
5591 /*
5592  * Local variables:
5593  * c-indentation-style: bsd
5594  * c-basic-offset: 4
5595  * indent-tabs-mode: t
5596  * End:
5597  *
5598  * ex: set ts=8 sts=4 sw=4 noet:
5599  */