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