pp_sys.c

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