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