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