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