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         const OP *next;
2908         SV * const tmpsv = amagic_call(arg,
2909                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2910                                 ftest_amg, AMGf_unary);
2911
2912         if (!tmpsv)
2913             return FALSE;
2914
2915         SPAGAIN;
2916
2917         if (PL_op->op_private & OPpFT_STACKING) {
2918             if (SvTRUE(tmpsv))
2919                 /* leave the object alone */
2920                 return TRUE;
2921         }
2922
2923         SETs(tmpsv);
2924         PUTBACK;
2925         return TRUE;
2926     }
2927     return FALSE;
2928 }
2929
2930
2931 /* This macro is used by the stacked filetest operators :
2932  * if the previous filetest failed, short-circuit and pass its value.
2933  * Else, discard it from the stack and continue. --rgs
2934  */
2935 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2936         if (!SvTRUE(TOPs)) { RETURN; } \
2937         else { (void)POPs; PUTBACK; } \
2938     }
2939
2940 PP(pp_ftrread)
2941 {
2942     dVAR;
2943     I32 result;
2944     /* Not const, because things tweak this below. Not bool, because there's
2945        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2946 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2947     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2948     /* Giving some sort of initial value silences compilers.  */
2949 #  ifdef R_OK
2950     int access_mode = R_OK;
2951 #  else
2952     int access_mode = 0;
2953 #  endif
2954 #else
2955     /* access_mode is never used, but leaving use_access in makes the
2956        conditional compiling below much clearer.  */
2957     I32 use_access = 0;
2958 #endif
2959     Mode_t stat_mode = S_IRUSR;
2960
2961     bool effective = FALSE;
2962     char opchar = '?';
2963     dSP;
2964
2965     switch (PL_op->op_type) {
2966     case OP_FTRREAD:    opchar = 'R'; break;
2967     case OP_FTRWRITE:   opchar = 'W'; break;
2968     case OP_FTREXEC:    opchar = 'X'; break;
2969     case OP_FTEREAD:    opchar = 'r'; break;
2970     case OP_FTEWRITE:   opchar = 'w'; break;
2971     case OP_FTEEXEC:    opchar = 'x'; break;
2972     }
2973     tryAMAGICftest_MG(opchar);
2974
2975     STACKED_FTEST_CHECK;
2976
2977     switch (PL_op->op_type) {
2978     case OP_FTRREAD:
2979 #if !(defined(HAS_ACCESS) && defined(R_OK))
2980         use_access = 0;
2981 #endif
2982         break;
2983
2984     case OP_FTRWRITE:
2985 #if defined(HAS_ACCESS) && defined(W_OK)
2986         access_mode = W_OK;
2987 #else
2988         use_access = 0;
2989 #endif
2990         stat_mode = S_IWUSR;
2991         break;
2992
2993     case OP_FTREXEC:
2994 #if defined(HAS_ACCESS) && defined(X_OK)
2995         access_mode = X_OK;
2996 #else
2997         use_access = 0;
2998 #endif
2999         stat_mode = S_IXUSR;
3000         break;
3001
3002     case OP_FTEWRITE:
3003 #ifdef PERL_EFF_ACCESS
3004         access_mode = W_OK;
3005 #endif
3006         stat_mode = S_IWUSR;
3007         /* fall through */
3008
3009     case OP_FTEREAD:
3010 #ifndef PERL_EFF_ACCESS
3011         use_access = 0;
3012 #endif
3013         effective = TRUE;
3014         break;
3015
3016     case OP_FTEEXEC:
3017 #ifdef PERL_EFF_ACCESS
3018         access_mode = X_OK;
3019 #else
3020         use_access = 0;
3021 #endif
3022         stat_mode = S_IXUSR;
3023         effective = TRUE;
3024         break;
3025     }
3026
3027     if (use_access) {
3028 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3029         const char *name = POPpx;
3030         if (effective) {
3031 #  ifdef PERL_EFF_ACCESS
3032             result = PERL_EFF_ACCESS(name, access_mode);
3033 #  else
3034             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3035                 OP_NAME(PL_op));
3036 #  endif
3037         }
3038         else {
3039 #  ifdef HAS_ACCESS
3040             result = access(name, access_mode);
3041 #  else
3042             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3043 #  endif
3044         }
3045         if (result == 0)
3046             RETPUSHYES;
3047         if (result < 0)
3048             RETPUSHUNDEF;
3049         RETPUSHNO;
3050 #endif
3051     }
3052
3053     result = my_stat_flags(0);
3054     SPAGAIN;
3055     if (result < 0)
3056         RETPUSHUNDEF;
3057     if (cando(stat_mode, effective, &PL_statcache))
3058         RETPUSHYES;
3059     RETPUSHNO;
3060 }
3061
3062 PP(pp_ftis)
3063 {
3064     dVAR;
3065     I32 result;
3066     const int op_type = PL_op->op_type;
3067     char opchar = '?';
3068     dSP;
3069
3070     switch (op_type) {
3071     case OP_FTIS:       opchar = 'e'; break;
3072     case OP_FTSIZE:     opchar = 's'; break;
3073     case OP_FTMTIME:    opchar = 'M'; break;
3074     case OP_FTCTIME:    opchar = 'C'; break;
3075     case OP_FTATIME:    opchar = 'A'; break;
3076     }
3077     tryAMAGICftest_MG(opchar);
3078
3079     STACKED_FTEST_CHECK;
3080
3081     result = my_stat_flags(0);
3082     SPAGAIN;
3083     if (result < 0)
3084         RETPUSHUNDEF;
3085     if (op_type == OP_FTIS)
3086         RETPUSHYES;
3087     {
3088         /* You can't dTARGET inside OP_FTIS, because you'll get
3089            "panic: pad_sv po" - the op is not flagged to have a target.  */
3090         dTARGET;
3091         switch (op_type) {
3092         case OP_FTSIZE:
3093 #if Off_t_size > IVSIZE
3094             PUSHn(PL_statcache.st_size);
3095 #else
3096             PUSHi(PL_statcache.st_size);
3097 #endif
3098             break;
3099         case OP_FTMTIME:
3100             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3101             break;
3102         case OP_FTATIME:
3103             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3104             break;
3105         case OP_FTCTIME:
3106             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3107             break;
3108         }
3109     }
3110     RETURN;
3111 }
3112
3113 PP(pp_ftrowned)
3114 {
3115     dVAR;
3116     I32 result;
3117     char opchar = '?';
3118     dSP;
3119
3120     switch (PL_op->op_type) {
3121     case OP_FTROWNED:   opchar = 'O'; break;
3122     case OP_FTEOWNED:   opchar = 'o'; break;
3123     case OP_FTZERO:     opchar = 'z'; break;
3124     case OP_FTSOCK:     opchar = 'S'; break;
3125     case OP_FTCHR:      opchar = 'c'; break;
3126     case OP_FTBLK:      opchar = 'b'; break;
3127     case OP_FTFILE:     opchar = 'f'; break;
3128     case OP_FTDIR:      opchar = 'd'; break;
3129     case OP_FTPIPE:     opchar = 'p'; break;
3130     case OP_FTSUID:     opchar = 'u'; break;
3131     case OP_FTSGID:     opchar = 'g'; break;
3132     case OP_FTSVTX:     opchar = 'k'; break;
3133     }
3134     tryAMAGICftest_MG(opchar);
3135
3136     STACKED_FTEST_CHECK;
3137
3138     /* I believe that all these three are likely to be defined on most every
3139        system these days.  */
3140 #ifndef S_ISUID
3141     if(PL_op->op_type == OP_FTSUID) {
3142         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3143             (void) POPs;
3144         RETPUSHNO;
3145     }
3146 #endif
3147 #ifndef S_ISGID
3148     if(PL_op->op_type == OP_FTSGID) {
3149         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3150             (void) POPs;
3151         RETPUSHNO;
3152     }
3153 #endif
3154 #ifndef S_ISVTX
3155     if(PL_op->op_type == OP_FTSVTX) {
3156         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3157             (void) POPs;
3158         RETPUSHNO;
3159     }
3160 #endif
3161
3162     result = my_stat_flags(0);
3163     SPAGAIN;
3164     if (result < 0)
3165         RETPUSHUNDEF;
3166     switch (PL_op->op_type) {
3167     case OP_FTROWNED:
3168         if (PL_statcache.st_uid == PL_uid)
3169             RETPUSHYES;
3170         break;
3171     case OP_FTEOWNED:
3172         if (PL_statcache.st_uid == PL_euid)
3173             RETPUSHYES;
3174         break;
3175     case OP_FTZERO:
3176         if (PL_statcache.st_size == 0)
3177             RETPUSHYES;
3178         break;
3179     case OP_FTSOCK:
3180         if (S_ISSOCK(PL_statcache.st_mode))
3181             RETPUSHYES;
3182         break;
3183     case OP_FTCHR:
3184         if (S_ISCHR(PL_statcache.st_mode))
3185             RETPUSHYES;
3186         break;
3187     case OP_FTBLK:
3188         if (S_ISBLK(PL_statcache.st_mode))
3189             RETPUSHYES;
3190         break;
3191     case OP_FTFILE:
3192         if (S_ISREG(PL_statcache.st_mode))
3193             RETPUSHYES;
3194         break;
3195     case OP_FTDIR:
3196         if (S_ISDIR(PL_statcache.st_mode))
3197             RETPUSHYES;
3198         break;
3199     case OP_FTPIPE:
3200         if (S_ISFIFO(PL_statcache.st_mode))
3201             RETPUSHYES;
3202         break;
3203 #ifdef S_ISUID
3204     case OP_FTSUID:
3205         if (PL_statcache.st_mode & S_ISUID)
3206             RETPUSHYES;
3207         break;
3208 #endif
3209 #ifdef S_ISGID
3210     case OP_FTSGID:
3211         if (PL_statcache.st_mode & S_ISGID)
3212             RETPUSHYES;
3213         break;
3214 #endif
3215 #ifdef S_ISVTX
3216     case OP_FTSVTX:
3217         if (PL_statcache.st_mode & S_ISVTX)
3218             RETPUSHYES;
3219         break;
3220 #endif
3221     }
3222     RETPUSHNO;
3223 }
3224
3225 PP(pp_ftlink)
3226 {
3227     dVAR;
3228     dSP;
3229     I32 result;
3230
3231     tryAMAGICftest_MG('l');
3232     result = my_lstat_flags(0);
3233     SPAGAIN;
3234
3235     if (result < 0)
3236         RETPUSHUNDEF;
3237     if (S_ISLNK(PL_statcache.st_mode))
3238         RETPUSHYES;
3239     RETPUSHNO;
3240 }
3241
3242 PP(pp_fttty)
3243 {
3244     dVAR;
3245     dSP;
3246     int fd;
3247     GV *gv;
3248     SV *tmpsv = NULL;
3249     char *name = NULL;
3250     STRLEN namelen;
3251
3252     tryAMAGICftest_MG('t');
3253
3254     STACKED_FTEST_CHECK;
3255
3256     if (PL_op->op_flags & OPf_REF)
3257         gv = cGVOP_gv;
3258     else if (isGV_with_GP(TOPs))
3259         gv = MUTABLE_GV(POPs);
3260     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3261         gv = MUTABLE_GV(SvRV(POPs));
3262     else {
3263         tmpsv = POPs;
3264         name = SvPV_nomg(tmpsv, namelen);
3265         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3266     }
3267
3268     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3269         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3270     else if (tmpsv && SvOK(tmpsv)) {
3271         if (isDIGIT(*name))
3272             fd = atoi(name);
3273         else
3274             RETPUSHUNDEF;
3275     }
3276     else
3277         RETPUSHUNDEF;
3278     if (PerlLIO_isatty(fd))
3279         RETPUSHYES;
3280     RETPUSHNO;
3281 }
3282
3283 #if defined(atarist) /* this will work with atariST. Configure will
3284                         make guesses for other systems. */
3285 # define FILE_base(f) ((f)->_base)
3286 # define FILE_ptr(f) ((f)->_ptr)
3287 # define FILE_cnt(f) ((f)->_cnt)
3288 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3289 #endif
3290
3291 PP(pp_fttext)
3292 {
3293     dVAR;
3294     dSP;
3295     I32 i;
3296     I32 len;
3297     I32 odd = 0;
3298     STDCHAR tbuf[512];
3299     register STDCHAR *s;
3300     register IO *io;
3301     register SV *sv;
3302     GV *gv;
3303     PerlIO *fp;
3304
3305     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3306
3307     STACKED_FTEST_CHECK;
3308
3309     if (PL_op->op_flags & OPf_REF)
3310         gv = cGVOP_gv;
3311     else if (isGV_with_GP(TOPs))
3312         gv = MUTABLE_GV(POPs);
3313     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3314         gv = MUTABLE_GV(SvRV(POPs));
3315     else
3316         gv = NULL;
3317
3318     if (gv) {
3319         EXTEND(SP, 1);
3320         if (gv == PL_defgv) {
3321             if (PL_statgv)
3322                 io = GvIO(PL_statgv);
3323             else {
3324                 sv = PL_statname;
3325                 goto really_filename;
3326             }
3327         }
3328         else {
3329             PL_statgv = gv;
3330             PL_laststatval = -1;
3331             sv_setpvs(PL_statname, "");
3332             io = GvIO(PL_statgv);
3333         }
3334         if (io && IoIFP(io)) {
3335             if (! PerlIO_has_base(IoIFP(io)))
3336                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3337             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3338             if (PL_laststatval < 0)
3339                 RETPUSHUNDEF;
3340             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3341                 if (PL_op->op_type == OP_FTTEXT)
3342                     RETPUSHNO;
3343                 else
3344                     RETPUSHYES;
3345             }
3346             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3347                 i = PerlIO_getc(IoIFP(io));
3348                 if (i != EOF)
3349                     (void)PerlIO_ungetc(IoIFP(io),i);
3350             }
3351             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3352                 RETPUSHYES;
3353             len = PerlIO_get_bufsiz(IoIFP(io));
3354             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3355             /* sfio can have large buffers - limit to 512 */
3356             if (len > 512)
3357                 len = 512;
3358         }
3359         else {
3360             report_evil_fh(cGVOP_gv);
3361             SETERRNO(EBADF,RMS_IFI);
3362             RETPUSHUNDEF;
3363         }
3364     }
3365     else {
3366         sv = POPs;
3367       really_filename:
3368         PL_statgv = NULL;
3369         PL_laststype = OP_STAT;
3370         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3371         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3372             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3373                                                '\n'))
3374                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3375             RETPUSHUNDEF;
3376         }
3377         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3378         if (PL_laststatval < 0) {
3379             (void)PerlIO_close(fp);
3380             RETPUSHUNDEF;
3381         }
3382         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3383         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3384         (void)PerlIO_close(fp);
3385         if (len <= 0) {
3386             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3387                 RETPUSHNO;              /* special case NFS directories */
3388             RETPUSHYES;         /* null file is anything */
3389         }
3390         s = tbuf;
3391     }
3392
3393     /* now scan s to look for textiness */
3394     /*   XXX ASCII dependent code */
3395
3396 #if defined(DOSISH) || defined(USEMYBINMODE)
3397     /* ignore trailing ^Z on short files */
3398     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3399         --len;
3400 #endif
3401
3402     for (i = 0; i < len; i++, s++) {
3403         if (!*s) {                      /* null never allowed in text */
3404             odd += len;
3405             break;
3406         }
3407 #ifdef EBCDIC
3408         else if (!(isPRINT(*s) || isSPACE(*s)))
3409             odd++;
3410 #else
3411         else if (*s & 128) {
3412 #ifdef USE_LOCALE
3413             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3414                 continue;
3415 #endif
3416             /* utf8 characters don't count as odd */
3417             if (UTF8_IS_START(*s)) {
3418                 int ulen = UTF8SKIP(s);
3419                 if (ulen < len - i) {
3420                     int j;
3421                     for (j = 1; j < ulen; j++) {
3422                         if (!UTF8_IS_CONTINUATION(s[j]))
3423                             goto not_utf8;
3424                     }
3425                     --ulen;     /* loop does extra increment */
3426                     s += ulen;
3427                     i += ulen;
3428                     continue;
3429                 }
3430             }
3431           not_utf8:
3432             odd++;
3433         }
3434         else if (*s < 32 &&
3435           *s != '\n' && *s != '\r' && *s != '\b' &&
3436           *s != '\t' && *s != '\f' && *s != 27)
3437             odd++;
3438 #endif
3439     }
3440
3441     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3442         RETPUSHNO;
3443     else
3444         RETPUSHYES;
3445 }
3446
3447 /* File calls. */
3448
3449 PP(pp_chdir)
3450 {
3451     dVAR; dSP; dTARGET;
3452     const char *tmps = NULL;
3453     GV *gv = NULL;
3454
3455     if( MAXARG == 1 ) {
3456         SV * const sv = POPs;
3457         if (PL_op->op_flags & OPf_SPECIAL) {
3458             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3459         }
3460         else if (isGV_with_GP(sv)) {
3461             gv = MUTABLE_GV(sv);
3462         }
3463         else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3464             gv = MUTABLE_GV(SvRV(sv));
3465         }
3466         else {
3467             tmps = SvPV_nolen_const(sv);
3468         }
3469     }
3470
3471     if( !gv && (!tmps || !*tmps) ) {
3472         HV * const table = GvHVn(PL_envgv);
3473         SV **svp;
3474
3475         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3476              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3477 #ifdef VMS
3478              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3479 #endif
3480            )
3481         {
3482             if( MAXARG == 1 )
3483                 deprecate("chdir('') or chdir(undef) as chdir()");
3484             tmps = SvPV_nolen_const(*svp);
3485         }
3486         else {
3487             PUSHi(0);
3488             TAINT_PROPER("chdir");
3489             RETURN;
3490         }
3491     }
3492
3493     TAINT_PROPER("chdir");
3494     if (gv) {
3495 #ifdef HAS_FCHDIR
3496         IO* const io = GvIO(gv);
3497         if (io) {
3498             if (IoDIRP(io)) {
3499                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3500             } else if (IoIFP(io)) {
3501                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3502             }
3503             else {
3504                 report_evil_fh(gv);
3505                 SETERRNO(EBADF, RMS_IFI);
3506                 PUSHi(0);
3507             }
3508         }
3509         else {
3510             report_evil_fh(gv);
3511             SETERRNO(EBADF,RMS_IFI);
3512             PUSHi(0);
3513         }
3514 #else
3515         DIE(aTHX_ PL_no_func, "fchdir");
3516 #endif
3517     }
3518     else
3519         PUSHi( PerlDir_chdir(tmps) >= 0 );
3520 #ifdef VMS
3521     /* Clear the DEFAULT element of ENV so we'll get the new value
3522      * in the future. */
3523     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3524 #endif
3525     RETURN;
3526 }
3527
3528 PP(pp_chown)
3529 {
3530     dVAR; dSP; dMARK; dTARGET;
3531     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3532
3533     SP = MARK;
3534     XPUSHi(value);
3535     RETURN;
3536 }
3537
3538 PP(pp_chroot)
3539 {
3540 #ifdef HAS_CHROOT
3541     dVAR; dSP; dTARGET;
3542     char * const tmps = POPpx;
3543     TAINT_PROPER("chroot");
3544     PUSHi( chroot(tmps) >= 0 );
3545     RETURN;
3546 #else
3547     DIE(aTHX_ PL_no_func, "chroot");
3548 #endif
3549 }
3550
3551 PP(pp_rename)
3552 {
3553     dVAR; dSP; dTARGET;
3554     int anum;
3555     const char * const tmps2 = POPpconstx;
3556     const char * const tmps = SvPV_nolen_const(TOPs);
3557     TAINT_PROPER("rename");
3558 #ifdef HAS_RENAME
3559     anum = PerlLIO_rename(tmps, tmps2);
3560 #else
3561     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3562         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3563             anum = 1;
3564         else {
3565             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3566                 (void)UNLINK(tmps2);
3567             if (!(anum = link(tmps, tmps2)))
3568                 anum = UNLINK(tmps);
3569         }
3570     }
3571 #endif
3572     SETi( anum >= 0 );
3573     RETURN;
3574 }
3575
3576 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3577 PP(pp_link)
3578 {
3579     dVAR; dSP; dTARGET;
3580     const int op_type = PL_op->op_type;
3581     int result;
3582
3583 #  ifndef HAS_LINK
3584     if (op_type == OP_LINK)
3585         DIE(aTHX_ PL_no_func, "link");
3586 #  endif
3587 #  ifndef HAS_SYMLINK
3588     if (op_type == OP_SYMLINK)
3589         DIE(aTHX_ PL_no_func, "symlink");
3590 #  endif
3591
3592     {
3593         const char * const tmps2 = POPpconstx;
3594         const char * const tmps = SvPV_nolen_const(TOPs);
3595         TAINT_PROPER(PL_op_desc[op_type]);
3596         result =
3597 #  if defined(HAS_LINK)
3598 #    if defined(HAS_SYMLINK)
3599             /* Both present - need to choose which.  */
3600             (op_type == OP_LINK) ?
3601             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3602 #    else
3603     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3604         PerlLIO_link(tmps, tmps2);
3605 #    endif
3606 #  else
3607 #    if defined(HAS_SYMLINK)
3608     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3609         symlink(tmps, tmps2);
3610 #    endif
3611 #  endif
3612     }
3613
3614     SETi( result >= 0 );
3615     RETURN;
3616 }
3617 #else
3618 PP(pp_link)
3619 {
3620     /* Have neither.  */
3621     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3622 }
3623 #endif
3624
3625 PP(pp_readlink)
3626 {
3627     dVAR;
3628     dSP;
3629 #ifdef HAS_SYMLINK
3630     dTARGET;
3631     const char *tmps;
3632     char buf[MAXPATHLEN];
3633     int len;
3634
3635 #ifndef INCOMPLETE_TAINTS
3636     TAINT;
3637 #endif
3638     tmps = POPpconstx;
3639     len = readlink(tmps, buf, sizeof(buf) - 1);
3640     if (len < 0)
3641         RETPUSHUNDEF;
3642     PUSHp(buf, len);
3643     RETURN;
3644 #else
3645     EXTEND(SP, 1);
3646     RETSETUNDEF;                /* just pretend it's a normal file */
3647 #endif
3648 }
3649
3650 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3651 STATIC int
3652 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3653 {
3654     char * const save_filename = filename;
3655     char *cmdline;
3656     char *s;
3657     PerlIO *myfp;
3658     int anum = 1;
3659     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3660
3661     PERL_ARGS_ASSERT_DOONELINER;
3662
3663     Newx(cmdline, size, char);
3664     my_strlcpy(cmdline, cmd, size);
3665     my_strlcat(cmdline, " ", size);
3666     for (s = cmdline + strlen(cmdline); *filename; ) {
3667         *s++ = '\\';
3668         *s++ = *filename++;
3669     }
3670     if (s - cmdline < size)
3671         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3672     myfp = PerlProc_popen(cmdline, "r");
3673     Safefree(cmdline);
3674
3675     if (myfp) {
3676         SV * const tmpsv = sv_newmortal();
3677         /* Need to save/restore 'PL_rs' ?? */
3678         s = sv_gets(tmpsv, myfp, 0);
3679         (void)PerlProc_pclose(myfp);
3680         if (s != NULL) {
3681             int e;
3682             for (e = 1;
3683 #ifdef HAS_SYS_ERRLIST
3684                  e <= sys_nerr
3685 #endif
3686                  ; e++)
3687             {
3688                 /* you don't see this */
3689                 const char * const errmsg =
3690 #ifdef HAS_SYS_ERRLIST
3691                     sys_errlist[e]
3692 #else
3693                     strerror(e)
3694 #endif
3695                     ;
3696                 if (!errmsg)
3697                     break;
3698                 if (instr(s, errmsg)) {
3699                     SETERRNO(e,0);
3700                     return 0;
3701                 }
3702             }
3703             SETERRNO(0,0);
3704 #ifndef EACCES
3705 #define EACCES EPERM
3706 #endif
3707             if (instr(s, "cannot make"))
3708                 SETERRNO(EEXIST,RMS_FEX);
3709             else if (instr(s, "existing file"))
3710                 SETERRNO(EEXIST,RMS_FEX);
3711             else if (instr(s, "ile exists"))
3712                 SETERRNO(EEXIST,RMS_FEX);
3713             else if (instr(s, "non-exist"))
3714                 SETERRNO(ENOENT,RMS_FNF);
3715             else if (instr(s, "does not exist"))
3716                 SETERRNO(ENOENT,RMS_FNF);
3717             else if (instr(s, "not empty"))
3718                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3719             else if (instr(s, "cannot access"))
3720                 SETERRNO(EACCES,RMS_PRV);
3721             else
3722                 SETERRNO(EPERM,RMS_PRV);
3723             return 0;
3724         }
3725         else {  /* some mkdirs return no failure indication */
3726             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3727             if (PL_op->op_type == OP_RMDIR)
3728                 anum = !anum;
3729             if (anum)
3730                 SETERRNO(0,0);
3731             else
3732                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3733         }
3734         return anum;
3735     }
3736     else
3737         return 0;
3738 }
3739 #endif
3740
3741 /* This macro removes trailing slashes from a directory name.
3742  * Different operating and file systems take differently to
3743  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3744  * any number of trailing slashes should be allowed.
3745  * Thusly we snip them away so that even non-conforming
3746  * systems are happy.
3747  * We should probably do this "filtering" for all
3748  * the functions that expect (potentially) directory names:
3749  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3750  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3751
3752 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3753     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3754         do { \
3755             (len)--; \
3756         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3757         (tmps) = savepvn((tmps), (len)); \
3758         (copy) = TRUE; \
3759     }
3760
3761 PP(pp_mkdir)
3762 {
3763     dVAR; dSP; dTARGET;
3764     STRLEN len;
3765     const char *tmps;
3766     bool copy = FALSE;
3767     const int mode = (MAXARG > 1) ? POPi : 0777;
3768
3769     TRIMSLASHES(tmps,len,copy);
3770
3771     TAINT_PROPER("mkdir");
3772 #ifdef HAS_MKDIR
3773     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3774 #else
3775     {
3776     int oldumask;
3777     SETi( dooneliner("mkdir", tmps) );
3778     oldumask = PerlLIO_umask(0);
3779     PerlLIO_umask(oldumask);
3780     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3781     }
3782 #endif
3783     if (copy)
3784         Safefree(tmps);
3785     RETURN;
3786 }
3787
3788 PP(pp_rmdir)
3789 {
3790     dVAR; dSP; dTARGET;
3791     STRLEN len;
3792     const char *tmps;
3793     bool copy = FALSE;
3794
3795     TRIMSLASHES(tmps,len,copy);
3796     TAINT_PROPER("rmdir");
3797 #ifdef HAS_RMDIR
3798     SETi( PerlDir_rmdir(tmps) >= 0 );
3799 #else
3800     SETi( dooneliner("rmdir", tmps) );
3801 #endif
3802     if (copy)
3803         Safefree(tmps);
3804     RETURN;
3805 }
3806
3807 /* Directory calls. */
3808
3809 PP(pp_open_dir)
3810 {
3811 #if defined(Direntry_t) && defined(HAS_READDIR)
3812     dVAR; dSP;
3813     const char * const dirname = POPpconstx;
3814     GV * const gv = MUTABLE_GV(POPs);
3815     register IO * const io = GvIOn(gv);
3816
3817     if (!io)
3818         goto nope;
3819
3820     if ((IoIFP(io) || IoOFP(io)))
3821         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3822                          "Opening filehandle %s also as a directory",
3823                          GvENAME(gv));
3824     if (IoDIRP(io))
3825         PerlDir_close(IoDIRP(io));
3826     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3827         goto nope;
3828
3829     RETPUSHYES;
3830 nope:
3831     if (!errno)
3832         SETERRNO(EBADF,RMS_DIR);
3833     RETPUSHUNDEF;
3834 #else
3835     DIE(aTHX_ PL_no_dir_func, "opendir");
3836 #endif
3837 }
3838
3839 PP(pp_readdir)
3840 {
3841 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3842     DIE(aTHX_ PL_no_dir_func, "readdir");
3843 #else
3844 #if !defined(I_DIRENT) && !defined(VMS)
3845     Direntry_t *readdir (DIR *);
3846 #endif
3847     dVAR;
3848     dSP;
3849
3850     SV *sv;
3851     const I32 gimme = GIMME;
3852     GV * const gv = MUTABLE_GV(POPs);
3853     register const Direntry_t *dp;
3854     register IO * const io = GvIOn(gv);
3855
3856     if (!io || !IoDIRP(io)) {
3857         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3858                        "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3859         goto nope;
3860     }
3861
3862     do {
3863         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3864         if (!dp)
3865             break;
3866 #ifdef DIRNAMLEN
3867         sv = newSVpvn(dp->d_name, dp->d_namlen);
3868 #else
3869         sv = newSVpv(dp->d_name, 0);
3870 #endif
3871 #ifndef INCOMPLETE_TAINTS
3872         if (!(IoFLAGS(io) & IOf_UNTAINT))
3873             SvTAINTED_on(sv);
3874 #endif
3875         mXPUSHs(sv);
3876     } while (gimme == G_ARRAY);
3877
3878     if (!dp && gimme != G_ARRAY)
3879         goto nope;
3880
3881     RETURN;
3882
3883 nope:
3884     if (!errno)
3885         SETERRNO(EBADF,RMS_ISI);
3886     if (GIMME == G_ARRAY)
3887         RETURN;
3888     else
3889         RETPUSHUNDEF;
3890 #endif
3891 }
3892
3893 PP(pp_telldir)
3894 {
3895 #if defined(HAS_TELLDIR) || defined(telldir)
3896     dVAR; dSP; dTARGET;
3897  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3898  /* XXX netbsd still seemed to.
3899     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3900     --JHI 1999-Feb-02 */
3901 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3902     long telldir (DIR *);
3903 # endif
3904     GV * const gv = MUTABLE_GV(POPs);
3905     register IO * const io = GvIOn(gv);
3906
3907     if (!io || !IoDIRP(io)) {
3908         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3909                        "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3910         goto nope;
3911     }
3912
3913     PUSHi( PerlDir_tell(IoDIRP(io)) );
3914     RETURN;
3915 nope:
3916     if (!errno)
3917         SETERRNO(EBADF,RMS_ISI);
3918     RETPUSHUNDEF;
3919 #else
3920     DIE(aTHX_ PL_no_dir_func, "telldir");
3921 #endif
3922 }
3923
3924 PP(pp_seekdir)
3925 {
3926 #if defined(HAS_SEEKDIR) || defined(seekdir)
3927     dVAR; dSP;
3928     const long along = POPl;
3929     GV * const gv = MUTABLE_GV(POPs);
3930     register IO * const io = GvIOn(gv);
3931
3932     if (!io || !IoDIRP(io)) {
3933         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3934                        "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3935         goto nope;
3936     }
3937     (void)PerlDir_seek(IoDIRP(io), along);
3938
3939     RETPUSHYES;
3940 nope:
3941     if (!errno)
3942         SETERRNO(EBADF,RMS_ISI);
3943     RETPUSHUNDEF;
3944 #else
3945     DIE(aTHX_ PL_no_dir_func, "seekdir");
3946 #endif
3947 }
3948
3949 PP(pp_rewinddir)
3950 {
3951 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3952     dVAR; dSP;
3953     GV * const gv = MUTABLE_GV(POPs);
3954     register IO * const io = GvIOn(gv);
3955
3956     if (!io || !IoDIRP(io)) {
3957         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3958                        "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3959         goto nope;
3960     }
3961     (void)PerlDir_rewind(IoDIRP(io));
3962     RETPUSHYES;
3963 nope:
3964     if (!errno)
3965         SETERRNO(EBADF,RMS_ISI);
3966     RETPUSHUNDEF;
3967 #else
3968     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3969 #endif
3970 }
3971
3972 PP(pp_closedir)
3973 {
3974 #if defined(Direntry_t) && defined(HAS_READDIR)
3975     dVAR; dSP;
3976     GV * const gv = MUTABLE_GV(POPs);
3977     register IO * const io = GvIOn(gv);
3978
3979     if (!io || !IoDIRP(io)) {
3980         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3981                        "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3982         goto nope;
3983     }
3984 #ifdef VOID_CLOSEDIR
3985     PerlDir_close(IoDIRP(io));
3986 #else
3987     if (PerlDir_close(IoDIRP(io)) < 0) {
3988         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3989         goto nope;
3990     }
3991 #endif
3992     IoDIRP(io) = 0;
3993
3994     RETPUSHYES;
3995 nope:
3996     if (!errno)
3997         SETERRNO(EBADF,RMS_IFI);
3998     RETPUSHUNDEF;
3999 #else
4000     DIE(aTHX_ PL_no_dir_func, "closedir");
4001 #endif
4002 }
4003
4004 /* Process control. */
4005
4006 PP(pp_fork)
4007 {
4008 #ifdef HAS_FORK
4009     dVAR; dSP; dTARGET;
4010     Pid_t childpid;
4011
4012     EXTEND(SP, 1);
4013     PERL_FLUSHALL_FOR_CHILD;
4014     childpid = PerlProc_fork();
4015     if (childpid < 0)
4016         RETSETUNDEF;
4017     if (!childpid) {
4018 #ifdef THREADS_HAVE_PIDS
4019         PL_ppid = (IV)getppid();
4020 #endif
4021 #ifdef PERL_USES_PL_PIDSTATUS
4022         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4023 #endif
4024     }
4025     PUSHi(childpid);
4026     RETURN;
4027 #else
4028 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4029     dSP; dTARGET;
4030     Pid_t childpid;
4031
4032     EXTEND(SP, 1);
4033     PERL_FLUSHALL_FOR_CHILD;
4034     childpid = PerlProc_fork();
4035     if (childpid == -1)
4036         RETSETUNDEF;
4037     PUSHi(childpid);
4038     RETURN;
4039 #  else
4040     DIE(aTHX_ PL_no_func, "fork");
4041 #  endif
4042 #endif
4043 }
4044
4045 PP(pp_wait)
4046 {
4047 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4048     dVAR; dSP; dTARGET;
4049     Pid_t childpid;
4050     int argflags;
4051
4052     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4053         childpid = wait4pid(-1, &argflags, 0);
4054     else {
4055         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4056                errno == EINTR) {
4057           PERL_ASYNC_CHECK();
4058         }
4059     }
4060 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4061     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4062     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4063 #  else
4064     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4065 #  endif
4066     XPUSHi(childpid);
4067     RETURN;
4068 #else
4069     DIE(aTHX_ PL_no_func, "wait");
4070 #endif
4071 }
4072
4073 PP(pp_waitpid)
4074 {
4075 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4076     dVAR; dSP; dTARGET;
4077     const int optype = POPi;
4078     const Pid_t pid = TOPi;
4079     Pid_t result;
4080     int argflags;
4081
4082     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4083         result = wait4pid(pid, &argflags, optype);
4084     else {
4085         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4086                errno == EINTR) {
4087           PERL_ASYNC_CHECK();
4088         }
4089     }
4090 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4091     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4092     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4093 #  else
4094     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4095 #  endif
4096     SETi(result);
4097     RETURN;
4098 #else
4099     DIE(aTHX_ PL_no_func, "waitpid");
4100 #endif
4101 }
4102
4103 PP(pp_system)
4104 {
4105     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4106 #if defined(__LIBCATAMOUNT__)
4107     PL_statusvalue = -1;
4108     SP = ORIGMARK;
4109     XPUSHi(-1);
4110 #else
4111     I32 value;
4112     int result;
4113
4114     if (PL_tainting) {
4115         TAINT_ENV();
4116         while (++MARK <= SP) {
4117             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4118             if (PL_tainted)
4119                 break;
4120         }
4121         MARK = ORIGMARK;
4122         TAINT_PROPER("system");
4123     }
4124     PERL_FLUSHALL_FOR_CHILD;
4125 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4126     {
4127         Pid_t childpid;
4128         int pp[2];
4129         I32 did_pipes = 0;
4130
4131         if (PerlProc_pipe(pp) >= 0)
4132             did_pipes = 1;
4133         while ((childpid = PerlProc_fork()) == -1) {
4134             if (errno != EAGAIN) {
4135                 value = -1;
4136                 SP = ORIGMARK;
4137                 XPUSHi(value);
4138                 if (did_pipes) {
4139                     PerlLIO_close(pp[0]);
4140                     PerlLIO_close(pp[1]);
4141                 }
4142                 RETURN;
4143             }
4144             sleep(5);
4145         }
4146         if (childpid > 0) {
4147             Sigsave_t ihand,qhand; /* place to save signals during system() */
4148             int status;
4149
4150             if (did_pipes)
4151                 PerlLIO_close(pp[1]);
4152 #ifndef PERL_MICRO
4153             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4154             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4155 #endif
4156             do {
4157                 result = wait4pid(childpid, &status, 0);
4158             } while (result == -1 && errno == EINTR);
4159 #ifndef PERL_MICRO
4160             (void)rsignal_restore(SIGINT, &ihand);
4161             (void)rsignal_restore(SIGQUIT, &qhand);
4162 #endif
4163             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4164             do_execfree();      /* free any memory child malloced on fork */
4165             SP = ORIGMARK;
4166             if (did_pipes) {
4167                 int errkid;
4168                 unsigned n = 0;
4169                 SSize_t n1;
4170
4171                 while (n < sizeof(int)) {
4172                     n1 = PerlLIO_read(pp[0],
4173                                       (void*)(((char*)&errkid)+n),
4174                                       (sizeof(int)) - n);
4175                     if (n1 <= 0)
4176                         break;
4177                     n += n1;
4178                 }
4179                 PerlLIO_close(pp[0]);
4180                 if (n) {                        /* Error */
4181                     if (n != sizeof(int))
4182                         DIE(aTHX_ "panic: kid popen errno read");
4183                     errno = errkid;             /* Propagate errno from kid */
4184                     STATUS_NATIVE_CHILD_SET(-1);
4185                 }
4186             }
4187             XPUSHi(STATUS_CURRENT);
4188             RETURN;
4189         }
4190         if (did_pipes) {
4191             PerlLIO_close(pp[0]);
4192 #if defined(HAS_FCNTL) && defined(F_SETFD)
4193             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4194 #endif
4195         }
4196         if (PL_op->op_flags & OPf_STACKED) {
4197             SV * const really = *++MARK;
4198             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4199         }
4200         else if (SP - MARK != 1)
4201             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4202         else {
4203             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4204         }
4205         PerlProc__exit(-1);
4206     }
4207 #else /* ! FORK or VMS or OS/2 */
4208     PL_statusvalue = 0;
4209     result = 0;
4210     if (PL_op->op_flags & OPf_STACKED) {
4211         SV * const really = *++MARK;
4212 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4213         value = (I32)do_aspawn(really, MARK, SP);
4214 #  else
4215         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4216 #  endif
4217     }
4218     else if (SP - MARK != 1) {
4219 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4220         value = (I32)do_aspawn(NULL, MARK, SP);
4221 #  else
4222         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4223 #  endif
4224     }
4225     else {
4226         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4227     }
4228     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4229         result = 1;
4230     STATUS_NATIVE_CHILD_SET(value);
4231     do_execfree();
4232     SP = ORIGMARK;
4233     XPUSHi(result ? value : STATUS_CURRENT);
4234 #endif /* !FORK or VMS or OS/2 */
4235 #endif
4236     RETURN;
4237 }
4238
4239 PP(pp_exec)
4240 {
4241     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4242     I32 value;
4243
4244     if (PL_tainting) {
4245         TAINT_ENV();
4246         while (++MARK <= SP) {
4247             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4248             if (PL_tainted)
4249                 break;
4250         }
4251         MARK = ORIGMARK;
4252         TAINT_PROPER("exec");
4253     }
4254     PERL_FLUSHALL_FOR_CHILD;
4255     if (PL_op->op_flags & OPf_STACKED) {
4256         SV * const really = *++MARK;
4257         value = (I32)do_aexec(really, MARK, SP);
4258     }
4259     else if (SP - MARK != 1)
4260 #ifdef VMS
4261         value = (I32)vms_do_aexec(NULL, MARK, SP);
4262 #else
4263 #  ifdef __OPEN_VM
4264         {
4265            (void ) do_aspawn(NULL, MARK, SP);
4266            value = 0;
4267         }
4268 #  else
4269         value = (I32)do_aexec(NULL, MARK, SP);
4270 #  endif
4271 #endif
4272     else {
4273 #ifdef VMS
4274         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4275 #else
4276 #  ifdef __OPEN_VM
4277         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4278         value = 0;
4279 #  else
4280         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4281 #  endif
4282 #endif
4283     }
4284
4285     SP = ORIGMARK;
4286     XPUSHi(value);
4287     RETURN;
4288 }
4289
4290 PP(pp_getppid)
4291 {
4292 #ifdef HAS_GETPPID
4293     dVAR; dSP; dTARGET;
4294 #   ifdef THREADS_HAVE_PIDS
4295     if (PL_ppid != 1 && getppid() == 1)
4296         /* maybe the parent process has died. Refresh ppid cache */
4297         PL_ppid = 1;
4298     XPUSHi( PL_ppid );
4299 #   else
4300     XPUSHi( getppid() );
4301 #   endif
4302     RETURN;
4303 #else
4304     DIE(aTHX_ PL_no_func, "getppid");
4305 #endif
4306 }
4307
4308 PP(pp_getpgrp)
4309 {
4310 #ifdef HAS_GETPGRP
4311     dVAR; dSP; dTARGET;
4312     Pid_t pgrp;
4313     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4314
4315 #ifdef BSD_GETPGRP
4316     pgrp = (I32)BSD_GETPGRP(pid);
4317 #else
4318     if (pid != 0 && pid != PerlProc_getpid())
4319         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4320     pgrp = getpgrp();
4321 #endif
4322     XPUSHi(pgrp);
4323     RETURN;
4324 #else
4325     DIE(aTHX_ PL_no_func, "getpgrp()");
4326 #endif
4327 }
4328
4329 PP(pp_setpgrp)
4330 {
4331 #ifdef HAS_SETPGRP
4332     dVAR; dSP; dTARGET;
4333     Pid_t pgrp;
4334     Pid_t pid;
4335     if (MAXARG < 2) {
4336         pgrp = 0;
4337         pid = 0;
4338         XPUSHi(-1);
4339     }
4340     else {
4341         pgrp = POPi;
4342         pid = TOPi;
4343     }
4344
4345     TAINT_PROPER("setpgrp");
4346 #ifdef BSD_SETPGRP
4347     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4348 #else
4349     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4350         || (pid != 0 && pid != PerlProc_getpid()))
4351     {
4352         DIE(aTHX_ "setpgrp can't take arguments");
4353     }
4354     SETi( setpgrp() >= 0 );
4355 #endif /* USE_BSDPGRP */
4356     RETURN;
4357 #else
4358     DIE(aTHX_ PL_no_func, "setpgrp()");
4359 #endif
4360 }
4361
4362 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4363 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4364 #else
4365 #  define PRIORITY_WHICH_T(which) which
4366 #endif
4367
4368 PP(pp_getpriority)
4369 {
4370 #ifdef HAS_GETPRIORITY
4371     dVAR; dSP; dTARGET;
4372     const int who = POPi;
4373     const int which = TOPi;
4374     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4375     RETURN;
4376 #else
4377     DIE(aTHX_ PL_no_func, "getpriority()");
4378 #endif
4379 }
4380
4381 PP(pp_setpriority)
4382 {
4383 #ifdef HAS_SETPRIORITY
4384     dVAR; dSP; dTARGET;
4385     const int niceval = POPi;
4386     const int who = POPi;
4387     const int which = TOPi;
4388     TAINT_PROPER("setpriority");
4389     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4390     RETURN;
4391 #else
4392     DIE(aTHX_ PL_no_func, "setpriority()");
4393 #endif
4394 }
4395
4396 #undef PRIORITY_WHICH_T
4397
4398 /* Time calls. */
4399
4400 PP(pp_time)
4401 {
4402     dVAR; dSP; dTARGET;
4403 #ifdef BIG_TIME
4404     XPUSHn( time(NULL) );
4405 #else
4406     XPUSHi( time(NULL) );
4407 #endif
4408     RETURN;
4409 }
4410
4411 PP(pp_tms)
4412 {
4413 #ifdef HAS_TIMES
4414     dVAR;
4415     dSP;
4416     EXTEND(SP, 4);
4417 #ifndef VMS
4418     (void)PerlProc_times(&PL_timesbuf);
4419 #else
4420     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4421                                                    /* struct tms, though same data   */
4422                                                    /* is returned.                   */
4423 #endif
4424
4425     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4426     if (GIMME == G_ARRAY) {
4427         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4428         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4429         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4430     }
4431     RETURN;
4432 #else
4433 #   ifdef PERL_MICRO
4434     dSP;
4435     mPUSHn(0.0);
4436     EXTEND(SP, 4);
4437     if (GIMME == G_ARRAY) {
4438          mPUSHn(0.0);
4439          mPUSHn(0.0);
4440          mPUSHn(0.0);
4441     }
4442     RETURN;
4443 #   else
4444     DIE(aTHX_ "times not implemented");
4445 #   endif
4446 #endif /* HAS_TIMES */
4447 }
4448
4449 /* The 32 bit int year limits the times we can represent to these
4450    boundaries with a few days wiggle room to account for time zone
4451    offsets
4452 */
4453 /* Sat Jan  3 00:00:00 -2147481748 */
4454 #define TIME_LOWER_BOUND -67768100567755200.0
4455 /* Sun Dec 29 12:00:00  2147483647 */
4456 #define TIME_UPPER_BOUND  67767976233316800.0
4457
4458 PP(pp_gmtime)
4459 {
4460     dVAR;
4461     dSP;
4462     Time64_T when;
4463     struct TM tmbuf;
4464     struct TM *err;
4465     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4466     static const char * const dayname[] =
4467         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4468     static const char * const monname[] =
4469         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4470          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4471
4472     if (MAXARG < 1) {
4473         time_t now;
4474         (void)time(&now);
4475         when = (Time64_T)now;
4476     }
4477     else {
4478         NV input = Perl_floor(POPn);
4479         when = (Time64_T)input;
4480         if (when != input) {
4481             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4482                            "%s(%.0" NVff ") too large", opname, input);
4483         }
4484     }
4485
4486     if ( TIME_LOWER_BOUND > when ) {
4487         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4488                        "%s(%.0" NVff ") too small", opname, when);
4489         err = NULL;
4490     }
4491     else if( when > TIME_UPPER_BOUND ) {
4492         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4493                        "%s(%.0" NVff ") too large", opname, when);
4494         err = NULL;
4495     }
4496     else {
4497         if (PL_op->op_type == OP_LOCALTIME)
4498             err = S_localtime64_r(&when, &tmbuf);
4499         else
4500             err = S_gmtime64_r(&when, &tmbuf);
4501     }
4502
4503     if (err == NULL) {
4504         /* XXX %lld broken for quads */
4505         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4506                        "%s(%.0" NVff ") failed", opname, when);
4507     }
4508
4509     if (GIMME != G_ARRAY) {     /* scalar context */
4510         SV *tsv;
4511         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4512         double year = (double)tmbuf.tm_year + 1900;
4513
4514         EXTEND(SP, 1);
4515         EXTEND_MORTAL(1);
4516         if (err == NULL)
4517             RETPUSHUNDEF;
4518
4519         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4520                             dayname[tmbuf.tm_wday],
4521                             monname[tmbuf.tm_mon],
4522                             tmbuf.tm_mday,
4523                             tmbuf.tm_hour,
4524                             tmbuf.tm_min,
4525                             tmbuf.tm_sec,
4526                             year);
4527         mPUSHs(tsv);
4528     }
4529     else {                      /* list context */
4530         if ( err == NULL )
4531             RETURN;
4532
4533         EXTEND(SP, 9);
4534         EXTEND_MORTAL(9);
4535         mPUSHi(tmbuf.tm_sec);
4536         mPUSHi(tmbuf.tm_min);
4537         mPUSHi(tmbuf.tm_hour);
4538         mPUSHi(tmbuf.tm_mday);
4539         mPUSHi(tmbuf.tm_mon);
4540         mPUSHn(tmbuf.tm_year);
4541         mPUSHi(tmbuf.tm_wday);
4542         mPUSHi(tmbuf.tm_yday);
4543         mPUSHi(tmbuf.tm_isdst);
4544     }
4545     RETURN;
4546 }
4547
4548 PP(pp_alarm)
4549 {
4550 #ifdef HAS_ALARM
4551     dVAR; dSP; dTARGET;
4552     int anum;
4553     anum = POPi;
4554     anum = alarm((unsigned int)anum);
4555     if (anum < 0)
4556         RETPUSHUNDEF;
4557     PUSHi(anum);
4558     RETURN;
4559 #else
4560     DIE(aTHX_ PL_no_func, "alarm");
4561 #endif
4562 }
4563
4564 PP(pp_sleep)
4565 {
4566     dVAR; dSP; dTARGET;
4567     I32 duration;
4568     Time_t lasttime;
4569     Time_t when;
4570
4571     (void)time(&lasttime);
4572     if (MAXARG < 1)
4573         PerlProc_pause();
4574     else {
4575         duration = POPi;
4576         PerlProc_sleep((unsigned int)duration);
4577     }
4578     (void)time(&when);
4579     XPUSHi(when - lasttime);
4580     RETURN;
4581 }
4582
4583 /* Shared memory. */
4584 /* Merged with some message passing. */
4585
4586 PP(pp_shmwrite)
4587 {
4588 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4589     dVAR; dSP; dMARK; dTARGET;
4590     const int op_type = PL_op->op_type;
4591     I32 value;
4592
4593     switch (op_type) {
4594     case OP_MSGSND:
4595         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4596         break;
4597     case OP_MSGRCV:
4598         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4599         break;
4600     case OP_SEMOP:
4601         value = (I32)(do_semop(MARK, SP) >= 0);
4602         break;
4603     default:
4604         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4605         break;
4606     }
4607
4608     SP = MARK;
4609     PUSHi(value);
4610     RETURN;
4611 #else
4612     return Perl_pp_semget(aTHX);
4613 #endif
4614 }
4615
4616 /* Semaphores. */
4617
4618 PP(pp_semget)
4619 {
4620 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4621     dVAR; dSP; dMARK; dTARGET;
4622     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4623     SP = MARK;
4624     if (anum == -1)
4625         RETPUSHUNDEF;
4626     PUSHi(anum);
4627     RETURN;
4628 #else
4629     DIE(aTHX_ "System V IPC is not implemented on this machine");
4630 #endif
4631 }
4632
4633 PP(pp_semctl)
4634 {
4635 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4636     dVAR; dSP; dMARK; dTARGET;
4637     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4638     SP = MARK;
4639     if (anum == -1)
4640         RETSETUNDEF;
4641     if (anum != 0) {
4642         PUSHi(anum);
4643     }
4644     else {
4645         PUSHp(zero_but_true, ZBTLEN);
4646     }
4647     RETURN;
4648 #else
4649     return Perl_pp_semget(aTHX);
4650 #endif
4651 }
4652
4653 /* I can't const this further without getting warnings about the types of
4654    various arrays passed in from structures.  */
4655 static SV *
4656 S_space_join_names_mortal(pTHX_ char *const *array)
4657 {
4658     SV *target;
4659
4660     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4661
4662     if (array && *array) {
4663         target = newSVpvs_flags("", SVs_TEMP);
4664         while (1) {
4665             sv_catpv(target, *array);
4666             if (!*++array)
4667                 break;
4668             sv_catpvs(target, " ");
4669         }
4670     } else {
4671         target = sv_mortalcopy(&PL_sv_no);
4672     }
4673     return target;
4674 }
4675
4676 /* Get system info. */
4677
4678 PP(pp_ghostent)
4679 {
4680 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4681     dVAR; dSP;
4682     I32 which = PL_op->op_type;
4683     register char **elem;
4684     register SV *sv;
4685 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4686     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4687     struct hostent *gethostbyname(Netdb_name_t);
4688     struct hostent *gethostent(void);
4689 #endif
4690     struct hostent *hent = NULL;
4691     unsigned long len;
4692
4693     EXTEND(SP, 10);
4694     if (which == OP_GHBYNAME) {
4695 #ifdef HAS_GETHOSTBYNAME
4696         const char* const name = POPpbytex;
4697         hent = PerlSock_gethostbyname(name);
4698 #else
4699         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4700 #endif
4701     }
4702     else if (which == OP_GHBYADDR) {
4703 #ifdef HAS_GETHOSTBYADDR
4704         const int addrtype = POPi;
4705         SV * const addrsv = POPs;
4706         STRLEN addrlen;
4707         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4708
4709         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4710 #else
4711         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4712 #endif
4713     }
4714     else
4715 #ifdef HAS_GETHOSTENT
4716         hent = PerlSock_gethostent();
4717 #else
4718         DIE(aTHX_ PL_no_sock_func, "gethostent");
4719 #endif
4720
4721 #ifdef HOST_NOT_FOUND
4722         if (!hent) {
4723 #ifdef USE_REENTRANT_API
4724 #   ifdef USE_GETHOSTENT_ERRNO
4725             h_errno = PL_reentrant_buffer->_gethostent_errno;
4726 #   endif
4727 #endif
4728             STATUS_UNIX_SET(h_errno);
4729         }
4730 #endif
4731
4732     if (GIMME != G_ARRAY) {
4733         PUSHs(sv = sv_newmortal());
4734         if (hent) {
4735             if (which == OP_GHBYNAME) {
4736                 if (hent->h_addr)
4737                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4738             }
4739             else
4740                 sv_setpv(sv, (char*)hent->h_name);
4741         }
4742         RETURN;
4743     }
4744
4745     if (hent) {
4746         mPUSHs(newSVpv((char*)hent->h_name, 0));
4747         PUSHs(space_join_names_mortal(hent->h_aliases));
4748         mPUSHi(hent->h_addrtype);
4749         len = hent->h_length;
4750         mPUSHi(len);
4751 #ifdef h_addr
4752         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4753             mXPUSHp(*elem, len);
4754         }
4755 #else
4756         if (hent->h_addr)
4757             mPUSHp(hent->h_addr, len);
4758         else
4759             PUSHs(sv_mortalcopy(&PL_sv_no));
4760 #endif /* h_addr */
4761     }
4762     RETURN;
4763 #else
4764     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4765 #endif
4766 }
4767
4768 PP(pp_gnetent)
4769 {
4770 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4771     dVAR; dSP;
4772     I32 which = PL_op->op_type;
4773     register SV *sv;
4774 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4775     struct netent *getnetbyaddr(Netdb_net_t, int);
4776     struct netent *getnetbyname(Netdb_name_t);
4777     struct netent *getnetent(void);
4778 #endif
4779     struct netent *nent;
4780
4781     if (which == OP_GNBYNAME){
4782 #ifdef HAS_GETNETBYNAME
4783         const char * const name = POPpbytex;
4784         nent = PerlSock_getnetbyname(name);
4785 #else
4786         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4787 #endif
4788     }
4789     else if (which == OP_GNBYADDR) {
4790 #ifdef HAS_GETNETBYADDR
4791         const int addrtype = POPi;
4792         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4793         nent = PerlSock_getnetbyaddr(addr, addrtype);
4794 #else
4795         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4796 #endif
4797     }
4798     else
4799 #ifdef HAS_GETNETENT
4800         nent = PerlSock_getnetent();
4801 #else
4802         DIE(aTHX_ PL_no_sock_func, "getnetent");
4803 #endif
4804
4805 #ifdef HOST_NOT_FOUND
4806         if (!nent) {
4807 #ifdef USE_REENTRANT_API
4808 #   ifdef USE_GETNETENT_ERRNO
4809              h_errno = PL_reentrant_buffer->_getnetent_errno;
4810 #   endif
4811 #endif
4812             STATUS_UNIX_SET(h_errno);
4813         }
4814 #endif
4815
4816     EXTEND(SP, 4);
4817     if (GIMME != G_ARRAY) {
4818         PUSHs(sv = sv_newmortal());
4819         if (nent) {
4820             if (which == OP_GNBYNAME)
4821                 sv_setiv(sv, (IV)nent->n_net);
4822             else
4823                 sv_setpv(sv, nent->n_name);
4824         }
4825         RETURN;
4826     }
4827
4828     if (nent) {
4829         mPUSHs(newSVpv(nent->n_name, 0));
4830         PUSHs(space_join_names_mortal(nent->n_aliases));
4831         mPUSHi(nent->n_addrtype);
4832         mPUSHi(nent->n_net);
4833     }
4834
4835     RETURN;
4836 #else
4837     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4838 #endif
4839 }
4840
4841 PP(pp_gprotoent)
4842 {
4843 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4844     dVAR; dSP;
4845     I32 which = PL_op->op_type;
4846     register SV *sv;
4847 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4848     struct protoent *getprotobyname(Netdb_name_t);
4849     struct protoent *getprotobynumber(int);
4850     struct protoent *getprotoent(void);
4851 #endif
4852     struct protoent *pent;
4853
4854     if (which == OP_GPBYNAME) {
4855 #ifdef HAS_GETPROTOBYNAME
4856         const char* const name = POPpbytex;
4857         pent = PerlSock_getprotobyname(name);
4858 #else
4859         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4860 #endif
4861     }
4862     else if (which == OP_GPBYNUMBER) {
4863 #ifdef HAS_GETPROTOBYNUMBER
4864         const int number = POPi;
4865         pent = PerlSock_getprotobynumber(number);
4866 #else
4867         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4868 #endif
4869     }
4870     else
4871 #ifdef HAS_GETPROTOENT
4872         pent = PerlSock_getprotoent();
4873 #else
4874         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4875 #endif
4876
4877     EXTEND(SP, 3);
4878     if (GIMME != G_ARRAY) {
4879         PUSHs(sv = sv_newmortal());
4880         if (pent) {
4881             if (which == OP_GPBYNAME)
4882                 sv_setiv(sv, (IV)pent->p_proto);
4883             else
4884                 sv_setpv(sv, pent->p_name);
4885         }
4886         RETURN;
4887     }
4888
4889     if (pent) {
4890         mPUSHs(newSVpv(pent->p_name, 0));
4891         PUSHs(space_join_names_mortal(pent->p_aliases));
4892         mPUSHi(pent->p_proto);
4893     }
4894
4895     RETURN;
4896 #else
4897     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4898 #endif
4899 }
4900
4901 PP(pp_gservent)
4902 {
4903 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4904     dVAR; dSP;
4905     I32 which = PL_op->op_type;
4906     register SV *sv;
4907 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4908     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4909     struct servent *getservbyport(int, Netdb_name_t);
4910     struct servent *getservent(void);
4911 #endif
4912     struct servent *sent;
4913
4914     if (which == OP_GSBYNAME) {
4915 #ifdef HAS_GETSERVBYNAME
4916         const char * const proto = POPpbytex;
4917         const char * const name = POPpbytex;
4918         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4919 #else
4920         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4921 #endif
4922     }
4923     else if (which == OP_GSBYPORT) {
4924 #ifdef HAS_GETSERVBYPORT
4925         const char * const proto = POPpbytex;
4926         unsigned short port = (unsigned short)POPu;
4927 #ifdef HAS_HTONS
4928         port = PerlSock_htons(port);
4929 #endif
4930         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4931 #else
4932         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4933 #endif
4934     }
4935     else
4936 #ifdef HAS_GETSERVENT
4937         sent = PerlSock_getservent();
4938 #else
4939         DIE(aTHX_ PL_no_sock_func, "getservent");
4940 #endif
4941
4942     EXTEND(SP, 4);
4943     if (GIMME != G_ARRAY) {
4944         PUSHs(sv = sv_newmortal());
4945         if (sent) {
4946             if (which == OP_GSBYNAME) {
4947 #ifdef HAS_NTOHS
4948                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4949 #else
4950                 sv_setiv(sv, (IV)(sent->s_port));
4951 #endif
4952             }
4953             else
4954                 sv_setpv(sv, sent->s_name);
4955         }
4956         RETURN;
4957     }
4958
4959     if (sent) {
4960         mPUSHs(newSVpv(sent->s_name, 0));
4961         PUSHs(space_join_names_mortal(sent->s_aliases));
4962 #ifdef HAS_NTOHS
4963         mPUSHi(PerlSock_ntohs(sent->s_port));
4964 #else
4965         mPUSHi(sent->s_port);
4966 #endif
4967         mPUSHs(newSVpv(sent->s_proto, 0));
4968     }
4969
4970     RETURN;
4971 #else
4972     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4973 #endif
4974 }
4975
4976 PP(pp_shostent)
4977 {
4978     dVAR; dSP;
4979     const int stayopen = TOPi;
4980     switch(PL_op->op_type) {
4981     case OP_SHOSTENT:
4982 #ifdef HAS_SETHOSTENT
4983         PerlSock_sethostent(stayopen);
4984 #else
4985         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4986 #endif
4987         break;
4988 #ifdef HAS_SETNETENT
4989     case OP_SNETENT:
4990         PerlSock_setnetent(stayopen);
4991 #else
4992         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4993 #endif
4994         break;
4995     case OP_SPROTOENT:
4996 #ifdef HAS_SETPROTOENT
4997         PerlSock_setprotoent(stayopen);
4998 #else
4999         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5000 #endif
5001         break;
5002     case OP_SSERVENT:
5003 #ifdef HAS_SETSERVENT
5004         PerlSock_setservent(stayopen);
5005 #else
5006         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5007 #endif
5008         break;
5009     }
5010     RETSETYES;
5011 }
5012
5013 PP(pp_ehostent)
5014 {
5015     dVAR; dSP;
5016     switch(PL_op->op_type) {
5017     case OP_EHOSTENT:
5018 #ifdef HAS_ENDHOSTENT
5019         PerlSock_endhostent();
5020 #else
5021         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5022 #endif
5023         break;
5024     case OP_ENETENT:
5025 #ifdef HAS_ENDNETENT
5026         PerlSock_endnetent();
5027 #else
5028         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5029 #endif
5030         break;
5031     case OP_EPROTOENT:
5032 #ifdef HAS_ENDPROTOENT
5033         PerlSock_endprotoent();
5034 #else
5035         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5036 #endif
5037         break;
5038     case OP_ESERVENT:
5039 #ifdef HAS_ENDSERVENT
5040         PerlSock_endservent();
5041 #else
5042         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5043 #endif
5044         break;
5045     case OP_SGRENT:
5046 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5047         setgrent();
5048 #else
5049         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5050 #endif
5051         break;
5052     case OP_EGRENT:
5053 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5054         endgrent();
5055 #else
5056         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5057 #endif
5058         break;
5059     case OP_SPWENT:
5060 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5061         setpwent();
5062 #else
5063         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5064 #endif
5065         break;
5066     case OP_EPWENT:
5067 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5068         endpwent();
5069 #else
5070         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5071 #endif
5072         break;
5073     }
5074     EXTEND(SP,1);
5075     RETPUSHYES;
5076 }
5077
5078 PP(pp_gpwent)
5079 {
5080 #ifdef HAS_PASSWD
5081     dVAR; dSP;
5082     I32 which = PL_op->op_type;
5083     register SV *sv;
5084     struct passwd *pwent  = NULL;
5085     /*
5086      * We currently support only the SysV getsp* shadow password interface.
5087      * The interface is declared in <shadow.h> and often one needs to link
5088      * with -lsecurity or some such.
5089      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5090      * (and SCO?)
5091      *
5092      * AIX getpwnam() is clever enough to return the encrypted password
5093      * only if the caller (euid?) is root.
5094      *
5095      * There are at least three other shadow password APIs.  Many platforms
5096      * seem to contain more than one interface for accessing the shadow
5097      * password databases, possibly for compatibility reasons.
5098      * The getsp*() is by far he simplest one, the other two interfaces
5099      * are much more complicated, but also very similar to each other.
5100      *
5101      * <sys/types.h>
5102      * <sys/security.h>
5103      * <prot.h>
5104      * struct pr_passwd *getprpw*();
5105      * The password is in
5106      * char getprpw*(...).ufld.fd_encrypt[]
5107      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5108      *
5109      * <sys/types.h>
5110      * <sys/security.h>
5111      * <prot.h>
5112      * struct es_passwd *getespw*();
5113      * The password is in
5114      * char *(getespw*(...).ufld.fd_encrypt)
5115      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5116      *
5117      * <userpw.h> (AIX)
5118      * struct userpw *getuserpw();
5119      * The password is in
5120      * char *(getuserpw(...)).spw_upw_passwd
5121      * (but the de facto standard getpwnam() should work okay)
5122      *
5123      * Mention I_PROT here so that Configure probes for it.
5124      *
5125      * In HP-UX for getprpw*() the manual page claims that one should include
5126      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5127      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5128      * and pp_sys.c already includes <shadow.h> if there is such.
5129      *
5130      * Note that <sys/security.h> is already probed for, but currently
5131      * it is only included in special cases.
5132      *
5133      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5134      * be preferred interface, even though also the getprpw*() interface
5135      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5136      * One also needs to call set_auth_parameters() in main() before
5137      * doing anything else, whether one is using getespw*() or getprpw*().
5138      *
5139      * Note that accessing the shadow databases can be magnitudes
5140      * slower than accessing the standard databases.
5141      *
5142      * --jhi
5143      */
5144
5145 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5146     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5147      * the pw_comment is left uninitialized. */
5148     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5149 #   endif
5150
5151     switch (which) {
5152     case OP_GPWNAM:
5153       {
5154         const char* const name = POPpbytex;
5155         pwent  = getpwnam(name);
5156       }
5157       break;
5158     case OP_GPWUID:
5159       {
5160         Uid_t uid = POPi;
5161         pwent = getpwuid(uid);
5162       }
5163         break;
5164     case OP_GPWENT:
5165 #   ifdef HAS_GETPWENT
5166         pwent  = getpwent();
5167 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5168         if (pwent) pwent = getpwnam(pwent->pw_name);
5169 #endif
5170 #   else
5171         DIE(aTHX_ PL_no_func, "getpwent");
5172 #   endif
5173         break;
5174     }
5175
5176     EXTEND(SP, 10);
5177     if (GIMME != G_ARRAY) {
5178         PUSHs(sv = sv_newmortal());
5179         if (pwent) {
5180             if (which == OP_GPWNAM)
5181 #   if Uid_t_sign <= 0
5182                 sv_setiv(sv, (IV)pwent->pw_uid);
5183 #   else
5184                 sv_setuv(sv, (UV)pwent->pw_uid);
5185 #   endif
5186             else
5187                 sv_setpv(sv, pwent->pw_name);
5188         }
5189         RETURN;
5190     }
5191
5192     if (pwent) {
5193         mPUSHs(newSVpv(pwent->pw_name, 0));
5194
5195         sv = newSViv(0);
5196         mPUSHs(sv);
5197         /* If we have getspnam(), we try to dig up the shadow
5198          * password.  If we are underprivileged, the shadow
5199          * interface will set the errno to EACCES or similar,
5200          * and return a null pointer.  If this happens, we will
5201          * use the dummy password (usually "*" or "x") from the
5202          * standard password database.
5203          *
5204          * In theory we could skip the shadow call completely
5205          * if euid != 0 but in practice we cannot know which
5206          * security measures are guarding the shadow databases
5207          * on a random platform.
5208          *
5209          * Resist the urge to use additional shadow interfaces.
5210          * Divert the urge to writing an extension instead.
5211          *
5212          * --jhi */
5213         /* Some AIX setups falsely(?) detect some getspnam(), which
5214          * has a different API than the Solaris/IRIX one. */
5215 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5216         {
5217             dSAVE_ERRNO;
5218             const struct spwd * const spwent = getspnam(pwent->pw_name);
5219                           /* Save and restore errno so that
5220                            * underprivileged attempts seem
5221                            * to have never made the unsuccessful
5222                            * attempt to retrieve the shadow password. */
5223             RESTORE_ERRNO;
5224             if (spwent && spwent->sp_pwdp)
5225                 sv_setpv(sv, spwent->sp_pwdp);
5226         }
5227 #   endif
5228 #   ifdef PWPASSWD
5229         if (!SvPOK(sv)) /* Use the standard password, then. */
5230             sv_setpv(sv, pwent->pw_passwd);
5231 #   endif
5232
5233 #   ifndef INCOMPLETE_TAINTS
5234         /* passwd is tainted because user himself can diddle with it.
5235          * admittedly not much and in a very limited way, but nevertheless. */
5236         SvTAINTED_on(sv);
5237 #   endif
5238
5239 #   if Uid_t_sign <= 0
5240         mPUSHi(pwent->pw_uid);
5241 #   else
5242         mPUSHu(pwent->pw_uid);
5243 #   endif
5244
5245 #   if Uid_t_sign <= 0
5246         mPUSHi(pwent->pw_gid);
5247 #   else
5248         mPUSHu(pwent->pw_gid);
5249 #   endif
5250         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5251          * because of the poor interface of the Perl getpw*(),
5252          * not because there's some standard/convention saying so.
5253          * A better interface would have been to return a hash,
5254          * but we are accursed by our history, alas. --jhi.  */
5255 #   ifdef PWCHANGE
5256         mPUSHi(pwent->pw_change);
5257 #   else
5258 #       ifdef PWQUOTA
5259         mPUSHi(pwent->pw_quota);
5260 #       else
5261 #           ifdef PWAGE
5262         mPUSHs(newSVpv(pwent->pw_age, 0));
5263 #           else
5264         /* I think that you can never get this compiled, but just in case.  */
5265         PUSHs(sv_mortalcopy(&PL_sv_no));
5266 #           endif
5267 #       endif
5268 #   endif
5269
5270         /* pw_class and pw_comment are mutually exclusive--.
5271          * see the above note for pw_change, pw_quota, and pw_age. */
5272 #   ifdef PWCLASS
5273         mPUSHs(newSVpv(pwent->pw_class, 0));
5274 #   else
5275 #       ifdef PWCOMMENT
5276         mPUSHs(newSVpv(pwent->pw_comment, 0));
5277 #       else
5278         /* I think that you can never get this compiled, but just in case.  */
5279         PUSHs(sv_mortalcopy(&PL_sv_no));
5280 #       endif
5281 #   endif
5282
5283 #   ifdef PWGECOS
5284         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5285 #   else
5286         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5287 #   endif
5288 #   ifndef INCOMPLETE_TAINTS
5289         /* pw_gecos is tainted because user himself can diddle with it. */
5290         SvTAINTED_on(sv);
5291 #   endif
5292
5293         mPUSHs(newSVpv(pwent->pw_dir, 0));
5294
5295         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5296 #   ifndef INCOMPLETE_TAINTS
5297         /* pw_shell is tainted because user himself can diddle with it. */
5298         SvTAINTED_on(sv);
5299 #   endif
5300
5301 #   ifdef PWEXPIRE
5302         mPUSHi(pwent->pw_expire);
5303 #   endif
5304     }
5305     RETURN;
5306 #else
5307     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5308 #endif
5309 }
5310
5311 PP(pp_ggrent)
5312 {
5313 #ifdef HAS_GROUP
5314     dVAR; dSP;
5315     const I32 which = PL_op->op_type;
5316     const struct group *grent;
5317
5318     if (which == OP_GGRNAM) {
5319         const char* const name = POPpbytex;
5320         grent = (const struct group *)getgrnam(name);
5321     }
5322     else if (which == OP_GGRGID) {
5323         const Gid_t gid = POPi;
5324         grent = (const struct group *)getgrgid(gid);
5325     }
5326     else
5327 #ifdef HAS_GETGRENT
5328         grent = (struct group *)getgrent();
5329 #else
5330         DIE(aTHX_ PL_no_func, "getgrent");
5331 #endif
5332
5333     EXTEND(SP, 4);
5334     if (GIMME != G_ARRAY) {
5335         SV * const sv = sv_newmortal();
5336
5337         PUSHs(sv);
5338         if (grent) {
5339             if (which == OP_GGRNAM)
5340 #if Gid_t_sign <= 0
5341                 sv_setiv(sv, (IV)grent->gr_gid);
5342 #else
5343                 sv_setuv(sv, (UV)grent->gr_gid);
5344 #endif
5345             else
5346                 sv_setpv(sv, grent->gr_name);
5347         }
5348         RETURN;
5349     }
5350
5351     if (grent) {
5352         mPUSHs(newSVpv(grent->gr_name, 0));
5353
5354 #ifdef GRPASSWD
5355         mPUSHs(newSVpv(grent->gr_passwd, 0));
5356 #else
5357         PUSHs(sv_mortalcopy(&PL_sv_no));
5358 #endif
5359
5360 #if Gid_t_sign <= 0
5361         mPUSHi(grent->gr_gid);
5362 #else
5363         mPUSHu(grent->gr_gid);
5364 #endif
5365
5366 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5367         /* In UNICOS/mk (_CRAYMPP) the multithreading
5368          * versions (getgrnam_r, getgrgid_r)
5369          * seem to return an illegal pointer
5370          * as the group members list, gr_mem.
5371          * getgrent() doesn't even have a _r version
5372          * but the gr_mem is poisonous anyway.
5373          * So yes, you cannot get the list of group
5374          * members if building multithreaded in UNICOS/mk. */
5375         PUSHs(space_join_names_mortal(grent->gr_mem));
5376 #endif
5377     }
5378
5379     RETURN;
5380 #else
5381     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5382 #endif
5383 }
5384
5385 PP(pp_getlogin)
5386 {
5387 #ifdef HAS_GETLOGIN
5388     dVAR; dSP; dTARGET;
5389     char *tmps;
5390     EXTEND(SP, 1);
5391     if (!(tmps = PerlProc_getlogin()))
5392         RETPUSHUNDEF;
5393     sv_setpv_mg(TARG, tmps);
5394     PUSHs(TARG);
5395     RETURN;
5396 #else
5397     DIE(aTHX_ PL_no_func, "getlogin");
5398 #endif
5399 }
5400
5401 /* Miscellaneous. */
5402
5403 PP(pp_syscall)
5404 {
5405 #ifdef HAS_SYSCALL
5406     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5407     register I32 items = SP - MARK;
5408     unsigned long a[20];
5409     register I32 i = 0;
5410     I32 retval = -1;
5411
5412     if (PL_tainting) {
5413         while (++MARK <= SP) {
5414             if (SvTAINTED(*MARK)) {
5415                 TAINT;
5416                 break;
5417             }
5418         }
5419         MARK = ORIGMARK;
5420         TAINT_PROPER("syscall");
5421     }
5422
5423     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5424      * or where sizeof(long) != sizeof(char*).  But such machines will
5425      * not likely have syscall implemented either, so who cares?
5426      */
5427     while (++MARK <= SP) {
5428         if (SvNIOK(*MARK) || !i)
5429             a[i++] = SvIV(*MARK);
5430         else if (*MARK == &PL_sv_undef)
5431             a[i++] = 0;
5432         else
5433             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5434         if (i > 15)
5435             break;
5436     }
5437     switch (items) {
5438     default:
5439         DIE(aTHX_ "Too many args to syscall");
5440     case 0:
5441         DIE(aTHX_ "Too few args to syscall");
5442     case 1:
5443         retval = syscall(a[0]);
5444         break;
5445     case 2:
5446         retval = syscall(a[0],a[1]);
5447         break;
5448     case 3:
5449         retval = syscall(a[0],a[1],a[2]);
5450         break;
5451     case 4:
5452         retval = syscall(a[0],a[1],a[2],a[3]);
5453         break;
5454     case 5:
5455         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5456         break;
5457     case 6:
5458         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5459         break;
5460     case 7:
5461         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5462         break;
5463     case 8:
5464         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5465         break;
5466 #ifdef atarist
5467     case 9:
5468         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5469         break;
5470     case 10:
5471         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5472         break;
5473     case 11:
5474         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5475           a[10]);
5476         break;
5477     case 12:
5478         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5479           a[10],a[11]);
5480         break;
5481     case 13:
5482         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5483           a[10],a[11],a[12]);
5484         break;
5485     case 14:
5486         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5487           a[10],a[11],a[12],a[13]);
5488         break;
5489 #endif /* atarist */
5490     }
5491     SP = ORIGMARK;
5492     PUSHi(retval);
5493     RETURN;
5494 #else
5495     DIE(aTHX_ PL_no_func, "syscall");
5496 #endif
5497 }
5498
5499 #ifdef FCNTL_EMULATE_FLOCK
5500
5501 /*  XXX Emulate flock() with fcntl().
5502     What's really needed is a good file locking module.
5503 */
5504
5505 static int
5506 fcntl_emulate_flock(int fd, int operation)
5507 {
5508     int res;
5509     struct flock flock;
5510
5511     switch (operation & ~LOCK_NB) {
5512     case LOCK_SH:
5513         flock.l_type = F_RDLCK;
5514         break;
5515     case LOCK_EX:
5516         flock.l_type = F_WRLCK;
5517         break;
5518     case LOCK_UN:
5519         flock.l_type = F_UNLCK;
5520         break;
5521     default:
5522         errno = EINVAL;
5523         return -1;
5524     }
5525     flock.l_whence = SEEK_SET;
5526     flock.l_start = flock.l_len = (Off_t)0;
5527
5528     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5529     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5530         errno = EWOULDBLOCK;
5531     return res;
5532 }
5533
5534 #endif /* FCNTL_EMULATE_FLOCK */
5535
5536 #ifdef LOCKF_EMULATE_FLOCK
5537
5538 /*  XXX Emulate flock() with lockf().  This is just to increase
5539     portability of scripts.  The calls are not completely
5540     interchangeable.  What's really needed is a good file
5541     locking module.
5542 */
5543
5544 /*  The lockf() constants might have been defined in <unistd.h>.
5545     Unfortunately, <unistd.h> causes troubles on some mixed
5546     (BSD/POSIX) systems, such as SunOS 4.1.3.
5547
5548    Further, the lockf() constants aren't POSIX, so they might not be
5549    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5550    just stick in the SVID values and be done with it.  Sigh.
5551 */
5552
5553 # ifndef F_ULOCK
5554 #  define F_ULOCK       0       /* Unlock a previously locked region */
5555 # endif
5556 # ifndef F_LOCK
5557 #  define F_LOCK        1       /* Lock a region for exclusive use */
5558 # endif
5559 # ifndef F_TLOCK
5560 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5561 # endif
5562 # ifndef F_TEST
5563 #  define F_TEST        3       /* Test a region for other processes locks */
5564 # endif
5565
5566 static int
5567 lockf_emulate_flock(int fd, int operation)
5568 {
5569     int i;
5570     Off_t pos;
5571     dSAVE_ERRNO;
5572
5573     /* flock locks entire file so for lockf we need to do the same      */
5574     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5575     if (pos > 0)        /* is seekable and needs to be repositioned     */
5576         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5577             pos = -1;   /* seek failed, so don't seek back afterwards   */
5578     RESTORE_ERRNO;
5579
5580     switch (operation) {
5581
5582         /* LOCK_SH - get a shared lock */
5583         case LOCK_SH:
5584         /* LOCK_EX - get an exclusive lock */
5585         case LOCK_EX:
5586             i = lockf (fd, F_LOCK, 0);
5587             break;
5588
5589         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5590         case LOCK_SH|LOCK_NB:
5591         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5592         case LOCK_EX|LOCK_NB:
5593             i = lockf (fd, F_TLOCK, 0);
5594             if (i == -1)
5595                 if ((errno == EAGAIN) || (errno == EACCES))
5596                     errno = EWOULDBLOCK;
5597             break;
5598
5599         /* LOCK_UN - unlock (non-blocking is a no-op) */
5600         case LOCK_UN:
5601         case LOCK_UN|LOCK_NB:
5602             i = lockf (fd, F_ULOCK, 0);
5603             break;
5604
5605         /* Default - can't decipher operation */
5606         default:
5607             i = -1;
5608             errno = EINVAL;
5609             break;
5610     }
5611
5612     if (pos > 0)      /* need to restore position of the handle */
5613         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5614
5615     return (i);
5616 }
5617
5618 #endif /* LOCKF_EMULATE_FLOCK */
5619
5620 /*
5621  * Local variables:
5622  * c-indentation-style: bsd
5623  * c-basic-offset: 4
5624  * indent-tabs-mode: t
5625  * End:
5626  *
5627  * ex: set ts=8 sts=4 sw=4 noet:
5628  */