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