pp_sys.c

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