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