pp_sys.c

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