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