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