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