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