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