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) {
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     else if (!gv) {
2094         if (!errno)
2095             SETERRNO(EBADF,RMS_IFI);
2096         PUSHi(-1);
2097         RETURN;
2098     }
2099
2100 #if LSEEKSIZE > IVSIZE
2101     PUSHn( do_tell(gv) );
2102 #else
2103     PUSHi( do_tell(gv) );
2104 #endif
2105     RETURN;
2106 }
2107
2108 PP(pp_sysseek)
2109 {
2110     dVAR; dSP;
2111     const int whence = POPi;
2112 #if LSEEKSIZE > IVSIZE
2113     const Off_t offset = (Off_t)SvNVx(POPs);
2114 #else
2115     const Off_t offset = (Off_t)SvIVx(POPs);
2116 #endif
2117
2118     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2119     IO *io;
2120
2121     if (gv && (io = GvIO(gv))) {
2122         MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2123         if (mg) {
2124             PUSHMARK(SP);
2125             XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2126 #if LSEEKSIZE > IVSIZE
2127             mXPUSHn((NV) offset);
2128 #else
2129             mXPUSHi(offset);
2130 #endif
2131             mXPUSHi(whence);
2132             PUTBACK;
2133             ENTER;
2134             call_method("SEEK", G_SCALAR);
2135             LEAVE;
2136             SPAGAIN;
2137             RETURN;
2138         }
2139     }
2140
2141     if (PL_op->op_type == OP_SEEK)
2142         PUSHs(boolSV(do_seek(gv, offset, whence)));
2143     else {
2144         const Off_t sought = do_sysseek(gv, offset, whence);
2145         if (sought < 0)
2146             PUSHs(&PL_sv_undef);
2147         else {
2148             SV* const sv = sought ?
2149 #if LSEEKSIZE > IVSIZE
2150                 newSVnv((NV)sought)
2151 #else
2152                 newSViv(sought)
2153 #endif
2154                 : newSVpvn(zero_but_true, ZBTLEN);
2155             mPUSHs(sv);
2156         }
2157     }
2158     RETURN;
2159 }
2160
2161 PP(pp_truncate)
2162 {
2163     dVAR;
2164     dSP;
2165     /* There seems to be no consensus on the length type of truncate()
2166      * and ftruncate(), both off_t and size_t have supporters. In
2167      * general one would think that when using large files, off_t is
2168      * at least as wide as size_t, so using an off_t should be okay. */
2169     /* XXX Configure probe for the length type of *truncate() needed XXX */
2170     Off_t len;
2171
2172 #if Off_t_size > IVSIZE
2173     len = (Off_t)POPn;
2174 #else
2175     len = (Off_t)POPi;
2176 #endif
2177     /* Checking for length < 0 is problematic as the type might or
2178      * might not be signed: if it is not, clever compilers will moan. */
2179     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2180     SETERRNO(0,0);
2181     {
2182         int result = 1;
2183         GV *tmpgv;
2184         IO *io;
2185
2186         if (PL_op->op_flags & OPf_SPECIAL) {
2187             tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2188
2189         do_ftruncate_gv:
2190             if (!GvIO(tmpgv))
2191                 result = 0;
2192             else {
2193                 PerlIO *fp;
2194                 io = GvIOp(tmpgv);
2195             do_ftruncate_io:
2196                 TAINT_PROPER("truncate");
2197                 if (!(fp = IoIFP(io))) {
2198                     result = 0;
2199                 }
2200                 else {
2201                     PerlIO_flush(fp);
2202 #ifdef HAS_TRUNCATE
2203                     if (ftruncate(PerlIO_fileno(fp), len) < 0)
2204 #else
2205                     if (my_chsize(PerlIO_fileno(fp), len) < 0)
2206 #endif
2207                         result = 0;
2208                 }
2209             }
2210         }
2211         else {
2212             SV * const sv = POPs;
2213             const char *name;
2214
2215             if (isGV_with_GP(sv)) {
2216                 tmpgv = MUTABLE_GV(sv);         /* *main::FRED for example */
2217                 goto do_ftruncate_gv;
2218             }
2219             else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2220                 tmpgv = MUTABLE_GV(SvRV(sv));   /* \*main::FRED for example */
2221                 goto do_ftruncate_gv;
2222             }
2223             else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2224                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2225                 goto do_ftruncate_io;
2226             }
2227
2228             name = SvPV_nolen_const(sv);
2229             TAINT_PROPER("truncate");
2230 #ifdef HAS_TRUNCATE
2231             if (truncate(name, len) < 0)
2232                 result = 0;
2233 #else
2234             {
2235                 const int tmpfd = PerlLIO_open(name, O_RDWR);
2236
2237                 if (tmpfd < 0)
2238                     result = 0;
2239                 else {
2240                     if (my_chsize(tmpfd, len) < 0)
2241                         result = 0;
2242                     PerlLIO_close(tmpfd);
2243                 }
2244             }
2245 #endif
2246         }
2247
2248         if (result)
2249             RETPUSHYES;
2250         if (!errno)
2251             SETERRNO(EBADF,RMS_IFI);
2252         RETPUSHUNDEF;
2253     }
2254 }
2255
2256 PP(pp_ioctl)
2257 {
2258     dVAR; dSP; dTARGET;
2259     SV * const argsv = POPs;
2260     const unsigned int func = POPu;
2261     const int optype = PL_op->op_type;
2262     GV * const gv = MUTABLE_GV(POPs);
2263     IO * const io = gv ? GvIOn(gv) : NULL;
2264     char *s;
2265     IV retval;
2266
2267     if (!io || !argsv || !IoIFP(io)) {
2268         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2269             report_evil_fh(gv, io, PL_op->op_type);
2270         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2271         RETPUSHUNDEF;
2272     }
2273
2274     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2275         STRLEN len;
2276         STRLEN need;
2277         s = SvPV_force(argsv, len);
2278         need = IOCPARM_LEN(func);
2279         if (len < need) {
2280             s = Sv_Grow(argsv, need + 1);
2281             SvCUR_set(argsv, need);
2282         }
2283
2284         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2285     }
2286     else {
2287         retval = SvIV(argsv);
2288         s = INT2PTR(char*,retval);              /* ouch */
2289     }
2290
2291     TAINT_PROPER(PL_op_desc[optype]);
2292
2293     if (optype == OP_IOCTL)
2294 #ifdef HAS_IOCTL
2295         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2296 #else
2297         DIE(aTHX_ "ioctl is not implemented");
2298 #endif
2299     else
2300 #ifndef HAS_FCNTL
2301       DIE(aTHX_ "fcntl is not implemented");
2302 #else
2303 #if defined(OS2) && defined(__EMX__)
2304         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2305 #else
2306         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2307 #endif
2308 #endif
2309
2310 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2311     if (SvPOK(argsv)) {
2312         if (s[SvCUR(argsv)] != 17)
2313             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2314                 OP_NAME(PL_op));
2315         s[SvCUR(argsv)] = 0;            /* put our null back */
2316         SvSETMAGIC(argsv);              /* Assume it has changed */
2317     }
2318
2319     if (retval == -1)
2320         RETPUSHUNDEF;
2321     if (retval != 0) {
2322         PUSHi(retval);
2323     }
2324     else {
2325         PUSHp(zero_but_true, ZBTLEN);
2326     }
2327 #endif
2328     RETURN;
2329 }
2330
2331 PP(pp_flock)
2332 {
2333 #ifdef FLOCK
2334     dVAR; dSP; dTARGET;
2335     I32 value;
2336     IO *io = NULL;
2337     PerlIO *fp;
2338     const int argtype = POPi;
2339     GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2340
2341     if (gv && (io = GvIO(gv)))
2342         fp = IoIFP(io);
2343     else {
2344         fp = NULL;
2345         io = NULL;
2346     }
2347     /* XXX Looks to me like io is always NULL at this point */
2348     if (fp) {
2349         (void)PerlIO_flush(fp);
2350         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2351     }
2352     else {
2353         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2354             report_evil_fh(gv, io, PL_op->op_type);
2355         value = 0;
2356         SETERRNO(EBADF,RMS_IFI);
2357     }
2358     PUSHi(value);
2359     RETURN;
2360 #else
2361     DIE(aTHX_ PL_no_func, "flock()");
2362 #endif
2363 }
2364
2365 /* Sockets. */
2366
2367 PP(pp_socket)
2368 {
2369 #ifdef HAS_SOCKET
2370     dVAR; dSP;
2371     const int protocol = POPi;
2372     const int type = POPi;
2373     const int domain = POPi;
2374     GV * const gv = MUTABLE_GV(POPs);
2375     register IO * const io = gv ? GvIOn(gv) : NULL;
2376     int fd;
2377
2378     if (!gv || !io) {
2379         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2380             report_evil_fh(gv, io, PL_op->op_type);
2381         if (io && IoIFP(io))
2382             do_close(gv, FALSE);
2383         SETERRNO(EBADF,LIB_INVARG);
2384         RETPUSHUNDEF;
2385     }
2386
2387     if (IoIFP(io))
2388         do_close(gv, FALSE);
2389
2390     TAINT_PROPER("socket");
2391     fd = PerlSock_socket(domain, type, protocol);
2392     if (fd < 0)
2393         RETPUSHUNDEF;
2394     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2395     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2396     IoTYPE(io) = IoTYPE_SOCKET;
2397     if (!IoIFP(io) || !IoOFP(io)) {
2398         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2399         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2400         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2401         RETPUSHUNDEF;
2402     }
2403 #if defined(HAS_FCNTL) && defined(F_SETFD)
2404     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2405 #endif
2406
2407 #ifdef EPOC
2408     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2409 #endif
2410
2411     RETPUSHYES;
2412 #else
2413     DIE(aTHX_ PL_no_sock_func, "socket");
2414 #endif
2415 }
2416
2417 PP(pp_sockpair)
2418 {
2419 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2420     dVAR; dSP;
2421     const int protocol = POPi;
2422     const int type = POPi;
2423     const int domain = POPi;
2424     GV * const gv2 = MUTABLE_GV(POPs);
2425     GV * const gv1 = MUTABLE_GV(POPs);
2426     register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2427     register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2428     int fd[2];
2429
2430     if (!gv1 || !gv2 || !io1 || !io2) {
2431         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2432             if (!gv1 || !io1)
2433                 report_evil_fh(gv1, io1, PL_op->op_type);
2434             if (!gv2 || !io2)
2435                 report_evil_fh(gv1, io2, PL_op->op_type);
2436         }
2437         if (io1 && IoIFP(io1))
2438             do_close(gv1, FALSE);
2439         if (io2 && IoIFP(io2))
2440             do_close(gv2, FALSE);
2441         RETPUSHUNDEF;
2442     }
2443
2444     if (IoIFP(io1))
2445         do_close(gv1, FALSE);
2446     if (IoIFP(io2))
2447         do_close(gv2, FALSE);
2448
2449     TAINT_PROPER("socketpair");
2450     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2451         RETPUSHUNDEF;
2452     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2453     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2454     IoTYPE(io1) = IoTYPE_SOCKET;
2455     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2456     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2457     IoTYPE(io2) = IoTYPE_SOCKET;
2458     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2459         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2460         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2461         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2462         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2463         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2464         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2465         RETPUSHUNDEF;
2466     }
2467 #if defined(HAS_FCNTL) && defined(F_SETFD)
2468     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2469     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2470 #endif
2471
2472     RETPUSHYES;
2473 #else
2474     DIE(aTHX_ PL_no_sock_func, "socketpair");
2475 #endif
2476 }
2477
2478 PP(pp_bind)
2479 {
2480 #ifdef HAS_SOCKET
2481     dVAR; dSP;
2482     SV * const addrsv = POPs;
2483     /* OK, so on what platform does bind modify addr?  */
2484     const char *addr;
2485     GV * const gv = MUTABLE_GV(POPs);
2486     register IO * const io = GvIOn(gv);
2487     STRLEN len;
2488
2489     if (!io || !IoIFP(io))
2490         goto nuts;
2491
2492     addr = SvPV_const(addrsv, len);
2493     TAINT_PROPER("bind");
2494     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2495         RETPUSHYES;
2496     else
2497         RETPUSHUNDEF;
2498
2499 nuts:
2500     if (ckWARN(WARN_CLOSED))
2501         report_evil_fh(gv, io, PL_op->op_type);
2502     SETERRNO(EBADF,SS_IVCHAN);
2503     RETPUSHUNDEF;
2504 #else
2505     DIE(aTHX_ PL_no_sock_func, "bind");
2506 #endif
2507 }
2508
2509 PP(pp_connect)
2510 {
2511 #ifdef HAS_SOCKET
2512     dVAR; dSP;
2513     SV * const addrsv = POPs;
2514     GV * const gv = MUTABLE_GV(POPs);
2515     register IO * const io = GvIOn(gv);
2516     const char *addr;
2517     STRLEN len;
2518
2519     if (!io || !IoIFP(io))
2520         goto nuts;
2521
2522     addr = SvPV_const(addrsv, len);
2523     TAINT_PROPER("connect");
2524     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2525         RETPUSHYES;
2526     else
2527         RETPUSHUNDEF;
2528
2529 nuts:
2530     if (ckWARN(WARN_CLOSED))
2531         report_evil_fh(gv, io, PL_op->op_type);
2532     SETERRNO(EBADF,SS_IVCHAN);
2533     RETPUSHUNDEF;
2534 #else
2535     DIE(aTHX_ PL_no_sock_func, "connect");
2536 #endif
2537 }
2538
2539 PP(pp_listen)
2540 {
2541 #ifdef HAS_SOCKET
2542     dVAR; dSP;
2543     const int backlog = POPi;
2544     GV * const gv = MUTABLE_GV(POPs);
2545     register IO * const io = gv ? GvIOn(gv) : NULL;
2546
2547     if (!gv || !io || !IoIFP(io))
2548         goto nuts;
2549
2550     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2551         RETPUSHYES;
2552     else
2553         RETPUSHUNDEF;
2554
2555 nuts:
2556     if (ckWARN(WARN_CLOSED))
2557         report_evil_fh(gv, io, PL_op->op_type);
2558     SETERRNO(EBADF,SS_IVCHAN);
2559     RETPUSHUNDEF;
2560 #else
2561     DIE(aTHX_ PL_no_sock_func, "listen");
2562 #endif
2563 }
2564
2565 PP(pp_accept)
2566 {
2567 #ifdef HAS_SOCKET
2568     dVAR; dSP; dTARGET;
2569     register IO *nstio;
2570     register IO *gstio;
2571     char namebuf[MAXPATHLEN];
2572 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2573     Sock_size_t len = sizeof (struct sockaddr_in);
2574 #else
2575     Sock_size_t len = sizeof namebuf;
2576 #endif
2577     GV * const ggv = MUTABLE_GV(POPs);
2578     GV * const ngv = MUTABLE_GV(POPs);
2579     int fd;
2580
2581     if (!ngv)
2582         goto badexit;
2583     if (!ggv)
2584         goto nuts;
2585
2586     gstio = GvIO(ggv);
2587     if (!gstio || !IoIFP(gstio))
2588         goto nuts;
2589
2590     nstio = GvIOn(ngv);
2591     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2592 #if defined(OEMVS)
2593     if (len == 0) {
2594         /* Some platforms indicate zero length when an AF_UNIX client is
2595          * not bound. Simulate a non-zero-length sockaddr structure in
2596          * this case. */
2597         namebuf[0] = 0;        /* sun_len */
2598         namebuf[1] = AF_UNIX;  /* sun_family */
2599         len = 2;
2600     }
2601 #endif
2602
2603     if (fd < 0)
2604         goto badexit;
2605     if (IoIFP(nstio))
2606         do_close(ngv, FALSE);
2607     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2608     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2609     IoTYPE(nstio) = IoTYPE_SOCKET;
2610     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2611         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2612         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2613         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2614         goto badexit;
2615     }
2616 #if defined(HAS_FCNTL) && defined(F_SETFD)
2617     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2618 #endif
2619
2620 #ifdef EPOC
2621     len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2622     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2623 #endif
2624 #ifdef __SCO_VERSION__
2625     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2626 #endif
2627
2628     PUSHp(namebuf, len);
2629     RETURN;
2630
2631 nuts:
2632     if (ckWARN(WARN_CLOSED))
2633         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2634     SETERRNO(EBADF,SS_IVCHAN);
2635
2636 badexit:
2637     RETPUSHUNDEF;
2638
2639 #else
2640     DIE(aTHX_ PL_no_sock_func, "accept");
2641 #endif
2642 }
2643
2644 PP(pp_shutdown)
2645 {
2646 #ifdef HAS_SOCKET
2647     dVAR; dSP; dTARGET;
2648     const int how = POPi;
2649     GV * const gv = MUTABLE_GV(POPs);
2650     register IO * const io = GvIOn(gv);
2651
2652     if (!io || !IoIFP(io))
2653         goto nuts;
2654
2655     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2656     RETURN;
2657
2658 nuts:
2659     if (ckWARN(WARN_CLOSED))
2660         report_evil_fh(gv, io, PL_op->op_type);
2661     SETERRNO(EBADF,SS_IVCHAN);
2662     RETPUSHUNDEF;
2663 #else
2664     DIE(aTHX_ PL_no_sock_func, "shutdown");
2665 #endif
2666 }
2667
2668 PP(pp_ssockopt)
2669 {
2670 #ifdef HAS_SOCKET
2671     dVAR; dSP;
2672     const int optype = PL_op->op_type;
2673     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2674     const unsigned int optname = (unsigned int) POPi;
2675     const unsigned int lvl = (unsigned int) POPi;
2676     GV * const gv = MUTABLE_GV(POPs);
2677     register IO * const io = GvIOn(gv);
2678     int fd;
2679     Sock_size_t len;
2680
2681     if (!io || !IoIFP(io))
2682         goto nuts;
2683
2684     fd = PerlIO_fileno(IoIFP(io));
2685     switch (optype) {
2686     case OP_GSOCKOPT:
2687         SvGROW(sv, 257);
2688         (void)SvPOK_only(sv);
2689         SvCUR_set(sv,256);
2690         *SvEND(sv) ='\0';
2691         len = SvCUR(sv);
2692         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2693             goto nuts2;
2694         SvCUR_set(sv, len);
2695         *SvEND(sv) ='\0';
2696         PUSHs(sv);
2697         break;
2698     case OP_SSOCKOPT: {
2699 #if defined(__SYMBIAN32__)
2700 # define SETSOCKOPT_OPTION_VALUE_T void *
2701 #else
2702 # define SETSOCKOPT_OPTION_VALUE_T const char *
2703 #endif
2704         /* XXX TODO: We need to have a proper type (a Configure probe,
2705          * etc.) for what the C headers think of the third argument of
2706          * setsockopt(), the option_value read-only buffer: is it
2707          * a "char *", or a "void *", const or not.  Some compilers
2708          * don't take kindly to e.g. assuming that "char *" implicitly
2709          * promotes to a "void *", or to explicitly promoting/demoting
2710          * consts to non/vice versa.  The "const void *" is the SUS
2711          * definition, but that does not fly everywhere for the above
2712          * reasons. */
2713             SETSOCKOPT_OPTION_VALUE_T buf;
2714             int aint;
2715             if (SvPOKp(sv)) {
2716                 STRLEN l;
2717                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2718                 len = l;
2719             }
2720             else {
2721                 aint = (int)SvIV(sv);
2722                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2723                 len = sizeof(int);
2724             }
2725             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2726                 goto nuts2;
2727             PUSHs(&PL_sv_yes);
2728         }
2729         break;
2730     }
2731     RETURN;
2732
2733 nuts:
2734     if (ckWARN(WARN_CLOSED))
2735         report_evil_fh(gv, io, optype);
2736     SETERRNO(EBADF,SS_IVCHAN);
2737 nuts2:
2738     RETPUSHUNDEF;
2739
2740 #else
2741     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2742 #endif
2743 }
2744
2745 PP(pp_getpeername)
2746 {
2747 #ifdef HAS_SOCKET
2748     dVAR; dSP;
2749     const int optype = PL_op->op_type;
2750     GV * const gv = MUTABLE_GV(POPs);
2751     register IO * const io = GvIOn(gv);
2752     Sock_size_t len;
2753     SV *sv;
2754     int fd;
2755
2756     if (!io || !IoIFP(io))
2757         goto nuts;
2758
2759     sv = sv_2mortal(newSV(257));
2760     (void)SvPOK_only(sv);
2761     len = 256;
2762     SvCUR_set(sv, len);
2763     *SvEND(sv) ='\0';
2764     fd = PerlIO_fileno(IoIFP(io));
2765     switch (optype) {
2766     case OP_GETSOCKNAME:
2767         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2768             goto nuts2;
2769         break;
2770     case OP_GETPEERNAME:
2771         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2772             goto nuts2;
2773 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2774         {
2775             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";
2776             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2777             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2778                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2779                         sizeof(u_short) + sizeof(struct in_addr))) {
2780                 goto nuts2;
2781             }
2782         }
2783 #endif
2784         break;
2785     }
2786 #ifdef BOGUS_GETNAME_RETURN
2787     /* Interactive Unix, getpeername() and getsockname()
2788       does not return valid namelen */
2789     if (len == BOGUS_GETNAME_RETURN)
2790         len = sizeof(struct sockaddr);
2791 #endif
2792     SvCUR_set(sv, len);
2793     *SvEND(sv) ='\0';
2794     PUSHs(sv);
2795     RETURN;
2796
2797 nuts:
2798     if (ckWARN(WARN_CLOSED))
2799         report_evil_fh(gv, io, optype);
2800     SETERRNO(EBADF,SS_IVCHAN);
2801 nuts2:
2802     RETPUSHUNDEF;
2803
2804 #else
2805     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2806 #endif
2807 }
2808
2809 /* Stat calls. */
2810
2811 PP(pp_stat)
2812 {
2813     dVAR;
2814     dSP;
2815     GV *gv = NULL;
2816     IO *io;
2817     I32 gimme;
2818     I32 max = 13;
2819
2820     if (PL_op->op_flags & OPf_REF) {
2821         gv = cGVOP_gv;
2822         if (PL_op->op_type == OP_LSTAT) {
2823             if (gv != PL_defgv) {
2824             do_fstat_warning_check:
2825                 if (ckWARN(WARN_IO))
2826                     Perl_warner(aTHX_ packWARN(WARN_IO),
2827                         "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2828             } else if (PL_laststype != OP_LSTAT)
2829                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2830         }
2831
2832       do_fstat:
2833         if (gv != PL_defgv) {
2834             PL_laststype = OP_STAT;
2835             PL_statgv = gv;
2836             sv_setpvs(PL_statname, "");
2837             if(gv) {
2838                 io = GvIO(gv);
2839                 do_fstat_have_io:
2840                 if (io) {
2841                     if (IoIFP(io)) {
2842                         PL_laststatval =
2843                             PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2844                     } else if (IoDIRP(io)) {
2845                         PL_laststatval =
2846                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2847                     } else {
2848                         PL_laststatval = -1;
2849                     }
2850                 }
2851             }
2852         }
2853
2854         if (PL_laststatval < 0) {
2855             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2856                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2857             max = 0;
2858         }
2859     }
2860     else {
2861         SV* const sv = POPs;
2862         if (isGV_with_GP(sv)) {
2863             gv = MUTABLE_GV(sv);
2864             goto do_fstat;
2865         } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2866             gv = MUTABLE_GV(SvRV(sv));
2867             if (PL_op->op_type == OP_LSTAT)
2868                 goto do_fstat_warning_check;
2869             goto do_fstat;
2870         } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2871             io = MUTABLE_IO(SvRV(sv));
2872             if (PL_op->op_type == OP_LSTAT)
2873                 goto do_fstat_warning_check;
2874             goto do_fstat_have_io;
2875         }
2876
2877         sv_setpv(PL_statname, SvPV_nolen_const(sv));
2878         PL_statgv = NULL;
2879         PL_laststype = PL_op->op_type;
2880         if (PL_op->op_type == OP_LSTAT)
2881             PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2882         else
2883             PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2884         if (PL_laststatval < 0) {
2885             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2886                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2887             max = 0;
2888         }
2889     }
2890
2891     gimme = GIMME_V;
2892     if (gimme != G_ARRAY) {
2893         if (gimme != G_VOID)
2894             XPUSHs(boolSV(max));
2895         RETURN;
2896     }
2897     if (max) {
2898         EXTEND(SP, max);
2899         EXTEND_MORTAL(max);
2900         mPUSHi(PL_statcache.st_dev);
2901         mPUSHi(PL_statcache.st_ino);
2902         mPUSHu(PL_statcache.st_mode);
2903         mPUSHu(PL_statcache.st_nlink);
2904 #if Uid_t_size > IVSIZE
2905         mPUSHn(PL_statcache.st_uid);
2906 #else
2907 #   if Uid_t_sign <= 0
2908         mPUSHi(PL_statcache.st_uid);
2909 #   else
2910         mPUSHu(PL_statcache.st_uid);
2911 #   endif
2912 #endif
2913 #if Gid_t_size > IVSIZE
2914         mPUSHn(PL_statcache.st_gid);
2915 #else
2916 #   if Gid_t_sign <= 0
2917         mPUSHi(PL_statcache.st_gid);
2918 #   else
2919         mPUSHu(PL_statcache.st_gid);
2920 #   endif
2921 #endif
2922 #ifdef USE_STAT_RDEV
2923         mPUSHi(PL_statcache.st_rdev);
2924 #else
2925         PUSHs(newSVpvs_flags("", SVs_TEMP));
2926 #endif
2927 #if Off_t_size > IVSIZE
2928         mPUSHn(PL_statcache.st_size);
2929 #else
2930         mPUSHi(PL_statcache.st_size);
2931 #endif
2932 #ifdef BIG_TIME
2933         mPUSHn(PL_statcache.st_atime);
2934         mPUSHn(PL_statcache.st_mtime);
2935         mPUSHn(PL_statcache.st_ctime);
2936 #else
2937         mPUSHi(PL_statcache.st_atime);
2938         mPUSHi(PL_statcache.st_mtime);
2939         mPUSHi(PL_statcache.st_ctime);
2940 #endif
2941 #ifdef USE_STAT_BLOCKS
2942         mPUSHu(PL_statcache.st_blksize);
2943         mPUSHu(PL_statcache.st_blocks);
2944 #else
2945         PUSHs(newSVpvs_flags("", SVs_TEMP));
2946         PUSHs(newSVpvs_flags("", SVs_TEMP));
2947 #endif
2948     }
2949     RETURN;
2950 }
2951
2952 /* This macro is used by the stacked filetest operators :
2953  * if the previous filetest failed, short-circuit and pass its value.
2954  * Else, discard it from the stack and continue. --rgs
2955  */
2956 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2957         if (!SvTRUE(TOPs)) { RETURN; } \
2958         else { (void)POPs; PUTBACK; } \
2959     }
2960
2961 PP(pp_ftrread)
2962 {
2963     dVAR;
2964     I32 result;
2965     /* Not const, because things tweak this below. Not bool, because there's
2966        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2967 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2968     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2969     /* Giving some sort of initial value silences compilers.  */
2970 #  ifdef R_OK
2971     int access_mode = R_OK;
2972 #  else
2973     int access_mode = 0;
2974 #  endif
2975 #else
2976     /* access_mode is never used, but leaving use_access in makes the
2977        conditional compiling below much clearer.  */
2978     I32 use_access = 0;
2979 #endif
2980     int stat_mode = S_IRUSR;
2981
2982     bool effective = FALSE;
2983     char opchar = '?';
2984     dSP;
2985
2986     switch (PL_op->op_type) {
2987     case OP_FTRREAD:    opchar = 'R'; break;
2988     case OP_FTRWRITE:   opchar = 'W'; break;
2989     case OP_FTREXEC:    opchar = 'X'; break;
2990     case OP_FTEREAD:    opchar = 'r'; break;
2991     case OP_FTEWRITE:   opchar = 'w'; break;
2992     case OP_FTEEXEC:    opchar = 'x'; break;
2993     }
2994     tryAMAGICftest(opchar);
2995
2996     STACKED_FTEST_CHECK;
2997
2998     switch (PL_op->op_type) {
2999     case OP_FTRREAD:
3000 #if !(defined(HAS_ACCESS) && defined(R_OK))
3001         use_access = 0;
3002 #endif
3003         break;
3004
3005     case OP_FTRWRITE:
3006 #if defined(HAS_ACCESS) && defined(W_OK)
3007         access_mode = W_OK;
3008 #else
3009         use_access = 0;
3010 #endif
3011         stat_mode = S_IWUSR;
3012         break;
3013
3014     case OP_FTREXEC:
3015 #if defined(HAS_ACCESS) && defined(X_OK)
3016         access_mode = X_OK;
3017 #else
3018         use_access = 0;
3019 #endif
3020         stat_mode = S_IXUSR;
3021         break;
3022
3023     case OP_FTEWRITE:
3024 #ifdef PERL_EFF_ACCESS
3025         access_mode = W_OK;
3026 #endif
3027         stat_mode = S_IWUSR;
3028         /* fall through */
3029
3030     case OP_FTEREAD:
3031 #ifndef PERL_EFF_ACCESS
3032         use_access = 0;
3033 #endif
3034         effective = TRUE;
3035         break;
3036
3037     case OP_FTEEXEC:
3038 #ifdef PERL_EFF_ACCESS
3039         access_mode = X_OK;
3040 #else
3041         use_access = 0;
3042 #endif
3043         stat_mode = S_IXUSR;
3044         effective = TRUE;
3045         break;
3046     }
3047
3048     if (use_access) {
3049 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3050         const char *name = POPpx;
3051         if (effective) {
3052 #  ifdef PERL_EFF_ACCESS
3053             result = PERL_EFF_ACCESS(name, access_mode);
3054 #  else
3055             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3056                 OP_NAME(PL_op));
3057 #  endif
3058         }
3059         else {
3060 #  ifdef HAS_ACCESS
3061             result = access(name, access_mode);
3062 #  else
3063             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3064 #  endif
3065         }
3066         if (result == 0)
3067             RETPUSHYES;
3068         if (result < 0)
3069             RETPUSHUNDEF;
3070         RETPUSHNO;
3071 #endif
3072     }
3073
3074     result = my_stat();
3075     SPAGAIN;
3076     if (result < 0)
3077         RETPUSHUNDEF;
3078     if (cando(stat_mode, effective, &PL_statcache))
3079         RETPUSHYES;
3080     RETPUSHNO;
3081 }
3082
3083 PP(pp_ftis)
3084 {
3085     dVAR;
3086     I32 result;
3087     const int op_type = PL_op->op_type;
3088     char opchar = '?';
3089     dSP;
3090
3091     switch (op_type) {
3092     case OP_FTIS:       opchar = 'e'; break;
3093     case OP_FTSIZE:     opchar = 's'; break;
3094     case OP_FTMTIME:    opchar = 'M'; break;
3095     case OP_FTCTIME:    opchar = 'C'; break;
3096     case OP_FTATIME:    opchar = 'A'; break;
3097     }
3098     tryAMAGICftest(opchar);
3099
3100     STACKED_FTEST_CHECK;
3101
3102     result = my_stat();
3103     SPAGAIN;
3104     if (result < 0)
3105         RETPUSHUNDEF;
3106     if (op_type == OP_FTIS)
3107         RETPUSHYES;
3108     {
3109         /* You can't dTARGET inside OP_FTIS, because you'll get
3110            "panic: pad_sv po" - the op is not flagged to have a target.  */
3111         dTARGET;
3112         switch (op_type) {
3113         case OP_FTSIZE:
3114 #if Off_t_size > IVSIZE
3115             PUSHn(PL_statcache.st_size);
3116 #else
3117             PUSHi(PL_statcache.st_size);
3118 #endif
3119             break;
3120         case OP_FTMTIME:
3121             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3122             break;
3123         case OP_FTATIME:
3124             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3125             break;
3126         case OP_FTCTIME:
3127             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3128             break;
3129         }
3130     }
3131     RETURN;
3132 }
3133
3134 PP(pp_ftrowned)
3135 {
3136     dVAR;
3137     I32 result;
3138     char opchar = '?';
3139     dSP;
3140
3141     switch (PL_op->op_type) {
3142     case OP_FTROWNED:   opchar = 'O'; break;
3143     case OP_FTEOWNED:   opchar = 'o'; break;
3144     case OP_FTZERO:     opchar = 'z'; break;
3145     case OP_FTSOCK:     opchar = 'S'; break;
3146     case OP_FTCHR:      opchar = 'c'; break;
3147     case OP_FTBLK:      opchar = 'b'; break;
3148     case OP_FTFILE:     opchar = 'f'; break;
3149     case OP_FTDIR:      opchar = 'd'; break;
3150     case OP_FTPIPE:     opchar = 'p'; break;
3151     case OP_FTSUID:     opchar = 'u'; break;
3152     case OP_FTSGID:     opchar = 'g'; break;
3153     case OP_FTSVTX:     opchar = 'k'; break;
3154     }
3155     tryAMAGICftest(opchar);
3156
3157     /* I believe that all these three are likely to be defined on most every
3158        system these days.  */
3159 #ifndef S_ISUID
3160     if(PL_op->op_type == OP_FTSUID)
3161         RETPUSHNO;
3162 #endif
3163 #ifndef S_ISGID
3164     if(PL_op->op_type == OP_FTSGID)
3165         RETPUSHNO;
3166 #endif
3167 #ifndef S_ISVTX
3168     if(PL_op->op_type == OP_FTSVTX)
3169         RETPUSHNO;
3170 #endif
3171
3172     STACKED_FTEST_CHECK;
3173
3174     result = my_stat();
3175     SPAGAIN;
3176     if (result < 0)
3177         RETPUSHUNDEF;
3178     switch (PL_op->op_type) {
3179     case OP_FTROWNED:
3180         if (PL_statcache.st_uid == PL_uid)
3181             RETPUSHYES;
3182         break;
3183     case OP_FTEOWNED:
3184         if (PL_statcache.st_uid == PL_euid)
3185             RETPUSHYES;
3186         break;
3187     case OP_FTZERO:
3188         if (PL_statcache.st_size == 0)
3189             RETPUSHYES;
3190         break;
3191     case OP_FTSOCK:
3192         if (S_ISSOCK(PL_statcache.st_mode))
3193             RETPUSHYES;
3194         break;
3195     case OP_FTCHR:
3196         if (S_ISCHR(PL_statcache.st_mode))
3197             RETPUSHYES;
3198         break;
3199     case OP_FTBLK:
3200         if (S_ISBLK(PL_statcache.st_mode))
3201             RETPUSHYES;
3202         break;
3203     case OP_FTFILE:
3204         if (S_ISREG(PL_statcache.st_mode))
3205             RETPUSHYES;
3206         break;
3207     case OP_FTDIR:
3208         if (S_ISDIR(PL_statcache.st_mode))
3209             RETPUSHYES;
3210         break;
3211     case OP_FTPIPE:
3212         if (S_ISFIFO(PL_statcache.st_mode))
3213             RETPUSHYES;
3214         break;
3215 #ifdef S_ISUID
3216     case OP_FTSUID:
3217         if (PL_statcache.st_mode & S_ISUID)
3218             RETPUSHYES;
3219         break;
3220 #endif
3221 #ifdef S_ISGID
3222     case OP_FTSGID:
3223         if (PL_statcache.st_mode & S_ISGID)
3224             RETPUSHYES;
3225         break;
3226 #endif
3227 #ifdef S_ISVTX
3228     case OP_FTSVTX:
3229         if (PL_statcache.st_mode & S_ISVTX)
3230             RETPUSHYES;
3231         break;
3232 #endif
3233     }
3234     RETPUSHNO;
3235 }
3236
3237 PP(pp_ftlink)
3238 {
3239     dVAR;
3240     dSP;
3241     I32 result;
3242
3243     tryAMAGICftest('l');
3244     result = my_lstat();
3245     SPAGAIN;
3246
3247     if (result < 0)
3248         RETPUSHUNDEF;
3249     if (S_ISLNK(PL_statcache.st_mode))
3250         RETPUSHYES;
3251     RETPUSHNO;
3252 }
3253
3254 PP(pp_fttty)
3255 {
3256     dVAR;
3257     dSP;
3258     int fd;
3259     GV *gv;
3260     SV *tmpsv = NULL;
3261
3262     tryAMAGICftest('t');
3263
3264     STACKED_FTEST_CHECK;
3265
3266     if (PL_op->op_flags & OPf_REF)
3267         gv = cGVOP_gv;
3268     else if (isGV(TOPs))
3269         gv = MUTABLE_GV(POPs);
3270     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3271         gv = MUTABLE_GV(SvRV(POPs));
3272     else
3273         gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3274
3275     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3276         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3277     else if (tmpsv && SvOK(tmpsv)) {
3278         const char *tmps = SvPV_nolen_const(tmpsv);
3279         if (isDIGIT(*tmps))
3280             fd = atoi(tmps);
3281         else
3282             RETPUSHUNDEF;
3283     }
3284     else
3285         RETPUSHUNDEF;
3286     if (PerlLIO_isatty(fd))
3287         RETPUSHYES;
3288     RETPUSHNO;
3289 }
3290
3291 #if defined(atarist) /* this will work with atariST. Configure will
3292                         make guesses for other systems. */
3293 # define FILE_base(f) ((f)->_base)
3294 # define FILE_ptr(f) ((f)->_ptr)
3295 # define FILE_cnt(f) ((f)->_cnt)
3296 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3297 #endif
3298
3299 PP(pp_fttext)
3300 {
3301     dVAR;
3302     dSP;
3303     I32 i;
3304     I32 len;
3305     I32 odd = 0;
3306     STDCHAR tbuf[512];
3307     register STDCHAR *s;
3308     register IO *io;
3309     register SV *sv;
3310     GV *gv;
3311     PerlIO *fp;
3312
3313     tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3314
3315     STACKED_FTEST_CHECK;
3316
3317     if (PL_op->op_flags & OPf_REF)
3318         gv = cGVOP_gv;
3319     else if (isGV(TOPs))
3320         gv = MUTABLE_GV(POPs);
3321     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3322         gv = MUTABLE_GV(SvRV(POPs));
3323     else
3324         gv = NULL;
3325
3326     if (gv) {
3327         EXTEND(SP, 1);
3328         if (gv == PL_defgv) {
3329             if (PL_statgv)
3330                 io = GvIO(PL_statgv);
3331             else {
3332                 sv = PL_statname;
3333                 goto really_filename;
3334             }
3335         }
3336         else {
3337             PL_statgv = gv;
3338             PL_laststatval = -1;
3339             sv_setpvs(PL_statname, "");
3340             io = GvIO(PL_statgv);
3341         }
3342         if (io && IoIFP(io)) {
3343             if (! PerlIO_has_base(IoIFP(io)))
3344                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3345             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3346             if (PL_laststatval < 0)
3347                 RETPUSHUNDEF;
3348             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3349                 if (PL_op->op_type == OP_FTTEXT)
3350                     RETPUSHNO;
3351                 else
3352                     RETPUSHYES;
3353             }
3354             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3355                 i = PerlIO_getc(IoIFP(io));
3356                 if (i != EOF)
3357                     (void)PerlIO_ungetc(IoIFP(io),i);
3358             }
3359             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3360                 RETPUSHYES;
3361             len = PerlIO_get_bufsiz(IoIFP(io));
3362             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3363             /* sfio can have large buffers - limit to 512 */
3364             if (len > 512)
3365                 len = 512;
3366         }
3367         else {
3368             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3369                 gv = cGVOP_gv;
3370                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3371             }
3372             SETERRNO(EBADF,RMS_IFI);
3373             RETPUSHUNDEF;
3374         }
3375     }
3376     else {
3377         sv = POPs;
3378       really_filename:
3379         PL_statgv = NULL;
3380         PL_laststype = OP_STAT;
3381         sv_setpv(PL_statname, SvPV_nolen_const(sv));
3382         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3383             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3384                                                '\n'))
3385                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3386             RETPUSHUNDEF;
3387         }
3388         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3389         if (PL_laststatval < 0) {
3390             (void)PerlIO_close(fp);
3391             RETPUSHUNDEF;
3392         }
3393         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3394         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3395         (void)PerlIO_close(fp);
3396         if (len <= 0) {
3397             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3398                 RETPUSHNO;              /* special case NFS directories */
3399             RETPUSHYES;         /* null file is anything */
3400         }
3401         s = tbuf;
3402     }
3403
3404     /* now scan s to look for textiness */
3405     /*   XXX ASCII dependent code */
3406
3407 #if defined(DOSISH) || defined(USEMYBINMODE)
3408     /* ignore trailing ^Z on short files */
3409     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3410         --len;
3411 #endif
3412
3413     for (i = 0; i < len; i++, s++) {
3414         if (!*s) {                      /* null never allowed in text */
3415             odd += len;
3416             break;
3417         }
3418 #ifdef EBCDIC
3419         else if (!(isPRINT(*s) || isSPACE(*s)))
3420             odd++;
3421 #else
3422         else if (*s & 128) {
3423 #ifdef USE_LOCALE
3424             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3425                 continue;
3426 #endif
3427             /* utf8 characters don't count as odd */
3428             if (UTF8_IS_START(*s)) {
3429                 int ulen = UTF8SKIP(s);
3430                 if (ulen < len - i) {
3431                     int j;
3432                     for (j = 1; j < ulen; j++) {
3433                         if (!UTF8_IS_CONTINUATION(s[j]))
3434                             goto not_utf8;
3435                     }
3436                     --ulen;     /* loop does extra increment */
3437                     s += ulen;
3438                     i += ulen;
3439                     continue;
3440                 }
3441             }
3442           not_utf8:
3443             odd++;
3444         }
3445         else if (*s < 32 &&
3446           *s != '\n' && *s != '\r' && *s != '\b' &&
3447           *s != '\t' && *s != '\f' && *s != 27)
3448             odd++;
3449 #endif
3450     }
3451
3452     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3453         RETPUSHNO;
3454     else
3455         RETPUSHYES;
3456 }
3457
3458 /* File calls. */
3459
3460 PP(pp_chdir)
3461 {
3462     dVAR; dSP; dTARGET;
3463     const char *tmps = NULL;
3464     GV *gv = NULL;
3465
3466     if( MAXARG == 1 ) {
3467         SV * const sv = POPs;
3468         if (PL_op->op_flags & OPf_SPECIAL) {
3469             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3470         }
3471         else if (isGV_with_GP(sv)) {
3472             gv = MUTABLE_GV(sv);
3473         }
3474         else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3475             gv = MUTABLE_GV(SvRV(sv));
3476         }
3477         else {
3478             tmps = SvPV_nolen_const(sv);
3479         }
3480     }
3481
3482     if( !gv && (!tmps || !*tmps) ) {
3483         HV * const table = GvHVn(PL_envgv);
3484         SV **svp;
3485
3486         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3487              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3488 #ifdef VMS
3489              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3490 #endif
3491            )
3492         {
3493             if( MAXARG == 1 )
3494                 deprecate("chdir('') or chdir(undef) as chdir()");
3495             tmps = SvPV_nolen_const(*svp);
3496         }
3497         else {
3498             PUSHi(0);
3499             TAINT_PROPER("chdir");
3500             RETURN;
3501         }
3502     }
3503
3504     TAINT_PROPER("chdir");
3505     if (gv) {
3506 #ifdef HAS_FCHDIR
3507         IO* const io = GvIO(gv);
3508         if (io) {
3509             if (IoDIRP(io)) {
3510                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3511             } else if (IoIFP(io)) {
3512                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3513             }
3514             else {
3515                 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3516                     report_evil_fh(gv, io, PL_op->op_type);
3517                 SETERRNO(EBADF, RMS_IFI);
3518                 PUSHi(0);
3519             }
3520         }
3521         else {
3522             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3523                 report_evil_fh(gv, io, PL_op->op_type);
3524             SETERRNO(EBADF,RMS_IFI);
3525             PUSHi(0);
3526         }
3527 #else
3528         DIE(aTHX_ PL_no_func, "fchdir");
3529 #endif
3530     }
3531     else
3532         PUSHi( PerlDir_chdir(tmps) >= 0 );
3533 #ifdef VMS
3534     /* Clear the DEFAULT element of ENV so we'll get the new value
3535      * in the future. */
3536     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3537 #endif
3538     RETURN;
3539 }
3540
3541 PP(pp_chown)
3542 {
3543     dVAR; dSP; dMARK; dTARGET;
3544     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3545
3546     SP = MARK;
3547     XPUSHi(value);
3548     RETURN;
3549 }
3550
3551 PP(pp_chroot)
3552 {
3553 #ifdef HAS_CHROOT
3554     dVAR; dSP; dTARGET;
3555     char * const tmps = POPpx;
3556     TAINT_PROPER("chroot");
3557     PUSHi( chroot(tmps) >= 0 );
3558     RETURN;
3559 #else
3560     DIE(aTHX_ PL_no_func, "chroot");
3561 #endif
3562 }
3563
3564 PP(pp_rename)
3565 {
3566     dVAR; dSP; dTARGET;
3567     int anum;
3568     const char * const tmps2 = POPpconstx;
3569     const char * const tmps = SvPV_nolen_const(TOPs);
3570     TAINT_PROPER("rename");
3571 #ifdef HAS_RENAME
3572     anum = PerlLIO_rename(tmps, tmps2);
3573 #else
3574     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3575         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3576             anum = 1;
3577         else {
3578             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3579                 (void)UNLINK(tmps2);
3580             if (!(anum = link(tmps, tmps2)))
3581                 anum = UNLINK(tmps);
3582         }
3583     }
3584 #endif
3585     SETi( anum >= 0 );
3586     RETURN;
3587 }
3588
3589 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3590 PP(pp_link)
3591 {
3592     dVAR; dSP; dTARGET;
3593     const int op_type = PL_op->op_type;
3594     int result;
3595
3596 #  ifndef HAS_LINK
3597     if (op_type == OP_LINK)
3598         DIE(aTHX_ PL_no_func, "link");
3599 #  endif
3600 #  ifndef HAS_SYMLINK
3601     if (op_type == OP_SYMLINK)
3602         DIE(aTHX_ PL_no_func, "symlink");
3603 #  endif
3604
3605     {
3606         const char * const tmps2 = POPpconstx;
3607         const char * const tmps = SvPV_nolen_const(TOPs);
3608         TAINT_PROPER(PL_op_desc[op_type]);
3609         result =
3610 #  if defined(HAS_LINK)
3611 #    if defined(HAS_SYMLINK)
3612             /* Both present - need to choose which.  */
3613             (op_type == OP_LINK) ?
3614             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3615 #    else
3616     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3617         PerlLIO_link(tmps, tmps2);
3618 #    endif
3619 #  else
3620 #    if defined(HAS_SYMLINK)
3621     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3622         symlink(tmps, tmps2);
3623 #    endif
3624 #  endif
3625     }
3626
3627     SETi( result >= 0 );
3628     RETURN;
3629 }
3630 #else
3631 PP(pp_link)
3632 {
3633     /* Have neither.  */
3634     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3635 }
3636 #endif
3637
3638 PP(pp_readlink)
3639 {
3640     dVAR;
3641     dSP;
3642 #ifdef HAS_SYMLINK
3643     dTARGET;
3644     const char *tmps;
3645     char buf[MAXPATHLEN];
3646     int len;
3647
3648 #ifndef INCOMPLETE_TAINTS
3649     TAINT;
3650 #endif
3651     tmps = POPpconstx;
3652     len = readlink(tmps, buf, sizeof(buf) - 1);
3653     EXTEND(SP, 1);
3654     if (len < 0)
3655         RETPUSHUNDEF;
3656     PUSHp(buf, len);
3657     RETURN;
3658 #else
3659     EXTEND(SP, 1);
3660     RETSETUNDEF;                /* just pretend it's a normal file */
3661 #endif
3662 }
3663
3664 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3665 STATIC int
3666 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3667 {
3668     char * const save_filename = filename;
3669     char *cmdline;
3670     char *s;
3671     PerlIO *myfp;
3672     int anum = 1;
3673     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3674
3675     PERL_ARGS_ASSERT_DOONELINER;
3676
3677     Newx(cmdline, size, char);
3678     my_strlcpy(cmdline, cmd, size);
3679     my_strlcat(cmdline, " ", size);
3680     for (s = cmdline + strlen(cmdline); *filename; ) {
3681         *s++ = '\\';
3682         *s++ = *filename++;
3683     }
3684     if (s - cmdline < size)
3685         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3686     myfp = PerlProc_popen(cmdline, "r");
3687     Safefree(cmdline);
3688
3689     if (myfp) {
3690         SV * const tmpsv = sv_newmortal();
3691         /* Need to save/restore 'PL_rs' ?? */
3692         s = sv_gets(tmpsv, myfp, 0);
3693         (void)PerlProc_pclose(myfp);
3694         if (s != NULL) {
3695             int e;
3696             for (e = 1;
3697 #ifdef HAS_SYS_ERRLIST
3698                  e <= sys_nerr
3699 #endif
3700                  ; e++)
3701             {
3702                 /* you don't see this */
3703                 const char * const errmsg =
3704 #ifdef HAS_SYS_ERRLIST
3705                     sys_errlist[e]
3706 #else
3707                     strerror(e)
3708 #endif
3709                     ;
3710                 if (!errmsg)
3711                     break;
3712                 if (instr(s, errmsg)) {
3713                     SETERRNO(e,0);
3714                     return 0;
3715                 }
3716             }
3717             SETERRNO(0,0);
3718 #ifndef EACCES
3719 #define EACCES EPERM
3720 #endif
3721             if (instr(s, "cannot make"))
3722                 SETERRNO(EEXIST,RMS_FEX);
3723             else if (instr(s, "existing file"))
3724                 SETERRNO(EEXIST,RMS_FEX);
3725             else if (instr(s, "ile exists"))
3726                 SETERRNO(EEXIST,RMS_FEX);
3727             else if (instr(s, "non-exist"))
3728                 SETERRNO(ENOENT,RMS_FNF);
3729             else if (instr(s, "does not exist"))
3730                 SETERRNO(ENOENT,RMS_FNF);
3731             else if (instr(s, "not empty"))
3732                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3733             else if (instr(s, "cannot access"))
3734                 SETERRNO(EACCES,RMS_PRV);
3735             else
3736                 SETERRNO(EPERM,RMS_PRV);
3737             return 0;
3738         }
3739         else {  /* some mkdirs return no failure indication */
3740             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3741             if (PL_op->op_type == OP_RMDIR)
3742                 anum = !anum;
3743             if (anum)
3744                 SETERRNO(0,0);
3745             else
3746                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3747         }
3748         return anum;
3749     }
3750     else
3751         return 0;
3752 }
3753 #endif
3754
3755 /* This macro removes trailing slashes from a directory name.
3756  * Different operating and file systems take differently to
3757  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3758  * any number of trailing slashes should be allowed.
3759  * Thusly we snip them away so that even non-conforming
3760  * systems are happy.
3761  * We should probably do this "filtering" for all
3762  * the functions that expect (potentially) directory names:
3763  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3764  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3765
3766 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3767     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3768         do { \
3769             (len)--; \
3770         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3771         (tmps) = savepvn((tmps), (len)); \
3772         (copy) = TRUE; \
3773     }
3774
3775 PP(pp_mkdir)
3776 {
3777     dVAR; dSP; dTARGET;
3778     STRLEN len;
3779     const char *tmps;
3780     bool copy = FALSE;
3781     const int mode = (MAXARG > 1) ? POPi : 0777;
3782
3783     TRIMSLASHES(tmps,len,copy);
3784
3785     TAINT_PROPER("mkdir");
3786 #ifdef HAS_MKDIR
3787     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3788 #else
3789     {
3790     int oldumask;
3791     SETi( dooneliner("mkdir", tmps) );
3792     oldumask = PerlLIO_umask(0);
3793     PerlLIO_umask(oldumask);
3794     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3795     }
3796 #endif
3797     if (copy)
3798         Safefree(tmps);
3799     RETURN;
3800 }
3801
3802 PP(pp_rmdir)
3803 {
3804     dVAR; dSP; dTARGET;
3805     STRLEN len;
3806     const char *tmps;
3807     bool copy = FALSE;
3808
3809     TRIMSLASHES(tmps,len,copy);
3810     TAINT_PROPER("rmdir");
3811 #ifdef HAS_RMDIR
3812     SETi( PerlDir_rmdir(tmps) >= 0 );
3813 #else
3814     SETi( dooneliner("rmdir", tmps) );
3815 #endif
3816     if (copy)
3817         Safefree(tmps);
3818     RETURN;
3819 }
3820
3821 /* Directory calls. */
3822
3823 PP(pp_open_dir)
3824 {
3825 #if defined(Direntry_t) && defined(HAS_READDIR)
3826     dVAR; dSP;
3827     const char * const dirname = POPpconstx;
3828     GV * const gv = MUTABLE_GV(POPs);
3829     register IO * const io = GvIOn(gv);
3830
3831     if (!io)
3832         goto nope;
3833
3834     if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3835         Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3836                 "Opening filehandle %s also as a directory", GvENAME(gv));
3837     if (IoDIRP(io))
3838         PerlDir_close(IoDIRP(io));
3839     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3840         goto nope;
3841
3842     RETPUSHYES;
3843 nope:
3844     if (!errno)
3845         SETERRNO(EBADF,RMS_DIR);
3846     RETPUSHUNDEF;
3847 #else
3848     DIE(aTHX_ PL_no_dir_func, "opendir");
3849 #endif
3850 }
3851
3852 PP(pp_readdir)
3853 {
3854 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3855     DIE(aTHX_ PL_no_dir_func, "readdir");
3856 #else
3857 #if !defined(I_DIRENT) && !defined(VMS)
3858     Direntry_t *readdir (DIR *);
3859 #endif
3860     dVAR;
3861     dSP;
3862
3863     SV *sv;
3864     const I32 gimme = GIMME;
3865     GV * const gv = MUTABLE_GV(POPs);
3866     register const Direntry_t *dp;
3867     register IO * const io = GvIOn(gv);
3868
3869     if (!io || !IoDIRP(io)) {
3870         if(ckWARN(WARN_IO)) {
3871             Perl_warner(aTHX_ packWARN(WARN_IO),
3872                 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3873         }
3874         goto nope;
3875     }
3876
3877     do {
3878         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3879         if (!dp)
3880             break;
3881 #ifdef DIRNAMLEN
3882         sv = newSVpvn(dp->d_name, dp->d_namlen);
3883 #else
3884         sv = newSVpv(dp->d_name, 0);
3885 #endif
3886 #ifndef INCOMPLETE_TAINTS
3887         if (!(IoFLAGS(io) & IOf_UNTAINT))
3888             SvTAINTED_on(sv);
3889 #endif
3890         mXPUSHs(sv);
3891     } while (gimme == G_ARRAY);
3892
3893     if (!dp && gimme != G_ARRAY)
3894         goto nope;
3895
3896     RETURN;
3897
3898 nope:
3899     if (!errno)
3900         SETERRNO(EBADF,RMS_ISI);
3901     if (GIMME == G_ARRAY)
3902         RETURN;
3903     else
3904         RETPUSHUNDEF;
3905 #endif
3906 }
3907
3908 PP(pp_telldir)
3909 {
3910 #if defined(HAS_TELLDIR) || defined(telldir)
3911     dVAR; dSP; dTARGET;
3912  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3913  /* XXX netbsd still seemed to.
3914     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3915     --JHI 1999-Feb-02 */
3916 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3917     long telldir (DIR *);
3918 # endif
3919     GV * const gv = MUTABLE_GV(POPs);
3920     register IO * const io = GvIOn(gv);
3921
3922     if (!io || !IoDIRP(io)) {
3923         if(ckWARN(WARN_IO)) {
3924             Perl_warner(aTHX_ packWARN(WARN_IO),
3925                 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3926         }
3927         goto nope;
3928     }
3929
3930     PUSHi( PerlDir_tell(IoDIRP(io)) );
3931     RETURN;
3932 nope:
3933     if (!errno)
3934         SETERRNO(EBADF,RMS_ISI);
3935     RETPUSHUNDEF;
3936 #else
3937     DIE(aTHX_ PL_no_dir_func, "telldir");
3938 #endif
3939 }
3940
3941 PP(pp_seekdir)
3942 {
3943 #if defined(HAS_SEEKDIR) || defined(seekdir)
3944     dVAR; dSP;
3945     const long along = POPl;
3946     GV * const gv = MUTABLE_GV(POPs);
3947     register IO * const io = GvIOn(gv);
3948
3949     if (!io || !IoDIRP(io)) {
3950         if(ckWARN(WARN_IO)) {
3951             Perl_warner(aTHX_ packWARN(WARN_IO),
3952                 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3953         }
3954         goto nope;
3955     }
3956     (void)PerlDir_seek(IoDIRP(io), along);
3957
3958     RETPUSHYES;
3959 nope:
3960     if (!errno)
3961         SETERRNO(EBADF,RMS_ISI);
3962     RETPUSHUNDEF;
3963 #else
3964     DIE(aTHX_ PL_no_dir_func, "seekdir");
3965 #endif
3966 }
3967
3968 PP(pp_rewinddir)
3969 {
3970 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3971     dVAR; dSP;
3972     GV * const gv = MUTABLE_GV(POPs);
3973     register IO * const io = GvIOn(gv);
3974
3975     if (!io || !IoDIRP(io)) {
3976         if(ckWARN(WARN_IO)) {
3977             Perl_warner(aTHX_ packWARN(WARN_IO),
3978                 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3979         }
3980         goto nope;
3981     }
3982     (void)PerlDir_rewind(IoDIRP(io));
3983     RETPUSHYES;
3984 nope:
3985     if (!errno)
3986         SETERRNO(EBADF,RMS_ISI);
3987     RETPUSHUNDEF;
3988 #else
3989     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3990 #endif
3991 }
3992
3993 PP(pp_closedir)
3994 {
3995 #if defined(Direntry_t) && defined(HAS_READDIR)
3996     dVAR; dSP;
3997     GV * const gv = MUTABLE_GV(POPs);
3998     register IO * const io = GvIOn(gv);
3999
4000     if (!io || !IoDIRP(io)) {
4001         if(ckWARN(WARN_IO)) {
4002             Perl_warner(aTHX_ packWARN(WARN_IO),
4003                 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4004         }
4005         goto nope;
4006     }
4007 #ifdef VOID_CLOSEDIR
4008     PerlDir_close(IoDIRP(io));
4009 #else
4010     if (PerlDir_close(IoDIRP(io)) < 0) {
4011         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4012         goto nope;
4013     }
4014 #endif
4015     IoDIRP(io) = 0;
4016
4017     RETPUSHYES;
4018 nope:
4019     if (!errno)
4020         SETERRNO(EBADF,RMS_IFI);
4021     RETPUSHUNDEF;
4022 #else
4023     DIE(aTHX_ PL_no_dir_func, "closedir");
4024 #endif
4025 }
4026
4027 /* Process control. */
4028
4029 PP(pp_fork)
4030 {
4031 #ifdef HAS_FORK
4032     dVAR; dSP; dTARGET;
4033     Pid_t childpid;
4034
4035     EXTEND(SP, 1);
4036     PERL_FLUSHALL_FOR_CHILD;
4037     childpid = PerlProc_fork();
4038     if (childpid < 0)
4039         RETSETUNDEF;
4040     if (!childpid) {
4041         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4042         if (tmpgv) {
4043             SvREADONLY_off(GvSV(tmpgv));
4044             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4045             SvREADONLY_on(GvSV(tmpgv));
4046         }
4047 #ifdef THREADS_HAVE_PIDS
4048         PL_ppid = (IV)getppid();
4049 #endif
4050 #ifdef PERL_USES_PL_PIDSTATUS
4051         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4052 #endif
4053     }
4054     PUSHi(childpid);
4055     RETURN;
4056 #else
4057 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4058     dSP; dTARGET;
4059     Pid_t childpid;
4060
4061     EXTEND(SP, 1);
4062     PERL_FLUSHALL_FOR_CHILD;
4063     childpid = PerlProc_fork();
4064     if (childpid == -1)
4065         RETSETUNDEF;
4066     PUSHi(childpid);
4067     RETURN;
4068 #  else
4069     DIE(aTHX_ PL_no_func, "fork");
4070 #  endif
4071 #endif
4072 }
4073
4074 PP(pp_wait)
4075 {
4076 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4077     dVAR; dSP; dTARGET;
4078     Pid_t childpid;
4079     int argflags;
4080
4081     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4082         childpid = wait4pid(-1, &argflags, 0);
4083     else {
4084         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4085                errno == EINTR) {
4086           PERL_ASYNC_CHECK();
4087         }
4088     }
4089 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4090     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4091     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4092 #  else
4093     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4094 #  endif
4095     XPUSHi(childpid);
4096     RETURN;
4097 #else
4098     DIE(aTHX_ PL_no_func, "wait");
4099 #endif
4100 }
4101
4102 PP(pp_waitpid)
4103 {
4104 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4105     dVAR; dSP; dTARGET;
4106     const int optype = POPi;
4107     const Pid_t pid = TOPi;
4108     Pid_t result;
4109     int argflags;
4110
4111     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4112         result = wait4pid(pid, &argflags, optype);
4113     else {
4114         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4115                errno == EINTR) {
4116           PERL_ASYNC_CHECK();
4117         }
4118     }
4119 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4120     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4121     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4122 #  else
4123     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4124 #  endif
4125     SETi(result);
4126     RETURN;
4127 #else
4128     DIE(aTHX_ PL_no_func, "waitpid");
4129 #endif
4130 }
4131
4132 PP(pp_system)
4133 {
4134     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4135 #if defined(__LIBCATAMOUNT__)
4136     PL_statusvalue = -1;
4137     SP = ORIGMARK;
4138     XPUSHi(-1);
4139 #else
4140     I32 value;
4141     int result;
4142
4143     if (PL_tainting) {
4144         TAINT_ENV();
4145         while (++MARK <= SP) {
4146             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4147             if (PL_tainted)
4148                 break;
4149         }
4150         MARK = ORIGMARK;
4151         TAINT_PROPER("system");
4152     }
4153     PERL_FLUSHALL_FOR_CHILD;
4154 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4155     {
4156         Pid_t childpid;
4157         int pp[2];
4158         I32 did_pipes = 0;
4159
4160         if (PerlProc_pipe(pp) >= 0)
4161             did_pipes = 1;
4162         while ((childpid = PerlProc_fork()) == -1) {
4163             if (errno != EAGAIN) {
4164                 value = -1;
4165                 SP = ORIGMARK;
4166                 XPUSHi(value);
4167                 if (did_pipes) {
4168                     PerlLIO_close(pp[0]);
4169                     PerlLIO_close(pp[1]);
4170                 }
4171                 RETURN;
4172             }
4173             sleep(5);
4174         }
4175         if (childpid > 0) {
4176             Sigsave_t ihand,qhand; /* place to save signals during system() */
4177             int status;
4178
4179             if (did_pipes)
4180                 PerlLIO_close(pp[1]);
4181 #ifndef PERL_MICRO
4182             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4183             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4184 #endif
4185             do {
4186                 result = wait4pid(childpid, &status, 0);
4187             } while (result == -1 && errno == EINTR);
4188 #ifndef PERL_MICRO
4189             (void)rsignal_restore(SIGINT, &ihand);
4190             (void)rsignal_restore(SIGQUIT, &qhand);
4191 #endif
4192             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4193             do_execfree();      /* free any memory child malloced on fork */
4194             SP = ORIGMARK;
4195             if (did_pipes) {
4196                 int errkid;
4197                 unsigned n = 0;
4198                 SSize_t n1;
4199
4200                 while (n < sizeof(int)) {
4201                     n1 = PerlLIO_read(pp[0],
4202                                       (void*)(((char*)&errkid)+n),
4203                                       (sizeof(int)) - n);
4204                     if (n1 <= 0)
4205                         break;
4206                     n += n1;
4207                 }
4208                 PerlLIO_close(pp[0]);
4209                 if (n) {                        /* Error */
4210                     if (n != sizeof(int))
4211                         DIE(aTHX_ "panic: kid popen errno read");
4212                     errno = errkid;             /* Propagate errno from kid */
4213                     STATUS_NATIVE_CHILD_SET(-1);
4214                 }
4215             }
4216             XPUSHi(STATUS_CURRENT);
4217             RETURN;
4218         }
4219         if (did_pipes) {
4220             PerlLIO_close(pp[0]);
4221 #if defined(HAS_FCNTL) && defined(F_SETFD)
4222             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4223 #endif
4224         }
4225         if (PL_op->op_flags & OPf_STACKED) {
4226             SV * const really = *++MARK;
4227             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4228         }
4229         else if (SP - MARK != 1)
4230             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4231         else {
4232             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4233         }
4234         PerlProc__exit(-1);
4235     }
4236 #else /* ! FORK or VMS or OS/2 */
4237     PL_statusvalue = 0;
4238     result = 0;
4239     if (PL_op->op_flags & OPf_STACKED) {
4240         SV * const really = *++MARK;
4241 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4242         value = (I32)do_aspawn(really, MARK, SP);
4243 #  else
4244         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4245 #  endif
4246     }
4247     else if (SP - MARK != 1) {
4248 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4249         value = (I32)do_aspawn(NULL, MARK, SP);
4250 #  else
4251         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4252 #  endif
4253     }
4254     else {
4255         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4256     }
4257     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4258         result = 1;
4259     STATUS_NATIVE_CHILD_SET(value);
4260     do_execfree();
4261     SP = ORIGMARK;
4262     XPUSHi(result ? value : STATUS_CURRENT);
4263 #endif /* !FORK or VMS or OS/2 */
4264 #endif
4265     RETURN;
4266 }
4267
4268 PP(pp_exec)
4269 {
4270     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4271     I32 value;
4272
4273     if (PL_tainting) {
4274         TAINT_ENV();
4275         while (++MARK <= SP) {
4276             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4277             if (PL_tainted)
4278                 break;
4279         }
4280         MARK = ORIGMARK;
4281         TAINT_PROPER("exec");
4282     }
4283     PERL_FLUSHALL_FOR_CHILD;
4284     if (PL_op->op_flags & OPf_STACKED) {
4285         SV * const really = *++MARK;
4286         value = (I32)do_aexec(really, MARK, SP);
4287     }
4288     else if (SP - MARK != 1)
4289 #ifdef VMS
4290         value = (I32)vms_do_aexec(NULL, MARK, SP);
4291 #else
4292 #  ifdef __OPEN_VM
4293         {
4294            (void ) do_aspawn(NULL, MARK, SP);
4295            value = 0;
4296         }
4297 #  else
4298         value = (I32)do_aexec(NULL, MARK, SP);
4299 #  endif
4300 #endif
4301     else {
4302 #ifdef VMS
4303         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4304 #else
4305 #  ifdef __OPEN_VM
4306         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4307         value = 0;
4308 #  else
4309         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4310 #  endif
4311 #endif
4312     }
4313
4314     SP = ORIGMARK;
4315     XPUSHi(value);
4316     RETURN;
4317 }
4318
4319 PP(pp_getppid)
4320 {
4321 #ifdef HAS_GETPPID
4322     dVAR; dSP; dTARGET;
4323 #   ifdef THREADS_HAVE_PIDS
4324     if (PL_ppid != 1 && getppid() == 1)
4325         /* maybe the parent process has died. Refresh ppid cache */
4326         PL_ppid = 1;
4327     XPUSHi( PL_ppid );
4328 #   else
4329     XPUSHi( getppid() );
4330 #   endif
4331     RETURN;
4332 #else
4333     DIE(aTHX_ PL_no_func, "getppid");
4334 #endif
4335 }
4336
4337 PP(pp_getpgrp)
4338 {
4339 #ifdef HAS_GETPGRP
4340     dVAR; dSP; dTARGET;
4341     Pid_t pgrp;
4342     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4343
4344 #ifdef BSD_GETPGRP
4345     pgrp = (I32)BSD_GETPGRP(pid);
4346 #else
4347     if (pid != 0 && pid != PerlProc_getpid())
4348         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4349     pgrp = getpgrp();
4350 #endif
4351     XPUSHi(pgrp);
4352     RETURN;
4353 #else
4354     DIE(aTHX_ PL_no_func, "getpgrp()");
4355 #endif
4356 }
4357
4358 PP(pp_setpgrp)
4359 {
4360 #ifdef HAS_SETPGRP
4361     dVAR; dSP; dTARGET;
4362     Pid_t pgrp;
4363     Pid_t pid;
4364     if (MAXARG < 2) {
4365         pgrp = 0;
4366         pid = 0;
4367         XPUSHi(-1);
4368     }
4369     else {
4370         pgrp = POPi;
4371         pid = TOPi;
4372     }
4373
4374     TAINT_PROPER("setpgrp");
4375 #ifdef BSD_SETPGRP
4376     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4377 #else
4378     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4379         || (pid != 0 && pid != PerlProc_getpid()))
4380     {
4381         DIE(aTHX_ "setpgrp can't take arguments");
4382     }
4383     SETi( setpgrp() >= 0 );
4384 #endif /* USE_BSDPGRP */
4385     RETURN;
4386 #else
4387     DIE(aTHX_ PL_no_func, "setpgrp()");
4388 #endif
4389 }
4390
4391 PP(pp_getpriority)
4392 {
4393 #ifdef HAS_GETPRIORITY
4394     dVAR; dSP; dTARGET;
4395     const int who = POPi;
4396     const int which = TOPi;
4397     SETi( getpriority(which, who) );
4398     RETURN;
4399 #else
4400     DIE(aTHX_ PL_no_func, "getpriority()");
4401 #endif
4402 }
4403
4404 PP(pp_setpriority)
4405 {
4406 #ifdef HAS_SETPRIORITY
4407     dVAR; dSP; dTARGET;
4408     const int niceval = POPi;
4409     const int who = POPi;
4410     const int which = TOPi;
4411     TAINT_PROPER("setpriority");
4412     SETi( setpriority(which, who, niceval) >= 0 );
4413     RETURN;
4414 #else
4415     DIE(aTHX_ PL_no_func, "setpriority()");
4416 #endif
4417 }
4418
4419 /* Time calls. */
4420
4421 PP(pp_time)
4422 {
4423     dVAR; dSP; dTARGET;
4424 #ifdef BIG_TIME
4425     XPUSHn( time(NULL) );
4426 #else
4427     XPUSHi( time(NULL) );
4428 #endif
4429     RETURN;
4430 }
4431
4432 PP(pp_tms)
4433 {
4434 #ifdef HAS_TIMES
4435     dVAR;
4436     dSP;
4437     EXTEND(SP, 4);
4438 #ifndef VMS
4439     (void)PerlProc_times(&PL_timesbuf);
4440 #else
4441     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4442                                                    /* struct tms, though same data   */
4443                                                    /* is returned.                   */
4444 #endif
4445
4446     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4447     if (GIMME == G_ARRAY) {
4448         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4449         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4450         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4451     }
4452     RETURN;
4453 #else
4454 #   ifdef PERL_MICRO
4455     dSP;
4456     mPUSHn(0.0);
4457     EXTEND(SP, 4);
4458     if (GIMME == G_ARRAY) {
4459          mPUSHn(0.0);
4460          mPUSHn(0.0);
4461          mPUSHn(0.0);
4462     }
4463     RETURN;
4464 #   else
4465     DIE(aTHX_ "times not implemented");
4466 #   endif
4467 #endif /* HAS_TIMES */
4468 }
4469
4470 PP(pp_gmtime)
4471 {
4472     dVAR;
4473     dSP;
4474     Time64_T when;
4475     struct TM tmbuf;
4476     struct TM *err;
4477     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4478     static const char * const dayname[] =
4479         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4480     static const char * const monname[] =
4481         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4482          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4483
4484     if (MAXARG < 1) {
4485         time_t now;
4486         (void)time(&now);
4487         when = (Time64_T)now;
4488     }
4489     else {
4490         double input = Perl_floor(POPn);
4491         when = (Time64_T)input;
4492         if (when != input && ckWARN(WARN_OVERFLOW)) {
4493             Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4494                         "%s(%.0f) too large", opname, input);
4495         }
4496     }
4497
4498     if (PL_op->op_type == OP_LOCALTIME)
4499         err = S_localtime64_r(&when, &tmbuf);
4500     else
4501         err = S_gmtime64_r(&when, &tmbuf);
4502
4503     if (err == NULL && ckWARN(WARN_OVERFLOW)) {
4504         /* XXX %lld broken for quads */
4505         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4506                     "%s(%.0f) failed", opname, (double)when);
4507     }
4508
4509     if (GIMME != G_ARRAY) {     /* scalar context */
4510         SV *tsv;
4511         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4512         double year = (double)tmbuf.tm_year + 1900;
4513
4514         EXTEND(SP, 1);
4515         EXTEND_MORTAL(1);
4516         if (err == NULL)
4517             RETPUSHUNDEF;
4518
4519         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4520                             dayname[tmbuf.tm_wday],
4521                             monname[tmbuf.tm_mon],
4522                             tmbuf.tm_mday,
4523                             tmbuf.tm_hour,
4524                             tmbuf.tm_min,
4525                             tmbuf.tm_sec,
4526                             year);
4527         mPUSHs(tsv);
4528     }
4529     else {                      /* list context */
4530         if ( err == NULL )
4531             RETURN;
4532
4533         EXTEND(SP, 9);
4534         EXTEND_MORTAL(9);
4535         mPUSHi(tmbuf.tm_sec);
4536         mPUSHi(tmbuf.tm_min);
4537         mPUSHi(tmbuf.tm_hour);
4538         mPUSHi(tmbuf.tm_mday);
4539         mPUSHi(tmbuf.tm_mon);
4540         mPUSHn(tmbuf.tm_year);
4541         mPUSHi(tmbuf.tm_wday);
4542         mPUSHi(tmbuf.tm_yday);
4543         mPUSHi(tmbuf.tm_isdst);
4544     }
4545     RETURN;
4546 }
4547
4548 PP(pp_alarm)
4549 {
4550 #ifdef HAS_ALARM
4551     dVAR; dSP; dTARGET;
4552     int anum;
4553     anum = POPi;
4554     anum = alarm((unsigned int)anum);
4555     EXTEND(SP, 1);
4556     if (anum < 0)
4557         RETPUSHUNDEF;
4558     PUSHi(anum);
4559     RETURN;
4560 #else
4561     DIE(aTHX_ PL_no_func, "alarm");
4562 #endif
4563 }
4564
4565 PP(pp_sleep)
4566 {
4567     dVAR; dSP; dTARGET;
4568     I32 duration;
4569     Time_t lasttime;
4570     Time_t when;
4571
4572     (void)time(&lasttime);
4573     if (MAXARG < 1)
4574         PerlProc_pause();
4575     else {
4576         duration = POPi;
4577         PerlProc_sleep((unsigned int)duration);
4578     }
4579     (void)time(&when);
4580     XPUSHi(when - lasttime);
4581     RETURN;
4582 }
4583
4584 /* Shared memory. */
4585 /* Merged with some message passing. */
4586
4587 PP(pp_shmwrite)
4588 {
4589 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4590     dVAR; dSP; dMARK; dTARGET;
4591     const int op_type = PL_op->op_type;
4592     I32 value;
4593
4594     switch (op_type) {
4595     case OP_MSGSND:
4596         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4597         break;
4598     case OP_MSGRCV:
4599         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4600         break;
4601     case OP_SEMOP:
4602         value = (I32)(do_semop(MARK, SP) >= 0);
4603         break;
4604     default:
4605         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4606         break;
4607     }
4608
4609     SP = MARK;
4610     PUSHi(value);
4611     RETURN;
4612 #else
4613     return pp_semget();
4614 #endif
4615 }
4616
4617 /* Semaphores. */
4618
4619 PP(pp_semget)
4620 {
4621 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4622     dVAR; dSP; dMARK; dTARGET;
4623     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4624     SP = MARK;
4625     if (anum == -1)
4626         RETPUSHUNDEF;
4627     PUSHi(anum);
4628     RETURN;
4629 #else
4630     DIE(aTHX_ "System V IPC is not implemented on this machine");
4631 #endif
4632 }
4633
4634 PP(pp_semctl)
4635 {
4636 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4637     dVAR; dSP; dMARK; dTARGET;
4638     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4639     SP = MARK;
4640     if (anum == -1)
4641         RETSETUNDEF;
4642     if (anum != 0) {
4643         PUSHi(anum);
4644     }
4645     else {
4646         PUSHp(zero_but_true, ZBTLEN);
4647     }
4648     RETURN;
4649 #else
4650     return pp_semget();
4651 #endif
4652 }
4653
4654 /* I can't const this further without getting warnings about the types of
4655    various arrays passed in from structures.  */
4656 static SV *
4657 S_space_join_names_mortal(pTHX_ char *const *array)
4658 {
4659     SV *target;
4660
4661     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4662
4663     if (array && *array) {
4664         target = newSVpvs_flags("", SVs_TEMP);
4665         while (1) {
4666             sv_catpv(target, *array);
4667             if (!*++array)
4668                 break;
4669             sv_catpvs(target, " ");
4670         }
4671     } else {
4672         target = sv_mortalcopy(&PL_sv_no);
4673     }
4674     return target;
4675 }
4676
4677 /* Get system info. */
4678
4679 PP(pp_ghostent)
4680 {
4681 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4682     dVAR; dSP;
4683     I32 which = PL_op->op_type;
4684     register char **elem;
4685     register SV *sv;
4686 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4687     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4688     struct hostent *gethostbyname(Netdb_name_t);
4689     struct hostent *gethostent(void);
4690 #endif
4691     struct hostent *hent;
4692     unsigned long len;
4693
4694     EXTEND(SP, 10);
4695     if (which == OP_GHBYNAME) {
4696 #ifdef HAS_GETHOSTBYNAME
4697         const char* const name = POPpbytex;
4698         hent = PerlSock_gethostbyname(name);
4699 #else
4700         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4701 #endif
4702     }
4703     else if (which == OP_GHBYADDR) {
4704 #ifdef HAS_GETHOSTBYADDR
4705         const int addrtype = POPi;
4706         SV * const addrsv = POPs;
4707         STRLEN addrlen;
4708         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4709
4710         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4711 #else
4712         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4713 #endif
4714     }
4715     else
4716 #ifdef HAS_GETHOSTENT
4717         hent = PerlSock_gethostent();
4718 #else
4719         DIE(aTHX_ PL_no_sock_func, "gethostent");
4720 #endif
4721
4722 #ifdef HOST_NOT_FOUND
4723         if (!hent) {
4724 #ifdef USE_REENTRANT_API
4725 #   ifdef USE_GETHOSTENT_ERRNO
4726             h_errno = PL_reentrant_buffer->_gethostent_errno;
4727 #   endif
4728 #endif
4729             STATUS_UNIX_SET(h_errno);
4730         }
4731 #endif
4732
4733     if (GIMME != G_ARRAY) {
4734         PUSHs(sv = sv_newmortal());
4735         if (hent) {
4736             if (which == OP_GHBYNAME) {
4737                 if (hent->h_addr)
4738                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4739             }
4740             else
4741                 sv_setpv(sv, (char*)hent->h_name);
4742         }
4743         RETURN;
4744     }
4745
4746     if (hent) {
4747         mPUSHs(newSVpv((char*)hent->h_name, 0));
4748         PUSHs(space_join_names_mortal(hent->h_aliases));
4749         mPUSHi(hent->h_addrtype);
4750         len = hent->h_length;
4751         mPUSHi(len);
4752 #ifdef h_addr
4753         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4754             mXPUSHp(*elem, len);
4755         }
4756 #else
4757         if (hent->h_addr)
4758             mPUSHp(hent->h_addr, len);
4759         else
4760             PUSHs(sv_mortalcopy(&PL_sv_no));
4761 #endif /* h_addr */
4762     }
4763     RETURN;
4764 #else
4765     DIE(aTHX_ PL_no_sock_func, "gethostent");
4766 #endif
4767 }
4768
4769 PP(pp_gnetent)
4770 {
4771 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4772     dVAR; dSP;
4773     I32 which = PL_op->op_type;
4774     register SV *sv;
4775 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4776     struct netent *getnetbyaddr(Netdb_net_t, int);
4777     struct netent *getnetbyname(Netdb_name_t);
4778     struct netent *getnetent(void);
4779 #endif
4780     struct netent *nent;
4781
4782     if (which == OP_GNBYNAME){
4783 #ifdef HAS_GETNETBYNAME
4784         const char * const name = POPpbytex;
4785         nent = PerlSock_getnetbyname(name);
4786 #else
4787         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4788 #endif
4789     }
4790     else if (which == OP_GNBYADDR) {
4791 #ifdef HAS_GETNETBYADDR
4792         const int addrtype = POPi;
4793         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4794         nent = PerlSock_getnetbyaddr(addr, addrtype);
4795 #else
4796         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4797 #endif
4798     }
4799     else
4800 #ifdef HAS_GETNETENT
4801         nent = PerlSock_getnetent();
4802 #else
4803         DIE(aTHX_ PL_no_sock_func, "getnetent");
4804 #endif
4805
4806 #ifdef HOST_NOT_FOUND
4807         if (!nent) {
4808 #ifdef USE_REENTRANT_API
4809 #   ifdef USE_GETNETENT_ERRNO
4810              h_errno = PL_reentrant_buffer->_getnetent_errno;
4811 #   endif
4812 #endif
4813             STATUS_UNIX_SET(h_errno);
4814         }
4815 #endif
4816
4817     EXTEND(SP, 4);
4818     if (GIMME != G_ARRAY) {
4819         PUSHs(sv = sv_newmortal());
4820         if (nent) {
4821             if (which == OP_GNBYNAME)
4822                 sv_setiv(sv, (IV)nent->n_net);
4823             else
4824                 sv_setpv(sv, nent->n_name);
4825         }
4826         RETURN;
4827     }
4828
4829     if (nent) {
4830         mPUSHs(newSVpv(nent->n_name, 0));
4831         PUSHs(space_join_names_mortal(nent->n_aliases));
4832         mPUSHi(nent->n_addrtype);
4833         mPUSHi(nent->n_net);
4834     }
4835
4836     RETURN;
4837 #else
4838     DIE(aTHX_ PL_no_sock_func, "getnetent");
4839 #endif
4840 }
4841
4842 PP(pp_gprotoent)
4843 {
4844 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4845     dVAR; dSP;
4846     I32 which = PL_op->op_type;
4847     register SV *sv;
4848 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4849     struct protoent *getprotobyname(Netdb_name_t);
4850     struct protoent *getprotobynumber(int);
4851     struct protoent *getprotoent(void);
4852 #endif
4853     struct protoent *pent;
4854
4855     if (which == OP_GPBYNAME) {
4856 #ifdef HAS_GETPROTOBYNAME
4857         const char* const name = POPpbytex;
4858         pent = PerlSock_getprotobyname(name);
4859 #else
4860         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4861 #endif
4862     }
4863     else if (which == OP_GPBYNUMBER) {
4864 #ifdef HAS_GETPROTOBYNUMBER
4865         const int number = POPi;
4866         pent = PerlSock_getprotobynumber(number);
4867 #else
4868         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4869 #endif
4870     }
4871     else
4872 #ifdef HAS_GETPROTOENT
4873         pent = PerlSock_getprotoent();
4874 #else
4875         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4876 #endif
4877
4878     EXTEND(SP, 3);
4879     if (GIMME != G_ARRAY) {
4880         PUSHs(sv = sv_newmortal());
4881         if (pent) {
4882             if (which == OP_GPBYNAME)
4883                 sv_setiv(sv, (IV)pent->p_proto);
4884             else
4885                 sv_setpv(sv, pent->p_name);
4886         }
4887         RETURN;
4888     }
4889
4890     if (pent) {
4891         mPUSHs(newSVpv(pent->p_name, 0));
4892         PUSHs(space_join_names_mortal(pent->p_aliases));
4893         mPUSHi(pent->p_proto);
4894     }
4895
4896     RETURN;
4897 #else
4898     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4899 #endif
4900 }
4901
4902 PP(pp_gservent)
4903 {
4904 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4905     dVAR; dSP;
4906     I32 which = PL_op->op_type;
4907     register SV *sv;
4908 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4909     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4910     struct servent *getservbyport(int, Netdb_name_t);
4911     struct servent *getservent(void);
4912 #endif
4913     struct servent *sent;
4914
4915     if (which == OP_GSBYNAME) {
4916 #ifdef HAS_GETSERVBYNAME
4917         const char * const proto = POPpbytex;
4918         const char * const name = POPpbytex;
4919         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4920 #else
4921         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4922 #endif
4923     }
4924     else if (which == OP_GSBYPORT) {
4925 #ifdef HAS_GETSERVBYPORT
4926         const char * const proto = POPpbytex;
4927         unsigned short port = (unsigned short)POPu;
4928 #ifdef HAS_HTONS
4929         port = PerlSock_htons(port);
4930 #endif
4931         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4932 #else
4933         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4934 #endif
4935     }
4936     else
4937 #ifdef HAS_GETSERVENT
4938         sent = PerlSock_getservent();
4939 #else
4940         DIE(aTHX_ PL_no_sock_func, "getservent");
4941 #endif
4942
4943     EXTEND(SP, 4);
4944     if (GIMME != G_ARRAY) {
4945         PUSHs(sv = sv_newmortal());
4946         if (sent) {
4947             if (which == OP_GSBYNAME) {
4948 #ifdef HAS_NTOHS
4949                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4950 #else
4951                 sv_setiv(sv, (IV)(sent->s_port));
4952 #endif
4953             }
4954             else
4955                 sv_setpv(sv, sent->s_name);
4956         }
4957         RETURN;
4958     }
4959
4960     if (sent) {
4961         mPUSHs(newSVpv(sent->s_name, 0));
4962         PUSHs(space_join_names_mortal(sent->s_aliases));
4963 #ifdef HAS_NTOHS
4964         mPUSHi(PerlSock_ntohs(sent->s_port));
4965 #else
4966         mPUSHi(sent->s_port);
4967 #endif
4968         mPUSHs(newSVpv(sent->s_proto, 0));
4969     }
4970
4971     RETURN;
4972 #else
4973     DIE(aTHX_ PL_no_sock_func, "getservent");
4974 #endif
4975 }
4976
4977 PP(pp_shostent)
4978 {
4979 #ifdef HAS_SETHOSTENT
4980     dVAR; dSP;
4981     PerlSock_sethostent(TOPi);
4982     RETSETYES;
4983 #else
4984     DIE(aTHX_ PL_no_sock_func, "sethostent");
4985 #endif
4986 }
4987
4988 PP(pp_snetent)
4989 {
4990 #ifdef HAS_SETNETENT
4991     dVAR; dSP;
4992     (void)PerlSock_setnetent(TOPi);
4993     RETSETYES;
4994 #else
4995     DIE(aTHX_ PL_no_sock_func, "setnetent");
4996 #endif
4997 }
4998
4999 PP(pp_sprotoent)
5000 {
5001 #ifdef HAS_SETPROTOENT
5002     dVAR; dSP;
5003     (void)PerlSock_setprotoent(TOPi);
5004     RETSETYES;
5005 #else
5006     DIE(aTHX_ PL_no_sock_func, "setprotoent");
5007 #endif
5008 }
5009
5010 PP(pp_sservent)
5011 {
5012 #ifdef HAS_SETSERVENT
5013     dVAR; dSP;
5014     (void)PerlSock_setservent(TOPi);
5015     RETSETYES;
5016 #else
5017     DIE(aTHX_ PL_no_sock_func, "setservent");
5018 #endif
5019 }
5020
5021 PP(pp_ehostent)
5022 {
5023 #ifdef HAS_ENDHOSTENT
5024     dVAR; dSP;
5025     PerlSock_endhostent();
5026     EXTEND(SP,1);
5027     RETPUSHYES;
5028 #else
5029     DIE(aTHX_ PL_no_sock_func, "endhostent");
5030 #endif
5031 }
5032
5033 PP(pp_enetent)
5034 {
5035 #ifdef HAS_ENDNETENT
5036     dVAR; dSP;
5037     PerlSock_endnetent();
5038     EXTEND(SP,1);
5039     RETPUSHYES;
5040 #else
5041     DIE(aTHX_ PL_no_sock_func, "endnetent");
5042 #endif
5043 }
5044
5045 PP(pp_eprotoent)
5046 {
5047 #ifdef HAS_ENDPROTOENT
5048     dVAR; dSP;
5049     PerlSock_endprotoent();
5050     EXTEND(SP,1);
5051     RETPUSHYES;
5052 #else
5053     DIE(aTHX_ PL_no_sock_func, "endprotoent");
5054 #endif
5055 }
5056
5057 PP(pp_eservent)
5058 {
5059 #ifdef HAS_ENDSERVENT
5060     dVAR; dSP;
5061     PerlSock_endservent();
5062     EXTEND(SP,1);
5063     RETPUSHYES;
5064 #else
5065     DIE(aTHX_ PL_no_sock_func, "endservent");
5066 #endif
5067 }
5068
5069 PP(pp_gpwent)
5070 {
5071 #ifdef HAS_PASSWD
5072     dVAR; dSP;
5073     I32 which = PL_op->op_type;
5074     register SV *sv;
5075     struct passwd *pwent  = NULL;
5076     /*
5077      * We currently support only the SysV getsp* shadow password interface.
5078      * The interface is declared in <shadow.h> and often one needs to link
5079      * with -lsecurity or some such.
5080      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5081      * (and SCO?)
5082      *
5083      * AIX getpwnam() is clever enough to return the encrypted password
5084      * only if the caller (euid?) is root.
5085      *
5086      * There are at least three other shadow password APIs.  Many platforms
5087      * seem to contain more than one interface for accessing the shadow
5088      * password databases, possibly for compatibility reasons.
5089      * The getsp*() is by far he simplest one, the other two interfaces
5090      * are much more complicated, but also very similar to each other.
5091      *
5092      * <sys/types.h>
5093      * <sys/security.h>
5094      * <prot.h>
5095      * struct pr_passwd *getprpw*();
5096      * The password is in
5097      * char getprpw*(...).ufld.fd_encrypt[]
5098      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5099      *
5100      * <sys/types.h>
5101      * <sys/security.h>
5102      * <prot.h>
5103      * struct es_passwd *getespw*();
5104      * The password is in
5105      * char *(getespw*(...).ufld.fd_encrypt)
5106      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5107      *
5108      * <userpw.h> (AIX)
5109      * struct userpw *getuserpw();
5110      * The password is in
5111      * char *(getuserpw(...)).spw_upw_passwd
5112      * (but the de facto standard getpwnam() should work okay)
5113      *
5114      * Mention I_PROT here so that Configure probes for it.
5115      *
5116      * In HP-UX for getprpw*() the manual page claims that one should include
5117      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5118      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5119      * and pp_sys.c already includes <shadow.h> if there is such.
5120      *
5121      * Note that <sys/security.h> is already probed for, but currently
5122      * it is only included in special cases.
5123      *
5124      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5125      * be preferred interface, even though also the getprpw*() interface
5126      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5127      * One also needs to call set_auth_parameters() in main() before
5128      * doing anything else, whether one is using getespw*() or getprpw*().
5129      *
5130      * Note that accessing the shadow databases can be magnitudes
5131      * slower than accessing the standard databases.
5132      *
5133      * --jhi
5134      */
5135
5136 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5137     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5138      * the pw_comment is left uninitialized. */
5139     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5140 #   endif
5141
5142     switch (which) {
5143     case OP_GPWNAM:
5144       {
5145         const char* const name = POPpbytex;
5146         pwent  = getpwnam(name);
5147       }
5148       break;
5149     case OP_GPWUID:
5150       {
5151         Uid_t uid = POPi;
5152         pwent = getpwuid(uid);
5153       }
5154         break;
5155     case OP_GPWENT:
5156 #   ifdef HAS_GETPWENT
5157         pwent  = getpwent();
5158 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5159         if (pwent) pwent = getpwnam(pwent->pw_name);
5160 #endif
5161 #   else
5162         DIE(aTHX_ PL_no_func, "getpwent");
5163 #   endif
5164         break;
5165     }
5166
5167     EXTEND(SP, 10);
5168     if (GIMME != G_ARRAY) {
5169         PUSHs(sv = sv_newmortal());
5170         if (pwent) {
5171             if (which == OP_GPWNAM)
5172 #   if Uid_t_sign <= 0
5173                 sv_setiv(sv, (IV)pwent->pw_uid);
5174 #   else
5175                 sv_setuv(sv, (UV)pwent->pw_uid);
5176 #   endif
5177             else
5178                 sv_setpv(sv, pwent->pw_name);
5179         }
5180         RETURN;
5181     }
5182
5183     if (pwent) {
5184         mPUSHs(newSVpv(pwent->pw_name, 0));
5185
5186         sv = newSViv(0);
5187         mPUSHs(sv);
5188         /* If we have getspnam(), we try to dig up the shadow
5189          * password.  If we are underprivileged, the shadow
5190          * interface will set the errno to EACCES or similar,
5191          * and return a null pointer.  If this happens, we will
5192          * use the dummy password (usually "*" or "x") from the
5193          * standard password database.
5194          *
5195          * In theory we could skip the shadow call completely
5196          * if euid != 0 but in practice we cannot know which
5197          * security measures are guarding the shadow databases
5198          * on a random platform.
5199          *
5200          * Resist the urge to use additional shadow interfaces.
5201          * Divert the urge to writing an extension instead.
5202          *
5203          * --jhi */
5204         /* Some AIX setups falsely(?) detect some getspnam(), which
5205          * has a different API than the Solaris/IRIX one. */
5206 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5207         {
5208             dSAVE_ERRNO;
5209             const struct spwd * const spwent = getspnam(pwent->pw_name);
5210                           /* Save and restore errno so that
5211                            * underprivileged attempts seem
5212                            * to have never made the unsccessful
5213                            * attempt to retrieve the shadow password. */
5214             RESTORE_ERRNO;
5215             if (spwent && spwent->sp_pwdp)
5216                 sv_setpv(sv, spwent->sp_pwdp);
5217         }
5218 #   endif
5219 #   ifdef PWPASSWD
5220         if (!SvPOK(sv)) /* Use the standard password, then. */
5221             sv_setpv(sv, pwent->pw_passwd);
5222 #   endif
5223
5224 #   ifndef INCOMPLETE_TAINTS
5225         /* passwd is tainted because user himself can diddle with it.
5226          * admittedly not much and in a very limited way, but nevertheless. */
5227         SvTAINTED_on(sv);
5228 #   endif
5229
5230 #   if Uid_t_sign <= 0
5231         mPUSHi(pwent->pw_uid);
5232 #   else
5233         mPUSHu(pwent->pw_uid);
5234 #   endif
5235
5236 #   if Uid_t_sign <= 0
5237         mPUSHi(pwent->pw_gid);
5238 #   else
5239         mPUSHu(pwent->pw_gid);
5240 #   endif
5241         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5242          * because of the poor interface of the Perl getpw*(),
5243          * not because there's some standard/convention saying so.
5244          * A better interface would have been to return a hash,
5245          * but we are accursed by our history, alas. --jhi.  */
5246 #   ifdef PWCHANGE
5247         mPUSHi(pwent->pw_change);
5248 #   else
5249 #       ifdef PWQUOTA
5250         mPUSHi(pwent->pw_quota);
5251 #       else
5252 #           ifdef PWAGE
5253         mPUSHs(newSVpv(pwent->pw_age, 0));
5254 #           else
5255         /* I think that you can never get this compiled, but just in case.  */
5256         PUSHs(sv_mortalcopy(&PL_sv_no));
5257 #           endif
5258 #       endif
5259 #   endif
5260
5261         /* pw_class and pw_comment are mutually exclusive--.
5262          * see the above note for pw_change, pw_quota, and pw_age. */
5263 #   ifdef PWCLASS
5264         mPUSHs(newSVpv(pwent->pw_class, 0));
5265 #   else
5266 #       ifdef PWCOMMENT
5267         mPUSHs(newSVpv(pwent->pw_comment, 0));
5268 #       else
5269         /* I think that you can never get this compiled, but just in case.  */
5270         PUSHs(sv_mortalcopy(&PL_sv_no));
5271 #       endif
5272 #   endif
5273
5274 #   ifdef PWGECOS
5275         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5276 #   else
5277         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5278 #   endif
5279 #   ifndef INCOMPLETE_TAINTS
5280         /* pw_gecos is tainted because user himself can diddle with it. */
5281         SvTAINTED_on(sv);
5282 #   endif
5283
5284         mPUSHs(newSVpv(pwent->pw_dir, 0));
5285
5286         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5287 #   ifndef INCOMPLETE_TAINTS
5288         /* pw_shell is tainted because user himself can diddle with it. */
5289         SvTAINTED_on(sv);
5290 #   endif
5291
5292 #   ifdef PWEXPIRE
5293         mPUSHi(pwent->pw_expire);
5294 #   endif
5295     }
5296     RETURN;
5297 #else
5298     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5299 #endif
5300 }
5301
5302 PP(pp_spwent)
5303 {
5304 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5305     dVAR; dSP;
5306     setpwent();
5307     RETPUSHYES;
5308 #else
5309     DIE(aTHX_ PL_no_func, "setpwent");
5310 #endif
5311 }
5312
5313 PP(pp_epwent)
5314 {
5315 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5316     dVAR; dSP;
5317     endpwent();
5318     RETPUSHYES;
5319 #else
5320     DIE(aTHX_ PL_no_func, "endpwent");
5321 #endif
5322 }
5323
5324 PP(pp_ggrent)
5325 {
5326 #ifdef HAS_GROUP
5327     dVAR; dSP;
5328     const I32 which = PL_op->op_type;
5329     const struct group *grent;
5330
5331     if (which == OP_GGRNAM) {
5332         const char* const name = POPpbytex;
5333         grent = (const struct group *)getgrnam(name);
5334     }
5335     else if (which == OP_GGRGID) {
5336         const Gid_t gid = POPi;
5337         grent = (const struct group *)getgrgid(gid);
5338     }
5339     else
5340 #ifdef HAS_GETGRENT
5341         grent = (struct group *)getgrent();
5342 #else
5343         DIE(aTHX_ PL_no_func, "getgrent");
5344 #endif
5345
5346     EXTEND(SP, 4);
5347     if (GIMME != G_ARRAY) {
5348         SV * const sv = sv_newmortal();
5349
5350         PUSHs(sv);
5351         if (grent) {
5352             if (which == OP_GGRNAM)
5353 #if Gid_t_sign <= 0
5354                 sv_setiv(sv, (IV)grent->gr_gid);
5355 #else
5356                 sv_setuv(sv, (UV)grent->gr_gid);
5357 #endif
5358             else
5359                 sv_setpv(sv, grent->gr_name);
5360         }
5361         RETURN;
5362     }
5363
5364     if (grent) {
5365         mPUSHs(newSVpv(grent->gr_name, 0));
5366
5367 #ifdef GRPASSWD
5368         mPUSHs(newSVpv(grent->gr_passwd, 0));
5369 #else
5370         PUSHs(sv_mortalcopy(&PL_sv_no));
5371 #endif
5372
5373 #if Gid_t_sign <= 0
5374         mPUSHi(grent->gr_gid);
5375 #else
5376         mPUSHu(grent->gr_gid);
5377 #endif
5378
5379 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5380         /* In UNICOS/mk (_CRAYMPP) the multithreading
5381          * versions (getgrnam_r, getgrgid_r)
5382          * seem to return an illegal pointer
5383          * as the group members list, gr_mem.
5384          * getgrent() doesn't even have a _r version
5385          * but the gr_mem is poisonous anyway.
5386          * So yes, you cannot get the list of group
5387          * members if building multithreaded in UNICOS/mk. */
5388         PUSHs(space_join_names_mortal(grent->gr_mem));
5389 #endif
5390     }
5391
5392     RETURN;
5393 #else
5394     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5395 #endif
5396 }
5397
5398 PP(pp_sgrent)
5399 {
5400 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5401     dVAR; dSP;
5402     setgrent();
5403     RETPUSHYES;
5404 #else
5405     DIE(aTHX_ PL_no_func, "setgrent");
5406 #endif
5407 }
5408
5409 PP(pp_egrent)
5410 {
5411 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5412     dVAR; dSP;
5413     endgrent();
5414     RETPUSHYES;
5415 #else
5416     DIE(aTHX_ PL_no_func, "endgrent");
5417 #endif
5418 }
5419
5420 PP(pp_getlogin)
5421 {
5422 #ifdef HAS_GETLOGIN
5423     dVAR; dSP; dTARGET;
5424     char *tmps;
5425     EXTEND(SP, 1);
5426     if (!(tmps = PerlProc_getlogin()))
5427         RETPUSHUNDEF;
5428     PUSHp(tmps, strlen(tmps));
5429     RETURN;
5430 #else
5431     DIE(aTHX_ PL_no_func, "getlogin");
5432 #endif
5433 }
5434
5435 /* Miscellaneous. */
5436
5437 PP(pp_syscall)
5438 {
5439 #ifdef HAS_SYSCALL
5440     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5441     register I32 items = SP - MARK;
5442     unsigned long a[20];
5443     register I32 i = 0;
5444     I32 retval = -1;
5445
5446     if (PL_tainting) {
5447         while (++MARK <= SP) {
5448             if (SvTAINTED(*MARK)) {
5449                 TAINT;
5450                 break;
5451             }
5452         }
5453         MARK = ORIGMARK;
5454         TAINT_PROPER("syscall");
5455     }
5456
5457     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5458      * or where sizeof(long) != sizeof(char*).  But such machines will
5459      * not likely have syscall implemented either, so who cares?
5460      */
5461     while (++MARK <= SP) {
5462         if (SvNIOK(*MARK) || !i)
5463             a[i++] = SvIV(*MARK);
5464         else if (*MARK == &PL_sv_undef)
5465             a[i++] = 0;
5466         else
5467             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5468         if (i > 15)
5469             break;
5470     }
5471     switch (items) {
5472     default:
5473         DIE(aTHX_ "Too many args to syscall");
5474     case 0:
5475         DIE(aTHX_ "Too few args to syscall");
5476     case 1:
5477         retval = syscall(a[0]);
5478         break;
5479     case 2:
5480         retval = syscall(a[0],a[1]);
5481         break;
5482     case 3:
5483         retval = syscall(a[0],a[1],a[2]);
5484         break;
5485     case 4:
5486         retval = syscall(a[0],a[1],a[2],a[3]);
5487         break;
5488     case 5:
5489         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5490         break;
5491     case 6:
5492         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5493         break;
5494     case 7:
5495         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5496         break;
5497     case 8:
5498         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5499         break;
5500 #ifdef atarist
5501     case 9:
5502         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5503         break;
5504     case 10:
5505         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5506         break;
5507     case 11:
5508         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5509           a[10]);
5510         break;
5511     case 12:
5512         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5513           a[10],a[11]);
5514         break;
5515     case 13:
5516         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5517           a[10],a[11],a[12]);
5518         break;
5519     case 14:
5520         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5521           a[10],a[11],a[12],a[13]);
5522         break;
5523 #endif /* atarist */
5524     }
5525     SP = ORIGMARK;
5526     PUSHi(retval);
5527     RETURN;
5528 #else
5529     DIE(aTHX_ PL_no_func, "syscall");
5530 #endif
5531 }
5532
5533 #ifdef FCNTL_EMULATE_FLOCK
5534
5535 /*  XXX Emulate flock() with fcntl().
5536     What's really needed is a good file locking module.
5537 */
5538
5539 static int
5540 fcntl_emulate_flock(int fd, int operation)
5541 {
5542     struct flock flock;
5543
5544     switch (operation & ~LOCK_NB) {
5545     case LOCK_SH:
5546         flock.l_type = F_RDLCK;
5547         break;
5548     case LOCK_EX:
5549         flock.l_type = F_WRLCK;
5550         break;
5551     case LOCK_UN:
5552         flock.l_type = F_UNLCK;
5553         break;
5554     default:
5555         errno = EINVAL;
5556         return -1;
5557     }
5558     flock.l_whence = SEEK_SET;
5559     flock.l_start = flock.l_len = (Off_t)0;
5560
5561     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5562 }
5563
5564 #endif /* FCNTL_EMULATE_FLOCK */
5565
5566 #ifdef LOCKF_EMULATE_FLOCK
5567
5568 /*  XXX Emulate flock() with lockf().  This is just to increase
5569     portability of scripts.  The calls are not completely
5570     interchangeable.  What's really needed is a good file
5571     locking module.
5572 */
5573
5574 /*  The lockf() constants might have been defined in <unistd.h>.
5575     Unfortunately, <unistd.h> causes troubles on some mixed
5576     (BSD/POSIX) systems, such as SunOS 4.1.3.
5577
5578    Further, the lockf() constants aren't POSIX, so they might not be
5579    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5580    just stick in the SVID values and be done with it.  Sigh.
5581 */
5582
5583 # ifndef F_ULOCK
5584 #  define F_ULOCK       0       /* Unlock a previously locked region */
5585 # endif
5586 # ifndef F_LOCK
5587 #  define F_LOCK        1       /* Lock a region for exclusive use */
5588 # endif
5589 # ifndef F_TLOCK
5590 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5591 # endif
5592 # ifndef F_TEST
5593 #  define F_TEST        3       /* Test a region for other processes locks */
5594 # endif
5595
5596 static int
5597 lockf_emulate_flock(int fd, int operation)
5598 {
5599     int i;
5600     Off_t pos;
5601     dSAVE_ERRNO;
5602
5603     /* flock locks entire file so for lockf we need to do the same      */
5604     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5605     if (pos > 0)        /* is seekable and needs to be repositioned     */
5606         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5607             pos = -1;   /* seek failed, so don't seek back afterwards   */
5608     RESTORE_ERRNO;
5609
5610     switch (operation) {
5611
5612         /* LOCK_SH - get a shared lock */
5613         case LOCK_SH:
5614         /* LOCK_EX - get an exclusive lock */
5615         case LOCK_EX:
5616             i = lockf (fd, F_LOCK, 0);
5617             break;
5618
5619         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5620         case LOCK_SH|LOCK_NB:
5621         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5622         case LOCK_EX|LOCK_NB:
5623             i = lockf (fd, F_TLOCK, 0);
5624             if (i == -1)
5625                 if ((errno == EAGAIN) || (errno == EACCES))
5626                     errno = EWOULDBLOCK;
5627             break;
5628
5629         /* LOCK_UN - unlock (non-blocking is a no-op) */
5630         case LOCK_UN:
5631         case LOCK_UN|LOCK_NB:
5632             i = lockf (fd, F_ULOCK, 0);
5633             break;
5634
5635         /* Default - can't decipher operation */
5636         default:
5637             i = -1;
5638             errno = EINVAL;
5639             break;
5640     }
5641
5642     if (pos > 0)      /* need to restore position of the handle */
5643         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5644
5645     return (i);
5646 }
5647
5648 #endif /* LOCKF_EMULATE_FLOCK */
5649
5650 /*
5651  * Local variables:
5652  * c-indentation-style: bsd
5653  * c-basic-offset: 4
5654  * indent-tabs-mode: t
5655  * End:
5656  *
5657  * ex: set ts=8 sts=4 sw=4 noet:
5658  */