pp_sys.c

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