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