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