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