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