pp_sys.c

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