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