pp_sys.c

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