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