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