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