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