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