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_ Nullformat);
 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                 OP_NAME(PL_op));
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     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2468     if (fd < 0)
2469         goto badexit;
2470     if (IoIFP(nstio))
2471         do_close(ngv, FALSE);
2472     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2473     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2474     IoTYPE(nstio) = IoTYPE_SOCKET;
2475     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2476         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2477         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2478         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2479         goto badexit;
2480     }
2481 #if defined(HAS_FCNTL) && defined(F_SETFD)
2482     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2483 #endif
2484
2485 #ifdef EPOC
2486     len = sizeof saddr;          /* EPOC somehow truncates info */
2487     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2488 #endif
2489
2490     PUSHp((char *)&saddr, len);
2491     RETURN;
2492
2493 nuts:
2494     if (ckWARN(WARN_CLOSED))
2495         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2496     SETERRNO(EBADF,SS$_IVCHAN);
2497
2498 badexit:
2499     RETPUSHUNDEF;
2500
2501 #else
2502     DIE(aTHX_ PL_no_sock_func, "accept");
2503 #endif
2504 }
2505
2506 PP(pp_shutdown)
2507 {
2508 #ifdef HAS_SOCKET
2509     dSP; dTARGET;
2510     int how = POPi;
2511     GV *gv = (GV*)POPs;
2512     register IO *io = GvIOn(gv);
2513
2514     if (!io || !IoIFP(io))
2515         goto nuts;
2516
2517     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2518     RETURN;
2519
2520 nuts:
2521     if (ckWARN(WARN_CLOSED))
2522         report_evil_fh(gv, io, PL_op->op_type);
2523     SETERRNO(EBADF,SS$_IVCHAN);
2524     RETPUSHUNDEF;
2525 #else
2526     DIE(aTHX_ PL_no_sock_func, "shutdown");
2527 #endif
2528 }
2529
2530 PP(pp_gsockopt)
2531 {
2532 #ifdef HAS_SOCKET
2533     return pp_ssockopt();
2534 #else
2535     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2536 #endif
2537 }
2538
2539 PP(pp_ssockopt)
2540 {
2541 #ifdef HAS_SOCKET
2542     dSP;
2543     int optype = PL_op->op_type;
2544     SV *sv;
2545     int fd;
2546     unsigned int optname;
2547     unsigned int lvl;
2548     GV *gv;
2549     register IO *io;
2550     Sock_size_t len;
2551
2552     if (optype == OP_GSOCKOPT)
2553         sv = sv_2mortal(NEWSV(22, 257));
2554     else
2555         sv = POPs;
2556     optname = (unsigned int) POPi;
2557     lvl = (unsigned int) POPi;
2558
2559     gv = (GV*)POPs;
2560     io = GvIOn(gv);
2561     if (!io || !IoIFP(io))
2562         goto nuts;
2563
2564     fd = PerlIO_fileno(IoIFP(io));
2565     switch (optype) {
2566     case OP_GSOCKOPT:
2567         SvGROW(sv, 257);
2568         (void)SvPOK_only(sv);
2569         SvCUR_set(sv,256);
2570         *SvEND(sv) ='\0';
2571         len = SvCUR(sv);
2572         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2573             goto nuts2;
2574         SvCUR_set(sv, len);
2575         *SvEND(sv) ='\0';
2576         PUSHs(sv);
2577         break;
2578     case OP_SSOCKOPT: {
2579             char *buf;
2580             int aint;
2581             if (SvPOKp(sv)) {
2582                 STRLEN l;
2583                 buf = SvPV(sv, l);
2584                 len = l;
2585             }
2586             else {
2587                 aint = (int)SvIV(sv);
2588                 buf = (char*)&aint;
2589                 len = sizeof(int);
2590             }
2591             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2592                 goto nuts2;
2593             PUSHs(&PL_sv_yes);
2594         }
2595         break;
2596     }
2597     RETURN;
2598
2599 nuts:
2600     if (ckWARN(WARN_CLOSED))
2601         report_evil_fh(gv, io, optype);
2602     SETERRNO(EBADF,SS$_IVCHAN);
2603 nuts2:
2604     RETPUSHUNDEF;
2605
2606 #else
2607     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2608 #endif
2609 }
2610
2611 PP(pp_getsockname)
2612 {
2613 #ifdef HAS_SOCKET
2614     return pp_getpeername();
2615 #else
2616     DIE(aTHX_ PL_no_sock_func, "getsockname");
2617 #endif
2618 }
2619
2620 PP(pp_getpeername)
2621 {
2622 #ifdef HAS_SOCKET
2623     dSP;
2624     int optype = PL_op->op_type;
2625     SV *sv;
2626     int fd;
2627     GV *gv = (GV*)POPs;
2628     register IO *io = GvIOn(gv);
2629     Sock_size_t len;
2630
2631     if (!io || !IoIFP(io))
2632         goto nuts;
2633
2634     sv = sv_2mortal(NEWSV(22, 257));
2635     (void)SvPOK_only(sv);
2636     len = 256;
2637     SvCUR_set(sv, len);
2638     *SvEND(sv) ='\0';
2639     fd = PerlIO_fileno(IoIFP(io));
2640     switch (optype) {
2641     case OP_GETSOCKNAME:
2642         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2643             goto nuts2;
2644         break;
2645     case OP_GETPEERNAME:
2646         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2647             goto nuts2;
2648 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2649         {
2650             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";
2651             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2652             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2653                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2654                         sizeof(u_short) + sizeof(struct in_addr))) {
2655                 goto nuts2;
2656             }
2657         }
2658 #endif
2659         break;
2660     }
2661 #ifdef BOGUS_GETNAME_RETURN
2662     /* Interactive Unix, getpeername() and getsockname()
2663       does not return valid namelen */
2664     if (len == BOGUS_GETNAME_RETURN)
2665         len = sizeof(struct sockaddr);
2666 #endif
2667     SvCUR_set(sv, len);
2668     *SvEND(sv) ='\0';
2669     PUSHs(sv);
2670     RETURN;
2671
2672 nuts:
2673     if (ckWARN(WARN_CLOSED))
2674         report_evil_fh(gv, io, optype);
2675     SETERRNO(EBADF,SS$_IVCHAN);
2676 nuts2:
2677     RETPUSHUNDEF;
2678
2679 #else
2680     DIE(aTHX_ PL_no_sock_func, "getpeername");
2681 #endif
2682 }
2683
2684 /* Stat calls. */
2685
2686 PP(pp_lstat)
2687 {
2688     return pp_stat();
2689 }
2690
2691 PP(pp_stat)
2692 {
2693     dSP;
2694     GV *gv;
2695     I32 gimme;
2696     I32 max = 13;
2697     STRLEN n_a;
2698
2699     if (PL_op->op_flags & OPf_REF) {
2700         gv = cGVOP_gv;
2701         if (PL_op->op_type == OP_LSTAT) {
2702             if (PL_laststype != OP_LSTAT)
2703                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2704             if (ckWARN(WARN_IO) && gv != PL_defgv)
2705                 Perl_warner(aTHX_ WARN_IO,
2706                         "lstat() on filehandle %s", GvENAME(gv));
2707                 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2708         }
2709
2710       do_fstat:
2711         if (gv != PL_defgv) {
2712             PL_laststype = OP_STAT;
2713             PL_statgv = gv;
2714             sv_setpv(PL_statname, "");
2715             PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2716                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2717         }
2718         if (PL_laststatval < 0) {
2719             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2720                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2721             max = 0;
2722         }
2723     }
2724     else {
2725         SV* sv = POPs;
2726         if (SvTYPE(sv) == SVt_PVGV) {
2727             gv = (GV*)sv;
2728             goto do_fstat;
2729         }
2730         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2731             gv = (GV*)SvRV(sv);
2732             goto do_fstat;
2733         }
2734         sv_setpv(PL_statname, SvPV(sv,n_a));
2735         PL_statgv = Nullgv;
2736 #ifdef HAS_LSTAT
2737         PL_laststype = PL_op->op_type;
2738         if (PL_op->op_type == OP_LSTAT)
2739             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2740         else
2741 #endif
2742             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2743         if (PL_laststatval < 0) {
2744             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2745                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2746             max = 0;
2747         }
2748     }
2749
2750     gimme = GIMME_V;
2751     if (gimme != G_ARRAY) {
2752         if (gimme != G_VOID)
2753             XPUSHs(boolSV(max));
2754         RETURN;
2755     }
2756     if (max) {
2757         EXTEND(SP, max);
2758         EXTEND_MORTAL(max);
2759         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2760         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2761         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2762         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2763 #if Uid_t_size > IVSIZE
2764         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2765 #else
2766 #   if Uid_t_sign <= 0
2767         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2768 #   else
2769         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2770 #   endif
2771 #endif
2772 #if Gid_t_size > IVSIZE
2773         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2774 #else
2775 #   if Gid_t_sign <= 0
2776         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2777 #   else
2778         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2779 #   endif
2780 #endif
2781 #ifdef USE_STAT_RDEV
2782         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2783 #else
2784         PUSHs(sv_2mortal(newSVpvn("", 0)));
2785 #endif
2786 #if Off_t_size > IVSIZE
2787         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2788 #else
2789         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2790 #endif
2791 #ifdef BIG_TIME
2792         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2793         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2794         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2795 #else
2796         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2797         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2798         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2799 #endif
2800 #ifdef USE_STAT_BLOCKS
2801         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2802         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2803 #else
2804         PUSHs(sv_2mortal(newSVpvn("", 0)));
2805         PUSHs(sv_2mortal(newSVpvn("", 0)));
2806 #endif
2807     }
2808     RETURN;
2809 }
2810
2811 PP(pp_ftrread)
2812 {
2813     I32 result;
2814     dSP;
2815 #if defined(HAS_ACCESS) && defined(R_OK)
2816     STRLEN n_a;
2817     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2818         result = access(TOPpx, R_OK);
2819         if (result == 0)
2820             RETPUSHYES;
2821         if (result < 0)
2822             RETPUSHUNDEF;
2823         RETPUSHNO;
2824     }
2825     else
2826         result = my_stat();
2827 #else
2828     result = my_stat();
2829 #endif
2830     SPAGAIN;
2831     if (result < 0)
2832         RETPUSHUNDEF;
2833     if (cando(S_IRUSR, 0, &PL_statcache))
2834         RETPUSHYES;
2835     RETPUSHNO;
2836 }
2837
2838 PP(pp_ftrwrite)
2839 {
2840     I32 result;
2841     dSP;
2842 #if defined(HAS_ACCESS) && defined(W_OK)
2843     STRLEN n_a;
2844     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2845         result = access(TOPpx, W_OK);
2846         if (result == 0)
2847             RETPUSHYES;
2848         if (result < 0)
2849             RETPUSHUNDEF;
2850         RETPUSHNO;
2851     }
2852     else
2853         result = my_stat();
2854 #else
2855     result = my_stat();
2856 #endif
2857     SPAGAIN;
2858     if (result < 0)
2859         RETPUSHUNDEF;
2860     if (cando(S_IWUSR, 0, &PL_statcache))
2861         RETPUSHYES;
2862     RETPUSHNO;
2863 }
2864
2865 PP(pp_ftrexec)
2866 {
2867     I32 result;
2868     dSP;
2869 #if defined(HAS_ACCESS) && defined(X_OK)
2870     STRLEN n_a;
2871     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2872         result = access(TOPpx, X_OK);
2873         if (result == 0)
2874             RETPUSHYES;
2875         if (result < 0)
2876             RETPUSHUNDEF;
2877         RETPUSHNO;
2878     }
2879     else
2880         result = my_stat();
2881 #else
2882     result = my_stat();
2883 #endif
2884     SPAGAIN;
2885     if (result < 0)
2886         RETPUSHUNDEF;
2887     if (cando(S_IXUSR, 0, &PL_statcache))
2888         RETPUSHYES;
2889     RETPUSHNO;
2890 }
2891
2892 PP(pp_fteread)
2893 {
2894     I32 result;
2895     dSP;
2896 #ifdef PERL_EFF_ACCESS_R_OK
2897     STRLEN n_a;
2898     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2899         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2900         if (result == 0)
2901             RETPUSHYES;
2902         if (result < 0)
2903             RETPUSHUNDEF;
2904         RETPUSHNO;
2905     }
2906     else
2907         result = my_stat();
2908 #else
2909     result = my_stat();
2910 #endif
2911     SPAGAIN;
2912     if (result < 0)
2913         RETPUSHUNDEF;
2914     if (cando(S_IRUSR, 1, &PL_statcache))
2915         RETPUSHYES;
2916     RETPUSHNO;
2917 }
2918
2919 PP(pp_ftewrite)
2920 {
2921     I32 result;
2922     dSP;
2923 #ifdef PERL_EFF_ACCESS_W_OK
2924     STRLEN n_a;
2925     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2926         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2927         if (result == 0)
2928             RETPUSHYES;
2929         if (result < 0)
2930             RETPUSHUNDEF;
2931         RETPUSHNO;
2932     }
2933     else
2934         result = my_stat();
2935 #else
2936     result = my_stat();
2937 #endif
2938     SPAGAIN;
2939     if (result < 0)
2940         RETPUSHUNDEF;
2941     if (cando(S_IWUSR, 1, &PL_statcache))
2942         RETPUSHYES;
2943     RETPUSHNO;
2944 }
2945
2946 PP(pp_fteexec)
2947 {
2948     I32 result;
2949     dSP;
2950 #ifdef PERL_EFF_ACCESS_X_OK
2951     STRLEN n_a;
2952     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2953         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2954         if (result == 0)
2955             RETPUSHYES;
2956         if (result < 0)
2957             RETPUSHUNDEF;
2958         RETPUSHNO;
2959     }
2960     else
2961         result = my_stat();
2962 #else
2963     result = my_stat();
2964 #endif
2965     SPAGAIN;
2966     if (result < 0)
2967         RETPUSHUNDEF;
2968     if (cando(S_IXUSR, 1, &PL_statcache))
2969         RETPUSHYES;
2970     RETPUSHNO;
2971 }
2972
2973 PP(pp_ftis)
2974 {
2975     I32 result = my_stat();
2976     dSP;
2977     if (result < 0)
2978         RETPUSHUNDEF;
2979     RETPUSHYES;
2980 }
2981
2982 PP(pp_fteowned)
2983 {
2984     return pp_ftrowned();
2985 }
2986
2987 PP(pp_ftrowned)
2988 {
2989     I32 result = my_stat();
2990     dSP;
2991     if (result < 0)
2992         RETPUSHUNDEF;
2993     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2994                                 PL_euid : PL_uid) )
2995         RETPUSHYES;
2996     RETPUSHNO;
2997 }
2998
2999 PP(pp_ftzero)
3000 {
3001     I32 result = my_stat();
3002     dSP;
3003     if (result < 0)
3004         RETPUSHUNDEF;
3005     if (PL_statcache.st_size == 0)
3006         RETPUSHYES;
3007     RETPUSHNO;
3008 }
3009
3010 PP(pp_ftsize)
3011 {
3012     I32 result = my_stat();
3013     dSP; dTARGET;
3014     if (result < 0)
3015         RETPUSHUNDEF;
3016 #if Off_t_size > IVSIZE
3017     PUSHn(PL_statcache.st_size);
3018 #else
3019     PUSHi(PL_statcache.st_size);
3020 #endif
3021     RETURN;
3022 }
3023
3024 PP(pp_ftmtime)
3025 {
3026     I32 result = my_stat();
3027     dSP; dTARGET;
3028     if (result < 0)
3029         RETPUSHUNDEF;
3030     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3031     RETURN;
3032 }
3033
3034 PP(pp_ftatime)
3035 {
3036     I32 result = my_stat();
3037     dSP; dTARGET;
3038     if (result < 0)
3039         RETPUSHUNDEF;
3040     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
3041     RETURN;
3042 }
3043
3044 PP(pp_ftctime)
3045 {
3046     I32 result = my_stat();
3047     dSP; dTARGET;
3048     if (result < 0)
3049         RETPUSHUNDEF;
3050     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3051     RETURN;
3052 }
3053
3054 PP(pp_ftsock)
3055 {
3056     I32 result = my_stat();
3057     dSP;
3058     if (result < 0)
3059         RETPUSHUNDEF;
3060     if (S_ISSOCK(PL_statcache.st_mode))
3061         RETPUSHYES;
3062     RETPUSHNO;
3063 }
3064
3065 PP(pp_ftchr)
3066 {
3067     I32 result = my_stat();
3068     dSP;
3069     if (result < 0)
3070         RETPUSHUNDEF;
3071     if (S_ISCHR(PL_statcache.st_mode))
3072         RETPUSHYES;
3073     RETPUSHNO;
3074 }
3075
3076 PP(pp_ftblk)
3077 {
3078     I32 result = my_stat();
3079     dSP;
3080     if (result < 0)
3081         RETPUSHUNDEF;
3082     if (S_ISBLK(PL_statcache.st_mode))
3083         RETPUSHYES;
3084     RETPUSHNO;
3085 }
3086
3087 PP(pp_ftfile)
3088 {
3089     I32 result = my_stat();
3090     dSP;
3091     if (result < 0)
3092         RETPUSHUNDEF;
3093     if (S_ISREG(PL_statcache.st_mode))
3094         RETPUSHYES;
3095     RETPUSHNO;
3096 }
3097
3098 PP(pp_ftdir)
3099 {
3100     I32 result = my_stat();
3101     dSP;
3102     if (result < 0)
3103         RETPUSHUNDEF;
3104     if (S_ISDIR(PL_statcache.st_mode))
3105         RETPUSHYES;
3106     RETPUSHNO;
3107 }
3108
3109 PP(pp_ftpipe)
3110 {
3111     I32 result = my_stat();
3112     dSP;
3113     if (result < 0)
3114         RETPUSHUNDEF;
3115     if (S_ISFIFO(PL_statcache.st_mode))
3116         RETPUSHYES;
3117     RETPUSHNO;
3118 }
3119
3120 PP(pp_ftlink)
3121 {
3122     I32 result = my_lstat();
3123     dSP;
3124     if (result < 0)
3125         RETPUSHUNDEF;
3126     if (S_ISLNK(PL_statcache.st_mode))
3127         RETPUSHYES;
3128     RETPUSHNO;
3129 }
3130
3131 PP(pp_ftsuid)
3132 {
3133     dSP;
3134 #ifdef S_ISUID
3135     I32 result = my_stat();
3136     SPAGAIN;
3137     if (result < 0)
3138         RETPUSHUNDEF;
3139     if (PL_statcache.st_mode & S_ISUID)
3140         RETPUSHYES;
3141 #endif
3142     RETPUSHNO;
3143 }
3144
3145 PP(pp_ftsgid)
3146 {
3147     dSP;
3148 #ifdef S_ISGID
3149     I32 result = my_stat();
3150     SPAGAIN;
3151     if (result < 0)
3152         RETPUSHUNDEF;
3153     if (PL_statcache.st_mode & S_ISGID)
3154         RETPUSHYES;
3155 #endif
3156     RETPUSHNO;
3157 }
3158
3159 PP(pp_ftsvtx)
3160 {
3161     dSP;
3162 #ifdef S_ISVTX
3163     I32 result = my_stat();
3164     SPAGAIN;
3165     if (result < 0)
3166         RETPUSHUNDEF;
3167     if (PL_statcache.st_mode & S_ISVTX)
3168         RETPUSHYES;
3169 #endif
3170     RETPUSHNO;
3171 }
3172
3173 PP(pp_fttty)
3174 {
3175     dSP;
3176     int fd;
3177     GV *gv;
3178     char *tmps = Nullch;
3179     STRLEN n_a;
3180
3181     if (PL_op->op_flags & OPf_REF)
3182         gv = cGVOP_gv;
3183     else if (isGV(TOPs))
3184         gv = (GV*)POPs;
3185     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3186         gv = (GV*)SvRV(POPs);
3187     else
3188         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3189
3190     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3191         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3192     else if (tmps && isDIGIT(*tmps))
3193         fd = atoi(tmps);
3194     else
3195         RETPUSHUNDEF;
3196     if (PerlLIO_isatty(fd))
3197         RETPUSHYES;
3198     RETPUSHNO;
3199 }
3200
3201 #if defined(atarist) /* this will work with atariST. Configure will
3202                         make guesses for other systems. */
3203 # define FILE_base(f) ((f)->_base)
3204 # define FILE_ptr(f) ((f)->_ptr)
3205 # define FILE_cnt(f) ((f)->_cnt)
3206 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3207 #endif
3208
3209 PP(pp_fttext)
3210 {
3211     dSP;
3212     I32 i;
3213     I32 len;
3214     I32 odd = 0;
3215     STDCHAR tbuf[512];
3216     register STDCHAR *s;
3217     register IO *io;
3218     register SV *sv;
3219     GV *gv;
3220     STRLEN n_a;
3221     PerlIO *fp;
3222
3223     if (PL_op->op_flags & OPf_REF)
3224         gv = cGVOP_gv;
3225     else if (isGV(TOPs))
3226         gv = (GV*)POPs;
3227     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3228         gv = (GV*)SvRV(POPs);
3229     else
3230         gv = Nullgv;
3231
3232     if (gv) {
3233         EXTEND(SP, 1);
3234         if (gv == PL_defgv) {
3235             if (PL_statgv)
3236                 io = GvIO(PL_statgv);
3237             else {
3238                 sv = PL_statname;
3239                 goto really_filename;
3240             }
3241         }
3242         else {
3243             PL_statgv = gv;
3244             PL_laststatval = -1;
3245             sv_setpv(PL_statname, "");
3246             io = GvIO(PL_statgv);
3247         }
3248         if (io && IoIFP(io)) {
3249             if (! PerlIO_has_base(IoIFP(io)))
3250                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3251             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3252             if (PL_laststatval < 0)
3253                 RETPUSHUNDEF;
3254             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3255                 if (PL_op->op_type == OP_FTTEXT)
3256                     RETPUSHNO;
3257                 else
3258                     RETPUSHYES;
3259             }
3260             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3261                 i = PerlIO_getc(IoIFP(io));
3262                 if (i != EOF)
3263                     (void)PerlIO_ungetc(IoIFP(io),i);
3264             }
3265             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3266                 RETPUSHYES;
3267             len = PerlIO_get_bufsiz(IoIFP(io));
3268             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3269             /* sfio can have large buffers - limit to 512 */
3270             if (len > 512)
3271                 len = 512;
3272         }
3273         else {
3274             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3275                 gv = cGVOP_gv;
3276                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3277             }
3278             SETERRNO(EBADF,RMS$_IFI);
3279             RETPUSHUNDEF;
3280         }
3281     }
3282     else {
3283         sv = POPs;
3284       really_filename:
3285         PL_statgv = Nullgv;
3286         PL_laststatval = -1;
3287         sv_setpv(PL_statname, SvPV(sv, n_a));
3288         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3289             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3290                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3291             RETPUSHUNDEF;
3292         }
3293         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3294         if (PL_laststatval < 0) {
3295             (void)PerlIO_close(fp);
3296             RETPUSHUNDEF;
3297         }
3298         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
3299         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3300         (void)PerlIO_close(fp);
3301         if (len <= 0) {
3302             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3303                 RETPUSHNO;              /* special case NFS directories */
3304             RETPUSHYES;         /* null file is anything */
3305         }
3306         s = tbuf;
3307     }
3308
3309     /* now scan s to look for textiness */
3310     /*   XXX ASCII dependent code */
3311
3312 #if defined(DOSISH) || defined(USEMYBINMODE)
3313     /* ignore trailing ^Z on short files */
3314     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3315         --len;
3316 #endif
3317
3318     for (i = 0; i < len; i++, s++) {
3319         if (!*s) {                      /* null never allowed in text */
3320             odd += len;
3321             break;
3322         }
3323 #ifdef EBCDIC
3324         else if (!(isPRINT(*s) || isSPACE(*s)))
3325             odd++;
3326 #else
3327         else if (*s & 128) {
3328 #ifdef USE_LOCALE
3329             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3330                 continue;
3331 #endif
3332             /* utf8 characters don't count as odd */
3333             if (UTF8_IS_START(*s)) {
3334                 int ulen = UTF8SKIP(s);
3335                 if (ulen < len - i) {
3336                     int j;
3337                     for (j = 1; j < ulen; j++) {
3338                         if (!UTF8_IS_CONTINUATION(s[j]))
3339                             goto not_utf8;
3340                     }
3341                     --ulen;     /* loop does extra increment */
3342                     s += ulen;
3343                     i += ulen;
3344                     continue;
3345                 }
3346             }
3347           not_utf8:
3348             odd++;
3349         }
3350         else if (*s < 32 &&
3351           *s != '\n' && *s != '\r' && *s != '\b' &&
3352           *s != '\t' && *s != '\f' && *s != 27)
3353             odd++;
3354 #endif
3355     }
3356
3357     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3358         RETPUSHNO;
3359     else
3360         RETPUSHYES;
3361 }
3362
3363 PP(pp_ftbinary)
3364 {
3365     return pp_fttext();
3366 }
3367
3368 /* File calls. */
3369
3370 PP(pp_chdir)
3371 {
3372     dSP; dTARGET;
3373     char *tmps;
3374     SV **svp;
3375     STRLEN n_a;
3376
3377     if( MAXARG == 1 )
3378         tmps = POPpx;
3379     else
3380         tmps = 0;
3381
3382     if( !tmps || !*tmps ) {
3383         if (    (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
3384              || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
3385 #ifdef VMS
3386              || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
3387 #endif
3388            )
3389         {
3390             if( MAXARG == 1 )
3391                 deprecate("chdir('') or chdir(undef) as chdir()");
3392             tmps = SvPV(*svp, n_a);
3393         }
3394         else {
3395             PUSHi(0);
3396             RETURN;
3397         }
3398     }
3399
3400     TAINT_PROPER("chdir");
3401     PUSHi( PerlDir_chdir(tmps) >= 0 );
3402 #ifdef VMS
3403     /* Clear the DEFAULT element of ENV so we'll get the new value
3404      * in the future. */
3405     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3406 #endif
3407     RETURN;
3408 }
3409
3410 PP(pp_chown)
3411 {
3412 #ifdef HAS_CHOWN
3413     dSP; dMARK; dTARGET;
3414     I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3415
3416     SP = MARK;
3417     PUSHi(value);
3418     RETURN;
3419 #else
3420     DIE(aTHX_ PL_no_func, "chown");
3421 #endif
3422 }
3423
3424 PP(pp_chroot)
3425 {
3426 #ifdef HAS_CHROOT
3427     dSP; dTARGET;
3428     STRLEN n_a;
3429     char *tmps = POPpx;
3430     TAINT_PROPER("chroot");
3431     PUSHi( chroot(tmps) >= 0 );
3432     RETURN;
3433 #else
3434     DIE(aTHX_ PL_no_func, "chroot");
3435 #endif
3436 }
3437
3438 PP(pp_unlink)
3439 {
3440     dSP; dMARK; dTARGET;
3441     I32 value;
3442     value = (I32)apply(PL_op->op_type, MARK, SP);
3443     SP = MARK;
3444     PUSHi(value);
3445     RETURN;
3446 }
3447
3448 PP(pp_chmod)
3449 {
3450     dSP; dMARK; dTARGET;
3451     I32 value;
3452     value = (I32)apply(PL_op->op_type, MARK, SP);
3453     SP = MARK;
3454     PUSHi(value);
3455     RETURN;
3456 }
3457
3458 PP(pp_utime)
3459 {
3460     dSP; dMARK; dTARGET;
3461     I32 value;
3462     value = (I32)apply(PL_op->op_type, MARK, SP);
3463     SP = MARK;
3464     PUSHi(value);
3465     RETURN;
3466 }
3467
3468 PP(pp_rename)
3469 {
3470     dSP; dTARGET;
3471     int anum;
3472     STRLEN n_a;
3473
3474     char *tmps2 = POPpx;
3475     char *tmps = SvPV(TOPs, n_a);
3476     TAINT_PROPER("rename");
3477 #ifdef HAS_RENAME
3478     anum = PerlLIO_rename(tmps, tmps2);
3479 #else
3480     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3481         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3482             anum = 1;
3483         else {
3484             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3485                 (void)UNLINK(tmps2);
3486             if (!(anum = link(tmps, tmps2)))
3487                 anum = UNLINK(tmps);
3488         }
3489     }
3490 #endif
3491     SETi( anum >= 0 );
3492     RETURN;
3493 }
3494
3495 PP(pp_link)
3496 {
3497     dSP;
3498 #ifdef HAS_LINK
3499     dTARGET;
3500     STRLEN n_a;
3501     char *tmps2 = POPpx;
3502     char *tmps = SvPV(TOPs, n_a);
3503     TAINT_PROPER("link");
3504     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3505     RETURN;
3506 #else
3507     DIE(aTHX_ PL_no_func, "link");
3508 #endif
3509 }
3510
3511 PP(pp_symlink)
3512 {
3513 #ifdef HAS_SYMLINK
3514     dSP; dTARGET;
3515     STRLEN n_a;
3516     char *tmps2 = POPpx;
3517     char *tmps = SvPV(TOPs, n_a);
3518     TAINT_PROPER("symlink");
3519     SETi( symlink(tmps, tmps2) >= 0 );
3520     RETURN;
3521 #else
3522     DIE(aTHX_ PL_no_func, "symlink");
3523 #endif
3524 }
3525
3526 PP(pp_readlink)
3527 {
3528     dSP;
3529 #ifdef HAS_SYMLINK
3530     dTARGET;
3531     char *tmps;
3532     char buf[MAXPATHLEN];
3533     int len;
3534     STRLEN n_a;
3535
3536 #ifndef INCOMPLETE_TAINTS
3537     TAINT;
3538 #endif
3539     tmps = POPpx;
3540     len = readlink(tmps, buf, sizeof(buf) - 1);
3541     EXTEND(SP, 1);
3542     if (len < 0)
3543         RETPUSHUNDEF;
3544     PUSHp(buf, len);
3545     RETURN;
3546 #else
3547     EXTEND(SP, 1);
3548     RETSETUNDEF;                /* just pretend it's a normal file */
3549 #endif
3550 }
3551
3552 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3553 STATIC int
3554 S_dooneliner(pTHX_ char *cmd, char *filename)
3555 {
3556     char *save_filename = filename;
3557     char *cmdline;
3558     char *s;
3559     PerlIO *myfp;
3560     int anum = 1;
3561
3562     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3563     strcpy(cmdline, cmd);
3564     strcat(cmdline, " ");
3565     for (s = cmdline + strlen(cmdline); *filename; ) {
3566         *s++ = '\\';
3567         *s++ = *filename++;
3568     }
3569     strcpy(s, " 2>&1");
3570     myfp = PerlProc_popen(cmdline, "r");
3571     Safefree(cmdline);
3572
3573     if (myfp) {
3574         SV *tmpsv = sv_newmortal();
3575         /* Need to save/restore 'PL_rs' ?? */
3576         s = sv_gets(tmpsv, myfp, 0);
3577         (void)PerlProc_pclose(myfp);
3578         if (s != Nullch) {
3579             int e;
3580             for (e = 1;
3581 #ifdef HAS_SYS_ERRLIST
3582                  e <= sys_nerr
3583 #endif
3584                  ; e++)
3585             {
3586                 /* you don't see this */
3587                 char *errmsg =
3588 #ifdef HAS_SYS_ERRLIST
3589                     sys_errlist[e]
3590 #else
3591                     strerror(e)
3592 #endif
3593                     ;
3594                 if (!errmsg)
3595                     break;
3596                 if (instr(s, errmsg)) {
3597                     SETERRNO(e,0);
3598                     return 0;
3599                 }
3600             }
3601             SETERRNO(0,0);
3602 #ifndef EACCES
3603 #define EACCES EPERM
3604 #endif
3605             if (instr(s, "cannot make"))
3606                 SETERRNO(EEXIST,RMS$_FEX);
3607             else if (instr(s, "existing file"))
3608                 SETERRNO(EEXIST,RMS$_FEX);
3609             else if (instr(s, "ile exists"))
3610                 SETERRNO(EEXIST,RMS$_FEX);
3611             else if (instr(s, "non-exist"))
3612                 SETERRNO(ENOENT,RMS$_FNF);
3613             else if (instr(s, "does not exist"))
3614                 SETERRNO(ENOENT,RMS$_FNF);
3615             else if (instr(s, "not empty"))
3616                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3617             else if (instr(s, "cannot access"))
3618                 SETERRNO(EACCES,RMS$_PRV);
3619             else
3620                 SETERRNO(EPERM,RMS$_PRV);
3621             return 0;
3622         }
3623         else {  /* some mkdirs return no failure indication */
3624             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3625             if (PL_op->op_type == OP_RMDIR)
3626                 anum = !anum;
3627             if (anum)
3628                 SETERRNO(0,0);
3629             else
3630                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3631         }
3632         return anum;
3633     }
3634     else
3635         return 0;
3636 }
3637 #endif
3638
3639 PP(pp_mkdir)
3640 {
3641     dSP; dTARGET;
3642     int mode;
3643 #ifndef HAS_MKDIR
3644     int oldumask;
3645 #endif
3646     STRLEN len;
3647     char *tmps;
3648     bool copy = FALSE;
3649
3650     if (MAXARG > 1)
3651         mode = POPi;
3652     else
3653         mode = 0777;
3654
3655     tmps = SvPV(TOPs, len);
3656     /* Different operating and file systems take differently to
3657      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3658      * any number of trailing slashes should be allowed.
3659      * Thusly we snip them away so that even non-conforming
3660      * systems are happy. */
3661     /* We should probably do this "filtering" for all
3662      * the functions that expect (potentially) directory names:
3663      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3664      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3665     if (len > 1 && tmps[len-1] == '/') {
3666         while (tmps[len] == '/' && len > 1)
3667             len--;
3668         tmps = savepvn(tmps, len);
3669         copy = TRUE;
3670     }
3671
3672     TAINT_PROPER("mkdir");
3673 #ifdef HAS_MKDIR
3674     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3675 #else
3676     SETi( dooneliner("mkdir", tmps) );
3677     oldumask = PerlLIO_umask(0);
3678     PerlLIO_umask(oldumask);
3679     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3680 #endif
3681     if (copy)
3682         Safefree(tmps);
3683     RETURN;
3684 }
3685
3686 PP(pp_rmdir)
3687 {
3688     dSP; dTARGET;
3689     char *tmps;
3690     STRLEN n_a;
3691
3692     tmps = POPpx;
3693     TAINT_PROPER("rmdir");
3694 #ifdef HAS_RMDIR
3695     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3696 #else
3697     XPUSHi( dooneliner("rmdir", tmps) );
3698 #endif
3699     RETURN;
3700 }
3701
3702 /* Directory calls. */
3703
3704 PP(pp_open_dir)
3705 {
3706 #if defined(Direntry_t) && defined(HAS_READDIR)
3707     dSP;
3708     STRLEN n_a;
3709     char *dirname = POPpx;
3710     GV *gv = (GV*)POPs;
3711     register IO *io = GvIOn(gv);
3712
3713     if (!io)
3714         goto nope;
3715
3716     if (IoDIRP(io))
3717         PerlDir_close(IoDIRP(io));
3718     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3719         goto nope;
3720
3721     RETPUSHYES;
3722 nope:
3723     if (!errno)
3724         SETERRNO(EBADF,RMS$_DIR);
3725     RETPUSHUNDEF;
3726 #else
3727     DIE(aTHX_ PL_no_dir_func, "opendir");
3728 #endif
3729 }
3730
3731 PP(pp_readdir)
3732 {
3733 #if defined(Direntry_t) && defined(HAS_READDIR)
3734     dSP;
3735 #if !defined(I_DIRENT) && !defined(VMS)
3736     Direntry_t *readdir (DIR *);
3737 #endif
3738     register Direntry_t *dp;
3739     GV *gv = (GV*)POPs;
3740     register IO *io = GvIOn(gv);
3741     SV *sv;
3742
3743     if (!io || !IoDIRP(io))
3744         goto nope;
3745
3746     if (GIMME == G_ARRAY) {
3747         /*SUPPRESS 560*/
3748         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3749 #ifdef DIRNAMLEN
3750             sv = newSVpvn(dp->d_name, dp->d_namlen);
3751 #else
3752             sv = newSVpv(dp->d_name, 0);
3753 #endif
3754 #ifndef INCOMPLETE_TAINTS
3755             if (!(IoFLAGS(io) & IOf_UNTAINT))
3756                 SvTAINTED_on(sv);
3757 #endif
3758             XPUSHs(sv_2mortal(sv));
3759         }
3760     }
3761     else {
3762         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3763             goto nope;
3764 #ifdef DIRNAMLEN
3765         sv = newSVpvn(dp->d_name, dp->d_namlen);
3766 #else
3767         sv = newSVpv(dp->d_name, 0);
3768 #endif
3769 #ifndef INCOMPLETE_TAINTS
3770         if (!(IoFLAGS(io) & IOf_UNTAINT))
3771             SvTAINTED_on(sv);
3772 #endif
3773         XPUSHs(sv_2mortal(sv));
3774     }
3775     RETURN;
3776
3777 nope:
3778     if (!errno)
3779         SETERRNO(EBADF,RMS$_ISI);
3780     if (GIMME == G_ARRAY)
3781         RETURN;
3782     else
3783         RETPUSHUNDEF;
3784 #else
3785     DIE(aTHX_ PL_no_dir_func, "readdir");
3786 #endif
3787 }
3788
3789 PP(pp_telldir)
3790 {
3791 #if defined(HAS_TELLDIR) || defined(telldir)
3792     dSP; dTARGET;
3793  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3794  /* XXX netbsd still seemed to.
3795     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3796     --JHI 1999-Feb-02 */
3797 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3798     long telldir (DIR *);
3799 # endif
3800     GV *gv = (GV*)POPs;
3801     register IO *io = GvIOn(gv);
3802
3803     if (!io || !IoDIRP(io))
3804         goto nope;
3805
3806     PUSHi( PerlDir_tell(IoDIRP(io)) );
3807     RETURN;
3808 nope:
3809     if (!errno)
3810         SETERRNO(EBADF,RMS$_ISI);
3811     RETPUSHUNDEF;
3812 #else
3813     DIE(aTHX_ PL_no_dir_func, "telldir");
3814 #endif
3815 }
3816
3817 PP(pp_seekdir)
3818 {
3819 #if defined(HAS_SEEKDIR) || defined(seekdir)
3820     dSP;
3821     long along = POPl;
3822     GV *gv = (GV*)POPs;
3823     register IO *io = GvIOn(gv);
3824
3825     if (!io || !IoDIRP(io))
3826         goto nope;
3827
3828     (void)PerlDir_seek(IoDIRP(io), along);
3829
3830     RETPUSHYES;
3831 nope:
3832     if (!errno)
3833         SETERRNO(EBADF,RMS$_ISI);
3834     RETPUSHUNDEF;
3835 #else
3836     DIE(aTHX_ PL_no_dir_func, "seekdir");
3837 #endif
3838 }
3839
3840 PP(pp_rewinddir)
3841 {
3842 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3843     dSP;
3844     GV *gv = (GV*)POPs;
3845     register IO *io = GvIOn(gv);
3846
3847     if (!io || !IoDIRP(io))
3848         goto nope;
3849
3850     (void)PerlDir_rewind(IoDIRP(io));
3851     RETPUSHYES;
3852 nope:
3853     if (!errno)
3854         SETERRNO(EBADF,RMS$_ISI);
3855     RETPUSHUNDEF;
3856 #else
3857     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3858 #endif
3859 }
3860
3861 PP(pp_closedir)
3862 {
3863 #if defined(Direntry_t) && defined(HAS_READDIR)
3864     dSP;
3865     GV *gv = (GV*)POPs;
3866     register IO *io = GvIOn(gv);
3867
3868     if (!io || !IoDIRP(io))
3869         goto nope;
3870
3871 #ifdef VOID_CLOSEDIR
3872     PerlDir_close(IoDIRP(io));
3873 #else
3874     if (PerlDir_close(IoDIRP(io)) < 0) {
3875         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3876         goto nope;
3877     }
3878 #endif
3879     IoDIRP(io) = 0;
3880
3881     RETPUSHYES;
3882 nope:
3883     if (!errno)
3884         SETERRNO(EBADF,RMS$_IFI);
3885     RETPUSHUNDEF;
3886 #else
3887     DIE(aTHX_ PL_no_dir_func, "closedir");
3888 #endif
3889 }
3890
3891 /* Process control. */
3892
3893 PP(pp_fork)
3894 {
3895 #ifdef HAS_FORK
3896     dSP; dTARGET;
3897     Pid_t childpid;
3898     GV *tmpgv;
3899
3900     EXTEND(SP, 1);
3901     PERL_FLUSHALL_FOR_CHILD;
3902     childpid = PerlProc_fork();
3903     if (childpid < 0)
3904         RETSETUNDEF;
3905     if (!childpid) {
3906         /*SUPPRESS 560*/
3907         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3908             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3909         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3910     }
3911     PUSHi(childpid);
3912     RETURN;
3913 #else
3914 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3915     dSP; dTARGET;
3916     Pid_t childpid;
3917
3918     EXTEND(SP, 1);
3919     PERL_FLUSHALL_FOR_CHILD;
3920     childpid = PerlProc_fork();
3921     if (childpid == -1)
3922         RETSETUNDEF;
3923     PUSHi(childpid);
3924     RETURN;
3925 #  else
3926     DIE(aTHX_ PL_no_func, "fork");
3927 #  endif
3928 #endif
3929 }
3930
3931 PP(pp_wait)
3932 {
3933 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3934     dSP; dTARGET;
3935     Pid_t childpid;
3936     int argflags;
3937
3938 #ifdef PERL_OLD_SIGNALS
3939     childpid = wait4pid(-1, &argflags, 0);
3940 #else
3941     while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3942         PERL_ASYNC_CHECK();
3943     }
3944 #endif
3945 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3946     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3947     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3948 #  else
3949     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3950 #  endif
3951     XPUSHi(childpid);
3952     RETURN;
3953 #else
3954     DIE(aTHX_ PL_no_func, "wait");
3955 #endif
3956 }
3957
3958 PP(pp_waitpid)
3959 {
3960 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3961     dSP; dTARGET;
3962     Pid_t childpid;
3963     int optype;
3964     int argflags;
3965
3966     optype = POPi;
3967     childpid = TOPi;
3968 #ifdef PERL_OLD_SIGNALS
3969     childpid = wait4pid(childpid, &argflags, optype);
3970 #else
3971     while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
3972         PERL_ASYNC_CHECK();
3973     }
3974 #endif
3975 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3976     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3977     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3978 #  else
3979     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3980 #  endif
3981     SETi(childpid);
3982     RETURN;
3983 #else
3984     DIE(aTHX_ PL_no_func, "waitpid");
3985 #endif
3986 }
3987
3988 PP(pp_system)
3989 {
3990     dSP; dMARK; dORIGMARK; dTARGET;
3991     I32 value;
3992     STRLEN n_a;
3993     int result;
3994     int pp[2];
3995     I32 did_pipes = 0;
3996
3997     if (SP - MARK == 1) {
3998         if (PL_tainting) {
3999             (void)SvPV_nolen(TOPs);      /* stringify for taint check */
4000             TAINT_ENV();
4001             TAINT_PROPER("system");
4002         }
4003     }
4004     PERL_FLUSHALL_FOR_CHILD;
4005 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4006     {
4007          Pid_t childpid;
4008          int status;
4009          Sigsave_t ihand,qhand;     /* place to save signals during system() */
4010
4011          if (PerlProc_pipe(pp) >= 0)
4012               did_pipes = 1;
4013          while ((childpid = PerlProc_fork()) == -1) {
4014               if (errno != EAGAIN) {
4015                    value = -1;
4016                    SP = ORIGMARK;
4017                    PUSHi(value);
4018                    if (did_pipes) {
4019                         PerlLIO_close(pp[0]);
4020                         PerlLIO_close(pp[1]);
4021                    }
4022                    RETURN;
4023               }
4024               sleep(5);
4025          }
4026          if (childpid > 0) {
4027               if (did_pipes)
4028                    PerlLIO_close(pp[1]);
4029 #ifndef PERL_MICRO
4030               rsignal_save(SIGINT, SIG_IGN, &ihand);
4031               rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4032 #endif
4033               do {
4034                    result = wait4pid(childpid, &status, 0);
4035               } while (result == -1 && errno == EINTR);
4036 #ifndef PERL_MICRO
4037               (void)rsignal_restore(SIGINT, &ihand);
4038               (void)rsignal_restore(SIGQUIT, &qhand);
4039 #endif
4040               STATUS_NATIVE_SET(result == -1 ? -1 : status);
4041               do_execfree();    /* free any memory child malloced on fork */
4042               SP = ORIGMARK;
4043               if (did_pipes) {
4044                    int errkid;
4045                    int n = 0, n1;
4046
4047                    while (n < sizeof(int)) {
4048                         n1 = PerlLIO_read(pp[0],
4049                                           (void*)(((char*)&errkid)+n),
4050                                           (sizeof(int)) - n);
4051                         if (n1 <= 0)
4052                              break;
4053                         n += n1;
4054                    }
4055                    PerlLIO_close(pp[0]);
4056                    if (n) {                     /* Error */
4057                         if (n != sizeof(int))
4058                              DIE(aTHX_ "panic: kid popen errno read");
4059                         errno = errkid;         /* Propagate errno from kid */
4060                         STATUS_CURRENT = -1;
4061                    }
4062               }
4063               PUSHi(STATUS_CURRENT);
4064               RETURN;
4065          }
4066          if (did_pipes) {
4067               PerlLIO_close(pp[0]);
4068 #if defined(HAS_FCNTL) && defined(F_SETFD)
4069               fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4070 #endif
4071          }
4072     }
4073     if (PL_op->op_flags & OPf_STACKED) {
4074         SV *really = *++MARK;
4075         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4076     }
4077     else if (SP - MARK != 1)
4078         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4079     else {
4080         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4081     }
4082     PerlProc__exit(-1);
4083 #else /* ! FORK or VMS or OS/2 */
4084     PL_statusvalue = 0;
4085     result = 0;
4086     if (PL_op->op_flags & OPf_STACKED) {
4087         SV *really = *++MARK;
4088         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4089     }
4090     else if (SP - MARK != 1)
4091         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4092     else {
4093         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4094     }
4095     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4096         result = 1;
4097     STATUS_NATIVE_SET(value);
4098     do_execfree();
4099     SP = ORIGMARK;
4100     PUSHi(result ? value : STATUS_CURRENT);
4101 #endif /* !FORK or VMS */
4102     RETURN;
4103 }
4104
4105 PP(pp_exec)
4106 {
4107     dSP; dMARK; dORIGMARK; dTARGET;
4108     I32 value;
4109     STRLEN n_a;
4110
4111     PERL_FLUSHALL_FOR_CHILD;
4112     if (PL_op->op_flags & OPf_STACKED) {
4113         SV *really = *++MARK;
4114         value = (I32)do_aexec(really, MARK, SP);
4115     }
4116     else if (SP - MARK != 1)
4117 #ifdef VMS
4118         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4119 #else
4120 #  ifdef __OPEN_VM
4121         {
4122            (void ) do_aspawn(Nullsv, MARK, SP);
4123            value = 0;
4124         }
4125 #  else
4126         value = (I32)do_aexec(Nullsv, MARK, SP);
4127 #  endif
4128 #endif
4129     else {
4130         if (PL_tainting) {
4131             (void)SvPV_nolen(*SP);      /* stringify for taint check */
4132             TAINT_ENV();
4133             TAINT_PROPER("exec");
4134         }
4135 #ifdef VMS
4136         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4137 #else
4138 #  ifdef __OPEN_VM
4139         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4140         value = 0;
4141 #  else
4142         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4143 #  endif
4144 #endif
4145     }
4146
4147     SP = ORIGMARK;
4148     PUSHi(value);
4149     RETURN;
4150 }
4151
4152 PP(pp_kill)
4153 {
4154 #ifdef HAS_KILL
4155     dSP; dMARK; dTARGET;
4156     I32 value;
4157     value = (I32)apply(PL_op->op_type, MARK, SP);
4158     SP = MARK;
4159     PUSHi(value);
4160     RETURN;
4161 #else
4162     DIE(aTHX_ PL_no_func, "kill");
4163 #endif
4164 }
4165
4166 PP(pp_getppid)
4167 {
4168 #ifdef HAS_GETPPID
4169     dSP; dTARGET;
4170     XPUSHi( getppid() );
4171     RETURN;
4172 #else
4173     DIE(aTHX_ PL_no_func, "getppid");
4174 #endif
4175 }
4176
4177 PP(pp_getpgrp)
4178 {
4179 #ifdef HAS_GETPGRP
4180     dSP; dTARGET;
4181     Pid_t pid;
4182     Pid_t pgrp;
4183
4184     if (MAXARG < 1)
4185         pid = 0;
4186     else
4187         pid = SvIVx(POPs);
4188 #ifdef BSD_GETPGRP
4189     pgrp = (I32)BSD_GETPGRP(pid);
4190 #else
4191     if (pid != 0 && pid != PerlProc_getpid())
4192         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4193     pgrp = getpgrp();
4194 #endif
4195     XPUSHi(pgrp);
4196     RETURN;
4197 #else
4198     DIE(aTHX_ PL_no_func, "getpgrp()");
4199 #endif
4200 }
4201
4202 PP(pp_setpgrp)
4203 {
4204 #ifdef HAS_SETPGRP
4205     dSP; dTARGET;
4206     Pid_t pgrp;
4207     Pid_t pid;
4208     if (MAXARG < 2) {
4209         pgrp = 0;
4210         pid = 0;
4211     }
4212     else {
4213         pgrp = POPi;
4214         pid = TOPi;
4215     }
4216
4217     TAINT_PROPER("setpgrp");
4218 #ifdef BSD_SETPGRP
4219     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4220 #else
4221     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4222         || (pid != 0 && pid != PerlProc_getpid()))
4223     {
4224         DIE(aTHX_ "setpgrp can't take arguments");
4225     }
4226     SETi( setpgrp() >= 0 );
4227 #endif /* USE_BSDPGRP */
4228     RETURN;
4229 #else
4230     DIE(aTHX_ PL_no_func, "setpgrp()");
4231 #endif
4232 }
4233
4234 PP(pp_getpriority)
4235 {
4236 #ifdef HAS_GETPRIORITY
4237     dSP; dTARGET;
4238     int who = POPi;
4239     int which = TOPi;
4240     SETi( getpriority(which, who) );
4241     RETURN;
4242 #else
4243     DIE(aTHX_ PL_no_func, "getpriority()");
4244 #endif
4245 }
4246
4247 PP(pp_setpriority)
4248 {
4249 #ifdef HAS_SETPRIORITY
4250     dSP; dTARGET;
4251     int niceval = POPi;
4252     int who = POPi;
4253     int which = TOPi;
4254     TAINT_PROPER("setpriority");
4255     SETi( setpriority(which, who, niceval) >= 0 );
4256     RETURN;
4257 #else
4258     DIE(aTHX_ PL_no_func, "setpriority()");
4259 #endif
4260 }
4261
4262 /* Time calls. */
4263
4264 PP(pp_time)
4265 {
4266     dSP; dTARGET;
4267 #ifdef BIG_TIME
4268     XPUSHn( time(Null(Time_t*)) );
4269 #else
4270     XPUSHi( time(Null(Time_t*)) );
4271 #endif
4272     RETURN;
4273 }
4274
4275 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4276    to HZ.  Probably.  For now, assume that if the system
4277    defines HZ, it does so correctly.  (Will this break
4278    on VMS?)
4279    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4280    it's supported.    --AD  9/96.
4281 */
4282
4283 #ifndef HZ
4284 #  ifdef CLK_TCK
4285 #    define HZ CLK_TCK
4286 #  else
4287 #    define HZ 60
4288 #  endif
4289 #endif
4290
4291 PP(pp_tms)
4292 {
4293 #ifdef HAS_TIMES
4294     dSP;
4295     EXTEND(SP, 4);
4296 #ifndef VMS
4297     (void)PerlProc_times(&PL_timesbuf);
4298 #else
4299     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4300                                                    /* struct tms, though same data   */
4301                                                    /* is returned.                   */
4302 #endif
4303
4304     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4305     if (GIMME == G_ARRAY) {
4306         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4307         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4308         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4309     }
4310     RETURN;
4311 #else
4312     DIE(aTHX_ "times not implemented");
4313 #endif /* HAS_TIMES */
4314 }
4315
4316 PP(pp_localtime)
4317 {
4318     return pp_gmtime();
4319 }
4320
4321 PP(pp_gmtime)
4322 {
4323     dSP;
4324     Time_t when;
4325     struct tm *tmbuf;
4326     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4327     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4328                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4329
4330     if (MAXARG < 1)
4331         (void)time(&when);
4332     else
4333 #ifdef BIG_TIME
4334         when = (Time_t)SvNVx(POPs);
4335 #else
4336         when = (Time_t)SvIVx(POPs);
4337 #endif
4338
4339     if (PL_op->op_type == OP_LOCALTIME)
4340         tmbuf = localtime(&when);
4341     else
4342         tmbuf = gmtime(&when);
4343
4344     if (GIMME != G_ARRAY) {
4345         SV *tsv;
4346         EXTEND(SP, 1);
4347         EXTEND_MORTAL(1);
4348         if (!tmbuf)
4349             RETPUSHUNDEF;
4350         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4351                             dayname[tmbuf->tm_wday],
4352                             monname[tmbuf->tm_mon],
4353                             tmbuf->tm_mday,
4354                             tmbuf->tm_hour,
4355                             tmbuf->tm_min,
4356                             tmbuf->tm_sec,
4357                             tmbuf->tm_year + 1900);
4358         PUSHs(sv_2mortal(tsv));
4359     }
4360     else if (tmbuf) {
4361         EXTEND(SP, 9);
4362         EXTEND_MORTAL(9);
4363         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4364         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4365         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4366         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4367         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4368         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4369         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4370         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4371         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4372     }
4373     RETURN;
4374 }
4375
4376 PP(pp_alarm)
4377 {
4378 #ifdef HAS_ALARM
4379     dSP; dTARGET;
4380     int anum;
4381     anum = POPi;
4382     anum = alarm((unsigned int)anum);
4383     EXTEND(SP, 1);
4384     if (anum < 0)
4385         RETPUSHUNDEF;
4386     PUSHi(anum);
4387     RETURN;
4388 #else
4389     DIE(aTHX_ PL_no_func, "alarm");
4390 #endif
4391 }
4392
4393 PP(pp_sleep)
4394 {
4395     dSP; dTARGET;
4396     I32 duration;
4397     Time_t lasttime;
4398     Time_t when;
4399
4400     (void)time(&lasttime);
4401     if (MAXARG < 1)
4402         PerlProc_pause();
4403     else {
4404         duration = POPi;
4405         PerlProc_sleep((unsigned int)duration);
4406     }
4407     (void)time(&when);
4408     XPUSHi(when - lasttime);
4409     RETURN;
4410 }
4411
4412 /* Shared memory. */
4413
4414 PP(pp_shmget)
4415 {
4416     return pp_semget();
4417 }
4418
4419 PP(pp_shmctl)
4420 {
4421     return pp_semctl();
4422 }
4423
4424 PP(pp_shmread)
4425 {
4426     return pp_shmwrite();
4427 }
4428
4429 PP(pp_shmwrite)
4430 {
4431 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4432     dSP; dMARK; dTARGET;
4433     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4434     SP = MARK;
4435     PUSHi(value);
4436     RETURN;
4437 #else
4438     return pp_semget();
4439 #endif
4440 }
4441
4442 /* Message passing. */
4443
4444 PP(pp_msgget)
4445 {
4446     return pp_semget();
4447 }
4448
4449 PP(pp_msgctl)
4450 {
4451     return pp_semctl();
4452 }
4453
4454 PP(pp_msgsnd)
4455 {
4456 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4457     dSP; dMARK; dTARGET;
4458     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4459     SP = MARK;
4460     PUSHi(value);
4461     RETURN;
4462 #else
4463     return pp_semget();
4464 #endif
4465 }
4466
4467 PP(pp_msgrcv)
4468 {
4469 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4470     dSP; dMARK; dTARGET;
4471     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4472     SP = MARK;
4473     PUSHi(value);
4474     RETURN;
4475 #else
4476     return pp_semget();
4477 #endif
4478 }
4479
4480 /* Semaphores. */
4481
4482 PP(pp_semget)
4483 {
4484 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4485     dSP; dMARK; dTARGET;
4486     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4487     SP = MARK;
4488     if (anum == -1)
4489         RETPUSHUNDEF;
4490     PUSHi(anum);
4491     RETURN;
4492 #else
4493     DIE(aTHX_ "System V IPC is not implemented on this machine");
4494 #endif
4495 }
4496
4497 PP(pp_semctl)
4498 {
4499 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4500     dSP; dMARK; dTARGET;
4501     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4502     SP = MARK;
4503     if (anum == -1)
4504         RETSETUNDEF;
4505     if (anum != 0) {
4506         PUSHi(anum);
4507     }
4508     else {
4509         PUSHp(zero_but_true, ZBTLEN);
4510     }
4511     RETURN;
4512 #else
4513     return pp_semget();
4514 #endif
4515 }
4516
4517 PP(pp_semop)
4518 {
4519 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4520     dSP; dMARK; dTARGET;
4521     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4522     SP = MARK;
4523     PUSHi(value);
4524     RETURN;
4525 #else
4526     return pp_semget();
4527 #endif
4528 }
4529
4530 /* Get system info. */
4531
4532 PP(pp_ghbyname)
4533 {
4534 #ifdef HAS_GETHOSTBYNAME
4535     return pp_ghostent();
4536 #else
4537     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4538 #endif
4539 }
4540
4541 PP(pp_ghbyaddr)
4542 {
4543 #ifdef HAS_GETHOSTBYADDR
4544     return pp_ghostent();
4545 #else
4546     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4547 #endif
4548 }
4549
4550 PP(pp_ghostent)
4551 {
4552 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4553     dSP;
4554     I32 which = PL_op->op_type;
4555     register char **elem;
4556     register SV *sv;
4557 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4558     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4559     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4560     struct hostent *PerlSock_gethostent(void);
4561 #endif
4562     struct hostent *hent;
4563     unsigned long len;
4564     STRLEN n_a;
4565
4566     EXTEND(SP, 10);
4567     if (which == OP_GHBYNAME)
4568 #ifdef HAS_GETHOSTBYNAME
4569         hent = PerlSock_gethostbyname(POPpbytex);
4570 #else
4571         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4572 #endif
4573     else if (which == OP_GHBYADDR) {
4574 #ifdef HAS_GETHOSTBYADDR
4575         int addrtype = POPi;
4576         SV *addrsv = POPs;
4577         STRLEN addrlen;
4578         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4579
4580         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4581 #else
4582         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4583 #endif
4584     }
4585     else
4586 #ifdef HAS_GETHOSTENT
4587         hent = PerlSock_gethostent();
4588 #else
4589         DIE(aTHX_ PL_no_sock_func, "gethostent");
4590 #endif
4591
4592 #ifdef HOST_NOT_FOUND
4593     if (!hent)
4594         STATUS_NATIVE_SET(h_errno);
4595 #endif
4596
4597     if (GIMME != G_ARRAY) {
4598         PUSHs(sv = sv_newmortal());
4599         if (hent) {
4600             if (which == OP_GHBYNAME) {
4601                 if (hent->h_addr)
4602                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4603             }
4604             else
4605                 sv_setpv(sv, (char*)hent->h_name);
4606         }
4607         RETURN;
4608     }
4609
4610     if (hent) {
4611         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4612         sv_setpv(sv, (char*)hent->h_name);
4613         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4614         for (elem = hent->h_aliases; elem && *elem; elem++) {
4615             sv_catpv(sv, *elem);
4616             if (elem[1])
4617                 sv_catpvn(sv, " ", 1);
4618         }
4619         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4620         sv_setiv(sv, (IV)hent->h_addrtype);
4621         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4622         len = hent->h_length;
4623         sv_setiv(sv, (IV)len);
4624 #ifdef h_addr
4625         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4626             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4627             sv_setpvn(sv, *elem, len);
4628         }
4629 #else
4630         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4631         if (hent->h_addr)
4632             sv_setpvn(sv, hent->h_addr, len);
4633 #endif /* h_addr */
4634     }
4635     RETURN;
4636 #else
4637     DIE(aTHX_ PL_no_sock_func, "gethostent");
4638 #endif
4639 }
4640
4641 PP(pp_gnbyname)
4642 {
4643 #ifdef HAS_GETNETBYNAME
4644     return pp_gnetent();
4645 #else
4646     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4647 #endif
4648 }
4649
4650 PP(pp_gnbyaddr)
4651 {
4652 #ifdef HAS_GETNETBYADDR
4653     return pp_gnetent();
4654 #else
4655     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4656 #endif
4657 }
4658
4659 PP(pp_gnetent)
4660 {
4661 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4662     dSP;
4663     I32 which = PL_op->op_type;
4664     register char **elem;
4665     register SV *sv;
4666 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4667     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4668     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4669     struct netent *PerlSock_getnetent(void);
4670 #endif
4671     struct netent *nent;
4672     STRLEN n_a;
4673
4674     if (which == OP_GNBYNAME)
4675 #ifdef HAS_GETNETBYNAME
4676         nent = PerlSock_getnetbyname(POPpbytex);
4677 #else
4678         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4679 #endif
4680     else if (which == OP_GNBYADDR) {
4681 #ifdef HAS_GETNETBYADDR
4682         int addrtype = POPi;
4683         Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4684         nent = PerlSock_getnetbyaddr(addr, addrtype);
4685 #else
4686         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4687 #endif
4688     }
4689     else
4690 #ifdef HAS_GETNETENT
4691         nent = PerlSock_getnetent();
4692 #else
4693         DIE(aTHX_ PL_no_sock_func, "getnetent");
4694 #endif
4695
4696     EXTEND(SP, 4);
4697     if (GIMME != G_ARRAY) {
4698         PUSHs(sv = sv_newmortal());
4699         if (nent) {
4700             if (which == OP_GNBYNAME)
4701                 sv_setiv(sv, (IV)nent->n_net);
4702             else
4703                 sv_setpv(sv, nent->n_name);
4704         }
4705         RETURN;
4706     }
4707
4708     if (nent) {
4709         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4710         sv_setpv(sv, nent->n_name);
4711         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4712         for (elem = nent->n_aliases; elem && *elem; elem++) {
4713             sv_catpv(sv, *elem);
4714             if (elem[1])
4715                 sv_catpvn(sv, " ", 1);
4716         }
4717         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4718         sv_setiv(sv, (IV)nent->n_addrtype);
4719         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4720         sv_setiv(sv, (IV)nent->n_net);
4721     }
4722
4723     RETURN;
4724 #else
4725     DIE(aTHX_ PL_no_sock_func, "getnetent");
4726 #endif
4727 }
4728
4729 PP(pp_gpbyname)
4730 {
4731 #ifdef HAS_GETPROTOBYNAME
4732     return pp_gprotoent();
4733 #else
4734     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4735 #endif
4736 }
4737
4738 PP(pp_gpbynumber)
4739 {
4740 #ifdef HAS_GETPROTOBYNUMBER
4741     return pp_gprotoent();
4742 #else
4743     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4744 #endif
4745 }
4746
4747 PP(pp_gprotoent)
4748 {
4749 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4750     dSP;
4751     I32 which = PL_op->op_type;
4752     register char **elem;
4753     register SV *sv;
4754 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4755     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4756     struct protoent *PerlSock_getprotobynumber(int);
4757     struct protoent *PerlSock_getprotoent(void);
4758 #endif
4759     struct protoent *pent;
4760     STRLEN n_a;
4761
4762     if (which == OP_GPBYNAME)
4763 #ifdef HAS_GETPROTOBYNAME
4764         pent = PerlSock_getprotobyname(POPpbytex);
4765 #else
4766         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4767 #endif
4768     else if (which == OP_GPBYNUMBER)
4769 #ifdef HAS_GETPROTOBYNUMBER
4770         pent = PerlSock_getprotobynumber(POPi);
4771 #else
4772     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4773 #endif
4774     else
4775 #ifdef HAS_GETPROTOENT
4776         pent = PerlSock_getprotoent();
4777 #else
4778         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4779 #endif
4780
4781     EXTEND(SP, 3);
4782     if (GIMME != G_ARRAY) {
4783         PUSHs(sv = sv_newmortal());
4784         if (pent) {
4785             if (which == OP_GPBYNAME)
4786                 sv_setiv(sv, (IV)pent->p_proto);
4787             else
4788                 sv_setpv(sv, pent->p_name);
4789         }
4790         RETURN;
4791     }
4792
4793     if (pent) {
4794         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4795         sv_setpv(sv, pent->p_name);
4796         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4797         for (elem = pent->p_aliases; elem && *elem; elem++) {
4798             sv_catpv(sv, *elem);
4799             if (elem[1])
4800                 sv_catpvn(sv, " ", 1);
4801         }
4802         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4803         sv_setiv(sv, (IV)pent->p_proto);
4804     }
4805
4806     RETURN;
4807 #else
4808     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4809 #endif
4810 }
4811
4812 PP(pp_gsbyname)
4813 {
4814 #ifdef HAS_GETSERVBYNAME
4815     return pp_gservent();
4816 #else
4817     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4818 #endif
4819 }
4820
4821 PP(pp_gsbyport)
4822 {
4823 #ifdef HAS_GETSERVBYPORT
4824     return pp_gservent();
4825 #else
4826     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4827 #endif
4828 }
4829
4830 PP(pp_gservent)
4831 {
4832 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4833     dSP;
4834     I32 which = PL_op->op_type;
4835     register char **elem;
4836     register SV *sv;
4837 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4838     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4839     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4840     struct servent *PerlSock_getservent(void);
4841 #endif
4842     struct servent *sent;
4843     STRLEN n_a;
4844
4845     if (which == OP_GSBYNAME) {
4846 #ifdef HAS_GETSERVBYNAME
4847         char *proto = POPpbytex;
4848         char *name = POPpbytex;
4849
4850         if (proto && !*proto)
4851             proto = Nullch;
4852
4853         sent = PerlSock_getservbyname(name, proto);
4854 #else
4855         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4856 #endif
4857     }
4858     else if (which == OP_GSBYPORT) {
4859 #ifdef HAS_GETSERVBYPORT
4860         char *proto = POPpbytex;
4861         unsigned short port = POPu;
4862
4863 #ifdef HAS_HTONS
4864         port = PerlSock_htons(port);
4865 #endif
4866         sent = PerlSock_getservbyport(port, proto);
4867 #else
4868         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4869 #endif
4870     }
4871     else
4872 #ifdef HAS_GETSERVENT
4873         sent = PerlSock_getservent();
4874 #else
4875         DIE(aTHX_ PL_no_sock_func, "getservent");
4876 #endif
4877
4878     EXTEND(SP, 4);
4879     if (GIMME != G_ARRAY) {
4880         PUSHs(sv = sv_newmortal());
4881         if (sent) {
4882             if (which == OP_GSBYNAME) {
4883 #ifdef HAS_NTOHS
4884                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4885 #else
4886                 sv_setiv(sv, (IV)(sent->s_port));
4887 #endif
4888             }
4889             else
4890                 sv_setpv(sv, sent->s_name);
4891         }
4892         RETURN;
4893     }
4894
4895     if (sent) {
4896         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4897         sv_setpv(sv, sent->s_name);
4898         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4899         for (elem = sent->s_aliases; elem && *elem; elem++) {
4900             sv_catpv(sv, *elem);
4901             if (elem[1])
4902                 sv_catpvn(sv, " ", 1);
4903         }
4904         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4905 #ifdef HAS_NTOHS
4906         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4907 #else
4908         sv_setiv(sv, (IV)(sent->s_port));
4909 #endif
4910         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4911         sv_setpv(sv, sent->s_proto);
4912     }
4913
4914     RETURN;
4915 #else
4916     DIE(aTHX_ PL_no_sock_func, "getservent");
4917 #endif
4918 }
4919
4920 PP(pp_shostent)
4921 {
4922 #ifdef HAS_SETHOSTENT
4923     dSP;
4924     PerlSock_sethostent(TOPi);
4925     RETSETYES;
4926 #else
4927     DIE(aTHX_ PL_no_sock_func, "sethostent");
4928 #endif
4929 }
4930
4931 PP(pp_snetent)
4932 {
4933 #ifdef HAS_SETNETENT
4934     dSP;
4935     PerlSock_setnetent(TOPi);
4936     RETSETYES;
4937 #else
4938     DIE(aTHX_ PL_no_sock_func, "setnetent");
4939 #endif
4940 }
4941
4942 PP(pp_sprotoent)
4943 {
4944 #ifdef HAS_SETPROTOENT
4945     dSP;
4946     PerlSock_setprotoent(TOPi);
4947     RETSETYES;
4948 #else
4949     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4950 #endif
4951 }
4952
4953 PP(pp_sservent)
4954 {
4955 #ifdef HAS_SETSERVENT
4956     dSP;
4957     PerlSock_setservent(TOPi);
4958     RETSETYES;
4959 #else
4960     DIE(aTHX_ PL_no_sock_func, "setservent");
4961 #endif
4962 }
4963
4964 PP(pp_ehostent)
4965 {
4966 #ifdef HAS_ENDHOSTENT
4967     dSP;
4968     PerlSock_endhostent();
4969     EXTEND(SP,1);
4970     RETPUSHYES;
4971 #else
4972     DIE(aTHX_ PL_no_sock_func, "endhostent");
4973 #endif
4974 }
4975
4976 PP(pp_enetent)
4977 {
4978 #ifdef HAS_ENDNETENT
4979     dSP;
4980     PerlSock_endnetent();
4981     EXTEND(SP,1);
4982     RETPUSHYES;
4983 #else
4984     DIE(aTHX_ PL_no_sock_func, "endnetent");
4985 #endif
4986 }
4987
4988 PP(pp_eprotoent)
4989 {
4990 #ifdef HAS_ENDPROTOENT
4991     dSP;
4992     PerlSock_endprotoent();
4993     EXTEND(SP,1);
4994     RETPUSHYES;
4995 #else
4996     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4997 #endif
4998 }
4999
5000 PP(pp_eservent)
5001 {
5002 #ifdef HAS_ENDSERVENT
5003     dSP;
5004     PerlSock_endservent();
5005     EXTEND(SP,1);
5006     RETPUSHYES;
5007 #else
5008     DIE(aTHX_ PL_no_sock_func, "endservent");
5009 #endif
5010 }
5011
5012 PP(pp_gpwnam)
5013 {
5014 #ifdef HAS_PASSWD
5015     return pp_gpwent();
5016 #else
5017     DIE(aTHX_ PL_no_func, "getpwnam");
5018 #endif
5019 }
5020
5021 PP(pp_gpwuid)
5022 {
5023 #ifdef HAS_PASSWD
5024     return pp_gpwent();
5025 #else
5026     DIE(aTHX_ PL_no_func, "getpwuid");
5027 #endif
5028 }
5029
5030 PP(pp_gpwent)
5031 {
5032 #ifdef HAS_PASSWD
5033     dSP;
5034     I32 which = PL_op->op_type;
5035     register SV *sv;
5036     STRLEN n_a;
5037     struct passwd *pwent  = NULL;
5038     /*
5039      * We currently support only the SysV getsp* shadow password interface.
5040      * The interface is declared in <shadow.h> and often one needs to link
5041      * with -lsecurity or some such.
5042      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5043      * (and SCO?)
5044      *
5045      * AIX getpwnam() is clever enough to return the encrypted password
5046      * only if the caller (euid?) is root.
5047      *
5048      * There are at least two other shadow password APIs.  Many platforms
5049      * seem to contain more than one interface for accessing the shadow
5050      * password databases, possibly for compatibility reasons.
5051      * The getsp*() is by far he simplest one, the other two interfaces
5052      * are much more complicated, but also very similar to each other.
5053      *
5054      * <sys/types.h>
5055      * <sys/security.h>
5056      * <prot.h>
5057      * struct pr_passwd *getprpw*();
5058      * The password is in
5059      * char getprpw*(...).ufld.fd_encrypt[]
5060      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5061      *
5062      * <sys/types.h>
5063      * <sys/security.h>
5064      * <prot.h>
5065      * struct es_passwd *getespw*();
5066      * The password is in
5067      * char *(getespw*(...).ufld.fd_encrypt)
5068      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5069      *
5070      * Mention I_PROT here so that Configure probes for it.
5071      *
5072      * In HP-UX for getprpw*() the manual page claims that one should include
5073      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5074      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5075      * and pp_sys.c already includes <shadow.h> if there is such.
5076      *
5077      * Note that <sys/security.h> is already probed for, but currently
5078      * it is only included in special cases.
5079      *
5080      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5081      * be preferred interface, even though also the getprpw*() interface
5082      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5083      * One also needs to call set_auth_parameters() in main() before
5084      * doing anything else, whether one is using getespw*() or getprpw*().
5085      *
5086      * Note that accessing the shadow databases can be magnitudes
5087      * slower than accessing the standard databases.
5088      *
5089      * --jhi
5090      */
5091
5092     switch (which) {
5093     case OP_GPWNAM:
5094         pwent  = getpwnam(POPpbytex);
5095         break;
5096     case OP_GPWUID:
5097         pwent = getpwuid((Uid_t)POPi);
5098         break;
5099     case OP_GPWENT:
5100 #   ifdef HAS_GETPWENT
5101         pwent  = getpwent();
5102 #   else
5103         DIE(aTHX_ PL_no_func, "getpwent");
5104 #   endif
5105         break;
5106     }
5107
5108     EXTEND(SP, 10);
5109     if (GIMME != G_ARRAY) {
5110         PUSHs(sv = sv_newmortal());
5111         if (pwent) {
5112             if (which == OP_GPWNAM)
5113 #   if Uid_t_sign <= 0
5114                 sv_setiv(sv, (IV)pwent->pw_uid);
5115 #   else
5116                 sv_setuv(sv, (UV)pwent->pw_uid);
5117 #   endif
5118             else
5119                 sv_setpv(sv, pwent->pw_name);
5120         }
5121         RETURN;
5122     }
5123
5124     if (pwent) {
5125         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5126         sv_setpv(sv, pwent->pw_name);
5127
5128         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5129         SvPOK_off(sv);
5130         /* If we have getspnam(), we try to dig up the shadow
5131          * password.  If we are underprivileged, the shadow
5132          * interface will set the errno to EACCES or similar,
5133          * and return a null pointer.  If this happens, we will
5134          * use the dummy password (usually "*" or "x") from the
5135          * standard password database.
5136          *
5137          * In theory we could skip the shadow call completely
5138          * if euid != 0 but in practice we cannot know which
5139          * security measures are guarding the shadow databases
5140          * on a random platform.
5141          *
5142          * Resist the urge to use additional shadow interfaces.
5143          * Divert the urge to writing an extension instead.
5144          *
5145          * --jhi */
5146 #   ifdef HAS_GETSPNAM
5147         {
5148             struct spwd *spwent;
5149             int saverrno; /* Save and restore errno so that
5150                            * underprivileged attempts seem
5151                            * to have never made the unsccessful
5152                            * attempt to retrieve the shadow password. */
5153
5154             saverrno = errno;
5155             spwent = getspnam(pwent->pw_name);
5156             errno = saverrno;
5157             if (spwent && spwent->sp_pwdp)
5158                 sv_setpv(sv, spwent->sp_pwdp);
5159         }
5160 #   endif
5161 #   ifdef PWPASSWD
5162         if (!SvPOK(sv)) /* Use the standard password, then. */
5163             sv_setpv(sv, pwent->pw_passwd);
5164 #   endif
5165
5166 #   ifndef INCOMPLETE_TAINTS
5167         /* passwd is tainted because user himself can diddle with it.
5168          * admittedly not much and in a very limited way, but nevertheless. */
5169         SvTAINTED_on(sv);
5170 #   endif
5171
5172         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5173 #   if Uid_t_sign <= 0
5174         sv_setiv(sv, (IV)pwent->pw_uid);
5175 #   else
5176         sv_setuv(sv, (UV)pwent->pw_uid);
5177 #   endif
5178
5179         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5180 #   if Uid_t_sign <= 0
5181         sv_setiv(sv, (IV)pwent->pw_gid);
5182 #   else
5183         sv_setuv(sv, (UV)pwent->pw_gid);
5184 #   endif
5185         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5186          * because of the poor interface of the Perl getpw*(),
5187          * not because there's some standard/convention saying so.
5188          * A better interface would have been to return a hash,
5189          * but we are accursed by our history, alas. --jhi.  */
5190         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5191 #   ifdef PWCHANGE
5192         sv_setiv(sv, (IV)pwent->pw_change);
5193 #   else
5194 #       ifdef PWQUOTA
5195         sv_setiv(sv, (IV)pwent->pw_quota);
5196 #       else
5197 #           ifdef PWAGE
5198         sv_setpv(sv, pwent->pw_age);
5199 #           endif
5200 #       endif
5201 #   endif
5202
5203         /* pw_class and pw_comment are mutually exclusive--.
5204          * see the above note for pw_change, pw_quota, and pw_age. */
5205         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5206 #   ifdef PWCLASS
5207         sv_setpv(sv, pwent->pw_class);
5208 #   else
5209 #       ifdef PWCOMMENT
5210         sv_setpv(sv, pwent->pw_comment);
5211 #       endif
5212 #   endif
5213
5214         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5215 #   ifdef PWGECOS
5216         sv_setpv(sv, pwent->pw_gecos);
5217 #   endif
5218 #   ifndef INCOMPLETE_TAINTS
5219         /* pw_gecos is tainted because user himself can diddle with it. */
5220         SvTAINTED_on(sv);
5221 #   endif
5222
5223         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5224         sv_setpv(sv, pwent->pw_dir);
5225
5226         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5227         sv_setpv(sv, pwent->pw_shell);
5228 #   ifndef INCOMPLETE_TAINTS
5229         /* pw_shell is tainted because user himself can diddle with it. */
5230         SvTAINTED_on(sv);
5231 #   endif
5232
5233 #   ifdef PWEXPIRE
5234         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5235         sv_setiv(sv, (IV)pwent->pw_expire);
5236 #   endif
5237     }
5238     RETURN;
5239 #else
5240     DIE(aTHX_ PL_no_func, "getpwent");
5241 #endif
5242 }
5243
5244 PP(pp_spwent)
5245 {
5246 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5247     dSP;
5248     setpwent();
5249     RETPUSHYES;
5250 #else
5251     DIE(aTHX_ PL_no_func, "setpwent");
5252 #endif
5253 }
5254
5255 PP(pp_epwent)
5256 {
5257 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5258     dSP;
5259     endpwent();
5260     RETPUSHYES;
5261 #else
5262     DIE(aTHX_ PL_no_func, "endpwent");
5263 #endif
5264 }
5265
5266 PP(pp_ggrnam)
5267 {
5268 #ifdef HAS_GROUP
5269     return pp_ggrent();
5270 #else
5271     DIE(aTHX_ PL_no_func, "getgrnam");
5272 #endif
5273 }
5274
5275 PP(pp_ggrgid)
5276 {
5277 #ifdef HAS_GROUP
5278     return pp_ggrent();
5279 #else
5280     DIE(aTHX_ PL_no_func, "getgrgid");
5281 #endif
5282 }
5283
5284 PP(pp_ggrent)
5285 {
5286 #ifdef HAS_GROUP
5287     dSP;
5288     I32 which = PL_op->op_type;
5289     register char **elem;
5290     register SV *sv;
5291     struct group *grent;
5292     STRLEN n_a;
5293
5294     if (which == OP_GGRNAM)
5295         grent = (struct group *)getgrnam(POPpbytex);
5296     else if (which == OP_GGRGID)
5297         grent = (struct group *)getgrgid(POPi);
5298     else
5299 #ifdef HAS_GETGRENT
5300         grent = (struct group *)getgrent();
5301 #else
5302         DIE(aTHX_ PL_no_func, "getgrent");
5303 #endif
5304
5305     EXTEND(SP, 4);
5306     if (GIMME != G_ARRAY) {
5307         PUSHs(sv = sv_newmortal());
5308         if (grent) {
5309             if (which == OP_GGRNAM)
5310                 sv_setiv(sv, (IV)grent->gr_gid);
5311             else
5312                 sv_setpv(sv, grent->gr_name);
5313         }
5314         RETURN;
5315     }
5316
5317     if (grent) {
5318         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5319         sv_setpv(sv, grent->gr_name);
5320
5321         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5322 #ifdef GRPASSWD
5323         sv_setpv(sv, grent->gr_passwd);
5324 #endif
5325
5326         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5327         sv_setiv(sv, (IV)grent->gr_gid);
5328
5329         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5330         for (elem = grent->gr_mem; elem && *elem; elem++) {
5331             sv_catpv(sv, *elem);
5332             if (elem[1])
5333                 sv_catpvn(sv, " ", 1);
5334         }
5335     }
5336
5337     RETURN;
5338 #else
5339     DIE(aTHX_ PL_no_func, "getgrent");
5340 #endif
5341 }
5342
5343 PP(pp_sgrent)
5344 {
5345 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5346     dSP;
5347     setgrent();
5348     RETPUSHYES;
5349 #else
5350     DIE(aTHX_ PL_no_func, "setgrent");
5351 #endif
5352 }
5353
5354 PP(pp_egrent)
5355 {
5356 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5357     dSP;
5358     endgrent();
5359     RETPUSHYES;
5360 #else
5361     DIE(aTHX_ PL_no_func, "endgrent");
5362 #endif
5363 }
5364
5365 PP(pp_getlogin)
5366 {
5367 #ifdef HAS_GETLOGIN
5368     dSP; dTARGET;
5369     char *tmps;
5370     EXTEND(SP, 1);
5371     if (!(tmps = PerlProc_getlogin()))
5372         RETPUSHUNDEF;
5373     PUSHp(tmps, strlen(tmps));
5374     RETURN;
5375 #else
5376     DIE(aTHX_ PL_no_func, "getlogin");
5377 #endif
5378 }
5379
5380 /* Miscellaneous. */
5381
5382 PP(pp_syscall)
5383 {
5384 #ifdef HAS_SYSCALL
5385     dSP; dMARK; dORIGMARK; dTARGET;
5386     register I32 items = SP - MARK;
5387     unsigned long a[20];
5388     register I32 i = 0;
5389     I32 retval = -1;
5390     STRLEN n_a;
5391
5392     if (PL_tainting) {
5393         while (++MARK <= SP) {
5394             if (SvTAINTED(*MARK)) {
5395                 TAINT;
5396                 break;
5397             }
5398         }
5399         MARK = ORIGMARK;
5400         TAINT_PROPER("syscall");
5401     }
5402
5403     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5404      * or where sizeof(long) != sizeof(char*).  But such machines will
5405      * not likely have syscall implemented either, so who cares?
5406      */
5407     while (++MARK <= SP) {
5408         if (SvNIOK(*MARK) || !i)
5409             a[i++] = SvIV(*MARK);
5410         else if (*MARK == &PL_sv_undef)
5411             a[i++] = 0;
5412         else
5413             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5414         if (i > 15)
5415             break;
5416     }
5417     switch (items) {
5418     default:
5419         DIE(aTHX_ "Too many args to syscall");
5420     case 0:
5421         DIE(aTHX_ "Too few args to syscall");
5422     case 1:
5423         retval = syscall(a[0]);
5424         break;
5425     case 2:
5426         retval = syscall(a[0],a[1]);
5427         break;
5428     case 3:
5429         retval = syscall(a[0],a[1],a[2]);
5430         break;
5431     case 4:
5432         retval = syscall(a[0],a[1],a[2],a[3]);
5433         break;
5434     case 5:
5435         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5436         break;
5437     case 6:
5438         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5439         break;
5440     case 7:
5441         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5442         break;
5443     case 8:
5444         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5445         break;
5446 #ifdef atarist
5447     case 9:
5448         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5449         break;
5450     case 10:
5451         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5452         break;
5453     case 11:
5454         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5455           a[10]);
5456         break;
5457     case 12:
5458         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5459           a[10],a[11]);
5460         break;
5461     case 13:
5462         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5463           a[10],a[11],a[12]);
5464         break;
5465     case 14:
5466         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5467           a[10],a[11],a[12],a[13]);
5468         break;
5469 #endif /* atarist */
5470     }
5471     SP = ORIGMARK;
5472     PUSHi(retval);
5473     RETURN;
5474 #else
5475     DIE(aTHX_ PL_no_func, "syscall");
5476 #endif
5477 }
5478
5479 #ifdef FCNTL_EMULATE_FLOCK
5480
5481 /*  XXX Emulate flock() with fcntl().
5482     What's really needed is a good file locking module.
5483 */
5484
5485 static int
5486 fcntl_emulate_flock(int fd, int operation)
5487 {
5488     struct flock flock;
5489
5490     switch (operation & ~LOCK_NB) {
5491     case LOCK_SH:
5492         flock.l_type = F_RDLCK;
5493         break;
5494     case LOCK_EX:
5495         flock.l_type = F_WRLCK;
5496         break;
5497     case LOCK_UN:
5498         flock.l_type = F_UNLCK;
5499         break;
5500     default:
5501         errno = EINVAL;
5502         return -1;
5503     }
5504     flock.l_whence = SEEK_SET;
5505     flock.l_start = flock.l_len = (Off_t)0;
5506
5507     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5508 }
5509
5510 #endif /* FCNTL_EMULATE_FLOCK */
5511
5512 #ifdef LOCKF_EMULATE_FLOCK
5513
5514 /*  XXX Emulate flock() with lockf().  This is just to increase
5515     portability of scripts.  The calls are not completely
5516     interchangeable.  What's really needed is a good file
5517     locking module.
5518 */
5519
5520 /*  The lockf() constants might have been defined in <unistd.h>.
5521     Unfortunately, <unistd.h> causes troubles on some mixed
5522     (BSD/POSIX) systems, such as SunOS 4.1.3.
5523
5524    Further, the lockf() constants aren't POSIX, so they might not be
5525    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5526    just stick in the SVID values and be done with it.  Sigh.
5527 */
5528
5529 # ifndef F_ULOCK
5530 #  define F_ULOCK       0       /* Unlock a previously locked region */
5531 # endif
5532 # ifndef F_LOCK
5533 #  define F_LOCK        1       /* Lock a region for exclusive use */
5534 # endif
5535 # ifndef F_TLOCK
5536 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5537 # endif
5538 # ifndef F_TEST
5539 #  define F_TEST        3       /* Test a region for other processes locks */
5540 # endif
5541
5542 static int
5543 lockf_emulate_flock(int fd, int operation)
5544 {
5545     int i;
5546     int save_errno;
5547     Off_t pos;
5548
5549     /* flock locks entire file so for lockf we need to do the same      */
5550     save_errno = errno;
5551     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5552     if (pos > 0)        /* is seekable and needs to be repositioned     */
5553         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5554             pos = -1;   /* seek failed, so don't seek back afterwards   */
5555     errno = save_errno;
5556
5557     switch (operation) {
5558
5559         /* LOCK_SH - get a shared lock */
5560         case LOCK_SH:
5561         /* LOCK_EX - get an exclusive lock */
5562         case LOCK_EX:
5563             i = lockf (fd, F_LOCK, 0);
5564             break;
5565
5566         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5567         case LOCK_SH|LOCK_NB:
5568         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5569         case LOCK_EX|LOCK_NB:
5570             i = lockf (fd, F_TLOCK, 0);
5571             if (i == -1)
5572                 if ((errno == EAGAIN) || (errno == EACCES))
5573                     errno = EWOULDBLOCK;
5574             break;
5575
5576         /* LOCK_UN - unlock (non-blocking is a no-op) */
5577         case LOCK_UN:
5578         case LOCK_UN|LOCK_NB:
5579             i = lockf (fd, F_ULOCK, 0);
5580             break;
5581
5582         /* Default - can't decipher operation */
5583         default:
5584             i = -1;
5585             errno = EINVAL;
5586             break;
5587     }
5588
5589     if (pos > 0)      /* need to restore position of the handle */
5590         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5591
5592     return (i);
5593 }
5594
5595 #endif /* LOCKF_EMULATE_FLOCK */