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