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