pp_sys.c

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