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         if (((svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
3380             || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
3381 #ifdef VMS
3382             || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
3383 #endif
3384             ) && SvPOK(*svp))
3385         {
3386             tmps = SvPV(*svp, n_a);
3387         }
3388         else
3389             tmps = Nullch;
3390     }
3391     else
3392         tmps = POPpx;
3393
3394     TAINT_PROPER("chdir");
3395     PUSHi( PerlDir_chdir(tmps) >= 0 );
3396 #ifdef VMS
3397     /* Clear the DEFAULT element of ENV so we'll get the new value
3398      * in the future. */
3399     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3400 #endif
3401     RETURN;
3402 }
3403
3404 PP(pp_chown)
3405 {
3406 #ifdef HAS_CHOWN
3407     dSP; dMARK; dTARGET;
3408     I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3409
3410     SP = MARK;
3411     PUSHi(value);
3412     RETURN;
3413 #else
3414     DIE(aTHX_ PL_no_func, "chown");
3415 #endif
3416 }
3417
3418 PP(pp_chroot)
3419 {
3420 #ifdef HAS_CHROOT
3421     dSP; dTARGET;
3422     STRLEN n_a;
3423     char *tmps = POPpx;
3424     TAINT_PROPER("chroot");
3425     PUSHi( chroot(tmps) >= 0 );
3426     RETURN;
3427 #else
3428     DIE(aTHX_ PL_no_func, "chroot");
3429 #endif
3430 }
3431
3432 PP(pp_unlink)
3433 {
3434     dSP; dMARK; dTARGET;
3435     I32 value;
3436     value = (I32)apply(PL_op->op_type, MARK, SP);
3437     SP = MARK;
3438     PUSHi(value);
3439     RETURN;
3440 }
3441
3442 PP(pp_chmod)
3443 {
3444     dSP; dMARK; dTARGET;
3445     I32 value;
3446     value = (I32)apply(PL_op->op_type, MARK, SP);
3447     SP = MARK;
3448     PUSHi(value);
3449     RETURN;
3450 }
3451
3452 PP(pp_utime)
3453 {
3454     dSP; dMARK; dTARGET;
3455     I32 value;
3456     value = (I32)apply(PL_op->op_type, MARK, SP);
3457     SP = MARK;
3458     PUSHi(value);
3459     RETURN;
3460 }
3461
3462 PP(pp_rename)
3463 {
3464     dSP; dTARGET;
3465     int anum;
3466     STRLEN n_a;
3467
3468     char *tmps2 = POPpx;
3469     char *tmps = SvPV(TOPs, n_a);
3470     TAINT_PROPER("rename");
3471 #ifdef HAS_RENAME
3472     anum = PerlLIO_rename(tmps, tmps2);
3473 #else
3474     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3475         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3476             anum = 1;
3477         else {
3478             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3479                 (void)UNLINK(tmps2);
3480             if (!(anum = link(tmps, tmps2)))
3481                 anum = UNLINK(tmps);
3482         }
3483     }
3484 #endif
3485     SETi( anum >= 0 );
3486     RETURN;
3487 }
3488
3489 PP(pp_link)
3490 {
3491     dSP;
3492 #ifdef HAS_LINK
3493     dTARGET;
3494     STRLEN n_a;
3495     char *tmps2 = POPpx;
3496     char *tmps = SvPV(TOPs, n_a);
3497     TAINT_PROPER("link");
3498     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3499     RETURN;
3500 #else
3501     DIE(aTHX_ PL_no_func, "link");
3502 #endif
3503 }
3504
3505 PP(pp_symlink)
3506 {
3507 #ifdef HAS_SYMLINK
3508     dSP; dTARGET;
3509     STRLEN n_a;
3510     char *tmps2 = POPpx;
3511     char *tmps = SvPV(TOPs, n_a);
3512     TAINT_PROPER("symlink");
3513     SETi( symlink(tmps, tmps2) >= 0 );
3514     RETURN;
3515 #else
3516     DIE(aTHX_ PL_no_func, "symlink");
3517 #endif
3518 }
3519
3520 PP(pp_readlink)
3521 {
3522     dSP;
3523 #ifdef HAS_SYMLINK
3524     dTARGET;
3525     char *tmps;
3526     char buf[MAXPATHLEN];
3527     int len;
3528     STRLEN n_a;
3529
3530 #ifndef INCOMPLETE_TAINTS
3531     TAINT;
3532 #endif
3533     tmps = POPpx;
3534     len = readlink(tmps, buf, sizeof(buf) - 1);
3535     EXTEND(SP, 1);
3536     if (len < 0)
3537         RETPUSHUNDEF;
3538     PUSHp(buf, len);
3539     RETURN;
3540 #else
3541     EXTEND(SP, 1);
3542     RETSETUNDEF;                /* just pretend it's a normal file */
3543 #endif
3544 }
3545
3546 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3547 STATIC int
3548 S_dooneliner(pTHX_ char *cmd, char *filename)
3549 {
3550     char *save_filename = filename;
3551     char *cmdline;
3552     char *s;
3553     PerlIO *myfp;
3554     int anum = 1;
3555
3556     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3557     strcpy(cmdline, cmd);
3558     strcat(cmdline, " ");
3559     for (s = cmdline + strlen(cmdline); *filename; ) {
3560         *s++ = '\\';
3561         *s++ = *filename++;
3562     }
3563     strcpy(s, " 2>&1");
3564     myfp = PerlProc_popen(cmdline, "r");
3565     Safefree(cmdline);
3566
3567     if (myfp) {
3568         SV *tmpsv = sv_newmortal();
3569         /* Need to save/restore 'PL_rs' ?? */
3570         s = sv_gets(tmpsv, myfp, 0);
3571         (void)PerlProc_pclose(myfp);
3572         if (s != Nullch) {
3573             int e;
3574             for (e = 1;
3575 #ifdef HAS_SYS_ERRLIST
3576                  e <= sys_nerr
3577 #endif
3578                  ; e++)
3579             {
3580                 /* you don't see this */
3581                 char *errmsg =
3582 #ifdef HAS_SYS_ERRLIST
3583                     sys_errlist[e]
3584 #else
3585                     strerror(e)
3586 #endif
3587                     ;
3588                 if (!errmsg)
3589                     break;
3590                 if (instr(s, errmsg)) {
3591                     SETERRNO(e,0);
3592                     return 0;
3593                 }
3594             }
3595             SETERRNO(0,0);
3596 #ifndef EACCES
3597 #define EACCES EPERM
3598 #endif
3599             if (instr(s, "cannot make"))
3600                 SETERRNO(EEXIST,RMS$_FEX);
3601             else if (instr(s, "existing file"))
3602                 SETERRNO(EEXIST,RMS$_FEX);
3603             else if (instr(s, "ile exists"))
3604                 SETERRNO(EEXIST,RMS$_FEX);
3605             else if (instr(s, "non-exist"))
3606                 SETERRNO(ENOENT,RMS$_FNF);
3607             else if (instr(s, "does not exist"))
3608                 SETERRNO(ENOENT,RMS$_FNF);
3609             else if (instr(s, "not empty"))
3610                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3611             else if (instr(s, "cannot access"))
3612                 SETERRNO(EACCES,RMS$_PRV);
3613             else
3614                 SETERRNO(EPERM,RMS$_PRV);
3615             return 0;
3616         }
3617         else {  /* some mkdirs return no failure indication */
3618             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3619             if (PL_op->op_type == OP_RMDIR)
3620                 anum = !anum;
3621             if (anum)
3622                 SETERRNO(0,0);
3623             else
3624                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3625         }
3626         return anum;
3627     }
3628     else
3629         return 0;
3630 }
3631 #endif
3632
3633 PP(pp_mkdir)
3634 {
3635     dSP; dTARGET;
3636     int mode;
3637 #ifndef HAS_MKDIR
3638     int oldumask;
3639 #endif
3640     STRLEN len;
3641     char *tmps;
3642     bool copy = FALSE;
3643
3644     if (MAXARG > 1)
3645         mode = POPi;
3646     else
3647         mode = 0777;
3648
3649     tmps = SvPV(TOPs, len);
3650     /* Different operating and file systems take differently to
3651      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3652      * any number of trailing slashes should be allowed.
3653      * Thusly we snip them away so that even non-conforming
3654      * systems are happy. */
3655     /* We should probably do this "filtering" for all
3656      * the functions that expect (potentially) directory names:
3657      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3658      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3659     if (len > 1 && tmps[len-1] == '/') {
3660         while (tmps[len] == '/' && len > 1)
3661             len--;
3662         tmps = savepvn(tmps, len);
3663         copy = TRUE;
3664     }
3665
3666     TAINT_PROPER("mkdir");
3667 #ifdef HAS_MKDIR
3668     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3669 #else
3670     SETi( dooneliner("mkdir", tmps) );
3671     oldumask = PerlLIO_umask(0);
3672     PerlLIO_umask(oldumask);
3673     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3674 #endif
3675     if (copy)
3676         Safefree(tmps);
3677     RETURN;
3678 }
3679
3680 PP(pp_rmdir)
3681 {
3682     dSP; dTARGET;
3683     char *tmps;
3684     STRLEN n_a;
3685
3686     tmps = POPpx;
3687     TAINT_PROPER("rmdir");
3688 #ifdef HAS_RMDIR
3689     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3690 #else
3691     XPUSHi( dooneliner("rmdir", tmps) );
3692 #endif
3693     RETURN;
3694 }
3695
3696 /* Directory calls. */
3697
3698 PP(pp_open_dir)
3699 {
3700 #if defined(Direntry_t) && defined(HAS_READDIR)
3701     dSP;
3702     STRLEN n_a;
3703     char *dirname = POPpx;
3704     GV *gv = (GV*)POPs;
3705     register IO *io = GvIOn(gv);
3706
3707     if (!io)
3708         goto nope;
3709
3710     if (IoDIRP(io))
3711         PerlDir_close(IoDIRP(io));
3712     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3713         goto nope;
3714
3715     RETPUSHYES;
3716 nope:
3717     if (!errno)
3718         SETERRNO(EBADF,RMS$_DIR);
3719     RETPUSHUNDEF;
3720 #else
3721     DIE(aTHX_ PL_no_dir_func, "opendir");
3722 #endif
3723 }
3724
3725 PP(pp_readdir)
3726 {
3727 #if defined(Direntry_t) && defined(HAS_READDIR)
3728     dSP;
3729 #if !defined(I_DIRENT) && !defined(VMS)
3730     Direntry_t *readdir (DIR *);
3731 #endif
3732     register Direntry_t *dp;
3733     GV *gv = (GV*)POPs;
3734     register IO *io = GvIOn(gv);
3735     SV *sv;
3736
3737     if (!io || !IoDIRP(io))
3738         goto nope;
3739
3740     if (GIMME == G_ARRAY) {
3741         /*SUPPRESS 560*/
3742         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3743 #ifdef DIRNAMLEN
3744             sv = newSVpvn(dp->d_name, dp->d_namlen);
3745 #else
3746             sv = newSVpv(dp->d_name, 0);
3747 #endif
3748 #ifndef INCOMPLETE_TAINTS
3749             if (!(IoFLAGS(io) & IOf_UNTAINT))
3750                 SvTAINTED_on(sv);
3751 #endif
3752             XPUSHs(sv_2mortal(sv));
3753         }
3754     }
3755     else {
3756         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3757             goto nope;
3758 #ifdef DIRNAMLEN
3759         sv = newSVpvn(dp->d_name, dp->d_namlen);
3760 #else
3761         sv = newSVpv(dp->d_name, 0);
3762 #endif
3763 #ifndef INCOMPLETE_TAINTS
3764         if (!(IoFLAGS(io) & IOf_UNTAINT))
3765             SvTAINTED_on(sv);
3766 #endif
3767         XPUSHs(sv_2mortal(sv));
3768     }
3769     RETURN;
3770
3771 nope:
3772     if (!errno)
3773         SETERRNO(EBADF,RMS$_ISI);
3774     if (GIMME == G_ARRAY)
3775         RETURN;
3776     else
3777         RETPUSHUNDEF;
3778 #else
3779     DIE(aTHX_ PL_no_dir_func, "readdir");
3780 #endif
3781 }
3782
3783 PP(pp_telldir)
3784 {
3785 #if defined(HAS_TELLDIR) || defined(telldir)
3786     dSP; dTARGET;
3787  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3788  /* XXX netbsd still seemed to.
3789     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3790     --JHI 1999-Feb-02 */
3791 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3792     long telldir (DIR *);
3793 # endif
3794     GV *gv = (GV*)POPs;
3795     register IO *io = GvIOn(gv);
3796
3797     if (!io || !IoDIRP(io))
3798         goto nope;
3799
3800     PUSHi( PerlDir_tell(IoDIRP(io)) );
3801     RETURN;
3802 nope:
3803     if (!errno)
3804         SETERRNO(EBADF,RMS$_ISI);
3805     RETPUSHUNDEF;
3806 #else
3807     DIE(aTHX_ PL_no_dir_func, "telldir");
3808 #endif
3809 }
3810
3811 PP(pp_seekdir)
3812 {
3813 #if defined(HAS_SEEKDIR) || defined(seekdir)
3814     dSP;
3815     long along = POPl;
3816     GV *gv = (GV*)POPs;
3817     register IO *io = GvIOn(gv);
3818
3819     if (!io || !IoDIRP(io))
3820         goto nope;
3821
3822     (void)PerlDir_seek(IoDIRP(io), along);
3823
3824     RETPUSHYES;
3825 nope:
3826     if (!errno)
3827         SETERRNO(EBADF,RMS$_ISI);
3828     RETPUSHUNDEF;
3829 #else
3830     DIE(aTHX_ PL_no_dir_func, "seekdir");
3831 #endif
3832 }
3833
3834 PP(pp_rewinddir)
3835 {
3836 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3837     dSP;
3838     GV *gv = (GV*)POPs;
3839     register IO *io = GvIOn(gv);
3840
3841     if (!io || !IoDIRP(io))
3842         goto nope;
3843
3844     (void)PerlDir_rewind(IoDIRP(io));
3845     RETPUSHYES;
3846 nope:
3847     if (!errno)
3848         SETERRNO(EBADF,RMS$_ISI);
3849     RETPUSHUNDEF;
3850 #else
3851     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3852 #endif
3853 }
3854
3855 PP(pp_closedir)
3856 {
3857 #if defined(Direntry_t) && defined(HAS_READDIR)
3858     dSP;
3859     GV *gv = (GV*)POPs;
3860     register IO *io = GvIOn(gv);
3861
3862     if (!io || !IoDIRP(io))
3863         goto nope;
3864
3865 #ifdef VOID_CLOSEDIR
3866     PerlDir_close(IoDIRP(io));
3867 #else
3868     if (PerlDir_close(IoDIRP(io)) < 0) {
3869         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3870         goto nope;
3871     }
3872 #endif
3873     IoDIRP(io) = 0;
3874
3875     RETPUSHYES;
3876 nope:
3877     if (!errno)
3878         SETERRNO(EBADF,RMS$_IFI);
3879     RETPUSHUNDEF;
3880 #else
3881     DIE(aTHX_ PL_no_dir_func, "closedir");
3882 #endif
3883 }
3884
3885 /* Process control. */
3886
3887 PP(pp_fork)
3888 {
3889 #ifdef HAS_FORK
3890     dSP; dTARGET;
3891     Pid_t childpid;
3892     GV *tmpgv;
3893
3894     EXTEND(SP, 1);
3895     PERL_FLUSHALL_FOR_CHILD;
3896     childpid = PerlProc_fork();
3897     if (childpid < 0)
3898         RETSETUNDEF;
3899     if (!childpid) {
3900         /*SUPPRESS 560*/
3901         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3902             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3903         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3904     }
3905     PUSHi(childpid);
3906     RETURN;
3907 #else
3908 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3909     dSP; dTARGET;
3910     Pid_t childpid;
3911
3912     EXTEND(SP, 1);
3913     PERL_FLUSHALL_FOR_CHILD;
3914     childpid = PerlProc_fork();
3915     if (childpid == -1)
3916         RETSETUNDEF;
3917     PUSHi(childpid);
3918     RETURN;
3919 #  else
3920     DIE(aTHX_ PL_no_func, "fork");
3921 #  endif
3922 #endif
3923 }
3924
3925 PP(pp_wait)
3926 {
3927 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3928     dSP; dTARGET;
3929     Pid_t childpid;
3930     int argflags;
3931
3932 #ifdef PERL_OLD_SIGNALS
3933     childpid = wait4pid(-1, &argflags, 0);
3934 #else
3935     while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3936         PERL_ASYNC_CHECK();
3937     }
3938 #endif
3939 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3940     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3941     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3942 #  else
3943     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3944 #  endif
3945     XPUSHi(childpid);
3946     RETURN;
3947 #else
3948     DIE(aTHX_ PL_no_func, "wait");
3949 #endif
3950 }
3951
3952 PP(pp_waitpid)
3953 {
3954 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3955     dSP; dTARGET;
3956     Pid_t childpid;
3957     int optype;
3958     int argflags;
3959
3960     optype = POPi;
3961     childpid = TOPi;
3962 #ifdef PERL_OLD_SIGNALS
3963     childpid = wait4pid(childpid, &argflags, optype);
3964 #else
3965     while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
3966         PERL_ASYNC_CHECK();
3967     }
3968 #endif
3969 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3970     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3971     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3972 #  else
3973     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3974 #  endif
3975     SETi(childpid);
3976     RETURN;
3977 #else
3978     DIE(aTHX_ PL_no_func, "waitpid");
3979 #endif
3980 }
3981
3982 PP(pp_system)
3983 {
3984     dSP; dMARK; dORIGMARK; dTARGET;
3985     I32 value;
3986     STRLEN n_a;
3987     int result;
3988     int pp[2];
3989     I32 did_pipes = 0;
3990
3991     if (SP - MARK == 1) {
3992         if (PL_tainting) {
3993             (void)SvPV_nolen(TOPs);      /* stringify for taint check */
3994             TAINT_ENV();
3995             TAINT_PROPER("system");
3996         }
3997     }
3998     PERL_FLUSHALL_FOR_CHILD;
3999 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4000     {
4001          Pid_t childpid;
4002          int status;
4003          Sigsave_t ihand,qhand;     /* place to save signals during system() */
4004
4005          if (PerlProc_pipe(pp) >= 0)
4006               did_pipes = 1;
4007          while ((childpid = PerlProc_fork()) == -1) {
4008               if (errno != EAGAIN) {
4009                    value = -1;
4010                    SP = ORIGMARK;
4011                    PUSHi(value);
4012                    if (did_pipes) {
4013                         PerlLIO_close(pp[0]);
4014                         PerlLIO_close(pp[1]);
4015                    }
4016                    RETURN;
4017               }
4018               sleep(5);
4019          }
4020          if (childpid > 0) {
4021               if (did_pipes)
4022                    PerlLIO_close(pp[1]);
4023 #ifndef PERL_MICRO
4024               rsignal_save(SIGINT, SIG_IGN, &ihand);
4025               rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4026 #endif
4027               do {
4028                    result = wait4pid(childpid, &status, 0);
4029               } while (result == -1 && errno == EINTR);
4030 #ifndef PERL_MICRO
4031               (void)rsignal_restore(SIGINT, &ihand);
4032               (void)rsignal_restore(SIGQUIT, &qhand);
4033 #endif
4034               STATUS_NATIVE_SET(result == -1 ? -1 : status);
4035               do_execfree();    /* free any memory child malloced on fork */
4036               SP = ORIGMARK;
4037               if (did_pipes) {
4038                    int errkid;
4039                    int n = 0, n1;
4040
4041                    while (n < sizeof(int)) {
4042                         n1 = PerlLIO_read(pp[0],
4043                                           (void*)(((char*)&errkid)+n),
4044                                           (sizeof(int)) - n);
4045                         if (n1 <= 0)
4046                              break;
4047                         n += n1;
4048                    }
4049                    PerlLIO_close(pp[0]);
4050                    if (n) {                     /* Error */
4051                         if (n != sizeof(int))
4052                              DIE(aTHX_ "panic: kid popen errno read");
4053                         errno = errkid;         /* Propagate errno from kid */
4054                         STATUS_CURRENT = -1;
4055                    }
4056               }
4057               PUSHi(STATUS_CURRENT);
4058               RETURN;
4059          }
4060          if (did_pipes) {
4061               PerlLIO_close(pp[0]);
4062 #if defined(HAS_FCNTL) && defined(F_SETFD)
4063               fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4064 #endif
4065          }
4066     }
4067     if (PL_op->op_flags & OPf_STACKED) {
4068         SV *really = *++MARK;
4069         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4070     }
4071     else if (SP - MARK != 1)
4072         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4073     else {
4074         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4075     }
4076     PerlProc__exit(-1);
4077 #else /* ! FORK or VMS or OS/2 */
4078     PL_statusvalue = 0;
4079     result = 0;
4080     if (PL_op->op_flags & OPf_STACKED) {
4081         SV *really = *++MARK;
4082         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4083     }
4084     else if (SP - MARK != 1)
4085         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4086     else {
4087         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4088     }
4089     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4090         result = 1;
4091     STATUS_NATIVE_SET(value);
4092     do_execfree();
4093     SP = ORIGMARK;
4094     PUSHi(result ? value : STATUS_CURRENT);
4095 #endif /* !FORK or VMS */
4096     RETURN;
4097 }
4098
4099 PP(pp_exec)
4100 {
4101     dSP; dMARK; dORIGMARK; dTARGET;
4102     I32 value;
4103     STRLEN n_a;
4104
4105     PERL_FLUSHALL_FOR_CHILD;
4106     if (PL_op->op_flags & OPf_STACKED) {
4107         SV *really = *++MARK;
4108         value = (I32)do_aexec(really, MARK, SP);
4109     }
4110     else if (SP - MARK != 1)
4111 #ifdef VMS
4112         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4113 #else
4114 #  ifdef __OPEN_VM
4115         {
4116            (void ) do_aspawn(Nullsv, MARK, SP);
4117            value = 0;
4118         }
4119 #  else
4120         value = (I32)do_aexec(Nullsv, MARK, SP);
4121 #  endif
4122 #endif
4123     else {
4124         if (PL_tainting) {
4125             (void)SvPV_nolen(*SP);      /* stringify for taint check */
4126             TAINT_ENV();
4127             TAINT_PROPER("exec");
4128         }
4129 #ifdef VMS
4130         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4131 #else
4132 #  ifdef __OPEN_VM
4133         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4134         value = 0;
4135 #  else
4136         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4137 #  endif
4138 #endif
4139     }
4140
4141     SP = ORIGMARK;
4142     PUSHi(value);
4143     RETURN;
4144 }
4145
4146 PP(pp_kill)
4147 {
4148 #ifdef HAS_KILL
4149     dSP; dMARK; dTARGET;
4150     I32 value;
4151     value = (I32)apply(PL_op->op_type, MARK, SP);
4152     SP = MARK;
4153     PUSHi(value);
4154     RETURN;
4155 #else
4156     DIE(aTHX_ PL_no_func, "kill");
4157 #endif
4158 }
4159
4160 PP(pp_getppid)
4161 {
4162 #ifdef HAS_GETPPID
4163     dSP; dTARGET;
4164     XPUSHi( getppid() );
4165     RETURN;
4166 #else
4167     DIE(aTHX_ PL_no_func, "getppid");
4168 #endif
4169 }
4170
4171 PP(pp_getpgrp)
4172 {
4173 #ifdef HAS_GETPGRP
4174     dSP; dTARGET;
4175     Pid_t pid;
4176     Pid_t pgrp;
4177
4178     if (MAXARG < 1)
4179         pid = 0;
4180     else
4181         pid = SvIVx(POPs);
4182 #ifdef BSD_GETPGRP
4183     pgrp = (I32)BSD_GETPGRP(pid);
4184 #else
4185     if (pid != 0 && pid != PerlProc_getpid())
4186         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4187     pgrp = getpgrp();
4188 #endif
4189     XPUSHi(pgrp);
4190     RETURN;
4191 #else
4192     DIE(aTHX_ PL_no_func, "getpgrp()");
4193 #endif
4194 }
4195
4196 PP(pp_setpgrp)
4197 {
4198 #ifdef HAS_SETPGRP
4199     dSP; dTARGET;
4200     Pid_t pgrp;
4201     Pid_t pid;
4202     if (MAXARG < 2) {
4203         pgrp = 0;
4204         pid = 0;
4205     }
4206     else {
4207         pgrp = POPi;
4208         pid = TOPi;
4209     }
4210
4211     TAINT_PROPER("setpgrp");
4212 #ifdef BSD_SETPGRP
4213     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4214 #else
4215     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4216         || (pid != 0 && pid != PerlProc_getpid()))
4217     {
4218         DIE(aTHX_ "setpgrp can't take arguments");
4219     }
4220     SETi( setpgrp() >= 0 );
4221 #endif /* USE_BSDPGRP */
4222     RETURN;
4223 #else
4224     DIE(aTHX_ PL_no_func, "setpgrp()");
4225 #endif
4226 }
4227
4228 PP(pp_getpriority)
4229 {
4230 #ifdef HAS_GETPRIORITY
4231     dSP; dTARGET;
4232     int who = POPi;
4233     int which = TOPi;
4234     SETi( getpriority(which, who) );
4235     RETURN;
4236 #else
4237     DIE(aTHX_ PL_no_func, "getpriority()");
4238 #endif
4239 }
4240
4241 PP(pp_setpriority)
4242 {
4243 #ifdef HAS_SETPRIORITY
4244     dSP; dTARGET;
4245     int niceval = POPi;
4246     int who = POPi;
4247     int which = TOPi;
4248     TAINT_PROPER("setpriority");
4249     SETi( setpriority(which, who, niceval) >= 0 );
4250     RETURN;
4251 #else
4252     DIE(aTHX_ PL_no_func, "setpriority()");
4253 #endif
4254 }
4255
4256 /* Time calls. */
4257
4258 PP(pp_time)
4259 {
4260     dSP; dTARGET;
4261 #ifdef BIG_TIME
4262     XPUSHn( time(Null(Time_t*)) );
4263 #else
4264     XPUSHi( time(Null(Time_t*)) );
4265 #endif
4266     RETURN;
4267 }
4268
4269 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4270    to HZ.  Probably.  For now, assume that if the system
4271    defines HZ, it does so correctly.  (Will this break
4272    on VMS?)
4273    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4274    it's supported.    --AD  9/96.
4275 */
4276
4277 #ifndef HZ
4278 #  ifdef CLK_TCK
4279 #    define HZ CLK_TCK
4280 #  else
4281 #    define HZ 60
4282 #  endif
4283 #endif
4284
4285 PP(pp_tms)
4286 {
4287 #ifdef HAS_TIMES
4288     dSP;
4289     EXTEND(SP, 4);
4290 #ifndef VMS
4291     (void)PerlProc_times(&PL_timesbuf);
4292 #else
4293     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4294                                                    /* struct tms, though same data   */
4295                                                    /* is returned.                   */
4296 #endif
4297
4298     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4299     if (GIMME == G_ARRAY) {
4300         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4301         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4302         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4303     }
4304     RETURN;
4305 #else
4306     DIE(aTHX_ "times not implemented");
4307 #endif /* HAS_TIMES */
4308 }
4309
4310 PP(pp_localtime)
4311 {
4312     return pp_gmtime();
4313 }
4314
4315 PP(pp_gmtime)
4316 {
4317     dSP;
4318     Time_t when;
4319     struct tm *tmbuf;
4320     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4321     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4322                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4323
4324     if (MAXARG < 1)
4325         (void)time(&when);
4326     else
4327 #ifdef BIG_TIME
4328         when = (Time_t)SvNVx(POPs);
4329 #else
4330         when = (Time_t)SvIVx(POPs);
4331 #endif
4332
4333     if (PL_op->op_type == OP_LOCALTIME)
4334         tmbuf = localtime(&when);
4335     else
4336         tmbuf = gmtime(&when);
4337
4338     if (GIMME != G_ARRAY) {
4339         SV *tsv;
4340         EXTEND(SP, 1);
4341         EXTEND_MORTAL(1);
4342         if (!tmbuf)
4343             RETPUSHUNDEF;
4344         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4345                             dayname[tmbuf->tm_wday],
4346                             monname[tmbuf->tm_mon],
4347                             tmbuf->tm_mday,
4348                             tmbuf->tm_hour,
4349                             tmbuf->tm_min,
4350                             tmbuf->tm_sec,
4351                             tmbuf->tm_year + 1900);
4352         PUSHs(sv_2mortal(tsv));
4353     }
4354     else if (tmbuf) {
4355         EXTEND(SP, 9);
4356         EXTEND_MORTAL(9);
4357         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4358         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4359         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4360         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4361         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4362         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4363         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4364         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4365         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4366     }
4367     RETURN;
4368 }
4369
4370 PP(pp_alarm)
4371 {
4372 #ifdef HAS_ALARM
4373     dSP; dTARGET;
4374     int anum;
4375     anum = POPi;
4376     anum = alarm((unsigned int)anum);
4377     EXTEND(SP, 1);
4378     if (anum < 0)
4379         RETPUSHUNDEF;
4380     PUSHi(anum);
4381     RETURN;
4382 #else
4383     DIE(aTHX_ PL_no_func, "alarm");
4384 #endif
4385 }
4386
4387 PP(pp_sleep)
4388 {
4389     dSP; dTARGET;
4390     I32 duration;
4391     Time_t lasttime;
4392     Time_t when;
4393
4394     (void)time(&lasttime);
4395     if (MAXARG < 1)
4396         PerlProc_pause();
4397     else {
4398         duration = POPi;
4399         PerlProc_sleep((unsigned int)duration);
4400     }
4401     (void)time(&when);
4402     XPUSHi(when - lasttime);
4403     RETURN;
4404 }
4405
4406 /* Shared memory. */
4407
4408 PP(pp_shmget)
4409 {
4410     return pp_semget();
4411 }
4412
4413 PP(pp_shmctl)
4414 {
4415     return pp_semctl();
4416 }
4417
4418 PP(pp_shmread)
4419 {
4420     return pp_shmwrite();
4421 }
4422
4423 PP(pp_shmwrite)
4424 {
4425 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4426     dSP; dMARK; dTARGET;
4427     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4428     SP = MARK;
4429     PUSHi(value);
4430     RETURN;
4431 #else
4432     return pp_semget();
4433 #endif
4434 }
4435
4436 /* Message passing. */
4437
4438 PP(pp_msgget)
4439 {
4440     return pp_semget();
4441 }
4442
4443 PP(pp_msgctl)
4444 {
4445     return pp_semctl();
4446 }
4447
4448 PP(pp_msgsnd)
4449 {
4450 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4451     dSP; dMARK; dTARGET;
4452     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4453     SP = MARK;
4454     PUSHi(value);
4455     RETURN;
4456 #else
4457     return pp_semget();
4458 #endif
4459 }
4460
4461 PP(pp_msgrcv)
4462 {
4463 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4464     dSP; dMARK; dTARGET;
4465     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4466     SP = MARK;
4467     PUSHi(value);
4468     RETURN;
4469 #else
4470     return pp_semget();
4471 #endif
4472 }
4473
4474 /* Semaphores. */
4475
4476 PP(pp_semget)
4477 {
4478 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4479     dSP; dMARK; dTARGET;
4480     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4481     SP = MARK;
4482     if (anum == -1)
4483         RETPUSHUNDEF;
4484     PUSHi(anum);
4485     RETURN;
4486 #else
4487     DIE(aTHX_ "System V IPC is not implemented on this machine");
4488 #endif
4489 }
4490
4491 PP(pp_semctl)
4492 {
4493 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4494     dSP; dMARK; dTARGET;
4495     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4496     SP = MARK;
4497     if (anum == -1)
4498         RETSETUNDEF;
4499     if (anum != 0) {
4500         PUSHi(anum);
4501     }
4502     else {
4503         PUSHp(zero_but_true, ZBTLEN);
4504     }
4505     RETURN;
4506 #else
4507     return pp_semget();
4508 #endif
4509 }
4510
4511 PP(pp_semop)
4512 {
4513 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4514     dSP; dMARK; dTARGET;
4515     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4516     SP = MARK;
4517     PUSHi(value);
4518     RETURN;
4519 #else
4520     return pp_semget();
4521 #endif
4522 }
4523
4524 /* Get system info. */
4525
4526 PP(pp_ghbyname)
4527 {
4528 #ifdef HAS_GETHOSTBYNAME
4529     return pp_ghostent();
4530 #else
4531     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4532 #endif
4533 }
4534
4535 PP(pp_ghbyaddr)
4536 {
4537 #ifdef HAS_GETHOSTBYADDR
4538     return pp_ghostent();
4539 #else
4540     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4541 #endif
4542 }
4543
4544 PP(pp_ghostent)
4545 {
4546 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4547     dSP;
4548     I32 which = PL_op->op_type;
4549     register char **elem;
4550     register SV *sv;
4551 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4552     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4553     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4554     struct hostent *PerlSock_gethostent(void);
4555 #endif
4556     struct hostent *hent;
4557     unsigned long len;
4558     STRLEN n_a;
4559
4560     EXTEND(SP, 10);
4561     if (which == OP_GHBYNAME)
4562 #ifdef HAS_GETHOSTBYNAME
4563         hent = PerlSock_gethostbyname(POPpbytex);
4564 #else
4565         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4566 #endif
4567     else if (which == OP_GHBYADDR) {
4568 #ifdef HAS_GETHOSTBYADDR
4569         int addrtype = POPi;
4570         SV *addrsv = POPs;
4571         STRLEN addrlen;
4572         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4573
4574         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4575 #else
4576         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4577 #endif
4578     }
4579     else
4580 #ifdef HAS_GETHOSTENT
4581         hent = PerlSock_gethostent();
4582 #else
4583         DIE(aTHX_ PL_no_sock_func, "gethostent");
4584 #endif
4585
4586 #ifdef HOST_NOT_FOUND
4587     if (!hent)
4588         STATUS_NATIVE_SET(h_errno);
4589 #endif
4590
4591     if (GIMME != G_ARRAY) {
4592         PUSHs(sv = sv_newmortal());
4593         if (hent) {
4594             if (which == OP_GHBYNAME) {
4595                 if (hent->h_addr)
4596                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4597             }
4598             else
4599                 sv_setpv(sv, (char*)hent->h_name);
4600         }
4601         RETURN;
4602     }
4603
4604     if (hent) {
4605         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4606         sv_setpv(sv, (char*)hent->h_name);
4607         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4608         for (elem = hent->h_aliases; elem && *elem; elem++) {
4609             sv_catpv(sv, *elem);
4610             if (elem[1])
4611                 sv_catpvn(sv, " ", 1);
4612         }
4613         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4614         sv_setiv(sv, (IV)hent->h_addrtype);
4615         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4616         len = hent->h_length;
4617         sv_setiv(sv, (IV)len);
4618 #ifdef h_addr
4619         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4620             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4621             sv_setpvn(sv, *elem, len);
4622         }
4623 #else
4624         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4625         if (hent->h_addr)
4626             sv_setpvn(sv, hent->h_addr, len);
4627 #endif /* h_addr */
4628     }
4629     RETURN;
4630 #else
4631     DIE(aTHX_ PL_no_sock_func, "gethostent");
4632 #endif
4633 }
4634
4635 PP(pp_gnbyname)
4636 {
4637 #ifdef HAS_GETNETBYNAME
4638     return pp_gnetent();
4639 #else
4640     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4641 #endif
4642 }
4643
4644 PP(pp_gnbyaddr)
4645 {
4646 #ifdef HAS_GETNETBYADDR
4647     return pp_gnetent();
4648 #else
4649     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4650 #endif
4651 }
4652
4653 PP(pp_gnetent)
4654 {
4655 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4656     dSP;
4657     I32 which = PL_op->op_type;
4658     register char **elem;
4659     register SV *sv;
4660 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4661     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4662     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4663     struct netent *PerlSock_getnetent(void);
4664 #endif
4665     struct netent *nent;
4666     STRLEN n_a;
4667
4668     if (which == OP_GNBYNAME)
4669 #ifdef HAS_GETNETBYNAME
4670         nent = PerlSock_getnetbyname(POPpbytex);
4671 #else
4672         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4673 #endif
4674     else if (which == OP_GNBYADDR) {
4675 #ifdef HAS_GETNETBYADDR
4676         int addrtype = POPi;
4677         Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4678         nent = PerlSock_getnetbyaddr(addr, addrtype);
4679 #else
4680         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4681 #endif
4682     }
4683     else
4684 #ifdef HAS_GETNETENT
4685         nent = PerlSock_getnetent();
4686 #else
4687         DIE(aTHX_ PL_no_sock_func, "getnetent");
4688 #endif
4689
4690     EXTEND(SP, 4);
4691     if (GIMME != G_ARRAY) {
4692         PUSHs(sv = sv_newmortal());
4693         if (nent) {
4694             if (which == OP_GNBYNAME)
4695                 sv_setiv(sv, (IV)nent->n_net);
4696             else
4697                 sv_setpv(sv, nent->n_name);
4698         }
4699         RETURN;
4700     }
4701
4702     if (nent) {
4703         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4704         sv_setpv(sv, nent->n_name);
4705         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4706         for (elem = nent->n_aliases; elem && *elem; elem++) {
4707             sv_catpv(sv, *elem);
4708             if (elem[1])
4709                 sv_catpvn(sv, " ", 1);
4710         }
4711         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4712         sv_setiv(sv, (IV)nent->n_addrtype);
4713         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4714         sv_setiv(sv, (IV)nent->n_net);
4715     }
4716
4717     RETURN;
4718 #else
4719     DIE(aTHX_ PL_no_sock_func, "getnetent");
4720 #endif
4721 }
4722
4723 PP(pp_gpbyname)
4724 {
4725 #ifdef HAS_GETPROTOBYNAME
4726     return pp_gprotoent();
4727 #else
4728     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4729 #endif
4730 }
4731
4732 PP(pp_gpbynumber)
4733 {
4734 #ifdef HAS_GETPROTOBYNUMBER
4735     return pp_gprotoent();
4736 #else
4737     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4738 #endif
4739 }
4740
4741 PP(pp_gprotoent)
4742 {
4743 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4744     dSP;
4745     I32 which = PL_op->op_type;
4746     register char **elem;
4747     register SV *sv;
4748 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4749     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4750     struct protoent *PerlSock_getprotobynumber(int);
4751     struct protoent *PerlSock_getprotoent(void);
4752 #endif
4753     struct protoent *pent;
4754     STRLEN n_a;
4755
4756     if (which == OP_GPBYNAME)
4757 #ifdef HAS_GETPROTOBYNAME
4758         pent = PerlSock_getprotobyname(POPpbytex);
4759 #else
4760         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4761 #endif
4762     else if (which == OP_GPBYNUMBER)
4763 #ifdef HAS_GETPROTOBYNUMBER
4764         pent = PerlSock_getprotobynumber(POPi);
4765 #else
4766     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4767 #endif
4768     else
4769 #ifdef HAS_GETPROTOENT
4770         pent = PerlSock_getprotoent();
4771 #else
4772         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4773 #endif
4774
4775     EXTEND(SP, 3);
4776     if (GIMME != G_ARRAY) {
4777         PUSHs(sv = sv_newmortal());
4778         if (pent) {
4779             if (which == OP_GPBYNAME)
4780                 sv_setiv(sv, (IV)pent->p_proto);
4781             else
4782                 sv_setpv(sv, pent->p_name);
4783         }
4784         RETURN;
4785     }
4786
4787     if (pent) {
4788         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4789         sv_setpv(sv, pent->p_name);
4790         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4791         for (elem = pent->p_aliases; elem && *elem; elem++) {
4792             sv_catpv(sv, *elem);
4793             if (elem[1])
4794                 sv_catpvn(sv, " ", 1);
4795         }
4796         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4797         sv_setiv(sv, (IV)pent->p_proto);
4798     }
4799
4800     RETURN;
4801 #else
4802     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4803 #endif
4804 }
4805
4806 PP(pp_gsbyname)
4807 {
4808 #ifdef HAS_GETSERVBYNAME
4809     return pp_gservent();
4810 #else
4811     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4812 #endif
4813 }
4814
4815 PP(pp_gsbyport)
4816 {
4817 #ifdef HAS_GETSERVBYPORT
4818     return pp_gservent();
4819 #else
4820     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4821 #endif
4822 }
4823
4824 PP(pp_gservent)
4825 {
4826 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4827     dSP;
4828     I32 which = PL_op->op_type;
4829     register char **elem;
4830     register SV *sv;
4831 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4832     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4833     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4834     struct servent *PerlSock_getservent(void);
4835 #endif
4836     struct servent *sent;
4837     STRLEN n_a;
4838
4839     if (which == OP_GSBYNAME) {
4840 #ifdef HAS_GETSERVBYNAME
4841         char *proto = POPpbytex;
4842         char *name = POPpbytex;
4843
4844         if (proto && !*proto)
4845             proto = Nullch;
4846
4847         sent = PerlSock_getservbyname(name, proto);
4848 #else
4849         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4850 #endif
4851     }
4852     else if (which == OP_GSBYPORT) {
4853 #ifdef HAS_GETSERVBYPORT
4854         char *proto = POPpbytex;
4855         unsigned short port = POPu;
4856
4857 #ifdef HAS_HTONS
4858         port = PerlSock_htons(port);
4859 #endif
4860         sent = PerlSock_getservbyport(port, proto);
4861 #else
4862         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4863 #endif
4864     }
4865     else
4866 #ifdef HAS_GETSERVENT
4867         sent = PerlSock_getservent();
4868 #else
4869         DIE(aTHX_ PL_no_sock_func, "getservent");
4870 #endif
4871
4872     EXTEND(SP, 4);
4873     if (GIMME != G_ARRAY) {
4874         PUSHs(sv = sv_newmortal());
4875         if (sent) {
4876             if (which == OP_GSBYNAME) {
4877 #ifdef HAS_NTOHS
4878                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4879 #else
4880                 sv_setiv(sv, (IV)(sent->s_port));
4881 #endif
4882             }
4883             else
4884                 sv_setpv(sv, sent->s_name);
4885         }
4886         RETURN;
4887     }
4888
4889     if (sent) {
4890         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4891         sv_setpv(sv, sent->s_name);
4892         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4893         for (elem = sent->s_aliases; elem && *elem; elem++) {
4894             sv_catpv(sv, *elem);
4895             if (elem[1])
4896                 sv_catpvn(sv, " ", 1);
4897         }
4898         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4899 #ifdef HAS_NTOHS
4900         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4901 #else
4902         sv_setiv(sv, (IV)(sent->s_port));
4903 #endif
4904         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4905         sv_setpv(sv, sent->s_proto);
4906     }
4907
4908     RETURN;
4909 #else
4910     DIE(aTHX_ PL_no_sock_func, "getservent");
4911 #endif
4912 }
4913
4914 PP(pp_shostent)
4915 {
4916 #ifdef HAS_SETHOSTENT
4917     dSP;
4918     PerlSock_sethostent(TOPi);
4919     RETSETYES;
4920 #else
4921     DIE(aTHX_ PL_no_sock_func, "sethostent");
4922 #endif
4923 }
4924
4925 PP(pp_snetent)
4926 {
4927 #ifdef HAS_SETNETENT
4928     dSP;
4929     PerlSock_setnetent(TOPi);
4930     RETSETYES;
4931 #else
4932     DIE(aTHX_ PL_no_sock_func, "setnetent");
4933 #endif
4934 }
4935
4936 PP(pp_sprotoent)
4937 {
4938 #ifdef HAS_SETPROTOENT
4939     dSP;
4940     PerlSock_setprotoent(TOPi);
4941     RETSETYES;
4942 #else
4943     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4944 #endif
4945 }
4946
4947 PP(pp_sservent)
4948 {
4949 #ifdef HAS_SETSERVENT
4950     dSP;
4951     PerlSock_setservent(TOPi);
4952     RETSETYES;
4953 #else
4954     DIE(aTHX_ PL_no_sock_func, "setservent");
4955 #endif
4956 }
4957
4958 PP(pp_ehostent)
4959 {
4960 #ifdef HAS_ENDHOSTENT
4961     dSP;
4962     PerlSock_endhostent();
4963     EXTEND(SP,1);
4964     RETPUSHYES;
4965 #else
4966     DIE(aTHX_ PL_no_sock_func, "endhostent");
4967 #endif
4968 }
4969
4970 PP(pp_enetent)
4971 {
4972 #ifdef HAS_ENDNETENT
4973     dSP;
4974     PerlSock_endnetent();
4975     EXTEND(SP,1);
4976     RETPUSHYES;
4977 #else
4978     DIE(aTHX_ PL_no_sock_func, "endnetent");
4979 #endif
4980 }
4981
4982 PP(pp_eprotoent)
4983 {
4984 #ifdef HAS_ENDPROTOENT
4985     dSP;
4986     PerlSock_endprotoent();
4987     EXTEND(SP,1);
4988     RETPUSHYES;
4989 #else
4990     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4991 #endif
4992 }
4993
4994 PP(pp_eservent)
4995 {
4996 #ifdef HAS_ENDSERVENT
4997     dSP;
4998     PerlSock_endservent();
4999     EXTEND(SP,1);
5000     RETPUSHYES;
5001 #else
5002     DIE(aTHX_ PL_no_sock_func, "endservent");
5003 #endif
5004 }
5005
5006 PP(pp_gpwnam)
5007 {
5008 #ifdef HAS_PASSWD
5009     return pp_gpwent();
5010 #else
5011     DIE(aTHX_ PL_no_func, "getpwnam");
5012 #endif
5013 }
5014
5015 PP(pp_gpwuid)
5016 {
5017 #ifdef HAS_PASSWD
5018     return pp_gpwent();
5019 #else
5020     DIE(aTHX_ PL_no_func, "getpwuid");
5021 #endif
5022 }
5023
5024 PP(pp_gpwent)
5025 {
5026 #ifdef HAS_PASSWD
5027     dSP;
5028     I32 which = PL_op->op_type;
5029     register SV *sv;
5030     STRLEN n_a;
5031     struct passwd *pwent  = NULL;
5032     /*
5033      * We currently support only the SysV getsp* shadow password interface.
5034      * The interface is declared in <shadow.h> and often one needs to link
5035      * with -lsecurity or some such.
5036      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5037      * (and SCO?)
5038      *
5039      * AIX getpwnam() is clever enough to return the encrypted password
5040      * only if the caller (euid?) is root.
5041      *
5042      * There are at least two other shadow password APIs.  Many platforms
5043      * seem to contain more than one interface for accessing the shadow
5044      * password databases, possibly for compatibility reasons.
5045      * The getsp*() is by far he simplest one, the other two interfaces
5046      * are much more complicated, but also very similar to each other.
5047      *
5048      * <sys/types.h>
5049      * <sys/security.h>
5050      * <prot.h>
5051      * struct pr_passwd *getprpw*();
5052      * The password is in
5053      * char getprpw*(...).ufld.fd_encrypt[]
5054      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5055      *
5056      * <sys/types.h>
5057      * <sys/security.h>
5058      * <prot.h>
5059      * struct es_passwd *getespw*();
5060      * The password is in
5061      * char *(getespw*(...).ufld.fd_encrypt)
5062      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5063      *
5064      * Mention I_PROT here so that Configure probes for it.
5065      *
5066      * In HP-UX for getprpw*() the manual page claims that one should include
5067      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5068      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5069      * and pp_sys.c already includes <shadow.h> if there is such.
5070      *
5071      * Note that <sys/security.h> is already probed for, but currently
5072      * it is only included in special cases.
5073      *
5074      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5075      * be preferred interface, even though also the getprpw*() interface
5076      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5077      * One also needs to call set_auth_parameters() in main() before
5078      * doing anything else, whether one is using getespw*() or getprpw*().
5079      *
5080      * Note that accessing the shadow databases can be magnitudes
5081      * slower than accessing the standard databases.
5082      *
5083      * --jhi
5084      */
5085
5086     switch (which) {
5087     case OP_GPWNAM:
5088         pwent  = getpwnam(POPpbytex);
5089         break;
5090     case OP_GPWUID:
5091         pwent = getpwuid((Uid_t)POPi);
5092         break;
5093     case OP_GPWENT:
5094 #   ifdef HAS_GETPWENT
5095         pwent  = getpwent();
5096 #   else
5097         DIE(aTHX_ PL_no_func, "getpwent");
5098 #   endif
5099         break;
5100     }
5101
5102     EXTEND(SP, 10);
5103     if (GIMME != G_ARRAY) {
5104         PUSHs(sv = sv_newmortal());
5105         if (pwent) {
5106             if (which == OP_GPWNAM)
5107 #   if Uid_t_sign <= 0
5108                 sv_setiv(sv, (IV)pwent->pw_uid);
5109 #   else
5110                 sv_setuv(sv, (UV)pwent->pw_uid);
5111 #   endif
5112             else
5113                 sv_setpv(sv, pwent->pw_name);
5114         }
5115         RETURN;
5116     }
5117
5118     if (pwent) {
5119         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5120         sv_setpv(sv, pwent->pw_name);
5121
5122         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5123         SvPOK_off(sv);
5124         /* If we have getspnam(), we try to dig up the shadow
5125          * password.  If we are underprivileged, the shadow
5126          * interface will set the errno to EACCES or similar,
5127          * and return a null pointer.  If this happens, we will
5128          * use the dummy password (usually "*" or "x") from the
5129          * standard password database.
5130          *
5131          * In theory we could skip the shadow call completely
5132          * if euid != 0 but in practice we cannot know which
5133          * security measures are guarding the shadow databases
5134          * on a random platform.
5135          *
5136          * Resist the urge to use additional shadow interfaces.
5137          * Divert the urge to writing an extension instead.
5138          *
5139          * --jhi */
5140 #   ifdef HAS_GETSPNAM
5141         {
5142             struct spwd *spwent;
5143             int saverrno; /* Save and restore errno so that
5144                            * underprivileged attempts seem
5145                            * to have never made the unsccessful
5146                            * attempt to retrieve the shadow password. */
5147
5148             saverrno = errno;
5149             spwent = getspnam(pwent->pw_name);
5150             errno = saverrno;
5151             if (spwent && spwent->sp_pwdp)
5152                 sv_setpv(sv, spwent->sp_pwdp);
5153         }
5154 #   endif
5155 #   ifdef PWPASSWD
5156         if (!SvPOK(sv)) /* Use the standard password, then. */
5157             sv_setpv(sv, pwent->pw_passwd);
5158 #   endif
5159
5160 #   ifndef INCOMPLETE_TAINTS
5161         /* passwd is tainted because user himself can diddle with it.
5162          * admittedly not much and in a very limited way, but nevertheless. */
5163         SvTAINTED_on(sv);
5164 #   endif
5165
5166         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5167 #   if Uid_t_sign <= 0
5168         sv_setiv(sv, (IV)pwent->pw_uid);
5169 #   else
5170         sv_setuv(sv, (UV)pwent->pw_uid);
5171 #   endif
5172
5173         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5174 #   if Uid_t_sign <= 0
5175         sv_setiv(sv, (IV)pwent->pw_gid);
5176 #   else
5177         sv_setuv(sv, (UV)pwent->pw_gid);
5178 #   endif
5179         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5180          * because of the poor interface of the Perl getpw*(),
5181          * not because there's some standard/convention saying so.
5182          * A better interface would have been to return a hash,
5183          * but we are accursed by our history, alas. --jhi.  */
5184         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5185 #   ifdef PWCHANGE
5186         sv_setiv(sv, (IV)pwent->pw_change);
5187 #   else
5188 #       ifdef PWQUOTA
5189         sv_setiv(sv, (IV)pwent->pw_quota);
5190 #       else
5191 #           ifdef PWAGE
5192         sv_setpv(sv, pwent->pw_age);
5193 #           endif
5194 #       endif
5195 #   endif
5196
5197         /* pw_class and pw_comment are mutually exclusive--.
5198          * see the above note for pw_change, pw_quota, and pw_age. */
5199         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5200 #   ifdef PWCLASS
5201         sv_setpv(sv, pwent->pw_class);
5202 #   else
5203 #       ifdef PWCOMMENT
5204         sv_setpv(sv, pwent->pw_comment);
5205 #       endif
5206 #   endif
5207
5208         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5209 #   ifdef PWGECOS
5210         sv_setpv(sv, pwent->pw_gecos);
5211 #   endif
5212 #   ifndef INCOMPLETE_TAINTS
5213         /* pw_gecos is tainted because user himself can diddle with it. */
5214         SvTAINTED_on(sv);
5215 #   endif
5216
5217         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5218         sv_setpv(sv, pwent->pw_dir);
5219
5220         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5221         sv_setpv(sv, pwent->pw_shell);
5222 #   ifndef INCOMPLETE_TAINTS
5223         /* pw_shell is tainted because user himself can diddle with it. */
5224         SvTAINTED_on(sv);
5225 #   endif
5226
5227 #   ifdef PWEXPIRE
5228         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5229         sv_setiv(sv, (IV)pwent->pw_expire);
5230 #   endif
5231     }
5232     RETURN;
5233 #else
5234     DIE(aTHX_ PL_no_func, "getpwent");
5235 #endif
5236 }
5237
5238 PP(pp_spwent)
5239 {
5240 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5241     dSP;
5242     setpwent();
5243     RETPUSHYES;
5244 #else
5245     DIE(aTHX_ PL_no_func, "setpwent");
5246 #endif
5247 }
5248
5249 PP(pp_epwent)
5250 {
5251 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5252     dSP;
5253     endpwent();
5254     RETPUSHYES;
5255 #else
5256     DIE(aTHX_ PL_no_func, "endpwent");
5257 #endif
5258 }
5259
5260 PP(pp_ggrnam)
5261 {
5262 #ifdef HAS_GROUP
5263     return pp_ggrent();
5264 #else
5265     DIE(aTHX_ PL_no_func, "getgrnam");
5266 #endif
5267 }
5268
5269 PP(pp_ggrgid)
5270 {
5271 #ifdef HAS_GROUP
5272     return pp_ggrent();
5273 #else
5274     DIE(aTHX_ PL_no_func, "getgrgid");
5275 #endif
5276 }
5277
5278 PP(pp_ggrent)
5279 {
5280 #ifdef HAS_GROUP
5281     dSP;
5282     I32 which = PL_op->op_type;
5283     register char **elem;
5284     register SV *sv;
5285     struct group *grent;
5286     STRLEN n_a;
5287
5288     if (which == OP_GGRNAM)
5289         grent = (struct group *)getgrnam(POPpbytex);
5290     else if (which == OP_GGRGID)
5291         grent = (struct group *)getgrgid(POPi);
5292     else
5293 #ifdef HAS_GETGRENT
5294         grent = (struct group *)getgrent();
5295 #else
5296         DIE(aTHX_ PL_no_func, "getgrent");
5297 #endif
5298
5299     EXTEND(SP, 4);
5300     if (GIMME != G_ARRAY) {
5301         PUSHs(sv = sv_newmortal());
5302         if (grent) {
5303             if (which == OP_GGRNAM)
5304                 sv_setiv(sv, (IV)grent->gr_gid);
5305             else
5306                 sv_setpv(sv, grent->gr_name);
5307         }
5308         RETURN;
5309     }
5310
5311     if (grent) {
5312         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5313         sv_setpv(sv, grent->gr_name);
5314
5315         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5316 #ifdef GRPASSWD
5317         sv_setpv(sv, grent->gr_passwd);
5318 #endif
5319
5320         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5321         sv_setiv(sv, (IV)grent->gr_gid);
5322
5323         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5324         for (elem = grent->gr_mem; elem && *elem; elem++) {
5325             sv_catpv(sv, *elem);
5326             if (elem[1])
5327                 sv_catpvn(sv, " ", 1);
5328         }
5329     }
5330
5331     RETURN;
5332 #else
5333     DIE(aTHX_ PL_no_func, "getgrent");
5334 #endif
5335 }
5336
5337 PP(pp_sgrent)
5338 {
5339 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5340     dSP;
5341     setgrent();
5342     RETPUSHYES;
5343 #else
5344     DIE(aTHX_ PL_no_func, "setgrent");
5345 #endif
5346 }
5347
5348 PP(pp_egrent)
5349 {
5350 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5351     dSP;
5352     endgrent();
5353     RETPUSHYES;
5354 #else
5355     DIE(aTHX_ PL_no_func, "endgrent");
5356 #endif
5357 }
5358
5359 PP(pp_getlogin)
5360 {
5361 #ifdef HAS_GETLOGIN
5362     dSP; dTARGET;
5363     char *tmps;
5364     EXTEND(SP, 1);
5365     if (!(tmps = PerlProc_getlogin()))
5366         RETPUSHUNDEF;
5367     PUSHp(tmps, strlen(tmps));
5368     RETURN;
5369 #else
5370     DIE(aTHX_ PL_no_func, "getlogin");
5371 #endif
5372 }
5373
5374 /* Miscellaneous. */
5375
5376 PP(pp_syscall)
5377 {
5378 #ifdef HAS_SYSCALL
5379     dSP; dMARK; dORIGMARK; dTARGET;
5380     register I32 items = SP - MARK;
5381     unsigned long a[20];
5382     register I32 i = 0;
5383     I32 retval = -1;
5384     STRLEN n_a;
5385
5386     if (PL_tainting) {
5387         while (++MARK <= SP) {
5388             if (SvTAINTED(*MARK)) {
5389                 TAINT;
5390                 break;
5391             }
5392         }
5393         MARK = ORIGMARK;
5394         TAINT_PROPER("syscall");
5395     }
5396
5397     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5398      * or where sizeof(long) != sizeof(char*).  But such machines will
5399      * not likely have syscall implemented either, so who cares?
5400      */
5401     while (++MARK <= SP) {
5402         if (SvNIOK(*MARK) || !i)
5403             a[i++] = SvIV(*MARK);
5404         else if (*MARK == &PL_sv_undef)
5405             a[i++] = 0;
5406         else
5407             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5408         if (i > 15)
5409             break;
5410     }
5411     switch (items) {
5412     default:
5413         DIE(aTHX_ "Too many args to syscall");
5414     case 0:
5415         DIE(aTHX_ "Too few args to syscall");
5416     case 1:
5417         retval = syscall(a[0]);
5418         break;
5419     case 2:
5420         retval = syscall(a[0],a[1]);
5421         break;
5422     case 3:
5423         retval = syscall(a[0],a[1],a[2]);
5424         break;
5425     case 4:
5426         retval = syscall(a[0],a[1],a[2],a[3]);
5427         break;
5428     case 5:
5429         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5430         break;
5431     case 6:
5432         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5433         break;
5434     case 7:
5435         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5436         break;
5437     case 8:
5438         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5439         break;
5440 #ifdef atarist
5441     case 9:
5442         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5443         break;
5444     case 10:
5445         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5446         break;
5447     case 11:
5448         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5449           a[10]);
5450         break;
5451     case 12:
5452         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5453           a[10],a[11]);
5454         break;
5455     case 13:
5456         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5457           a[10],a[11],a[12]);
5458         break;
5459     case 14:
5460         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5461           a[10],a[11],a[12],a[13]);
5462         break;
5463 #endif /* atarist */
5464     }
5465     SP = ORIGMARK;
5466     PUSHi(retval);
5467     RETURN;
5468 #else
5469     DIE(aTHX_ PL_no_func, "syscall");
5470 #endif
5471 }
5472
5473 #ifdef FCNTL_EMULATE_FLOCK
5474
5475 /*  XXX Emulate flock() with fcntl().
5476     What's really needed is a good file locking module.
5477 */
5478
5479 static int
5480 fcntl_emulate_flock(int fd, int operation)
5481 {
5482     struct flock flock;
5483
5484     switch (operation & ~LOCK_NB) {
5485     case LOCK_SH:
5486         flock.l_type = F_RDLCK;
5487         break;
5488     case LOCK_EX:
5489         flock.l_type = F_WRLCK;
5490         break;
5491     case LOCK_UN:
5492         flock.l_type = F_UNLCK;
5493         break;
5494     default:
5495         errno = EINVAL;
5496         return -1;
5497     }
5498     flock.l_whence = SEEK_SET;
5499     flock.l_start = flock.l_len = (Off_t)0;
5500
5501     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5502 }
5503
5504 #endif /* FCNTL_EMULATE_FLOCK */
5505
5506 #ifdef LOCKF_EMULATE_FLOCK
5507
5508 /*  XXX Emulate flock() with lockf().  This is just to increase
5509     portability of scripts.  The calls are not completely
5510     interchangeable.  What's really needed is a good file
5511     locking module.
5512 */
5513
5514 /*  The lockf() constants might have been defined in <unistd.h>.
5515     Unfortunately, <unistd.h> causes troubles on some mixed
5516     (BSD/POSIX) systems, such as SunOS 4.1.3.
5517
5518    Further, the lockf() constants aren't POSIX, so they might not be
5519    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5520    just stick in the SVID values and be done with it.  Sigh.
5521 */
5522
5523 # ifndef F_ULOCK
5524 #  define F_ULOCK       0       /* Unlock a previously locked region */
5525 # endif
5526 # ifndef F_LOCK
5527 #  define F_LOCK        1       /* Lock a region for exclusive use */
5528 # endif
5529 # ifndef F_TLOCK
5530 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5531 # endif
5532 # ifndef F_TEST
5533 #  define F_TEST        3       /* Test a region for other processes locks */
5534 # endif
5535
5536 static int
5537 lockf_emulate_flock(int fd, int operation)
5538 {
5539     int i;
5540     int save_errno;
5541     Off_t pos;
5542
5543     /* flock locks entire file so for lockf we need to do the same      */
5544     save_errno = errno;
5545     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5546     if (pos > 0)        /* is seekable and needs to be repositioned     */
5547         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5548             pos = -1;   /* seek failed, so don't seek back afterwards   */
5549     errno = save_errno;
5550
5551     switch (operation) {
5552
5553         /* LOCK_SH - get a shared lock */
5554         case LOCK_SH:
5555         /* LOCK_EX - get an exclusive lock */
5556         case LOCK_EX:
5557             i = lockf (fd, F_LOCK, 0);
5558             break;
5559
5560         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5561         case LOCK_SH|LOCK_NB:
5562         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5563         case LOCK_EX|LOCK_NB:
5564             i = lockf (fd, F_TLOCK, 0);
5565             if (i == -1)
5566                 if ((errno == EAGAIN) || (errno == EACCES))
5567                     errno = EWOULDBLOCK;
5568             break;
5569
5570         /* LOCK_UN - unlock (non-blocking is a no-op) */
5571         case LOCK_UN:
5572         case LOCK_UN|LOCK_NB:
5573             i = lockf (fd, F_ULOCK, 0);
5574             break;
5575
5576         /* Default - can't decipher operation */
5577         default:
5578             i = -1;
5579             errno = EINVAL;
5580             break;
5581     }
5582
5583     if (pos > 0)      /* need to restore position of the handle */
5584         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5585
5586     return (i);
5587 }
5588
5589 #endif /* LOCKF_EMULATE_FLOCK */