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