pp_sys.c

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