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