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