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