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