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