pp_sys.c

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