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