pp_sys.c

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