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