pp_sys.c

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