pp_sys.c

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