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 defined(OEMVS)
2561     if (len == 0) {
2562         /* Some platforms indicate zero length when an AF_UNIX client is
2563          * not bound. Simulate a non-zero-length sockaddr structure in
2564          * this case. */
2565         namebuf[0] = 0;        /* sun_len */
2566         namebuf[1] = AF_UNIX;  /* sun_family */
2567         len = 2;
2568     }
2569 #endif
2570
2571     if (fd < 0)
2572         goto badexit;
2573     if (IoIFP(nstio))
2574         do_close(ngv, FALSE);
2575     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2576     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2577     IoTYPE(nstio) = IoTYPE_SOCKET;
2578     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2579         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2580         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2581         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2582         goto badexit;
2583     }
2584 #if defined(HAS_FCNTL) && defined(F_SETFD)
2585     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2586 #endif
2587
2588 #ifdef EPOC
2589     len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2590     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2591 #endif
2592 #ifdef __SCO_VERSION__
2593     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2594 #endif
2595
2596     PUSHp(namebuf, len);
2597     RETURN;
2598
2599 nuts:
2600     if (ckWARN(WARN_CLOSED))
2601         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2602     SETERRNO(EBADF,SS_IVCHAN);
2603
2604 badexit:
2605     RETPUSHUNDEF;
2606
2607 #else
2608     DIE(aTHX_ PL_no_sock_func, "accept");
2609 #endif
2610 }
2611
2612 PP(pp_shutdown)
2613 {
2614 #ifdef HAS_SOCKET
2615     dVAR; dSP; dTARGET;
2616     const int how = POPi;
2617     GV * const gv = (GV*)POPs;
2618     register IO * const io = GvIOn(gv);
2619
2620     if (!io || !IoIFP(io))
2621         goto nuts;
2622
2623     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2624     RETURN;
2625
2626 nuts:
2627     if (ckWARN(WARN_CLOSED))
2628         report_evil_fh(gv, io, PL_op->op_type);
2629     SETERRNO(EBADF,SS_IVCHAN);
2630     RETPUSHUNDEF;
2631 #else
2632     DIE(aTHX_ PL_no_sock_func, "shutdown");
2633 #endif
2634 }
2635
2636 PP(pp_ssockopt)
2637 {
2638 #ifdef HAS_SOCKET
2639     dVAR; dSP;
2640     const int optype = PL_op->op_type;
2641     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2642     const unsigned int optname = (unsigned int) POPi;
2643     const unsigned int lvl = (unsigned int) POPi;
2644     GV * const gv = (GV*)POPs;
2645     register IO * const io = GvIOn(gv);
2646     int fd;
2647     Sock_size_t len;
2648
2649     if (!io || !IoIFP(io))
2650         goto nuts;
2651
2652     fd = PerlIO_fileno(IoIFP(io));
2653     switch (optype) {
2654     case OP_GSOCKOPT:
2655         SvGROW(sv, 257);
2656         (void)SvPOK_only(sv);
2657         SvCUR_set(sv,256);
2658         *SvEND(sv) ='\0';
2659         len = SvCUR(sv);
2660         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2661             goto nuts2;
2662         SvCUR_set(sv, len);
2663         *SvEND(sv) ='\0';
2664         PUSHs(sv);
2665         break;
2666     case OP_SSOCKOPT: {
2667 #if defined(__SYMBIAN32__)
2668 # define SETSOCKOPT_OPTION_VALUE_T void *
2669 #else
2670 # define SETSOCKOPT_OPTION_VALUE_T const char *
2671 #endif
2672         /* XXX TODO: We need to have a proper type (a Configure probe,
2673          * etc.) for what the C headers think of the third argument of
2674          * setsockopt(), the option_value read-only buffer: is it
2675          * a "char *", or a "void *", const or not.  Some compilers
2676          * don't take kindly to e.g. assuming that "char *" implicitly
2677          * promotes to a "void *", or to explicitly promoting/demoting
2678          * consts to non/vice versa.  The "const void *" is the SUS
2679          * definition, but that does not fly everywhere for the above
2680          * reasons. */
2681             SETSOCKOPT_OPTION_VALUE_T buf;
2682             int aint;
2683             if (SvPOKp(sv)) {
2684                 STRLEN l;
2685                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2686                 len = l;
2687             }
2688             else {
2689                 aint = (int)SvIV(sv);
2690                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2691                 len = sizeof(int);
2692             }
2693             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2694                 goto nuts2;
2695             PUSHs(&PL_sv_yes);
2696         }
2697         break;
2698     }
2699     RETURN;
2700
2701 nuts:
2702     if (ckWARN(WARN_CLOSED))
2703         report_evil_fh(gv, io, optype);
2704     SETERRNO(EBADF,SS_IVCHAN);
2705 nuts2:
2706     RETPUSHUNDEF;
2707
2708 #else
2709     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2710 #endif
2711 }
2712
2713 PP(pp_getpeername)
2714 {
2715 #ifdef HAS_SOCKET
2716     dVAR; dSP;
2717     const int optype = PL_op->op_type;
2718     GV * const gv = (GV*)POPs;
2719     register IO * const io = GvIOn(gv);
2720     Sock_size_t len;
2721     SV *sv;
2722     int fd;
2723
2724     if (!io || !IoIFP(io))
2725         goto nuts;
2726
2727     sv = sv_2mortal(newSV(257));
2728     (void)SvPOK_only(sv);
2729     len = 256;
2730     SvCUR_set(sv, len);
2731     *SvEND(sv) ='\0';
2732     fd = PerlIO_fileno(IoIFP(io));
2733     switch (optype) {
2734     case OP_GETSOCKNAME:
2735         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2736             goto nuts2;
2737         break;
2738     case OP_GETPEERNAME:
2739         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2740             goto nuts2;
2741 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2742         {
2743             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";
2744             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2745             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2746                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2747                         sizeof(u_short) + sizeof(struct in_addr))) {
2748                 goto nuts2;
2749             }
2750         }
2751 #endif
2752         break;
2753     }
2754 #ifdef BOGUS_GETNAME_RETURN
2755     /* Interactive Unix, getpeername() and getsockname()
2756       does not return valid namelen */
2757     if (len == BOGUS_GETNAME_RETURN)
2758         len = sizeof(struct sockaddr);
2759 #endif
2760     SvCUR_set(sv, len);
2761     *SvEND(sv) ='\0';
2762     PUSHs(sv);
2763     RETURN;
2764
2765 nuts:
2766     if (ckWARN(WARN_CLOSED))
2767         report_evil_fh(gv, io, optype);
2768     SETERRNO(EBADF,SS_IVCHAN);
2769 nuts2:
2770     RETPUSHUNDEF;
2771
2772 #else
2773     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2774 #endif
2775 }
2776
2777 /* Stat calls. */
2778
2779 PP(pp_stat)
2780 {
2781     dVAR;
2782     dSP;
2783     GV *gv;
2784     IO *io;
2785     I32 gimme;
2786     I32 max = 13;
2787
2788     if (PL_op->op_flags & OPf_REF) {
2789         gv = cGVOP_gv;
2790         if (PL_op->op_type == OP_LSTAT) {
2791             if (gv != PL_defgv) {
2792             do_fstat_warning_check:
2793                 if (ckWARN(WARN_IO))
2794                     Perl_warner(aTHX_ packWARN(WARN_IO),
2795                         "lstat() on filehandle %s", GvENAME(gv));
2796             } else if (PL_laststype != OP_LSTAT)
2797                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2798         }
2799
2800       do_fstat:
2801         if (gv != PL_defgv) {
2802             PL_laststype = OP_STAT;
2803             PL_statgv = gv;
2804             sv_setpvn(PL_statname, "", 0);
2805             if(gv) {
2806                 io = GvIO(gv);
2807                 do_fstat_have_io:
2808                 if (io) {
2809                     if (IoIFP(io)) {
2810                         PL_laststatval =
2811                             PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2812                     } else if (IoDIRP(io)) {
2813 #ifdef HAS_DIRFD
2814                         PL_laststatval =
2815                             PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2816 #else
2817                         DIE(aTHX_ PL_no_func, "dirfd");
2818 #endif
2819                     } else {
2820                         PL_laststatval = -1;
2821                     }
2822                 }
2823             }
2824         }
2825
2826         if (PL_laststatval < 0) {
2827             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2828                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2829             max = 0;
2830         }
2831     }
2832     else {
2833         SV* const sv = POPs;
2834         if (SvTYPE(sv) == SVt_PVGV) {
2835             gv = (GV*)sv;
2836             goto do_fstat;
2837         } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2838             gv = (GV*)SvRV(sv);
2839             if (PL_op->op_type == OP_LSTAT)
2840                 goto do_fstat_warning_check;
2841             goto do_fstat;
2842         } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2843             io = (IO*)SvRV(sv);
2844             if (PL_op->op_type == OP_LSTAT)
2845                 goto do_fstat_warning_check;
2846             goto do_fstat_have_io;
2847         }
2848
2849         sv_setpv(PL_statname, SvPV_nolen_const(sv));
2850         PL_statgv = NULL;
2851         PL_laststype = PL_op->op_type;
2852         if (PL_op->op_type == OP_LSTAT)
2853             PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2854         else
2855             PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2856         if (PL_laststatval < 0) {
2857             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2858                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2859             max = 0;
2860         }
2861     }
2862
2863     gimme = GIMME_V;
2864     if (gimme != G_ARRAY) {
2865         if (gimme != G_VOID)
2866             XPUSHs(boolSV(max));
2867         RETURN;
2868     }
2869     if (max) {
2870         EXTEND(SP, max);
2871         EXTEND_MORTAL(max);
2872         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2873         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2874         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2875         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2876 #if Uid_t_size > IVSIZE
2877         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2878 #else
2879 #   if Uid_t_sign <= 0
2880         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2881 #   else
2882         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2883 #   endif
2884 #endif
2885 #if Gid_t_size > IVSIZE
2886         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2887 #else
2888 #   if Gid_t_sign <= 0
2889         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2890 #   else
2891         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2892 #   endif
2893 #endif
2894 #ifdef USE_STAT_RDEV
2895         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2896 #else
2897         PUSHs(sv_2mortal(newSVpvs("")));
2898 #endif
2899 #if Off_t_size > IVSIZE
2900         PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2901 #else
2902         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2903 #endif
2904 #ifdef BIG_TIME
2905         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2906         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2907         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2908 #else
2909         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2910         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2911         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2912 #endif
2913 #ifdef USE_STAT_BLOCKS
2914         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2915         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2916 #else
2917         PUSHs(sv_2mortal(newSVpvs("")));
2918         PUSHs(sv_2mortal(newSVpvs("")));
2919 #endif
2920     }
2921     RETURN;
2922 }
2923
2924 /* This macro is used by the stacked filetest operators :
2925  * if the previous filetest failed, short-circuit and pass its value.
2926  * Else, discard it from the stack and continue. --rgs
2927  */
2928 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2929         if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2930         else { (void)POPs; PUTBACK; } \
2931     }
2932
2933 PP(pp_ftrread)
2934 {
2935     dVAR;
2936     I32 result;
2937     /* Not const, because things tweak this below. Not bool, because there's
2938        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2939 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2940     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2941     /* Giving some sort of initial value silences compilers.  */
2942 #  ifdef R_OK
2943     int access_mode = R_OK;
2944 #  else
2945     int access_mode = 0;
2946 #  endif
2947 #else
2948     /* access_mode is never used, but leaving use_access in makes the
2949        conditional compiling below much clearer.  */
2950     I32 use_access = 0;
2951 #endif
2952     int stat_mode = S_IRUSR;
2953
2954     bool effective = FALSE;
2955     dSP;
2956
2957     STACKED_FTEST_CHECK;
2958
2959     switch (PL_op->op_type) {
2960     case OP_FTRREAD:
2961 #if !(defined(HAS_ACCESS) && defined(R_OK))
2962         use_access = 0;
2963 #endif
2964         break;
2965
2966     case OP_FTRWRITE:
2967 #if defined(HAS_ACCESS) && defined(W_OK)
2968         access_mode = W_OK;
2969 #else
2970         use_access = 0;
2971 #endif
2972         stat_mode = S_IWUSR;
2973         break;
2974
2975     case OP_FTREXEC:
2976 #if defined(HAS_ACCESS) && defined(X_OK)
2977         access_mode = X_OK;
2978 #else
2979         use_access = 0;
2980 #endif
2981         stat_mode = S_IXUSR;
2982         break;
2983
2984     case OP_FTEWRITE:
2985 #ifdef PERL_EFF_ACCESS
2986         access_mode = W_OK;
2987 #endif
2988         stat_mode = S_IWUSR;
2989         /* Fall through  */
2990
2991     case OP_FTEREAD:
2992 #ifndef PERL_EFF_ACCESS
2993         use_access = 0;
2994 #endif
2995         effective = TRUE;
2996         break;
2997
2998
2999     case OP_FTEEXEC:
3000 #ifdef PERL_EFF_ACCESS
3001         access_mode = W_OK;
3002 #else
3003         use_access = 0;
3004 #endif
3005         stat_mode = S_IXUSR;
3006         effective = TRUE;
3007         break;
3008     }
3009
3010     if (use_access) {
3011 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3012         const char *const name = POPpx;
3013         if (effective) {
3014 #  ifdef PERL_EFF_ACCESS
3015             result = PERL_EFF_ACCESS(name, access_mode);
3016 #  else
3017             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3018                 OP_NAME(PL_op));
3019 #  endif
3020         }
3021         else {
3022 #  ifdef HAS_ACCESS
3023             result = access(name, access_mode);
3024 #  else
3025             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3026 #  endif
3027         }
3028         if (result == 0)
3029             RETPUSHYES;
3030         if (result < 0)
3031             RETPUSHUNDEF;
3032         RETPUSHNO;
3033 #endif
3034     }
3035
3036     result = my_stat();
3037     SPAGAIN;
3038     if (result < 0)
3039         RETPUSHUNDEF;
3040     if (cando(stat_mode, effective, &PL_statcache))
3041         RETPUSHYES;
3042     RETPUSHNO;
3043 }
3044
3045 PP(pp_ftis)
3046 {
3047     dVAR;
3048     I32 result;
3049     const int op_type = PL_op->op_type;
3050     dSP;
3051     STACKED_FTEST_CHECK;
3052     result = my_stat();
3053     SPAGAIN;
3054     if (result < 0)
3055         RETPUSHUNDEF;
3056     if (op_type == OP_FTIS)
3057         RETPUSHYES;
3058     {
3059         /* You can't dTARGET inside OP_FTIS, because you'll get
3060            "panic: pad_sv po" - the op is not flagged to have a target.  */
3061         dTARGET;
3062         switch (op_type) {
3063         case OP_FTSIZE:
3064 #if Off_t_size > IVSIZE
3065             PUSHn(PL_statcache.st_size);
3066 #else
3067             PUSHi(PL_statcache.st_size);
3068 #endif
3069             break;
3070         case OP_FTMTIME:
3071             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3072             break;
3073         case OP_FTATIME:
3074             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3075             break;
3076         case OP_FTCTIME:
3077             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3078             break;
3079         }
3080     }
3081     RETURN;
3082 }
3083
3084 PP(pp_ftrowned)
3085 {
3086     dVAR;
3087     I32 result;
3088     dSP;
3089
3090     /* I believe that all these three are likely to be defined on most every
3091        system these days.  */
3092 #ifndef S_ISUID
3093     if(PL_op->op_type == OP_FTSUID)
3094         RETPUSHNO;
3095 #endif
3096 #ifndef S_ISGID
3097     if(PL_op->op_type == OP_FTSGID)
3098         RETPUSHNO;
3099 #endif
3100 #ifndef S_ISVTX
3101     if(PL_op->op_type == OP_FTSVTX)
3102         RETPUSHNO;
3103 #endif
3104
3105     STACKED_FTEST_CHECK;
3106     result = my_stat();
3107     SPAGAIN;
3108     if (result < 0)
3109         RETPUSHUNDEF;
3110     switch (PL_op->op_type) {
3111     case OP_FTROWNED:
3112         if (PL_statcache.st_uid == PL_uid)
3113             RETPUSHYES;
3114         break;
3115     case OP_FTEOWNED:
3116         if (PL_statcache.st_uid == PL_euid)
3117             RETPUSHYES;
3118         break;
3119     case OP_FTZERO:
3120         if (PL_statcache.st_size == 0)
3121             RETPUSHYES;
3122         break;
3123     case OP_FTSOCK:
3124         if (S_ISSOCK(PL_statcache.st_mode))
3125             RETPUSHYES;
3126         break;
3127     case OP_FTCHR:
3128         if (S_ISCHR(PL_statcache.st_mode))
3129             RETPUSHYES;
3130         break;
3131     case OP_FTBLK:
3132         if (S_ISBLK(PL_statcache.st_mode))
3133             RETPUSHYES;
3134         break;
3135     case OP_FTFILE:
3136         if (S_ISREG(PL_statcache.st_mode))
3137             RETPUSHYES;
3138         break;
3139     case OP_FTDIR:
3140         if (S_ISDIR(PL_statcache.st_mode))
3141             RETPUSHYES;
3142         break;
3143     case OP_FTPIPE:
3144         if (S_ISFIFO(PL_statcache.st_mode))
3145             RETPUSHYES;
3146         break;
3147 #ifdef S_ISUID
3148     case OP_FTSUID:
3149         if (PL_statcache.st_mode & S_ISUID)
3150             RETPUSHYES;
3151         break;
3152 #endif
3153 #ifdef S_ISGID
3154     case OP_FTSGID:
3155         if (PL_statcache.st_mode & S_ISGID)
3156             RETPUSHYES;
3157         break;
3158 #endif
3159 #ifdef S_ISVTX
3160     case OP_FTSVTX:
3161         if (PL_statcache.st_mode & S_ISVTX)
3162             RETPUSHYES;
3163         break;
3164 #endif
3165     }
3166     RETPUSHNO;
3167 }
3168
3169 PP(pp_ftlink)
3170 {
3171     dVAR;
3172     I32 result = my_lstat();
3173     dSP;
3174     if (result < 0)
3175         RETPUSHUNDEF;
3176     if (S_ISLNK(PL_statcache.st_mode))
3177         RETPUSHYES;
3178     RETPUSHNO;
3179 }
3180
3181 PP(pp_fttty)
3182 {
3183     dVAR;
3184     dSP;
3185     int fd;
3186     GV *gv;
3187     SV *tmpsv = NULL;
3188
3189     STACKED_FTEST_CHECK;
3190
3191     if (PL_op->op_flags & OPf_REF)
3192         gv = cGVOP_gv;
3193     else if (isGV(TOPs))
3194         gv = (GV*)POPs;
3195     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3196         gv = (GV*)SvRV(POPs);
3197     else
3198         gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3199
3200     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3201         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3202     else if (tmpsv && SvOK(tmpsv)) {
3203         const char *tmps = SvPV_nolen_const(tmpsv);
3204         if (isDIGIT(*tmps))
3205             fd = atoi(tmps);
3206         else
3207             RETPUSHUNDEF;
3208     }
3209     else
3210         RETPUSHUNDEF;
3211     if (PerlLIO_isatty(fd))
3212         RETPUSHYES;
3213     RETPUSHNO;
3214 }
3215
3216 #if defined(atarist) /* this will work with atariST. Configure will
3217                         make guesses for other systems. */
3218 # define FILE_base(f) ((f)->_base)
3219 # define FILE_ptr(f) ((f)->_ptr)
3220 # define FILE_cnt(f) ((f)->_cnt)
3221 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3222 #endif
3223
3224 PP(pp_fttext)
3225 {
3226     dVAR;
3227     dSP;
3228     I32 i;
3229     I32 len;
3230     I32 odd = 0;
3231     STDCHAR tbuf[512];
3232     register STDCHAR *s;
3233     register IO *io;
3234     register SV *sv;
3235     GV *gv;
3236     PerlIO *fp;
3237
3238     STACKED_FTEST_CHECK;
3239
3240     if (PL_op->op_flags & OPf_REF)
3241         gv = cGVOP_gv;
3242     else if (isGV(TOPs))
3243         gv = (GV*)POPs;
3244     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3245         gv = (GV*)SvRV(POPs);
3246     else
3247         gv = NULL;
3248
3249     if (gv) {
3250         EXTEND(SP, 1);
3251         if (gv == PL_defgv) {
3252             if (PL_statgv)
3253                 io = GvIO(PL_statgv);
3254             else {
3255                 sv = PL_statname;
3256                 goto really_filename;
3257             }
3258         }
3259         else {
3260             PL_statgv = gv;
3261             PL_laststatval = -1;
3262             sv_setpvn(PL_statname, "", 0);
3263             io = GvIO(PL_statgv);
3264         }
3265         if (io && IoIFP(io)) {
3266             if (! PerlIO_has_base(IoIFP(io)))
3267                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3268             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3269             if (PL_laststatval < 0)
3270                 RETPUSHUNDEF;
3271             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3272                 if (PL_op->op_type == OP_FTTEXT)
3273                     RETPUSHNO;
3274                 else
3275                     RETPUSHYES;
3276             }
3277             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3278                 i = PerlIO_getc(IoIFP(io));
3279                 if (i != EOF)
3280                     (void)PerlIO_ungetc(IoIFP(io),i);
3281             }
3282             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3283                 RETPUSHYES;
3284             len = PerlIO_get_bufsiz(IoIFP(io));
3285             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3286             /* sfio can have large buffers - limit to 512 */
3287             if (len > 512)
3288                 len = 512;
3289         }
3290         else {
3291             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3292                 gv = cGVOP_gv;
3293                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3294             }
3295             SETERRNO(EBADF,RMS_IFI);
3296             RETPUSHUNDEF;
3297         }
3298     }
3299     else {
3300         sv = POPs;
3301       really_filename:
3302         PL_statgv = NULL;
3303         PL_laststype = OP_STAT;
3304         sv_setpv(PL_statname, SvPV_nolen_const(sv));
3305         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3306             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3307                                                '\n'))
3308                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3309             RETPUSHUNDEF;
3310         }
3311         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3312         if (PL_laststatval < 0) {
3313             (void)PerlIO_close(fp);
3314             RETPUSHUNDEF;
3315         }
3316         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3317         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3318         (void)PerlIO_close(fp);
3319         if (len <= 0) {
3320             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3321                 RETPUSHNO;              /* special case NFS directories */
3322             RETPUSHYES;         /* null file is anything */
3323         }
3324         s = tbuf;
3325     }
3326
3327     /* now scan s to look for textiness */
3328     /*   XXX ASCII dependent code */
3329
3330 #if defined(DOSISH) || defined(USEMYBINMODE)
3331     /* ignore trailing ^Z on short files */
3332     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3333         --len;
3334 #endif
3335
3336     for (i = 0; i < len; i++, s++) {
3337         if (!*s) {                      /* null never allowed in text */
3338             odd += len;
3339             break;
3340         }
3341 #ifdef EBCDIC
3342         else if (!(isPRINT(*s) || isSPACE(*s)))
3343             odd++;
3344 #else
3345         else if (*s & 128) {
3346 #ifdef USE_LOCALE
3347             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3348                 continue;
3349 #endif
3350             /* utf8 characters don't count as odd */
3351             if (UTF8_IS_START(*s)) {
3352                 int ulen = UTF8SKIP(s);
3353                 if (ulen < len - i) {
3354                     int j;
3355                     for (j = 1; j < ulen; j++) {
3356                         if (!UTF8_IS_CONTINUATION(s[j]))
3357                             goto not_utf8;
3358                     }
3359                     --ulen;     /* loop does extra increment */
3360                     s += ulen;
3361                     i += ulen;
3362                     continue;
3363                 }
3364             }
3365           not_utf8:
3366             odd++;
3367         }
3368         else if (*s < 32 &&
3369           *s != '\n' && *s != '\r' && *s != '\b' &&
3370           *s != '\t' && *s != '\f' && *s != 27)
3371             odd++;
3372 #endif
3373     }
3374
3375     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3376         RETPUSHNO;
3377     else
3378         RETPUSHYES;
3379 }
3380
3381 /* File calls. */
3382
3383 PP(pp_chdir)
3384 {
3385     dVAR; dSP; dTARGET;
3386     const char *tmps = NULL;
3387     GV *gv = NULL;
3388
3389     if( MAXARG == 1 ) {
3390         SV * const sv = POPs;
3391         if (PL_op->op_flags & OPf_SPECIAL) {
3392             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3393         }
3394         else if (SvTYPE(sv) == SVt_PVGV) {
3395             gv = (GV*)sv;
3396         }
3397         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3398             gv = (GV*)SvRV(sv);
3399         }
3400         else {
3401             tmps = SvPVx_nolen_const(sv);
3402         }
3403     }
3404
3405     if( !gv && (!tmps || !*tmps) ) {
3406         HV * const table = GvHVn(PL_envgv);
3407         SV **svp;
3408
3409         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3410              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3411 #ifdef VMS
3412              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3413 #endif
3414            )
3415         {
3416             if( MAXARG == 1 )
3417                 deprecate("chdir('') or chdir(undef) as chdir()");
3418             tmps = SvPV_nolen_const(*svp);
3419         }
3420         else {
3421             PUSHi(0);
3422             TAINT_PROPER("chdir");
3423             RETURN;
3424         }
3425     }
3426
3427     TAINT_PROPER("chdir");
3428     if (gv) {
3429 #ifdef HAS_FCHDIR
3430         IO* const io = GvIO(gv);
3431         if (io) {
3432             if (IoIFP(io)) {
3433                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3434             }
3435             else if (IoDIRP(io)) {
3436 #ifdef HAS_DIRFD
3437                 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3438 #else
3439                 DIE(aTHX_ PL_no_func, "dirfd");
3440 #endif
3441             }
3442             else {
3443                 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3444                     report_evil_fh(gv, io, PL_op->op_type);
3445                 SETERRNO(EBADF, RMS_IFI);
3446                 PUSHi(0);
3447             }
3448         }
3449         else {
3450             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3451                 report_evil_fh(gv, io, PL_op->op_type);
3452             SETERRNO(EBADF,RMS_IFI);
3453             PUSHi(0);
3454         }
3455 #else
3456         DIE(aTHX_ PL_no_func, "fchdir");
3457 #endif
3458     }
3459     else
3460         PUSHi( PerlDir_chdir(tmps) >= 0 );
3461 #ifdef VMS
3462     /* Clear the DEFAULT element of ENV so we'll get the new value
3463      * in the future. */
3464     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3465 #endif
3466     RETURN;
3467 }
3468
3469 PP(pp_chown)
3470 {
3471     dVAR; dSP; dMARK; dTARGET;
3472     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3473
3474     SP = MARK;
3475     XPUSHi(value);
3476     RETURN;
3477 }
3478
3479 PP(pp_chroot)
3480 {
3481 #ifdef HAS_CHROOT
3482     dVAR; dSP; dTARGET;
3483     char * const tmps = POPpx;
3484     TAINT_PROPER("chroot");
3485     PUSHi( chroot(tmps) >= 0 );
3486     RETURN;
3487 #else
3488     DIE(aTHX_ PL_no_func, "chroot");
3489 #endif
3490 }
3491
3492 PP(pp_rename)
3493 {
3494     dVAR; dSP; dTARGET;
3495     int anum;
3496     const char * const tmps2 = POPpconstx;
3497     const char * const tmps = SvPV_nolen_const(TOPs);
3498     TAINT_PROPER("rename");
3499 #ifdef HAS_RENAME
3500     anum = PerlLIO_rename(tmps, tmps2);
3501 #else
3502     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3503         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3504             anum = 1;
3505         else {
3506             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3507                 (void)UNLINK(tmps2);
3508             if (!(anum = link(tmps, tmps2)))
3509                 anum = UNLINK(tmps);
3510         }
3511     }
3512 #endif
3513     SETi( anum >= 0 );
3514     RETURN;
3515 }
3516
3517 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3518 PP(pp_link)
3519 {
3520     dVAR; dSP; dTARGET;
3521     const int op_type = PL_op->op_type;
3522     int result;
3523
3524 #  ifndef HAS_LINK
3525     if (op_type == OP_LINK)
3526         DIE(aTHX_ PL_no_func, "link");
3527 #  endif
3528 #  ifndef HAS_SYMLINK
3529     if (op_type == OP_SYMLINK)
3530         DIE(aTHX_ PL_no_func, "symlink");
3531 #  endif
3532
3533     {
3534         const char * const tmps2 = POPpconstx;
3535         const char * const tmps = SvPV_nolen_const(TOPs);
3536         TAINT_PROPER(PL_op_desc[op_type]);
3537         result =
3538 #  if defined(HAS_LINK)
3539 #    if defined(HAS_SYMLINK)
3540             /* Both present - need to choose which.  */
3541             (op_type == OP_LINK) ?
3542             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3543 #    else
3544     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3545         PerlLIO_link(tmps, tmps2);
3546 #    endif
3547 #  else
3548 #    if defined(HAS_SYMLINK)
3549     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3550         symlink(tmps, tmps2);
3551 #    endif
3552 #  endif
3553     }
3554
3555     SETi( result >= 0 );
3556     RETURN;
3557 }
3558 #else
3559 PP(pp_link)
3560 {
3561     /* Have neither.  */
3562     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3563 }
3564 #endif
3565
3566 PP(pp_readlink)
3567 {
3568     dVAR;
3569     dSP;
3570 #ifdef HAS_SYMLINK
3571     dTARGET;
3572     const char *tmps;
3573     char buf[MAXPATHLEN];
3574     int len;
3575
3576 #ifndef INCOMPLETE_TAINTS
3577     TAINT;
3578 #endif
3579     tmps = POPpconstx;
3580     len = readlink(tmps, buf, sizeof(buf) - 1);
3581     EXTEND(SP, 1);
3582     if (len < 0)
3583         RETPUSHUNDEF;
3584     PUSHp(buf, len);
3585     RETURN;
3586 #else
3587     EXTEND(SP, 1);
3588     RETSETUNDEF;                /* just pretend it's a normal file */
3589 #endif
3590 }
3591
3592 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3593 STATIC int
3594 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3595 {
3596     char * const save_filename = filename;
3597     char *cmdline;
3598     char *s;
3599     PerlIO *myfp;
3600     int anum = 1;
3601     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3602
3603     Newx(cmdline, size, char);
3604     my_strlcpy(cmdline, cmd, size);
3605     my_strlcat(cmdline, " ", size);
3606     for (s = cmdline + strlen(cmdline); *filename; ) {
3607         *s++ = '\\';
3608         *s++ = *filename++;
3609     }
3610     if (s - cmdline < size)
3611         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3612     myfp = PerlProc_popen(cmdline, "r");
3613     Safefree(cmdline);
3614
3615     if (myfp) {
3616         SV * const tmpsv = sv_newmortal();
3617         /* Need to save/restore 'PL_rs' ?? */
3618         s = sv_gets(tmpsv, myfp, 0);
3619         (void)PerlProc_pclose(myfp);
3620         if (s != NULL) {
3621             int e;
3622             for (e = 1;
3623 #ifdef HAS_SYS_ERRLIST
3624                  e <= sys_nerr
3625 #endif
3626                  ; e++)
3627             {
3628                 /* you don't see this */
3629                 const char * const errmsg =
3630 #ifdef HAS_SYS_ERRLIST
3631                     sys_errlist[e]
3632 #else
3633                     strerror(e)
3634 #endif
3635                     ;
3636                 if (!errmsg)
3637                     break;
3638                 if (instr(s, errmsg)) {
3639                     SETERRNO(e,0);
3640                     return 0;
3641                 }
3642             }
3643             SETERRNO(0,0);
3644 #ifndef EACCES
3645 #define EACCES EPERM
3646 #endif
3647             if (instr(s, "cannot make"))
3648                 SETERRNO(EEXIST,RMS_FEX);
3649             else if (instr(s, "existing file"))
3650                 SETERRNO(EEXIST,RMS_FEX);
3651             else if (instr(s, "ile exists"))
3652                 SETERRNO(EEXIST,RMS_FEX);
3653             else if (instr(s, "non-exist"))
3654                 SETERRNO(ENOENT,RMS_FNF);
3655             else if (instr(s, "does not exist"))
3656                 SETERRNO(ENOENT,RMS_FNF);
3657             else if (instr(s, "not empty"))
3658                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3659             else if (instr(s, "cannot access"))
3660                 SETERRNO(EACCES,RMS_PRV);
3661             else
3662                 SETERRNO(EPERM,RMS_PRV);
3663             return 0;
3664         }
3665         else {  /* some mkdirs return no failure indication */
3666             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3667             if (PL_op->op_type == OP_RMDIR)
3668                 anum = !anum;
3669             if (anum)
3670                 SETERRNO(0,0);
3671             else
3672                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3673         }
3674         return anum;
3675     }
3676     else
3677         return 0;
3678 }
3679 #endif
3680
3681 /* This macro removes trailing slashes from a directory name.
3682  * Different operating and file systems take differently to
3683  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3684  * any number of trailing slashes should be allowed.
3685  * Thusly we snip them away so that even non-conforming
3686  * systems are happy.
3687  * We should probably do this "filtering" for all
3688  * the functions that expect (potentially) directory names:
3689  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3690  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3691
3692 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3693     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3694         do { \
3695             (len)--; \
3696         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3697         (tmps) = savepvn((tmps), (len)); \
3698         (copy) = TRUE; \
3699     }
3700
3701 PP(pp_mkdir)
3702 {
3703     dVAR; dSP; dTARGET;
3704     STRLEN len;
3705     const char *tmps;
3706     bool copy = FALSE;
3707     const int mode = (MAXARG > 1) ? POPi : 0777;
3708
3709     TRIMSLASHES(tmps,len,copy);
3710
3711     TAINT_PROPER("mkdir");
3712 #ifdef HAS_MKDIR
3713     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3714 #else
3715     {
3716     int oldumask;
3717     SETi( dooneliner("mkdir", tmps) );
3718     oldumask = PerlLIO_umask(0);
3719     PerlLIO_umask(oldumask);
3720     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3721     }
3722 #endif
3723     if (copy)
3724         Safefree(tmps);
3725     RETURN;
3726 }
3727
3728 PP(pp_rmdir)
3729 {
3730     dVAR; dSP; dTARGET;
3731     STRLEN len;
3732     const char *tmps;
3733     bool copy = FALSE;
3734
3735     TRIMSLASHES(tmps,len,copy);
3736     TAINT_PROPER("rmdir");
3737 #ifdef HAS_RMDIR
3738     SETi( PerlDir_rmdir(tmps) >= 0 );
3739 #else
3740     SETi( dooneliner("rmdir", tmps) );
3741 #endif
3742     if (copy)
3743         Safefree(tmps);
3744     RETURN;
3745 }
3746
3747 /* Directory calls. */
3748
3749 PP(pp_open_dir)
3750 {
3751 #if defined(Direntry_t) && defined(HAS_READDIR)
3752     dVAR; dSP;
3753     const char * const dirname = POPpconstx;
3754     GV * const gv = (GV*)POPs;
3755     register IO * const io = GvIOn(gv);
3756
3757     if (!io)
3758         goto nope;
3759
3760     if (IoDIRP(io))
3761         PerlDir_close(IoDIRP(io));
3762     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3763         goto nope;
3764
3765     RETPUSHYES;
3766 nope:
3767     if (!errno)
3768         SETERRNO(EBADF,RMS_DIR);
3769     RETPUSHUNDEF;
3770 #else
3771     DIE(aTHX_ PL_no_dir_func, "opendir");
3772 #endif
3773 }
3774
3775 PP(pp_readdir)
3776 {
3777 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3778     DIE(aTHX_ PL_no_dir_func, "readdir");
3779 #else
3780 #if !defined(I_DIRENT) && !defined(VMS)
3781     Direntry_t *readdir (DIR *);
3782 #endif
3783     dVAR;
3784     dSP;
3785
3786     SV *sv;
3787     const I32 gimme = GIMME;
3788     GV * const gv = (GV *)POPs;
3789     register const Direntry_t *dp;
3790     register IO * const io = GvIOn(gv);
3791
3792     if (!io || !IoDIRP(io)) {
3793         if(ckWARN(WARN_IO)) {
3794             Perl_warner(aTHX_ packWARN(WARN_IO),
3795                 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3796         }
3797         goto nope;
3798     }
3799
3800     do {
3801         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3802         if (!dp)
3803             break;
3804 #ifdef DIRNAMLEN
3805         sv = newSVpvn(dp->d_name, dp->d_namlen);
3806 #else
3807         sv = newSVpv(dp->d_name, 0);
3808 #endif
3809 #ifndef INCOMPLETE_TAINTS
3810         if (!(IoFLAGS(io) & IOf_UNTAINT))
3811             SvTAINTED_on(sv);
3812 #endif
3813         XPUSHs(sv_2mortal(sv));
3814     } while (gimme == G_ARRAY);
3815
3816     if (!dp && gimme != G_ARRAY)
3817         goto nope;
3818
3819     RETURN;
3820
3821 nope:
3822     if (!errno)
3823         SETERRNO(EBADF,RMS_ISI);
3824     if (GIMME == G_ARRAY)
3825         RETURN;
3826     else
3827         RETPUSHUNDEF;
3828 #endif
3829 }
3830
3831 PP(pp_telldir)
3832 {
3833 #if defined(HAS_TELLDIR) || defined(telldir)
3834     dVAR; dSP; dTARGET;
3835  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3836  /* XXX netbsd still seemed to.
3837     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3838     --JHI 1999-Feb-02 */
3839 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3840     long telldir (DIR *);
3841 # endif
3842     GV * const gv = (GV*)POPs;
3843     register IO * const io = GvIOn(gv);
3844
3845     if (!io || !IoDIRP(io)) {
3846         if(ckWARN(WARN_IO)) {
3847             Perl_warner(aTHX_ packWARN(WARN_IO),
3848                 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3849         }
3850         goto nope;
3851     }
3852
3853     PUSHi( PerlDir_tell(IoDIRP(io)) );
3854     RETURN;
3855 nope:
3856     if (!errno)
3857         SETERRNO(EBADF,RMS_ISI);
3858     RETPUSHUNDEF;
3859 #else
3860     DIE(aTHX_ PL_no_dir_func, "telldir");
3861 #endif
3862 }
3863
3864 PP(pp_seekdir)
3865 {
3866 #if defined(HAS_SEEKDIR) || defined(seekdir)
3867     dVAR; dSP;
3868     const long along = POPl;
3869     GV * const gv = (GV*)POPs;
3870     register IO * const io = GvIOn(gv);
3871
3872     if (!io || !IoDIRP(io)) {
3873         if(ckWARN(WARN_IO)) {
3874             Perl_warner(aTHX_ packWARN(WARN_IO),
3875                 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3876         }
3877         goto nope;
3878     }
3879     (void)PerlDir_seek(IoDIRP(io), along);
3880
3881     RETPUSHYES;
3882 nope:
3883     if (!errno)
3884         SETERRNO(EBADF,RMS_ISI);
3885     RETPUSHUNDEF;
3886 #else
3887     DIE(aTHX_ PL_no_dir_func, "seekdir");
3888 #endif
3889 }
3890
3891 PP(pp_rewinddir)
3892 {
3893 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3894     dVAR; dSP;
3895     GV * const gv = (GV*)POPs;
3896     register IO * const io = GvIOn(gv);
3897
3898     if (!io || !IoDIRP(io)) {
3899         if(ckWARN(WARN_IO)) {
3900             Perl_warner(aTHX_ packWARN(WARN_IO),
3901                 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3902         }
3903         goto nope;
3904     }
3905     (void)PerlDir_rewind(IoDIRP(io));
3906     RETPUSHYES;
3907 nope:
3908     if (!errno)
3909         SETERRNO(EBADF,RMS_ISI);
3910     RETPUSHUNDEF;
3911 #else
3912     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3913 #endif
3914 }
3915
3916 PP(pp_closedir)
3917 {
3918 #if defined(Direntry_t) && defined(HAS_READDIR)
3919     dVAR; dSP;
3920     GV * const gv = (GV*)POPs;
3921     register IO * const io = GvIOn(gv);
3922
3923     if (!io || !IoDIRP(io)) {
3924         if(ckWARN(WARN_IO)) {
3925             Perl_warner(aTHX_ packWARN(WARN_IO),
3926                 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3927         }
3928         goto nope;
3929     }
3930 #ifdef VOID_CLOSEDIR
3931     PerlDir_close(IoDIRP(io));
3932 #else
3933     if (PerlDir_close(IoDIRP(io)) < 0) {
3934         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3935         goto nope;
3936     }
3937 #endif
3938     IoDIRP(io) = 0;
3939
3940     RETPUSHYES;
3941 nope:
3942     if (!errno)
3943         SETERRNO(EBADF,RMS_IFI);
3944     RETPUSHUNDEF;
3945 #else
3946     DIE(aTHX_ PL_no_dir_func, "closedir");
3947 #endif
3948 }
3949
3950 /* Process control. */
3951
3952 PP(pp_fork)
3953 {
3954 #ifdef HAS_FORK
3955     dVAR; dSP; dTARGET;
3956     Pid_t childpid;
3957
3958     EXTEND(SP, 1);
3959     PERL_FLUSHALL_FOR_CHILD;
3960     childpid = PerlProc_fork();
3961     if (childpid < 0)
3962         RETSETUNDEF;
3963     if (!childpid) {
3964         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3965         if (tmpgv) {
3966             SvREADONLY_off(GvSV(tmpgv));
3967             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3968             SvREADONLY_on(GvSV(tmpgv));
3969         }
3970 #ifdef THREADS_HAVE_PIDS
3971         PL_ppid = (IV)getppid();
3972 #endif
3973 #ifdef PERL_USES_PL_PIDSTATUS
3974         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3975 #endif
3976     }
3977     PUSHi(childpid);
3978     RETURN;
3979 #else
3980 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3981     dSP; dTARGET;
3982     Pid_t childpid;
3983
3984     EXTEND(SP, 1);
3985     PERL_FLUSHALL_FOR_CHILD;
3986     childpid = PerlProc_fork();
3987     if (childpid == -1)
3988         RETSETUNDEF;
3989     PUSHi(childpid);
3990     RETURN;
3991 #  else
3992     DIE(aTHX_ PL_no_func, "fork");
3993 #  endif
3994 #endif
3995 }
3996
3997 PP(pp_wait)
3998 {
3999 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4000     dVAR; dSP; dTARGET;
4001     Pid_t childpid;
4002     int argflags;
4003
4004     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4005         childpid = wait4pid(-1, &argflags, 0);
4006     else {
4007         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4008                errno == EINTR) {
4009           PERL_ASYNC_CHECK();
4010         }
4011     }
4012 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4013     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4014     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4015 #  else
4016     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4017 #  endif
4018     XPUSHi(childpid);
4019     RETURN;
4020 #else
4021     DIE(aTHX_ PL_no_func, "wait");
4022 #endif
4023 }
4024
4025 PP(pp_waitpid)
4026 {
4027 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4028     dVAR; dSP; dTARGET;
4029     const int optype = POPi;
4030     const Pid_t pid = TOPi;
4031     Pid_t result;
4032     int argflags;
4033
4034     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4035         result = wait4pid(pid, &argflags, optype);
4036     else {
4037         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4038                errno == EINTR) {
4039           PERL_ASYNC_CHECK();
4040         }
4041     }
4042 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4043     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4044     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4045 #  else
4046     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4047 #  endif
4048     SETi(result);
4049     RETURN;
4050 #else
4051     DIE(aTHX_ PL_no_func, "waitpid");
4052 #endif
4053 }
4054
4055 PP(pp_system)
4056 {
4057     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4058     I32 value;
4059     int result;
4060
4061     if (PL_tainting) {
4062         TAINT_ENV();
4063         while (++MARK <= SP) {
4064             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4065             if (PL_tainted)
4066                 break;
4067         }
4068         MARK = ORIGMARK;
4069         TAINT_PROPER("system");
4070     }
4071     PERL_FLUSHALL_FOR_CHILD;
4072 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4073     {
4074         Pid_t childpid;
4075         int pp[2];
4076         I32 did_pipes = 0;
4077
4078         if (PerlProc_pipe(pp) >= 0)
4079             did_pipes = 1;
4080         while ((childpid = PerlProc_fork()) == -1) {
4081             if (errno != EAGAIN) {
4082                 value = -1;
4083                 SP = ORIGMARK;
4084                 XPUSHi(value);
4085                 if (did_pipes) {
4086                     PerlLIO_close(pp[0]);
4087                     PerlLIO_close(pp[1]);
4088                 }
4089                 RETURN;
4090             }
4091             sleep(5);
4092         }
4093         if (childpid > 0) {
4094             Sigsave_t ihand,qhand; /* place to save signals during system() */
4095             int status;
4096
4097             if (did_pipes)
4098                 PerlLIO_close(pp[1]);
4099 #ifndef PERL_MICRO
4100             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4101             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4102 #endif
4103             do {
4104                 result = wait4pid(childpid, &status, 0);
4105             } while (result == -1 && errno == EINTR);
4106 #ifndef PERL_MICRO
4107             (void)rsignal_restore(SIGINT, &ihand);
4108             (void)rsignal_restore(SIGQUIT, &qhand);
4109 #endif
4110             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4111             do_execfree();      /* free any memory child malloced on fork */
4112             SP = ORIGMARK;
4113             if (did_pipes) {
4114                 int errkid;
4115                 unsigned n = 0;
4116                 SSize_t n1;
4117
4118                 while (n < sizeof(int)) {
4119                     n1 = PerlLIO_read(pp[0],
4120                                       (void*)(((char*)&errkid)+n),
4121                                       (sizeof(int)) - n);
4122                     if (n1 <= 0)
4123                         break;
4124                     n += n1;
4125                 }
4126                 PerlLIO_close(pp[0]);
4127                 if (n) {                        /* Error */
4128                     if (n != sizeof(int))
4129                         DIE(aTHX_ "panic: kid popen errno read");
4130                     errno = errkid;             /* Propagate errno from kid */
4131                     STATUS_NATIVE_CHILD_SET(-1);
4132                 }
4133             }
4134             XPUSHi(STATUS_CURRENT);
4135             RETURN;
4136         }
4137         if (did_pipes) {
4138             PerlLIO_close(pp[0]);
4139 #if defined(HAS_FCNTL) && defined(F_SETFD)
4140             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4141 #endif
4142         }
4143         if (PL_op->op_flags & OPf_STACKED) {
4144             SV * const really = *++MARK;
4145             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4146         }
4147         else if (SP - MARK != 1)
4148             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4149         else {
4150             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4151         }
4152         PerlProc__exit(-1);
4153     }
4154 #else /* ! FORK or VMS or OS/2 */
4155     PL_statusvalue = 0;
4156     result = 0;
4157     if (PL_op->op_flags & OPf_STACKED) {
4158         SV * const really = *++MARK;
4159 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4160         value = (I32)do_aspawn(really, MARK, SP);
4161 #  else
4162         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4163 #  endif
4164     }
4165     else if (SP - MARK != 1) {
4166 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4167         value = (I32)do_aspawn(NULL, MARK, SP);
4168 #  else
4169         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4170 #  endif
4171     }
4172     else {
4173         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4174     }
4175     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4176         result = 1;
4177     STATUS_NATIVE_CHILD_SET(value);
4178     do_execfree();
4179     SP = ORIGMARK;
4180     XPUSHi(result ? value : STATUS_CURRENT);
4181 #endif /* !FORK or VMS */
4182     RETURN;
4183 }
4184
4185 PP(pp_exec)
4186 {
4187     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4188     I32 value;
4189
4190     if (PL_tainting) {
4191         TAINT_ENV();
4192         while (++MARK <= SP) {
4193             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4194             if (PL_tainted)
4195                 break;
4196         }
4197         MARK = ORIGMARK;
4198         TAINT_PROPER("exec");
4199     }
4200     PERL_FLUSHALL_FOR_CHILD;
4201     if (PL_op->op_flags & OPf_STACKED) {
4202         SV * const really = *++MARK;
4203         value = (I32)do_aexec(really, MARK, SP);
4204     }
4205     else if (SP - MARK != 1)
4206 #ifdef VMS
4207         value = (I32)vms_do_aexec(NULL, MARK, SP);
4208 #else
4209 #  ifdef __OPEN_VM
4210         {
4211            (void ) do_aspawn(NULL, MARK, SP);
4212            value = 0;
4213         }
4214 #  else
4215         value = (I32)do_aexec(NULL, MARK, SP);
4216 #  endif
4217 #endif
4218     else {
4219 #ifdef VMS
4220         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4221 #else
4222 #  ifdef __OPEN_VM
4223         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4224         value = 0;
4225 #  else
4226         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4227 #  endif
4228 #endif
4229     }
4230
4231     SP = ORIGMARK;
4232     XPUSHi(value);
4233     RETURN;
4234 }
4235
4236 PP(pp_getppid)
4237 {
4238 #ifdef HAS_GETPPID
4239     dVAR; dSP; dTARGET;
4240 #   ifdef THREADS_HAVE_PIDS
4241     if (PL_ppid != 1 && getppid() == 1)
4242         /* maybe the parent process has died. Refresh ppid cache */
4243         PL_ppid = 1;
4244     XPUSHi( PL_ppid );
4245 #   else
4246     XPUSHi( getppid() );
4247 #   endif
4248     RETURN;
4249 #else
4250     DIE(aTHX_ PL_no_func, "getppid");
4251 #endif
4252 }
4253
4254 PP(pp_getpgrp)
4255 {
4256 #ifdef HAS_GETPGRP
4257     dVAR; dSP; dTARGET;
4258     Pid_t pgrp;
4259     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4260
4261 #ifdef BSD_GETPGRP
4262     pgrp = (I32)BSD_GETPGRP(pid);
4263 #else
4264     if (pid != 0 && pid != PerlProc_getpid())
4265         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4266     pgrp = getpgrp();
4267 #endif
4268     XPUSHi(pgrp);
4269     RETURN;
4270 #else
4271     DIE(aTHX_ PL_no_func, "getpgrp()");
4272 #endif
4273 }
4274
4275 PP(pp_setpgrp)
4276 {
4277 #ifdef HAS_SETPGRP
4278     dVAR; dSP; dTARGET;
4279     Pid_t pgrp;
4280     Pid_t pid;
4281     if (MAXARG < 2) {
4282         pgrp = 0;
4283         pid = 0;
4284     }
4285     else {
4286         pgrp = POPi;
4287         pid = TOPi;
4288     }
4289
4290     TAINT_PROPER("setpgrp");
4291 #ifdef BSD_SETPGRP
4292     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4293 #else
4294     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4295         || (pid != 0 && pid != PerlProc_getpid()))
4296     {
4297         DIE(aTHX_ "setpgrp can't take arguments");
4298     }
4299     SETi( setpgrp() >= 0 );
4300 #endif /* USE_BSDPGRP */
4301     RETURN;
4302 #else
4303     DIE(aTHX_ PL_no_func, "setpgrp()");
4304 #endif
4305 }
4306
4307 PP(pp_getpriority)
4308 {
4309 #ifdef HAS_GETPRIORITY
4310     dVAR; dSP; dTARGET;
4311     const int who = POPi;
4312     const int which = TOPi;
4313     SETi( getpriority(which, who) );
4314     RETURN;
4315 #else
4316     DIE(aTHX_ PL_no_func, "getpriority()");
4317 #endif
4318 }
4319
4320 PP(pp_setpriority)
4321 {
4322 #ifdef HAS_SETPRIORITY
4323     dVAR; dSP; dTARGET;
4324     const int niceval = POPi;
4325     const int who = POPi;
4326     const int which = TOPi;
4327     TAINT_PROPER("setpriority");
4328     SETi( setpriority(which, who, niceval) >= 0 );
4329     RETURN;
4330 #else
4331     DIE(aTHX_ PL_no_func, "setpriority()");
4332 #endif
4333 }
4334
4335 /* Time calls. */
4336
4337 PP(pp_time)
4338 {
4339     dVAR; dSP; dTARGET;
4340 #ifdef BIG_TIME
4341     XPUSHn( time(NULL) );
4342 #else
4343     XPUSHi( time(NULL) );
4344 #endif
4345     RETURN;
4346 }
4347
4348 PP(pp_tms)
4349 {
4350 #ifdef HAS_TIMES
4351     dVAR;
4352     dSP;
4353     EXTEND(SP, 4);
4354 #ifndef VMS
4355     (void)PerlProc_times(&PL_timesbuf);
4356 #else
4357     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4358                                                    /* struct tms, though same data   */
4359                                                    /* is returned.                   */
4360 #endif
4361
4362     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4363     if (GIMME == G_ARRAY) {
4364         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4365         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4366         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4367     }
4368     RETURN;
4369 #else
4370 #   ifdef PERL_MICRO
4371     dSP;
4372     PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4373     EXTEND(SP, 4);
4374     if (GIMME == G_ARRAY) {
4375          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4376          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4377          PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4378     }
4379     RETURN;
4380 #   else
4381     DIE(aTHX_ "times not implemented");
4382 #   endif
4383 #endif /* HAS_TIMES */
4384 }
4385
4386 #ifdef LOCALTIME_EDGECASE_BROKEN
4387 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4388 {
4389     auto time_t     T;
4390     auto struct tm *P;
4391
4392     /* No workarounds in the valid range */
4393     if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4394         return (localtime (tp));
4395
4396     /* This edge case is to workaround the undefined behaviour, where the
4397      * TIMEZONE makes the time go beyond the defined range.
4398      * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4399      * If there is a negative offset in TZ, like MET-1METDST, some broken
4400      * implementations of localtime () (like AIX 5.2) barf with bogus
4401      * return values:
4402      * 0x7fffffff gmtime               2038-01-19 03:14:07
4403      * 0x7fffffff localtime            1901-12-13 21:45:51
4404      * 0x7fffffff mylocaltime          2038-01-19 04:14:07
4405      * 0x3c19137f gmtime               2001-12-13 20:45:51
4406      * 0x3c19137f localtime            2001-12-13 21:45:51
4407      * 0x3c19137f mylocaltime          2001-12-13 21:45:51
4408      * Given that legal timezones are typically between GMT-12 and GMT+12
4409      * we turn back the clock 23 hours before calling the localtime
4410      * function, and add those to the return value. This will never cause
4411      * day wrapping problems, since the edge case is Tue Jan *19*
4412      */
4413     T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4414     P = localtime (&T);
4415     P->tm_hour += 23;
4416     if (P->tm_hour >= 24) {
4417         P->tm_hour -= 24;
4418         P->tm_mday++;   /* 18  -> 19  */
4419         P->tm_wday++;   /* Mon -> Tue */
4420         P->tm_yday++;   /* 18  -> 19  */
4421     }
4422     return (P);
4423 } /* S_my_localtime */
4424 #endif
4425
4426 PP(pp_gmtime)
4427 {
4428     dVAR;
4429     dSP;
4430     Time_t when;
4431     const struct tm *tmbuf;
4432     static const char * const dayname[] =
4433         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4434     static const char * const monname[] =
4435         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4436          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4437
4438     if (MAXARG < 1)
4439         (void)time(&when);
4440     else
4441 #ifdef BIG_TIME
4442         when = (Time_t)SvNVx(POPs);
4443 #else
4444         when = (Time_t)SvIVx(POPs);
4445 #endif
4446
4447     if (PL_op->op_type == OP_LOCALTIME)
4448 #ifdef LOCALTIME_EDGECASE_BROKEN
4449         tmbuf = S_my_localtime(aTHX_ &when);
4450 #else
4451         tmbuf = localtime(&when);
4452 #endif
4453     else
4454         tmbuf = gmtime(&when);
4455
4456     if (GIMME != G_ARRAY) {
4457         SV *tsv;
4458         EXTEND(SP, 1);
4459         EXTEND_MORTAL(1);
4460         if (!tmbuf)
4461             RETPUSHUNDEF;
4462         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4463                             dayname[tmbuf->tm_wday],
4464                             monname[tmbuf->tm_mon],
4465                             tmbuf->tm_mday,
4466                             tmbuf->tm_hour,
4467                             tmbuf->tm_min,
4468                             tmbuf->tm_sec,
4469                             tmbuf->tm_year + 1900);
4470         PUSHs(sv_2mortal(tsv));
4471     }
4472     else if (tmbuf) {
4473         EXTEND(SP, 9);
4474         EXTEND_MORTAL(9);
4475         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4476         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4477         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4478         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4479         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4480         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4481         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4482         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4483         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4484     }
4485     RETURN;
4486 }
4487
4488 PP(pp_alarm)
4489 {
4490 #ifdef HAS_ALARM
4491     dVAR; dSP; dTARGET;
4492     int anum;
4493     anum = POPi;
4494     anum = alarm((unsigned int)anum);
4495     EXTEND(SP, 1);
4496     if (anum < 0)
4497         RETPUSHUNDEF;
4498     PUSHi(anum);
4499     RETURN;
4500 #else
4501     DIE(aTHX_ PL_no_func, "alarm");
4502 #endif
4503 }
4504
4505 PP(pp_sleep)
4506 {
4507     dVAR; dSP; dTARGET;
4508     I32 duration;
4509     Time_t lasttime;
4510     Time_t when;
4511
4512     (void)time(&lasttime);
4513     if (MAXARG < 1)
4514         PerlProc_pause();
4515     else {
4516         duration = POPi;
4517         PerlProc_sleep((unsigned int)duration);
4518     }
4519     (void)time(&when);
4520     XPUSHi(when - lasttime);
4521     RETURN;
4522 }
4523
4524 /* Shared memory. */
4525 /* Merged with some message passing. */
4526
4527 PP(pp_shmwrite)
4528 {
4529 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4530     dVAR; dSP; dMARK; dTARGET;
4531     const int op_type = PL_op->op_type;
4532     I32 value;
4533
4534     switch (op_type) {
4535     case OP_MSGSND:
4536         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4537         break;
4538     case OP_MSGRCV:
4539         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4540         break;
4541     case OP_SEMOP:
4542         value = (I32)(do_semop(MARK, SP) >= 0);
4543         break;
4544     default:
4545         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4546         break;
4547     }
4548
4549     SP = MARK;
4550     PUSHi(value);
4551     RETURN;
4552 #else
4553     return pp_semget();
4554 #endif
4555 }
4556
4557 /* Semaphores. */
4558
4559 PP(pp_semget)
4560 {
4561 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4562     dVAR; dSP; dMARK; dTARGET;
4563     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4564     SP = MARK;
4565     if (anum == -1)
4566         RETPUSHUNDEF;
4567     PUSHi(anum);
4568     RETURN;
4569 #else
4570     DIE(aTHX_ "System V IPC is not implemented on this machine");
4571 #endif
4572 }
4573
4574 PP(pp_semctl)
4575 {
4576 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4577     dVAR; dSP; dMARK; dTARGET;
4578     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4579     SP = MARK;
4580     if (anum == -1)
4581         RETSETUNDEF;
4582     if (anum != 0) {
4583         PUSHi(anum);
4584     }
4585     else {
4586         PUSHp(zero_but_true, ZBTLEN);
4587     }
4588     RETURN;
4589 #else
4590     return pp_semget();
4591 #endif
4592 }
4593
4594 /* I can't const this further without getting warnings about the types of
4595    various arrays passed in from structures.  */
4596 static SV *
4597 S_space_join_names_mortal(pTHX_ char *const *array)
4598 {
4599     SV *target;
4600
4601     if (array && *array) {
4602         target = sv_2mortal(newSVpvs(""));
4603         while (1) {
4604             sv_catpv(target, *array);
4605             if (!*++array)
4606                 break;
4607             sv_catpvs(target, " ");
4608         }
4609     } else {
4610         target = sv_mortalcopy(&PL_sv_no);
4611     }
4612     return target;
4613 }
4614
4615 /* Get system info. */
4616
4617 PP(pp_ghostent)
4618 {
4619 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4620     dVAR; dSP;
4621     I32 which = PL_op->op_type;
4622     register char **elem;
4623     register SV *sv;
4624 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4625     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4626     struct hostent *gethostbyname(Netdb_name_t);
4627     struct hostent *gethostent(void);
4628 #endif
4629     struct hostent *hent;
4630     unsigned long len;
4631
4632     EXTEND(SP, 10);
4633     if (which == OP_GHBYNAME) {
4634 #ifdef HAS_GETHOSTBYNAME
4635         const char* const name = POPpbytex;
4636         hent = PerlSock_gethostbyname(name);
4637 #else
4638         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4639 #endif
4640     }
4641     else if (which == OP_GHBYADDR) {
4642 #ifdef HAS_GETHOSTBYADDR
4643         const int addrtype = POPi;
4644         SV * const addrsv = POPs;
4645         STRLEN addrlen;
4646         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4647
4648         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4649 #else
4650         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4651 #endif
4652     }
4653     else
4654 #ifdef HAS_GETHOSTENT
4655         hent = PerlSock_gethostent();
4656 #else
4657         DIE(aTHX_ PL_no_sock_func, "gethostent");
4658 #endif
4659
4660 #ifdef HOST_NOT_FOUND
4661         if (!hent) {
4662 #ifdef USE_REENTRANT_API
4663 #   ifdef USE_GETHOSTENT_ERRNO
4664             h_errno = PL_reentrant_buffer->_gethostent_errno;
4665 #   endif
4666 #endif
4667             STATUS_UNIX_SET(h_errno);
4668         }
4669 #endif
4670
4671     if (GIMME != G_ARRAY) {
4672         PUSHs(sv = sv_newmortal());
4673         if (hent) {
4674             if (which == OP_GHBYNAME) {
4675                 if (hent->h_addr)
4676                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4677             }
4678             else
4679                 sv_setpv(sv, (char*)hent->h_name);
4680         }
4681         RETURN;
4682     }
4683
4684     if (hent) {
4685         PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4686         PUSHs(space_join_names_mortal(hent->h_aliases));
4687         PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4688         len = hent->h_length;
4689         PUSHs(sv_2mortal(newSViv((IV)len)));
4690 #ifdef h_addr
4691         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4692             XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4693         }
4694 #else
4695         if (hent->h_addr)
4696             PUSHs(newSVpvn(hent->h_addr, len));
4697         else
4698             PUSHs(sv_mortalcopy(&PL_sv_no));
4699 #endif /* h_addr */
4700     }
4701     RETURN;
4702 #else
4703     DIE(aTHX_ PL_no_sock_func, "gethostent");
4704 #endif
4705 }
4706
4707 PP(pp_gnetent)
4708 {
4709 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4710     dVAR; dSP;
4711     I32 which = PL_op->op_type;
4712     register SV *sv;
4713 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4714     struct netent *getnetbyaddr(Netdb_net_t, int);
4715     struct netent *getnetbyname(Netdb_name_t);
4716     struct netent *getnetent(void);
4717 #endif
4718     struct netent *nent;
4719
4720     if (which == OP_GNBYNAME){
4721 #ifdef HAS_GETNETBYNAME
4722         const char * const name = POPpbytex;
4723         nent = PerlSock_getnetbyname(name);
4724 #else
4725         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4726 #endif
4727     }
4728     else if (which == OP_GNBYADDR) {
4729 #ifdef HAS_GETNETBYADDR
4730         const int addrtype = POPi;
4731         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4732         nent = PerlSock_getnetbyaddr(addr, addrtype);
4733 #else
4734         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4735 #endif
4736     }
4737     else
4738 #ifdef HAS_GETNETENT
4739         nent = PerlSock_getnetent();
4740 #else
4741         DIE(aTHX_ PL_no_sock_func, "getnetent");
4742 #endif
4743
4744 #ifdef HOST_NOT_FOUND
4745         if (!nent) {
4746 #ifdef USE_REENTRANT_API
4747 #   ifdef USE_GETNETENT_ERRNO
4748              h_errno = PL_reentrant_buffer->_getnetent_errno;
4749 #   endif
4750 #endif
4751             STATUS_UNIX_SET(h_errno);
4752         }
4753 #endif
4754
4755     EXTEND(SP, 4);
4756     if (GIMME != G_ARRAY) {
4757         PUSHs(sv = sv_newmortal());
4758         if (nent) {
4759             if (which == OP_GNBYNAME)
4760                 sv_setiv(sv, (IV)nent->n_net);
4761             else
4762                 sv_setpv(sv, nent->n_name);
4763         }
4764         RETURN;
4765     }
4766
4767     if (nent) {
4768         PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4769         PUSHs(space_join_names_mortal(nent->n_aliases));
4770         PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4771         PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4772     }
4773
4774     RETURN;
4775 #else
4776     DIE(aTHX_ PL_no_sock_func, "getnetent");
4777 #endif
4778 }
4779
4780 PP(pp_gprotoent)
4781 {
4782 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4783     dVAR; dSP;
4784     I32 which = PL_op->op_type;
4785     register SV *sv;
4786 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4787     struct protoent *getprotobyname(Netdb_name_t);
4788     struct protoent *getprotobynumber(int);
4789     struct protoent *getprotoent(void);
4790 #endif
4791     struct protoent *pent;
4792
4793     if (which == OP_GPBYNAME) {
4794 #ifdef HAS_GETPROTOBYNAME
4795         const char* const name = POPpbytex;
4796         pent = PerlSock_getprotobyname(name);
4797 #else
4798         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4799 #endif
4800     }
4801     else if (which == OP_GPBYNUMBER) {
4802 #ifdef HAS_GETPROTOBYNUMBER
4803         const int number = POPi;
4804         pent = PerlSock_getprotobynumber(number);
4805 #else
4806         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4807 #endif
4808     }
4809     else
4810 #ifdef HAS_GETPROTOENT
4811         pent = PerlSock_getprotoent();
4812 #else
4813         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4814 #endif
4815
4816     EXTEND(SP, 3);
4817     if (GIMME != G_ARRAY) {
4818         PUSHs(sv = sv_newmortal());
4819         if (pent) {
4820             if (which == OP_GPBYNAME)
4821                 sv_setiv(sv, (IV)pent->p_proto);
4822             else
4823                 sv_setpv(sv, pent->p_name);
4824         }
4825         RETURN;
4826     }
4827
4828     if (pent) {
4829         PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4830         PUSHs(space_join_names_mortal(pent->p_aliases));
4831         PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4832     }
4833
4834     RETURN;
4835 #else
4836     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4837 #endif
4838 }
4839
4840 PP(pp_gservent)
4841 {
4842 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4843     dVAR; dSP;
4844     I32 which = PL_op->op_type;
4845     register SV *sv;
4846 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4847     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4848     struct servent *getservbyport(int, Netdb_name_t);
4849     struct servent *getservent(void);
4850 #endif
4851     struct servent *sent;
4852
4853     if (which == OP_GSBYNAME) {
4854 #ifdef HAS_GETSERVBYNAME
4855         const char * const proto = POPpbytex;
4856         const char * const name = POPpbytex;
4857         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4858 #else
4859         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4860 #endif
4861     }
4862     else if (which == OP_GSBYPORT) {
4863 #ifdef HAS_GETSERVBYPORT
4864         const char * const proto = POPpbytex;
4865         unsigned short port = (unsigned short)POPu;
4866 #ifdef HAS_HTONS
4867         port = PerlSock_htons(port);
4868 #endif
4869         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4870 #else
4871         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4872 #endif
4873     }
4874     else
4875 #ifdef HAS_GETSERVENT
4876         sent = PerlSock_getservent();
4877 #else
4878         DIE(aTHX_ PL_no_sock_func, "getservent");
4879 #endif
4880
4881     EXTEND(SP, 4);
4882     if (GIMME != G_ARRAY) {
4883         PUSHs(sv = sv_newmortal());
4884         if (sent) {
4885             if (which == OP_GSBYNAME) {
4886 #ifdef HAS_NTOHS
4887                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4888 #else
4889                 sv_setiv(sv, (IV)(sent->s_port));
4890 #endif
4891             }
4892             else
4893                 sv_setpv(sv, sent->s_name);
4894         }
4895         RETURN;
4896     }
4897
4898     if (sent) {
4899         PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4900         PUSHs(space_join_names_mortal(sent->s_aliases));
4901 #ifdef HAS_NTOHS
4902         PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4903 #else
4904         PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4905 #endif
4906         PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4907     }
4908
4909     RETURN;
4910 #else
4911     DIE(aTHX_ PL_no_sock_func, "getservent");
4912 #endif
4913 }
4914
4915 PP(pp_shostent)
4916 {
4917 #ifdef HAS_SETHOSTENT
4918     dVAR; dSP;
4919     PerlSock_sethostent(TOPi);
4920     RETSETYES;
4921 #else
4922     DIE(aTHX_ PL_no_sock_func, "sethostent");
4923 #endif
4924 }
4925
4926 PP(pp_snetent)
4927 {
4928 #ifdef HAS_SETNETENT
4929     dVAR; dSP;
4930     PerlSock_setnetent(TOPi);
4931     RETSETYES;
4932 #else
4933     DIE(aTHX_ PL_no_sock_func, "setnetent");
4934 #endif
4935 }
4936
4937 PP(pp_sprotoent)
4938 {
4939 #ifdef HAS_SETPROTOENT
4940     dVAR; dSP;
4941     PerlSock_setprotoent(TOPi);
4942     RETSETYES;
4943 #else
4944     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4945 #endif
4946 }
4947
4948 PP(pp_sservent)
4949 {
4950 #ifdef HAS_SETSERVENT
4951     dVAR; dSP;
4952     PerlSock_setservent(TOPi);
4953     RETSETYES;
4954 #else
4955     DIE(aTHX_ PL_no_sock_func, "setservent");
4956 #endif
4957 }
4958
4959 PP(pp_ehostent)
4960 {
4961 #ifdef HAS_ENDHOSTENT
4962     dVAR; dSP;
4963     PerlSock_endhostent();
4964     EXTEND(SP,1);
4965     RETPUSHYES;
4966 #else
4967     DIE(aTHX_ PL_no_sock_func, "endhostent");
4968 #endif
4969 }
4970
4971 PP(pp_enetent)
4972 {
4973 #ifdef HAS_ENDNETENT
4974     dVAR; dSP;
4975     PerlSock_endnetent();
4976     EXTEND(SP,1);
4977     RETPUSHYES;
4978 #else
4979     DIE(aTHX_ PL_no_sock_func, "endnetent");
4980 #endif
4981 }
4982
4983 PP(pp_eprotoent)
4984 {
4985 #ifdef HAS_ENDPROTOENT
4986     dVAR; dSP;
4987     PerlSock_endprotoent();
4988     EXTEND(SP,1);
4989     RETPUSHYES;
4990 #else
4991     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4992 #endif
4993 }
4994
4995 PP(pp_eservent)
4996 {
4997 #ifdef HAS_ENDSERVENT
4998     dVAR; dSP;
4999     PerlSock_endservent();
5000     EXTEND(SP,1);
5001     RETPUSHYES;
5002 #else
5003     DIE(aTHX_ PL_no_sock_func, "endservent");
5004 #endif
5005 }
5006
5007 PP(pp_gpwent)
5008 {
5009 #ifdef HAS_PASSWD
5010     dVAR; dSP;
5011     I32 which = PL_op->op_type;
5012     register SV *sv;
5013     struct passwd *pwent  = NULL;
5014     /*
5015      * We currently support only the SysV getsp* shadow password interface.
5016      * The interface is declared in <shadow.h> and often one needs to link
5017      * with -lsecurity or some such.
5018      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5019      * (and SCO?)
5020      *
5021      * AIX getpwnam() is clever enough to return the encrypted password
5022      * only if the caller (euid?) is root.
5023      *
5024      * There are at least three other shadow password APIs.  Many platforms
5025      * seem to contain more than one interface for accessing the shadow
5026      * password databases, possibly for compatibility reasons.
5027      * The getsp*() is by far he simplest one, the other two interfaces
5028      * are much more complicated, but also very similar to each other.
5029      *
5030      * <sys/types.h>
5031      * <sys/security.h>
5032      * <prot.h>
5033      * struct pr_passwd *getprpw*();
5034      * The password is in
5035      * char getprpw*(...).ufld.fd_encrypt[]
5036      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5037      *
5038      * <sys/types.h>
5039      * <sys/security.h>
5040      * <prot.h>
5041      * struct es_passwd *getespw*();
5042      * The password is in
5043      * char *(getespw*(...).ufld.fd_encrypt)
5044      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5045      *
5046      * <userpw.h> (AIX)
5047      * struct userpw *getuserpw();
5048      * The password is in
5049      * char *(getuserpw(...)).spw_upw_passwd
5050      * (but the de facto standard getpwnam() should work okay)
5051      *
5052      * Mention I_PROT here so that Configure probes for it.
5053      *
5054      * In HP-UX for getprpw*() the manual page claims that one should include
5055      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5056      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5057      * and pp_sys.c already includes <shadow.h> if there is such.
5058      *
5059      * Note that <sys/security.h> is already probed for, but currently
5060      * it is only included in special cases.
5061      *
5062      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5063      * be preferred interface, even though also the getprpw*() interface
5064      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5065      * One also needs to call set_auth_parameters() in main() before
5066      * doing anything else, whether one is using getespw*() or getprpw*().
5067      *
5068      * Note that accessing the shadow databases can be magnitudes
5069      * slower than accessing the standard databases.
5070      *
5071      * --jhi
5072      */
5073
5074 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5075     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5076      * the pw_comment is left uninitialized. */
5077     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5078 #   endif
5079
5080     switch (which) {
5081     case OP_GPWNAM:
5082       {
5083         const char* const name = POPpbytex;
5084         pwent  = getpwnam(name);
5085       }
5086       break;
5087     case OP_GPWUID:
5088       {
5089         Uid_t uid = POPi;
5090         pwent = getpwuid(uid);
5091       }
5092         break;
5093     case OP_GPWENT:
5094 #   ifdef HAS_GETPWENT
5095         pwent  = getpwent();
5096 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5097         if (pwent) pwent = getpwnam(pwent->pw_name);
5098 #endif
5099 #   else
5100         DIE(aTHX_ PL_no_func, "getpwent");
5101 #   endif
5102         break;
5103     }
5104
5105     EXTEND(SP, 10);
5106     if (GIMME != G_ARRAY) {
5107         PUSHs(sv = sv_newmortal());
5108         if (pwent) {
5109             if (which == OP_GPWNAM)
5110 #   if Uid_t_sign <= 0
5111                 sv_setiv(sv, (IV)pwent->pw_uid);
5112 #   else
5113                 sv_setuv(sv, (UV)pwent->pw_uid);
5114 #   endif
5115             else
5116                 sv_setpv(sv, pwent->pw_name);
5117         }
5118         RETURN;
5119     }
5120
5121     if (pwent) {
5122         PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5123
5124         PUSHs(sv = sv_2mortal(newSViv(0)));
5125         /* If we have getspnam(), we try to dig up the shadow
5126          * password.  If we are underprivileged, the shadow
5127          * interface will set the errno to EACCES or similar,
5128          * and return a null pointer.  If this happens, we will
5129          * use the dummy password (usually "*" or "x") from the
5130          * standard password database.
5131          *
5132          * In theory we could skip the shadow call completely
5133          * if euid != 0 but in practice we cannot know which
5134          * security measures are guarding the shadow databases
5135          * on a random platform.
5136          *
5137          * Resist the urge to use additional shadow interfaces.
5138          * Divert the urge to writing an extension instead.
5139          *
5140          * --jhi */
5141         /* Some AIX setups falsely(?) detect some getspnam(), which
5142          * has a different API than the Solaris/IRIX one. */
5143 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5144         {
5145             const int saverrno = errno;
5146             const struct spwd * const spwent = getspnam(pwent->pw_name);
5147                           /* Save and restore errno so that
5148                            * underprivileged attempts seem
5149                            * to have never made the unsccessful
5150                            * attempt to retrieve the shadow password. */
5151             errno = saverrno;
5152             if (spwent && spwent->sp_pwdp)
5153                 sv_setpv(sv, spwent->sp_pwdp);
5154         }
5155 #   endif
5156 #   ifdef PWPASSWD
5157         if (!SvPOK(sv)) /* Use the standard password, then. */
5158             sv_setpv(sv, pwent->pw_passwd);
5159 #   endif
5160
5161 #   ifndef INCOMPLETE_TAINTS
5162         /* passwd is tainted because user himself can diddle with it.
5163          * admittedly not much and in a very limited way, but nevertheless. */
5164         SvTAINTED_on(sv);
5165 #   endif
5166
5167 #   if Uid_t_sign <= 0
5168         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5169 #   else
5170         PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5171 #   endif
5172
5173 #   if Uid_t_sign <= 0
5174         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5175 #   else
5176         PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5177 #   endif
5178         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5179          * because of the poor interface of the Perl getpw*(),
5180          * not because there's some standard/convention saying so.
5181          * A better interface would have been to return a hash,
5182          * but we are accursed by our history, alas. --jhi.  */
5183 #   ifdef PWCHANGE
5184         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5185 #   else
5186 #       ifdef PWQUOTA
5187         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5188 #       else
5189 #           ifdef PWAGE
5190         PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5191 #           else
5192         /* I think that you can never get this compiled, but just in case.  */
5193         PUSHs(sv_mortalcopy(&PL_sv_no));
5194 #           endif
5195 #       endif
5196 #   endif
5197
5198         /* pw_class and pw_comment are mutually exclusive--.
5199          * see the above note for pw_change, pw_quota, and pw_age. */
5200 #   ifdef PWCLASS
5201         PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5202 #   else
5203 #       ifdef PWCOMMENT
5204         PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5205 #       else
5206         /* I think that you can never get this compiled, but just in case.  */
5207         PUSHs(sv_mortalcopy(&PL_sv_no));
5208 #       endif
5209 #   endif
5210
5211 #   ifdef PWGECOS
5212         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5213 #   else
5214         PUSHs(sv_mortalcopy(&PL_sv_no));
5215 #   endif
5216 #   ifndef INCOMPLETE_TAINTS
5217         /* pw_gecos is tainted because user himself can diddle with it. */
5218         SvTAINTED_on(sv);
5219 #   endif
5220
5221         PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5222
5223         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5224 #   ifndef INCOMPLETE_TAINTS
5225         /* pw_shell is tainted because user himself can diddle with it. */
5226         SvTAINTED_on(sv);
5227 #   endif
5228
5229 #   ifdef PWEXPIRE
5230         PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5231 #   endif
5232     }
5233     RETURN;
5234 #else
5235     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5236 #endif
5237 }
5238
5239 PP(pp_spwent)
5240 {
5241 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5242     dVAR; dSP;
5243     setpwent();
5244     RETPUSHYES;
5245 #else
5246     DIE(aTHX_ PL_no_func, "setpwent");
5247 #endif
5248 }
5249
5250 PP(pp_epwent)
5251 {
5252 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5253     dVAR; dSP;
5254     endpwent();
5255     RETPUSHYES;
5256 #else
5257     DIE(aTHX_ PL_no_func, "endpwent");
5258 #endif
5259 }
5260
5261 PP(pp_ggrent)
5262 {
5263 #ifdef HAS_GROUP
5264     dVAR; dSP;
5265     const I32 which = PL_op->op_type;
5266     const struct group *grent;
5267
5268     if (which == OP_GGRNAM) {
5269         const char* const name = POPpbytex;
5270         grent = (const struct group *)getgrnam(name);
5271     }
5272     else if (which == OP_GGRGID) {
5273         const Gid_t gid = POPi;
5274         grent = (const struct group *)getgrgid(gid);
5275     }
5276     else
5277 #ifdef HAS_GETGRENT
5278         grent = (struct group *)getgrent();
5279 #else
5280         DIE(aTHX_ PL_no_func, "getgrent");
5281 #endif
5282
5283     EXTEND(SP, 4);
5284     if (GIMME != G_ARRAY) {
5285         SV * const sv = sv_newmortal();
5286
5287         PUSHs(sv);
5288         if (grent) {
5289             if (which == OP_GGRNAM)
5290                 sv_setiv(sv, (IV)grent->gr_gid);
5291             else
5292                 sv_setpv(sv, grent->gr_name);
5293         }
5294         RETURN;
5295     }
5296
5297     if (grent) {
5298         PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5299
5300 #ifdef GRPASSWD
5301         PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5302 #else
5303         PUSHs(sv_mortalcopy(&PL_sv_no));
5304 #endif
5305
5306         PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5307
5308 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5309         /* In UNICOS/mk (_CRAYMPP) the multithreading
5310          * versions (getgrnam_r, getgrgid_r)
5311          * seem to return an illegal pointer
5312          * as the group members list, gr_mem.
5313          * getgrent() doesn't even have a _r version
5314          * but the gr_mem is poisonous anyway.
5315          * So yes, you cannot get the list of group
5316          * members if building multithreaded in UNICOS/mk. */
5317         PUSHs(space_join_names_mortal(grent->gr_mem));
5318 #endif
5319     }
5320
5321     RETURN;
5322 #else
5323     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5324 #endif
5325 }
5326
5327 PP(pp_sgrent)
5328 {
5329 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5330     dVAR; dSP;
5331     setgrent();
5332     RETPUSHYES;
5333 #else
5334     DIE(aTHX_ PL_no_func, "setgrent");
5335 #endif
5336 }
5337
5338 PP(pp_egrent)
5339 {
5340 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5341     dVAR; dSP;
5342     endgrent();
5343     RETPUSHYES;
5344 #else
5345     DIE(aTHX_ PL_no_func, "endgrent");
5346 #endif
5347 }
5348
5349 PP(pp_getlogin)
5350 {
5351 #ifdef HAS_GETLOGIN
5352     dVAR; dSP; dTARGET;
5353     char *tmps;
5354     EXTEND(SP, 1);
5355     if (!(tmps = PerlProc_getlogin()))
5356         RETPUSHUNDEF;
5357     PUSHp(tmps, strlen(tmps));
5358     RETURN;
5359 #else
5360     DIE(aTHX_ PL_no_func, "getlogin");
5361 #endif
5362 }
5363
5364 /* Miscellaneous. */
5365
5366 PP(pp_syscall)
5367 {
5368 #ifdef HAS_SYSCALL
5369     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5370     register I32 items = SP - MARK;
5371     unsigned long a[20];
5372     register I32 i = 0;
5373     I32 retval = -1;
5374
5375     if (PL_tainting) {
5376         while (++MARK <= SP) {
5377             if (SvTAINTED(*MARK)) {
5378                 TAINT;
5379                 break;
5380             }
5381         }
5382         MARK = ORIGMARK;
5383         TAINT_PROPER("syscall");
5384     }
5385
5386     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5387      * or where sizeof(long) != sizeof(char*).  But such machines will
5388      * not likely have syscall implemented either, so who cares?
5389      */
5390     while (++MARK <= SP) {
5391         if (SvNIOK(*MARK) || !i)
5392             a[i++] = SvIV(*MARK);
5393         else if (*MARK == &PL_sv_undef)
5394             a[i++] = 0;
5395         else
5396             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5397         if (i > 15)
5398             break;
5399     }
5400     switch (items) {
5401     default:
5402         DIE(aTHX_ "Too many args to syscall");
5403     case 0:
5404         DIE(aTHX_ "Too few args to syscall");
5405     case 1:
5406         retval = syscall(a[0]);
5407         break;
5408     case 2:
5409         retval = syscall(a[0],a[1]);
5410         break;
5411     case 3:
5412         retval = syscall(a[0],a[1],a[2]);
5413         break;
5414     case 4:
5415         retval = syscall(a[0],a[1],a[2],a[3]);
5416         break;
5417     case 5:
5418         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5419         break;
5420     case 6:
5421         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5422         break;
5423     case 7:
5424         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5425         break;
5426     case 8:
5427         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5428         break;
5429 #ifdef atarist
5430     case 9:
5431         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5432         break;
5433     case 10:
5434         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5435         break;
5436     case 11:
5437         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5438           a[10]);
5439         break;
5440     case 12:
5441         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5442           a[10],a[11]);
5443         break;
5444     case 13:
5445         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5446           a[10],a[11],a[12]);
5447         break;
5448     case 14:
5449         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5450           a[10],a[11],a[12],a[13]);
5451         break;
5452 #endif /* atarist */
5453     }
5454     SP = ORIGMARK;
5455     PUSHi(retval);
5456     RETURN;
5457 #else
5458     DIE(aTHX_ PL_no_func, "syscall");
5459 #endif
5460 }
5461
5462 #ifdef FCNTL_EMULATE_FLOCK
5463
5464 /*  XXX Emulate flock() with fcntl().
5465     What's really needed is a good file locking module.
5466 */
5467
5468 static int
5469 fcntl_emulate_flock(int fd, int operation)
5470 {
5471     struct flock flock;
5472
5473     switch (operation & ~LOCK_NB) {
5474     case LOCK_SH:
5475         flock.l_type = F_RDLCK;
5476         break;
5477     case LOCK_EX:
5478         flock.l_type = F_WRLCK;
5479         break;
5480     case LOCK_UN:
5481         flock.l_type = F_UNLCK;
5482         break;
5483     default:
5484         errno = EINVAL;
5485         return -1;
5486     }
5487     flock.l_whence = SEEK_SET;
5488     flock.l_start = flock.l_len = (Off_t)0;
5489
5490     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5491 }
5492
5493 #endif /* FCNTL_EMULATE_FLOCK */
5494
5495 #ifdef LOCKF_EMULATE_FLOCK
5496
5497 /*  XXX Emulate flock() with lockf().  This is just to increase
5498     portability of scripts.  The calls are not completely
5499     interchangeable.  What's really needed is a good file
5500     locking module.
5501 */
5502
5503 /*  The lockf() constants might have been defined in <unistd.h>.
5504     Unfortunately, <unistd.h> causes troubles on some mixed
5505     (BSD/POSIX) systems, such as SunOS 4.1.3.
5506
5507    Further, the lockf() constants aren't POSIX, so they might not be
5508    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5509    just stick in the SVID values and be done with it.  Sigh.
5510 */
5511
5512 # ifndef F_ULOCK
5513 #  define F_ULOCK       0       /* Unlock a previously locked region */
5514 # endif
5515 # ifndef F_LOCK
5516 #  define F_LOCK        1       /* Lock a region for exclusive use */
5517 # endif
5518 # ifndef F_TLOCK
5519 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5520 # endif
5521 # ifndef F_TEST
5522 #  define F_TEST        3       /* Test a region for other processes locks */
5523 # endif
5524
5525 static int
5526 lockf_emulate_flock(int fd, int operation)
5527 {
5528     int i;
5529     const int save_errno = errno;
5530     Off_t pos;
5531
5532     /* flock locks entire file so for lockf we need to do the same      */
5533     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5534     if (pos > 0)        /* is seekable and needs to be repositioned     */
5535         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5536             pos = -1;   /* seek failed, so don't seek back afterwards   */
5537     errno = save_errno;
5538
5539     switch (operation) {
5540
5541         /* LOCK_SH - get a shared lock */
5542         case LOCK_SH:
5543         /* LOCK_EX - get an exclusive lock */
5544         case LOCK_EX:
5545             i = lockf (fd, F_LOCK, 0);
5546             break;
5547
5548         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5549         case LOCK_SH|LOCK_NB:
5550         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5551         case LOCK_EX|LOCK_NB:
5552             i = lockf (fd, F_TLOCK, 0);
5553             if (i == -1)
5554                 if ((errno == EAGAIN) || (errno == EACCES))
5555                     errno = EWOULDBLOCK;
5556             break;
5557
5558         /* LOCK_UN - unlock (non-blocking is a no-op) */
5559         case LOCK_UN:
5560         case LOCK_UN|LOCK_NB:
5561             i = lockf (fd, F_ULOCK, 0);
5562             break;
5563
5564         /* Default - can't decipher operation */
5565         default:
5566             i = -1;
5567             errno = EINVAL;
5568             break;
5569     }
5570
5571     if (pos > 0)      /* need to restore position of the handle */
5572         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5573
5574     return (i);
5575 }
5576
5577 #endif /* LOCKF_EMULATE_FLOCK */
5578
5579 /*
5580  * Local variables:
5581  * c-indentation-style: bsd
5582  * c-basic-offset: 4
5583  * indent-tabs-mode: t
5584  * End:
5585  *
5586  * ex: set ts=8 sts=4 sw=4 noet:
5587  */