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