pp_sys.c

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