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