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(newSVpv(CopFILE(PL_curcop),0));
 479                     SV *line = sv_2mortal(newSViv(CopLINE(PL_curcop)));
 480                     EXTEND(SP, 3);
 481                     PUSHMARK(SP);
 482                     PUSHs(error);
 483                     PUSHs(file);
 484                     PUSHs(line);
 485                     PUTBACK;
 486                     call_sv((SV*)GvCV(gv),
 487                             G_SCALAR|G_EVAL|G_KEEPERR);
 488                     sv_setsv(error,*PL_stack_sp--);
 489                 }
 490             }
 491             DIE(aTHX_ Nullch);
 492         }
 493         else {
 494             if (SvPOK(error) && SvCUR(error))
 495                 sv_catpv(error, "\t...propagated");
 496             tmpsv = error;
 497             tmps = SvPV(tmpsv, len);
 498         }
 499     }
 500     if (!tmps || !len)
 501         tmpsv = sv_2mortal(newSVpvn("Died", 4));
 502
 503     DIE(aTHX_ "%_", tmpsv);
 504 }
 505
 506 /* I/O. */
 507
 508 PP(pp_open)
 509 {
 510     djSP; dTARGET;
 511     GV *gv;
 512     SV *sv;
 513     SV *name;
 514     I32 have_name = 0;
 515     char *tmps;
 516     STRLEN len;
 517     MAGIC *mg;
 518
 519     if (MAXARG > 2) {
 520         name = POPs;
 521         have_name = 1;
 522     }
 523     if (MAXARG > 1)
 524         sv = POPs;
 525     if (!isGV(TOPs))
 526         DIE(aTHX_ PL_no_usym, "filehandle");
 527     if (MAXARG <= 1)
 528         sv = GvSV(TOPs);
 529     gv = (GV*)POPs;
 530     if (!isGV(gv))
 531         DIE(aTHX_ PL_no_usym, "filehandle");
 532     if (GvIOp(gv))
 533         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 534
 535     if (mg = SvTIED_mg((SV*)gv, 'q')) {
 536         PUSHMARK(SP);
 537         XPUSHs(SvTIED_obj((SV*)gv, mg));
 538         XPUSHs(sv);
 539         if (have_name)
 540             XPUSHs(name);
 541         PUTBACK;
 542         ENTER;
 543         call_method("OPEN", G_SCALAR);
 544         LEAVE;
 545         SPAGAIN;
 546         RETURN;
 547     }
 548
 549     tmps = SvPV(sv, len);
 550     if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
 551         PUSHi( (I32)PL_forkprocess );
 552     else if (PL_forkprocess == 0)               /* we are a new child */
 553         PUSHi(0);
 554     else
 555         RETPUSHUNDEF;
 556     RETURN;
 557 }
 558
 559 PP(pp_close)
 560 {
 561     djSP;
 562     GV *gv;
 563     MAGIC *mg;
 564
 565     if (MAXARG == 0)
 566         gv = PL_defoutgv;
 567     else
 568         gv = (GV*)POPs;
 569
 570     if (mg = SvTIED_mg((SV*)gv, 'q')) {
 571         PUSHMARK(SP);
 572         XPUSHs(SvTIED_obj((SV*)gv, mg));
 573         PUTBACK;
 574         ENTER;
 575         call_method("CLOSE", G_SCALAR);
 576         LEAVE;
 577         SPAGAIN;
 578         RETURN;
 579     }
 580     EXTEND(SP, 1);
 581     PUSHs(boolSV(do_close(gv, TRUE)));
 582     RETURN;
 583 }
 584
 585 PP(pp_pipe_op)
 586 {
 587     djSP;
 588 #ifdef HAS_PIPE
 589     GV *rgv;
 590     GV *wgv;
 591     register IO *rstio;
 592     register IO *wstio;
 593     int fd[2];
 594
 595     wgv = (GV*)POPs;
 596     rgv = (GV*)POPs;
 597
 598     if (!rgv || !wgv)
 599         goto badexit;
 600
 601     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
 602         DIE(aTHX_ PL_no_usym, "filehandle");
 603     rstio = GvIOn(rgv);
 604     wstio = GvIOn(wgv);
 605
 606     if (IoIFP(rstio))
 607         do_close(rgv, FALSE);
 608     if (IoIFP(wstio))
 609         do_close(wgv, FALSE);
 610
 611     if (PerlProc_pipe(fd) < 0)
 612         goto badexit;
 613
 614     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 615     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 616     IoIFP(wstio) = IoOFP(wstio);
 617     IoTYPE(rstio) = '<';
 618     IoTYPE(wstio) = '>';
 619
 620     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 621         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 622         else PerlLIO_close(fd[0]);
 623         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 624         else PerlLIO_close(fd[1]);
 625         goto badexit;
 626     }
 627 #if defined(HAS_FCNTL) && defined(F_SETFD)
 628     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
 629     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
 630 #endif
 631     RETPUSHYES;
 632
 633 badexit:
 634     RETPUSHUNDEF;
 635 #else
 636     DIE(aTHX_ PL_no_func, "pipe");
 637 #endif
 638 }
 639
 640 PP(pp_fileno)
 641 {
 642     djSP; dTARGET;
 643     GV *gv;
 644     IO *io;
 645     PerlIO *fp;
 646     MAGIC  *mg;
 647
 648     if (MAXARG < 1)
 649         RETPUSHUNDEF;
 650     gv = (GV*)POPs;
 651
 652     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 653         PUSHMARK(SP);
 654         XPUSHs(SvTIED_obj((SV*)gv, mg));
 655         PUTBACK;
 656         ENTER;
 657         call_method("FILENO", G_SCALAR);
 658         LEAVE;
 659         SPAGAIN;
 660         RETURN;
 661     }
 662
 663     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
 664         RETPUSHUNDEF;
 665     PUSHi(PerlIO_fileno(fp));
 666     RETURN;
 667 }
 668
 669 PP(pp_umask)
 670 {
 671     djSP; dTARGET;
 672     Mode_t anum;
 673
 674 #ifdef HAS_UMASK
 675     if (MAXARG < 1) {
 676         anum = PerlLIO_umask(0);
 677         (void)PerlLIO_umask(anum);
 678     }
 679     else
 680         anum = PerlLIO_umask(POPi);
 681     TAINT_PROPER("umask");
 682     XPUSHi(anum);
 683 #else
 684     /* Only DIE if trying to restrict permissions on `user' (self).
 685      * Otherwise it's harmless and more useful to just return undef
 686      * since 'group' and 'other' concepts probably don't exist here. */
 687     if (MAXARG >= 1 && (POPi & 0700))
 688         DIE(aTHX_ "umask not implemented");
 689     XPUSHs(&PL_sv_undef);
 690 #endif
 691     RETURN;
 692 }
 693
 694 PP(pp_binmode)
 695 {
 696     djSP;
 697     GV *gv;
 698     IO *io;
 699     PerlIO *fp;
 700     MAGIC *mg;
 701
 702     if (MAXARG < 1)
 703         RETPUSHUNDEF;
 704
 705     gv = (GV*)POPs;
 706
 707     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 708         PUSHMARK(SP);
 709         XPUSHs(SvTIED_obj((SV*)gv, mg));
 710         PUTBACK;
 711         ENTER;
 712         call_method("BINMODE", G_SCALAR);
 713         LEAVE;
 714         SPAGAIN;
 715         RETURN;
 716     }
 717
 718     EXTEND(SP, 1);
 719     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
 720         RETPUSHUNDEF;
 721
 722     if (do_binmode(fp,IoTYPE(io),TRUE))
 723         RETPUSHYES;
 724     else
 725         RETPUSHUNDEF;
 726 }
 727
 728
 729 PP(pp_tie)
 730 {
 731     djSP;
 732     dMARK;
 733     SV *varsv;
 734     HV* stash;
 735     GV *gv;
 736     SV *sv;
 737     I32 markoff = MARK - PL_stack_base;
 738     char *methname;
 739     int how = 'P';
 740     U32 items;
 741     STRLEN n_a;
 742
 743     varsv = *++MARK;
 744     switch(SvTYPE(varsv)) {
 745         case SVt_PVHV:
 746             methname = "TIEHASH";
 747             break;
 748         case SVt_PVAV:
 749             methname = "TIEARRAY";
 750             break;
 751         case SVt_PVGV:
 752             methname = "TIEHANDLE";
 753             how = 'q';
 754             break;
 755         default:
 756             methname = "TIESCALAR";
 757             how = 'q';
 758             break;
 759     }
 760     items = SP - MARK++;
 761     if (sv_isobject(*MARK)) {
 762         ENTER;
 763         PUSHSTACKi(PERLSI_MAGIC);
 764         PUSHMARK(SP);
 765         EXTEND(SP,items);
 766         while (items--)
 767             PUSHs(*MARK++);
 768         PUTBACK;
 769         call_method(methname, G_SCALAR);
 770     }
 771     else {
 772         /* Not clear why we don't call call_method here too.
 773          * perhaps to get different error message ?
 774          */
 775         stash = gv_stashsv(*MARK, FALSE);
 776         if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 777             DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
 778                  methname, SvPV(*MARK,n_a));
 779         }
 780         ENTER;
 781         PUSHSTACKi(PERLSI_MAGIC);
 782         PUSHMARK(SP);
 783         EXTEND(SP,items);
 784         while (items--)
 785             PUSHs(*MARK++);
 786         PUTBACK;
 787         call_sv((SV*)GvCV(gv), G_SCALAR);
 788     }
 789     SPAGAIN;
 790
 791     sv = TOPs;
 792     POPSTACK;
 793     if (sv_isobject(sv)) {
 794         sv_unmagic(varsv, how);
 795         sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
 796     }
 797     LEAVE;
 798     SP = PL_stack_base + markoff;
 799     PUSHs(sv);
 800     RETURN;
 801 }
 802
 803 PP(pp_untie)
 804 {
 805     djSP;
 806     SV *sv = POPs;
 807     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 808
 809     if (ckWARN(WARN_UNTIE)) {
 810         MAGIC * mg ;
 811         if (mg = SvTIED_mg(sv, how)) {
 812             if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
 813                 Perl_warner(aTHX_ WARN_UNTIE,
 814                     "untie attempted while %"UVuf" inner references still exist",
 815                     (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
 816         }
 817     }
 818
 819     sv_unmagic(sv, how);
 820     RETPUSHYES;
 821 }
 822
 823 PP(pp_tied)
 824 {
 825     djSP;
 826     SV *sv = POPs;
 827     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 828     MAGIC *mg;
 829
 830     if (mg = SvTIED_mg(sv, how)) {
 831         SV *osv = SvTIED_obj(sv, mg);
 832         if (osv == mg->mg_obj)
 833             osv = sv_mortalcopy(osv);
 834         PUSHs(osv);
 835         RETURN;
 836     }
 837     RETPUSHUNDEF;
 838 }
 839
 840 PP(pp_dbmopen)
 841 {
 842     djSP;
 843     HV *hv;
 844     dPOPPOPssrl;
 845     HV* stash;
 846     GV *gv;
 847     SV *sv;
 848
 849     hv = (HV*)POPs;
 850
 851     sv = sv_mortalcopy(&PL_sv_no);
 852     sv_setpv(sv, "AnyDBM_File");
 853     stash = gv_stashsv(sv, FALSE);
 854     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
 855         PUTBACK;
 856         require_pv("AnyDBM_File.pm");
 857         SPAGAIN;
 858         if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
 859             DIE(aTHX_ "No dbm on this machine");
 860     }
 861
 862     ENTER;
 863     PUSHMARK(SP);
 864
 865     EXTEND(SP, 5);
 866     PUSHs(sv);
 867     PUSHs(left);
 868     if (SvIV(right))
 869         PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
 870     else
 871         PUSHs(sv_2mortal(newSViv(O_RDWR)));
 872     PUSHs(right);
 873     PUTBACK;
 874     call_sv((SV*)GvCV(gv), G_SCALAR);
 875     SPAGAIN;
 876
 877     if (!sv_isobject(TOPs)) {
 878         SP--;
 879         PUSHMARK(SP);
 880         PUSHs(sv);
 881         PUSHs(left);
 882         PUSHs(sv_2mortal(newSViv(O_RDONLY)));
 883         PUSHs(right);
 884         PUTBACK;
 885         call_sv((SV*)GvCV(gv), G_SCALAR);
 886         SPAGAIN;
 887     }
 888
 889     if (sv_isobject(TOPs)) {
 890         sv_unmagic((SV *) hv, 'P');
 891         sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
 892     }
 893     LEAVE;
 894     RETURN;
 895 }
 896
 897 PP(pp_dbmclose)
 898 {
 899     return pp_untie();
 900 }
 901
 902 PP(pp_sselect)
 903 {
 904     djSP; dTARGET;
 905 #ifdef HAS_SELECT
 906     register I32 i;
 907     register I32 j;
 908     register char *s;
 909     register SV *sv;
 910     NV value;
 911     I32 maxlen = 0;
 912     I32 nfound;
 913     struct timeval timebuf;
 914     struct timeval *tbuf = &timebuf;
 915     I32 growsize;
 916     char *fd_sets[4];
 917     STRLEN n_a;
 918 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
 919         I32 masksize;
 920         I32 offset;
 921         I32 k;
 922
 923 #   if BYTEORDER & 0xf0000
 924 #       define ORDERBYTE (0x88888888 - BYTEORDER)
 925 #   else
 926 #       define ORDERBYTE (0x4444 - BYTEORDER)
 927 #   endif
 928
 929 #endif
 930
 931     SP -= 4;
 932     for (i = 1; i <= 3; i++) {
 933         if (!SvPOK(SP[i]))
 934             continue;
 935         j = SvCUR(SP[i]);
 936         if (maxlen < j)
 937             maxlen = j;
 938     }
 939
 940 /* little endians can use vecs directly */
 941 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
 942 #  if SELECT_MIN_BITS > 1
 943     /* If SELECT_MIN_BITS is greater than one we most probably will want
 944      * to align the sizes with SELECT_MIN_BITS/8 because for example
 945      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
 946      * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
 947      * on (sets/tests/clears bits) is 32 bits.  */
 948     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
 949 #  else
 950     growsize = sizeof(fd_set);
 951 #  endif
 952 # else
 953 #  ifdef NFDBITS
 954
 955 #    ifndef NBBY
 956 #     define NBBY 8
 957 #    endif
 958
 959     masksize = NFDBITS / NBBY;
 960 #  else
 961     masksize = sizeof(long);    /* documented int, everyone seems to use long */
 962 #  endif
 963     growsize = maxlen + (masksize - (maxlen % masksize));
 964     Zero(&fd_sets[0], 4, char*);
 965 #endif
 966
 967     sv = SP[4];
 968     if (SvOK(sv)) {
 969         value = SvNV(sv);
 970         if (value < 0.0)
 971             value = 0.0;
 972         timebuf.tv_sec = (long)value;
 973         value -= (NV)timebuf.tv_sec;
 974         timebuf.tv_usec = (long)(value * 1000000.0);
 975     }
 976     else
 977         tbuf = Null(struct timeval*);
 978
 979     for (i = 1; i <= 3; i++) {
 980         sv = SP[i];
 981         if (!SvOK(sv)) {
 982             fd_sets[i] = 0;
 983             continue;
 984         }
 985         else if (!SvPOK(sv))
 986             SvPV_force(sv,n_a); /* force string conversion */
 987         j = SvLEN(sv);
 988         if (j < growsize) {
 989             Sv_Grow(sv, growsize);
 990         }
 991         j = SvCUR(sv);
 992         s = SvPVX(sv) + j;
 993         while (++j <= growsize) {
 994             *s++ = '\0';
 995         }
 996
 997 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
 998         s = SvPVX(sv);
 999         New(403, fd_sets[i], growsize, char);
1000         for (offset = 0; offset < growsize; offset += masksize) {
1001             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1002                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1003         }
1004 #else
1005         fd_sets[i] = SvPVX(sv);
1006 #endif
1007     }
1008
1009     nfound = PerlSock_select(
1010         maxlen * 8,
1011         (Select_fd_set_t) fd_sets[1],
1012         (Select_fd_set_t) fd_sets[2],
1013         (Select_fd_set_t) fd_sets[3],
1014         tbuf);
1015     for (i = 1; i <= 3; i++) {
1016         if (fd_sets[i]) {
1017             sv = SP[i];
1018 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1019             s = SvPVX(sv);
1020             for (offset = 0; offset < growsize; offset += masksize) {
1021                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1022                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1023             }
1024             Safefree(fd_sets[i]);
1025 #endif
1026             SvSETMAGIC(sv);
1027         }
1028     }
1029
1030     PUSHi(nfound);
1031     if (GIMME == G_ARRAY && tbuf) {
1032         value = (NV)(timebuf.tv_sec) +
1033                 (NV)(timebuf.tv_usec) / 1000000.0;
1034         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1035         sv_setnv(sv, value);
1036     }
1037     RETURN;
1038 #else
1039     DIE(aTHX_ "select not implemented");
1040 #endif
1041 }
1042
1043 void
1044 Perl_setdefout(pTHX_ GV *gv)
1045 {
1046     dTHR;
1047     if (gv)
1048         (void)SvREFCNT_inc(gv);
1049     if (PL_defoutgv)
1050         SvREFCNT_dec(PL_defoutgv);
1051     PL_defoutgv = gv;
1052 }
1053
1054 PP(pp_select)
1055 {
1056     djSP; dTARGET;
1057     GV *newdefout, *egv;
1058     HV *hv;
1059
1060     newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
1061
1062     egv = GvEGV(PL_defoutgv);
1063     if (!egv)
1064         egv = PL_defoutgv;
1065     hv = GvSTASH(egv);
1066     if (! hv)
1067         XPUSHs(&PL_sv_undef);
1068     else {
1069         GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1070         if (gvp && *gvp == egv) {
1071             gv_efullname3(TARG, PL_defoutgv, Nullch);
1072             XPUSHTARG;
1073         }
1074         else {
1075             XPUSHs(sv_2mortal(newRV((SV*)egv)));
1076         }
1077     }
1078
1079     if (newdefout) {
1080         if (!GvIO(newdefout))
1081             gv_IOadd(newdefout);
1082         setdefout(newdefout);
1083     }
1084
1085     RETURN;
1086 }
1087
1088 PP(pp_getc)
1089 {
1090     djSP; dTARGET;
1091     GV *gv;
1092     MAGIC *mg;
1093
1094     if (MAXARG <= 0)
1095         gv = PL_stdingv;
1096     else
1097         gv = (GV*)POPs;
1098     if (!gv)
1099         gv = PL_argvgv;
1100
1101     if (mg = SvTIED_mg((SV*)gv, 'q')) {
1102         I32 gimme = GIMME_V;
1103         PUSHMARK(SP);
1104         XPUSHs(SvTIED_obj((SV*)gv, mg));
1105         PUTBACK;
1106         ENTER;
1107         call_method("GETC", gimme);
1108         LEAVE;
1109         SPAGAIN;
1110         if (gimme == G_SCALAR)
1111             SvSetMagicSV_nosteal(TARG, TOPs);
1112         RETURN;
1113     }
1114     if (!gv || do_eof(gv)) /* make sure we have fp with something */
1115         RETPUSHUNDEF;
1116     TAINT;
1117     sv_setpv(TARG, " ");
1118     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1119     PUSHTARG;
1120     RETURN;
1121 }
1122
1123 PP(pp_read)
1124 {
1125     return pp_sysread();
1126 }
1127
1128 STATIC OP *
1129 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1130 {
1131     dTHR;
1132     register PERL_CONTEXT *cx;
1133     I32 gimme = GIMME_V;
1134     AV* padlist = CvPADLIST(cv);
1135     SV** svp = AvARRAY(padlist);
1136
1137     ENTER;
1138     SAVETMPS;
1139
1140     push_return(retop);
1141     PUSHBLOCK(cx, CXt_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 #  ifdef USE_ITHREADS
3586     /* XXXXXX testing */
3587     djSP; dTARGET;
3588     /* XXX this just an approximation of what will eventually be run
3589      * in a different thread */
3590     PerlInterpreter *new_perl = perl_clone(my_perl, 0);
3591     Perl_pp_enter(new_perl);
3592     new_perl->Top = new_perl->Top->op_next; /* continue from next op */
3593     CALLRUNOPS(new_perl);
3594
3595     /* parent returns with negative pseudo-pid */
3596     PUSHi(-1);
3597     RETURN;
3598 #  else
3599     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3600 #  endif
3601 #endif
3602 }
3603
3604 PP(pp_wait)
3605 {
3606 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3607     djSP; dTARGET;
3608     Pid_t childpid;
3609     int argflags;
3610
3611     childpid = wait4pid(-1, &argflags, 0);
3612     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3613     XPUSHi(childpid);
3614     RETURN;
3615 #else
3616     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3617 #endif
3618 }
3619
3620 PP(pp_waitpid)
3621 {
3622 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3623     djSP; dTARGET;
3624     Pid_t childpid;
3625     int optype;
3626     int argflags;
3627
3628     optype = POPi;
3629     childpid = TOPi;
3630     childpid = wait4pid(childpid, &argflags, optype);
3631     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3632     SETi(childpid);
3633     RETURN;
3634 #else
3635     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3636 #endif
3637 }
3638
3639 PP(pp_system)
3640 {
3641     djSP; dMARK; dORIGMARK; dTARGET;
3642     I32 value;
3643     Pid_t childpid;
3644     int result;
3645     int status;
3646     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3647     STRLEN n_a;
3648     I32 did_pipes = 0;
3649     int pp[2];
3650
3651     if (SP - MARK == 1) {
3652         if (PL_tainting) {
3653             char *junk = SvPV(TOPs, n_a);
3654             TAINT_ENV();
3655             TAINT_PROPER("system");
3656         }
3657     }
3658     PERL_FLUSHALL_FOR_CHILD;
3659 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3660     if (PerlProc_pipe(pp) >= 0)
3661         did_pipes = 1;
3662     while ((childpid = vfork()) == -1) {
3663         if (errno != EAGAIN) {
3664             value = -1;
3665             SP = ORIGMARK;
3666             PUSHi(value);
3667             if (did_pipes) {
3668                 PerlLIO_close(pp[0]);
3669                 PerlLIO_close(pp[1]);
3670             }
3671             RETURN;
3672         }
3673         sleep(5);
3674     }
3675     if (childpid > 0) {
3676         if (did_pipes)
3677             PerlLIO_close(pp[1]);
3678         rsignal_save(SIGINT, SIG_IGN, &ihand);
3679         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3680         do {
3681             result = wait4pid(childpid, &status, 0);
3682         } while (result == -1 && errno == EINTR);
3683         (void)rsignal_restore(SIGINT, &ihand);
3684         (void)rsignal_restore(SIGQUIT, &qhand);
3685         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3686         do_execfree();  /* free any memory child malloced on vfork */
3687         SP = ORIGMARK;
3688         if (did_pipes) {
3689             int errkid;
3690             int n = 0, n1;
3691
3692             while (n < sizeof(int)) {
3693                 n1 = PerlLIO_read(pp[0],
3694                                   (void*)(((char*)&errkid)+n),
3695                                   (sizeof(int)) - n);
3696                 if (n1 <= 0)
3697                     break;
3698                 n += n1;
3699             }
3700             PerlLIO_close(pp[0]);
3701             if (n) {                    /* Error */
3702                 if (n != sizeof(int))
3703                     DIE(aTHX_ "panic: kid popen errno read");
3704                 errno = errkid;         /* Propagate errno from kid */
3705                 STATUS_CURRENT = -1;
3706             }
3707         }
3708         PUSHi(STATUS_CURRENT);
3709         RETURN;
3710     }
3711     if (did_pipes) {
3712         PerlLIO_close(pp[0]);
3713 #if defined(HAS_FCNTL) && defined(F_SETFD)
3714         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3715 #endif
3716     }
3717     if (PL_op->op_flags & OPf_STACKED) {
3718         SV *really = *++MARK;
3719         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
3720     }
3721     else if (SP - MARK != 1)
3722         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
3723     else {
3724         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
3725     }
3726     PerlProc__exit(-1);
3727 #else /* ! FORK or VMS or OS/2 */
3728     if (PL_op->op_flags & OPf_STACKED) {
3729         SV *really = *++MARK;
3730         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3731     }
3732     else if (SP - MARK != 1)
3733         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3734     else {
3735         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3736     }
3737     STATUS_NATIVE_SET(value);
3738     do_execfree();
3739     SP = ORIGMARK;
3740     PUSHi(STATUS_CURRENT);
3741 #endif /* !FORK or VMS */
3742     RETURN;
3743 }
3744
3745 PP(pp_exec)
3746 {
3747     djSP; dMARK; dORIGMARK; dTARGET;
3748     I32 value;
3749     STRLEN n_a;
3750
3751     PERL_FLUSHALL_FOR_CHILD;
3752     if (PL_op->op_flags & OPf_STACKED) {
3753         SV *really = *++MARK;
3754         value = (I32)do_aexec(really, MARK, SP);
3755     }
3756     else if (SP - MARK != 1)
3757 #ifdef VMS
3758         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3759 #else
3760 #  ifdef __OPEN_VM
3761         {
3762            (void ) do_aspawn(Nullsv, MARK, SP);
3763            value = 0;
3764         }
3765 #  else
3766         value = (I32)do_aexec(Nullsv, MARK, SP);
3767 #  endif
3768 #endif
3769     else {
3770         if (PL_tainting) {
3771             char *junk = SvPV(*SP, n_a);
3772             TAINT_ENV();
3773             TAINT_PROPER("exec");
3774         }
3775 #ifdef VMS
3776         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3777 #else
3778 #  ifdef __OPEN_VM
3779         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3780         value = 0;
3781 #  else
3782         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3783 #  endif
3784 #endif
3785     }
3786     SP = ORIGMARK;
3787     PUSHi(value);
3788     RETURN;
3789 }
3790
3791 PP(pp_kill)
3792 {
3793     djSP; dMARK; dTARGET;
3794     I32 value;
3795 #ifdef HAS_KILL
3796     value = (I32)apply(PL_op->op_type, MARK, SP);
3797     SP = MARK;
3798     PUSHi(value);
3799     RETURN;
3800 #else
3801     DIE(aTHX_ PL_no_func, "Unsupported function kill");
3802 #endif
3803 }
3804
3805 PP(pp_getppid)
3806 {
3807 #ifdef HAS_GETPPID
3808     djSP; dTARGET;
3809     XPUSHi( getppid() );
3810     RETURN;
3811 #else
3812     DIE(aTHX_ PL_no_func, "getppid");
3813 #endif
3814 }
3815
3816 PP(pp_getpgrp)
3817 {
3818 #ifdef HAS_GETPGRP
3819     djSP; dTARGET;
3820     Pid_t pid;
3821     Pid_t pgrp;
3822
3823     if (MAXARG < 1)
3824         pid = 0;
3825     else
3826         pid = SvIVx(POPs);
3827 #ifdef BSD_GETPGRP
3828     pgrp = (I32)BSD_GETPGRP(pid);
3829 #else
3830     if (pid != 0 && pid != getpid())
3831         DIE(aTHX_ "POSIX getpgrp can't take an argument");
3832     pgrp = getpgrp();
3833 #endif
3834     XPUSHi(pgrp);
3835     RETURN;
3836 #else
3837     DIE(aTHX_ PL_no_func, "getpgrp()");
3838 #endif
3839 }
3840
3841 PP(pp_setpgrp)
3842 {
3843 #ifdef HAS_SETPGRP
3844     djSP; dTARGET;
3845     Pid_t pgrp;
3846     Pid_t pid;
3847     if (MAXARG < 2) {
3848         pgrp = 0;
3849         pid = 0;
3850     }
3851     else {
3852         pgrp = POPi;
3853         pid = TOPi;
3854     }
3855
3856     TAINT_PROPER("setpgrp");
3857 #ifdef BSD_SETPGRP
3858     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3859 #else
3860     if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
3861         DIE(aTHX_ "setpgrp can't take arguments");
3862     SETi( setpgrp() >= 0 );
3863 #endif /* USE_BSDPGRP */
3864     RETURN;
3865 #else
3866     DIE(aTHX_ PL_no_func, "setpgrp()");
3867 #endif
3868 }
3869
3870 PP(pp_getpriority)
3871 {
3872     djSP; dTARGET;
3873     int which;
3874     int who;
3875 #ifdef HAS_GETPRIORITY
3876     who = POPi;
3877     which = TOPi;
3878     SETi( getpriority(which, who) );
3879     RETURN;
3880 #else
3881     DIE(aTHX_ PL_no_func, "getpriority()");
3882 #endif
3883 }
3884
3885 PP(pp_setpriority)
3886 {
3887     djSP; dTARGET;
3888     int which;
3889     int who;
3890     int niceval;
3891 #ifdef HAS_SETPRIORITY
3892     niceval = POPi;
3893     who = POPi;
3894     which = TOPi;
3895     TAINT_PROPER("setpriority");
3896     SETi( setpriority(which, who, niceval) >= 0 );
3897     RETURN;
3898 #else
3899     DIE(aTHX_ PL_no_func, "setpriority()");
3900 #endif
3901 }
3902
3903 /* Time calls. */
3904
3905 PP(pp_time)
3906 {
3907     djSP; dTARGET;
3908 #ifdef BIG_TIME
3909     XPUSHn( time(Null(Time_t*)) );
3910 #else
3911     XPUSHi( time(Null(Time_t*)) );
3912 #endif
3913     RETURN;
3914 }
3915
3916 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3917    to HZ.  Probably.  For now, assume that if the system
3918    defines HZ, it does so correctly.  (Will this break
3919    on VMS?)
3920    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3921    it's supported.    --AD  9/96.
3922 */
3923
3924 #ifndef HZ
3925 #  ifdef CLK_TCK
3926 #    define HZ CLK_TCK
3927 #  else
3928 #    define HZ 60
3929 #  endif
3930 #endif
3931
3932 PP(pp_tms)
3933 {
3934     djSP;
3935
3936 #ifndef HAS_TIMES
3937     DIE(aTHX_ "times not implemented");
3938 #else
3939     EXTEND(SP, 4);
3940
3941 #ifndef VMS
3942     (void)PerlProc_times(&PL_timesbuf);
3943 #else
3944     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
3945                                                    /* struct tms, though same data   */
3946                                                    /* is returned.                   */
3947 #endif
3948
3949     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
3950     if (GIMME == G_ARRAY) {
3951         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
3952         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
3953         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
3954     }
3955     RETURN;
3956 #endif /* HAS_TIMES */
3957 }
3958
3959 PP(pp_localtime)
3960 {
3961     return pp_gmtime();
3962 }
3963
3964 PP(pp_gmtime)
3965 {
3966     djSP;
3967     Time_t when;
3968     struct tm *tmbuf;
3969     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3970     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3971                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3972
3973     if (MAXARG < 1)
3974         (void)time(&when);
3975     else
3976 #ifdef BIG_TIME
3977         when = (Time_t)SvNVx(POPs);
3978 #else
3979         when = (Time_t)SvIVx(POPs);
3980 #endif
3981
3982     if (PL_op->op_type == OP_LOCALTIME)
3983         tmbuf = localtime(&when);
3984     else
3985         tmbuf = gmtime(&when);
3986
3987     EXTEND(SP, 9);
3988     EXTEND_MORTAL(9);
3989     if (GIMME != G_ARRAY) {
3990         dTARGET;
3991         SV *tsv;
3992         if (!tmbuf)
3993             RETPUSHUNDEF;
3994         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
3995                             dayname[tmbuf->tm_wday],
3996                             monname[tmbuf->tm_mon],
3997                             tmbuf->tm_mday,
3998                             tmbuf->tm_hour,
3999                             tmbuf->tm_min,
4000                             tmbuf->tm_sec,
4001                             tmbuf->tm_year + 1900);
4002         PUSHs(sv_2mortal(tsv));
4003     }
4004     else if (tmbuf) {
4005         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4006         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4007         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4008         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4009         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4010         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4011         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4012         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4013         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4014     }
4015     RETURN;
4016 }
4017
4018 PP(pp_alarm)
4019 {
4020     djSP; dTARGET;
4021     int anum;
4022 #ifdef HAS_ALARM
4023     anum = POPi;
4024     anum = alarm((unsigned int)anum);
4025     EXTEND(SP, 1);
4026     if (anum < 0)
4027         RETPUSHUNDEF;
4028     PUSHi(anum);
4029     RETURN;
4030 #else
4031     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4032 #endif
4033 }
4034
4035 PP(pp_sleep)
4036 {
4037     djSP; dTARGET;
4038     I32 duration;
4039     Time_t lasttime;
4040     Time_t when;
4041
4042     (void)time(&lasttime);
4043     if (MAXARG < 1)
4044         PerlProc_pause();
4045     else {
4046         duration = POPi;
4047         PerlProc_sleep((unsigned int)duration);
4048     }
4049     (void)time(&when);
4050     XPUSHi(when - lasttime);
4051     RETURN;
4052 }
4053
4054 /* Shared memory. */
4055
4056 PP(pp_shmget)
4057 {
4058     return pp_semget();
4059 }
4060
4061 PP(pp_shmctl)
4062 {
4063     return pp_semctl();
4064 }
4065
4066 PP(pp_shmread)
4067 {
4068     return pp_shmwrite();
4069 }
4070
4071 PP(pp_shmwrite)
4072 {
4073 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4074     djSP; dMARK; dTARGET;
4075     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4076     SP = MARK;
4077     PUSHi(value);
4078     RETURN;
4079 #else
4080     return pp_semget();
4081 #endif
4082 }
4083
4084 /* Message passing. */
4085
4086 PP(pp_msgget)
4087 {
4088     return pp_semget();
4089 }
4090
4091 PP(pp_msgctl)
4092 {
4093     return pp_semctl();
4094 }
4095
4096 PP(pp_msgsnd)
4097 {
4098 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4099     djSP; dMARK; dTARGET;
4100     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4101     SP = MARK;
4102     PUSHi(value);
4103     RETURN;
4104 #else
4105     return pp_semget();
4106 #endif
4107 }
4108
4109 PP(pp_msgrcv)
4110 {
4111 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4112     djSP; dMARK; dTARGET;
4113     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4114     SP = MARK;
4115     PUSHi(value);
4116     RETURN;
4117 #else
4118     return pp_semget();
4119 #endif
4120 }
4121
4122 /* Semaphores. */
4123
4124 PP(pp_semget)
4125 {
4126 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4127     djSP; dMARK; dTARGET;
4128     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4129     SP = MARK;
4130     if (anum == -1)
4131         RETPUSHUNDEF;
4132     PUSHi(anum);
4133     RETURN;
4134 #else
4135     DIE(aTHX_ "System V IPC is not implemented on this machine");
4136 #endif
4137 }
4138
4139 PP(pp_semctl)
4140 {
4141 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4142     djSP; dMARK; dTARGET;
4143     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4144     SP = MARK;
4145     if (anum == -1)
4146         RETSETUNDEF;
4147     if (anum != 0) {
4148         PUSHi(anum);
4149     }
4150     else {
4151         PUSHp(zero_but_true, ZBTLEN);
4152     }
4153     RETURN;
4154 #else
4155     return pp_semget();
4156 #endif
4157 }
4158
4159 PP(pp_semop)
4160 {
4161 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4162     djSP; dMARK; dTARGET;
4163     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4164     SP = MARK;
4165     PUSHi(value);
4166     RETURN;
4167 #else
4168     return pp_semget();
4169 #endif
4170 }
4171
4172 /* Get system info. */
4173
4174 PP(pp_ghbyname)
4175 {
4176 #ifdef HAS_GETHOSTBYNAME
4177     return pp_ghostent();
4178 #else
4179     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4180 #endif
4181 }
4182
4183 PP(pp_ghbyaddr)
4184 {
4185 #ifdef HAS_GETHOSTBYADDR
4186     return pp_ghostent();
4187 #else
4188     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4189 #endif
4190 }
4191
4192 PP(pp_ghostent)
4193 {
4194     djSP;
4195 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4196     I32 which = PL_op->op_type;
4197     register char **elem;
4198     register SV *sv;
4199 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4200     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4201     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4202     struct hostent *PerlSock_gethostent(void);
4203 #endif
4204     struct hostent *hent;
4205     unsigned long len;
4206     STRLEN n_a;
4207
4208     EXTEND(SP, 10);
4209     if (which == OP_GHBYNAME)
4210 #ifdef HAS_GETHOSTBYNAME
4211         hent = PerlSock_gethostbyname(POPpx);
4212 #else
4213         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4214 #endif
4215     else if (which == OP_GHBYADDR) {
4216 #ifdef HAS_GETHOSTBYADDR
4217         int addrtype = POPi;
4218         SV *addrsv = POPs;
4219         STRLEN addrlen;
4220         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
4221
4222         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4223 #else
4224         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4225 #endif
4226     }
4227     else
4228 #ifdef HAS_GETHOSTENT
4229         hent = PerlSock_gethostent();
4230 #else
4231         DIE(aTHX_ PL_no_sock_func, "gethostent");
4232 #endif
4233
4234 #ifdef HOST_NOT_FOUND
4235     if (!hent)
4236         STATUS_NATIVE_SET(h_errno);
4237 #endif
4238
4239     if (GIMME != G_ARRAY) {
4240         PUSHs(sv = sv_newmortal());
4241         if (hent) {
4242             if (which == OP_GHBYNAME) {
4243                 if (hent->h_addr)
4244                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4245             }
4246             else
4247                 sv_setpv(sv, (char*)hent->h_name);
4248         }
4249         RETURN;
4250     }
4251
4252     if (hent) {
4253         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4254         sv_setpv(sv, (char*)hent->h_name);
4255         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4256         for (elem = hent->h_aliases; elem && *elem; elem++) {
4257             sv_catpv(sv, *elem);
4258             if (elem[1])
4259                 sv_catpvn(sv, " ", 1);
4260         }
4261         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4262         sv_setiv(sv, (IV)hent->h_addrtype);
4263         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4264         len = hent->h_length;
4265         sv_setiv(sv, (IV)len);
4266 #ifdef h_addr
4267         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4268             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4269             sv_setpvn(sv, *elem, len);
4270         }
4271 #else
4272         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4273         if (hent->h_addr)
4274             sv_setpvn(sv, hent->h_addr, len);
4275 #endif /* h_addr */
4276     }
4277     RETURN;
4278 #else
4279     DIE(aTHX_ PL_no_sock_func, "gethostent");
4280 #endif
4281 }
4282
4283 PP(pp_gnbyname)
4284 {
4285 #ifdef HAS_GETNETBYNAME
4286     return pp_gnetent();
4287 #else
4288     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4289 #endif
4290 }
4291
4292 PP(pp_gnbyaddr)
4293 {
4294 #ifdef HAS_GETNETBYADDR
4295     return pp_gnetent();
4296 #else
4297     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4298 #endif
4299 }
4300
4301 PP(pp_gnetent)
4302 {
4303     djSP;
4304 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4305     I32 which = PL_op->op_type;
4306     register char **elem;
4307     register SV *sv;
4308 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4309     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4310     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4311     struct netent *PerlSock_getnetent(void);
4312 #endif
4313     struct netent *nent;
4314     STRLEN n_a;
4315
4316     if (which == OP_GNBYNAME)
4317 #ifdef HAS_GETNETBYNAME
4318         nent = PerlSock_getnetbyname(POPpx);
4319 #else
4320         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4321 #endif
4322     else if (which == OP_GNBYADDR) {
4323 #ifdef HAS_GETNETBYADDR
4324         int addrtype = POPi;
4325         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4326         nent = PerlSock_getnetbyaddr(addr, addrtype);
4327 #else
4328         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4329 #endif
4330     }
4331     else
4332 #ifdef HAS_GETNETENT
4333         nent = PerlSock_getnetent();
4334 #else
4335         DIE(aTHX_ PL_no_sock_func, "getnetent");
4336 #endif
4337
4338     EXTEND(SP, 4);
4339     if (GIMME != G_ARRAY) {
4340         PUSHs(sv = sv_newmortal());
4341         if (nent) {
4342             if (which == OP_GNBYNAME)
4343                 sv_setiv(sv, (IV)nent->n_net);
4344             else
4345                 sv_setpv(sv, nent->n_name);
4346         }
4347         RETURN;
4348     }
4349
4350     if (nent) {
4351         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4352         sv_setpv(sv, nent->n_name);
4353         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4354         for (elem = nent->n_aliases; elem && *elem; elem++) {
4355             sv_catpv(sv, *elem);
4356             if (elem[1])
4357                 sv_catpvn(sv, " ", 1);
4358         }
4359         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4360         sv_setiv(sv, (IV)nent->n_addrtype);
4361         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4362         sv_setiv(sv, (IV)nent->n_net);
4363     }
4364
4365     RETURN;
4366 #else
4367     DIE(aTHX_ PL_no_sock_func, "getnetent");
4368 #endif
4369 }
4370
4371 PP(pp_gpbyname)
4372 {
4373 #ifdef HAS_GETPROTOBYNAME
4374     return pp_gprotoent();
4375 #else
4376     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4377 #endif
4378 }
4379
4380 PP(pp_gpbynumber)
4381 {
4382 #ifdef HAS_GETPROTOBYNUMBER
4383     return pp_gprotoent();
4384 #else
4385     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4386 #endif
4387 }
4388
4389 PP(pp_gprotoent)
4390 {
4391     djSP;
4392 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4393     I32 which = PL_op->op_type;
4394     register char **elem;
4395     register SV *sv;
4396 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4397     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4398     struct protoent *PerlSock_getprotobynumber(int);
4399     struct protoent *PerlSock_getprotoent(void);
4400 #endif
4401     struct protoent *pent;
4402     STRLEN n_a;
4403
4404     if (which == OP_GPBYNAME)
4405 #ifdef HAS_GETPROTOBYNAME
4406         pent = PerlSock_getprotobyname(POPpx);
4407 #else
4408         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4409 #endif
4410     else if (which == OP_GPBYNUMBER)
4411 #ifdef HAS_GETPROTOBYNUMBER
4412         pent = PerlSock_getprotobynumber(POPi);
4413 #else
4414     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4415 #endif
4416     else
4417 #ifdef HAS_GETPROTOENT
4418         pent = PerlSock_getprotoent();
4419 #else
4420         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4421 #endif
4422
4423     EXTEND(SP, 3);
4424     if (GIMME != G_ARRAY) {
4425         PUSHs(sv = sv_newmortal());
4426         if (pent) {
4427             if (which == OP_GPBYNAME)
4428                 sv_setiv(sv, (IV)pent->p_proto);
4429             else
4430                 sv_setpv(sv, pent->p_name);
4431         }
4432         RETURN;
4433     }
4434
4435     if (pent) {
4436         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4437         sv_setpv(sv, pent->p_name);
4438         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4439         for (elem = pent->p_aliases; elem && *elem; elem++) {
4440             sv_catpv(sv, *elem);
4441             if (elem[1])
4442                 sv_catpvn(sv, " ", 1);
4443         }
4444         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4445         sv_setiv(sv, (IV)pent->p_proto);
4446     }
4447
4448     RETURN;
4449 #else
4450     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4451 #endif
4452 }
4453
4454 PP(pp_gsbyname)
4455 {
4456 #ifdef HAS_GETSERVBYNAME
4457     return pp_gservent();
4458 #else
4459     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4460 #endif
4461 }
4462
4463 PP(pp_gsbyport)
4464 {
4465 #ifdef HAS_GETSERVBYPORT
4466     return pp_gservent();
4467 #else
4468     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4469 #endif
4470 }
4471
4472 PP(pp_gservent)
4473 {
4474     djSP;
4475 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4476     I32 which = PL_op->op_type;
4477     register char **elem;
4478     register SV *sv;
4479 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4480     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4481     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4482     struct servent *PerlSock_getservent(void);
4483 #endif
4484     struct servent *sent;
4485     STRLEN n_a;
4486
4487     if (which == OP_GSBYNAME) {
4488 #ifdef HAS_GETSERVBYNAME
4489         char *proto = POPpx;
4490         char *name = POPpx;
4491
4492         if (proto && !*proto)
4493             proto = Nullch;
4494
4495         sent = PerlSock_getservbyname(name, proto);
4496 #else
4497         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4498 #endif
4499     }
4500     else if (which == OP_GSBYPORT) {
4501 #ifdef HAS_GETSERVBYPORT
4502         char *proto = POPpx;
4503         unsigned short port = POPu;
4504
4505 #ifdef HAS_HTONS
4506         port = PerlSock_htons(port);
4507 #endif
4508         sent = PerlSock_getservbyport(port, proto);
4509 #else
4510         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4511 #endif
4512     }
4513     else
4514 #ifdef HAS_GETSERVENT
4515         sent = PerlSock_getservent();
4516 #else
4517         DIE(aTHX_ PL_no_sock_func, "getservent");
4518 #endif
4519
4520     EXTEND(SP, 4);
4521     if (GIMME != G_ARRAY) {
4522         PUSHs(sv = sv_newmortal());
4523         if (sent) {
4524             if (which == OP_GSBYNAME) {
4525 #ifdef HAS_NTOHS
4526                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4527 #else
4528                 sv_setiv(sv, (IV)(sent->s_port));
4529 #endif
4530             }
4531             else
4532                 sv_setpv(sv, sent->s_name);
4533         }
4534         RETURN;
4535     }
4536
4537     if (sent) {
4538         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4539         sv_setpv(sv, sent->s_name);
4540         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4541         for (elem = sent->s_aliases; elem && *elem; elem++) {
4542             sv_catpv(sv, *elem);
4543             if (elem[1])
4544                 sv_catpvn(sv, " ", 1);
4545         }
4546         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4547 #ifdef HAS_NTOHS
4548         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4549 #else
4550         sv_setiv(sv, (IV)(sent->s_port));
4551 #endif
4552         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4553         sv_setpv(sv, sent->s_proto);
4554     }
4555
4556     RETURN;
4557 #else
4558     DIE(aTHX_ PL_no_sock_func, "getservent");
4559 #endif
4560 }
4561
4562 PP(pp_shostent)
4563 {
4564     djSP;
4565 #ifdef HAS_SETHOSTENT
4566     PerlSock_sethostent(TOPi);
4567     RETSETYES;
4568 #else
4569     DIE(aTHX_ PL_no_sock_func, "sethostent");
4570 #endif
4571 }
4572
4573 PP(pp_snetent)
4574 {
4575     djSP;
4576 #ifdef HAS_SETNETENT
4577     PerlSock_setnetent(TOPi);
4578     RETSETYES;
4579 #else
4580     DIE(aTHX_ PL_no_sock_func, "setnetent");
4581 #endif
4582 }
4583
4584 PP(pp_sprotoent)
4585 {
4586     djSP;
4587 #ifdef HAS_SETPROTOENT
4588     PerlSock_setprotoent(TOPi);
4589     RETSETYES;
4590 #else
4591     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4592 #endif
4593 }
4594
4595 PP(pp_sservent)
4596 {
4597     djSP;
4598 #ifdef HAS_SETSERVENT
4599     PerlSock_setservent(TOPi);
4600     RETSETYES;
4601 #else
4602     DIE(aTHX_ PL_no_sock_func, "setservent");
4603 #endif
4604 }
4605
4606 PP(pp_ehostent)
4607 {
4608     djSP;
4609 #ifdef HAS_ENDHOSTENT
4610     PerlSock_endhostent();
4611     EXTEND(SP,1);
4612     RETPUSHYES;
4613 #else
4614     DIE(aTHX_ PL_no_sock_func, "endhostent");
4615 #endif
4616 }
4617
4618 PP(pp_enetent)
4619 {
4620     djSP;
4621 #ifdef HAS_ENDNETENT
4622     PerlSock_endnetent();
4623     EXTEND(SP,1);
4624     RETPUSHYES;
4625 #else
4626     DIE(aTHX_ PL_no_sock_func, "endnetent");
4627 #endif
4628 }
4629
4630 PP(pp_eprotoent)
4631 {
4632     djSP;
4633 #ifdef HAS_ENDPROTOENT
4634     PerlSock_endprotoent();
4635     EXTEND(SP,1);
4636     RETPUSHYES;
4637 #else
4638     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4639 #endif
4640 }
4641
4642 PP(pp_eservent)
4643 {
4644     djSP;
4645 #ifdef HAS_ENDSERVENT
4646     PerlSock_endservent();
4647     EXTEND(SP,1);
4648     RETPUSHYES;
4649 #else
4650     DIE(aTHX_ PL_no_sock_func, "endservent");
4651 #endif
4652 }
4653
4654 PP(pp_gpwnam)
4655 {
4656 #ifdef HAS_PASSWD
4657     return pp_gpwent();
4658 #else
4659     DIE(aTHX_ PL_no_func, "getpwnam");
4660 #endif
4661 }
4662
4663 PP(pp_gpwuid)
4664 {
4665 #ifdef HAS_PASSWD
4666     return pp_gpwent();
4667 #else
4668     DIE(aTHX_ PL_no_func, "getpwuid");
4669 #endif
4670 }
4671
4672 PP(pp_gpwent)
4673 {
4674     djSP;
4675 #if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
4676     I32 which = PL_op->op_type;
4677     register SV *sv;
4678     struct passwd *pwent;
4679     STRLEN n_a;
4680 #if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
4681     struct spwd *spwent = NULL;
4682 #endif
4683
4684     if (which == OP_GPWNAM)
4685         pwent = getpwnam(POPpx);
4686     else if (which == OP_GPWUID)
4687         pwent = getpwuid(POPi);
4688     else
4689         pwent = (struct passwd *)getpwent();
4690
4691 #ifdef HAS_GETSPNAM
4692     if (which == OP_GPWNAM) {
4693         if (pwent)
4694             spwent = getspnam(pwent->pw_name);
4695     }
4696 #  ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
4697     else if (which == OP_GPWUID) {
4698         if (pwent)
4699             spwent = getspnam(pwent->pw_name);
4700     }
4701 #  endif
4702 #  ifdef HAS_GETSPENT
4703     else
4704         spwent = (struct spwd *)getspent();
4705 #  endif
4706 #endif
4707
4708     EXTEND(SP, 10);
4709     if (GIMME != G_ARRAY) {
4710         PUSHs(sv = sv_newmortal());
4711         if (pwent) {
4712             if (which == OP_GPWNAM)
4713                 sv_setiv(sv, (IV)pwent->pw_uid);
4714             else
4715                 sv_setpv(sv, pwent->pw_name);
4716         }
4717         RETURN;
4718     }
4719
4720     if (pwent) {
4721         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4722         sv_setpv(sv, pwent->pw_name);
4723
4724         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4725 #ifdef PWPASSWD
4726 #   if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
4727       if (spwent)
4728               sv_setpv(sv, spwent->sp_pwdp);
4729       else
4730               sv_setpv(sv, pwent->pw_passwd);
4731 #   else
4732         sv_setpv(sv, pwent->pw_passwd);
4733 #   endif
4734 #endif
4735
4736         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4737         sv_setiv(sv, (IV)pwent->pw_uid);
4738
4739         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4740         sv_setiv(sv, (IV)pwent->pw_gid);
4741
4742         /* pw_change, pw_quota, and pw_age are mutually exclusive. */
4743         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4744 #ifdef PWCHANGE
4745         sv_setiv(sv, (IV)pwent->pw_change);
4746 #else
4747 #   ifdef PWQUOTA
4748         sv_setiv(sv, (IV)pwent->pw_quota);
4749 #   else
4750 #       ifdef PWAGE
4751         sv_setpv(sv, pwent->pw_age);
4752 #       endif
4753 #   endif
4754 #endif
4755
4756         /* pw_class and pw_comment are mutually exclusive. */
4757         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4758 #ifdef PWCLASS
4759         sv_setpv(sv, pwent->pw_class);
4760 #else
4761 #   ifdef PWCOMMENT
4762         sv_setpv(sv, pwent->pw_comment);
4763 #   endif
4764 #endif
4765
4766         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4767 #ifdef PWGECOS
4768         sv_setpv(sv, pwent->pw_gecos);
4769 #endif
4770 #ifndef INCOMPLETE_TAINTS
4771         /* pw_gecos is tainted because user himself can diddle with it. */
4772         SvTAINTED_on(sv);
4773 #endif
4774
4775         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4776         sv_setpv(sv, pwent->pw_dir);
4777
4778         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4779         sv_setpv(sv, pwent->pw_shell);
4780
4781 #ifdef PWEXPIRE
4782         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4783         sv_setiv(sv, (IV)pwent->pw_expire);
4784 #endif
4785     }
4786     RETURN;
4787 #else
4788     DIE(aTHX_ PL_no_func, "getpwent");
4789 #endif
4790 }
4791
4792 PP(pp_spwent)
4793 {
4794     djSP;
4795 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
4796     setpwent();
4797 #   ifdef HAS_SETSPENT
4798     setspent();
4799 #   endif
4800     RETPUSHYES;
4801 #else
4802     DIE(aTHX_ PL_no_func, "setpwent");
4803 #endif
4804 }
4805
4806 PP(pp_epwent)
4807 {
4808     djSP;
4809 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
4810     endpwent();
4811 #   ifdef HAS_ENDSPENT
4812     endspent();
4813 #   endif
4814     RETPUSHYES;
4815 #else
4816     DIE(aTHX_ PL_no_func, "endpwent");
4817 #endif
4818 }
4819
4820 PP(pp_ggrnam)
4821 {
4822 #ifdef HAS_GROUP
4823     return pp_ggrent();
4824 #else
4825     DIE(aTHX_ PL_no_func, "getgrnam");
4826 #endif
4827 }
4828
4829 PP(pp_ggrgid)
4830 {
4831 #ifdef HAS_GROUP
4832     return pp_ggrent();
4833 #else
4834     DIE(aTHX_ PL_no_func, "getgrgid");
4835 #endif
4836 }
4837
4838 PP(pp_ggrent)
4839 {
4840     djSP;
4841 #if defined(HAS_GROUP) && defined(HAS_GETGRENT)
4842     I32 which = PL_op->op_type;
4843     register char **elem;
4844     register SV *sv;
4845     struct group *grent;
4846     STRLEN n_a;
4847
4848     if (which == OP_GGRNAM)
4849         grent = (struct group *)getgrnam(POPpx);
4850     else if (which == OP_GGRGID)
4851         grent = (struct group *)getgrgid(POPi);
4852     else
4853         grent = (struct group *)getgrent();
4854
4855     EXTEND(SP, 4);
4856     if (GIMME != G_ARRAY) {
4857         PUSHs(sv = sv_newmortal());
4858         if (grent) {
4859             if (which == OP_GGRNAM)
4860                 sv_setiv(sv, (IV)grent->gr_gid);
4861             else
4862                 sv_setpv(sv, grent->gr_name);
4863         }
4864         RETURN;
4865     }
4866
4867     if (grent) {
4868         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4869         sv_setpv(sv, grent->gr_name);
4870
4871         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4872 #ifdef GRPASSWD
4873         sv_setpv(sv, grent->gr_passwd);
4874 #endif
4875
4876         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4877         sv_setiv(sv, (IV)grent->gr_gid);
4878
4879         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4880         for (elem = grent->gr_mem; elem && *elem; elem++) {
4881             sv_catpv(sv, *elem);
4882             if (elem[1])
4883                 sv_catpvn(sv, " ", 1);
4884         }
4885     }
4886
4887     RETURN;
4888 #else
4889     DIE(aTHX_ PL_no_func, "getgrent");
4890 #endif
4891 }
4892
4893 PP(pp_sgrent)
4894 {
4895     djSP;
4896 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
4897     setgrent();
4898     RETPUSHYES;
4899 #else
4900     DIE(aTHX_ PL_no_func, "setgrent");
4901 #endif
4902 }
4903
4904 PP(pp_egrent)
4905 {
4906     djSP;
4907 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
4908     endgrent();
4909     RETPUSHYES;
4910 #else
4911     DIE(aTHX_ PL_no_func, "endgrent");
4912 #endif
4913 }
4914
4915 PP(pp_getlogin)
4916 {
4917     djSP; dTARGET;
4918 #ifdef HAS_GETLOGIN
4919     char *tmps;
4920     EXTEND(SP, 1);
4921     if (!(tmps = PerlProc_getlogin()))
4922         RETPUSHUNDEF;
4923     PUSHp(tmps, strlen(tmps));
4924     RETURN;
4925 #else
4926     DIE(aTHX_ PL_no_func, "getlogin");
4927 #endif
4928 }
4929
4930 /* Miscellaneous. */
4931
4932 PP(pp_syscall)
4933 {
4934 #ifdef HAS_SYSCALL
4935     djSP; dMARK; dORIGMARK; dTARGET;
4936     register I32 items = SP - MARK;
4937     unsigned long a[20];
4938     register I32 i = 0;
4939     I32 retval = -1;
4940     MAGIC *mg;
4941     STRLEN n_a;
4942
4943     if (PL_tainting) {
4944         while (++MARK <= SP) {
4945             if (SvTAINTED(*MARK)) {
4946                 TAINT;
4947                 break;
4948             }
4949         }
4950         MARK = ORIGMARK;
4951         TAINT_PROPER("syscall");
4952     }
4953
4954     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4955      * or where sizeof(long) != sizeof(char*).  But such machines will
4956      * not likely have syscall implemented either, so who cares?
4957      */
4958     while (++MARK <= SP) {
4959         if (SvNIOK(*MARK) || !i)
4960             a[i++] = SvIV(*MARK);
4961         else if (*MARK == &PL_sv_undef)
4962             a[i++] = 0;
4963         else
4964             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
4965         if (i > 15)
4966             break;
4967     }
4968     switch (items) {
4969     default:
4970         DIE(aTHX_ "Too many args to syscall");
4971     case 0:
4972         DIE(aTHX_ "Too few args to syscall");
4973     case 1:
4974         retval = syscall(a[0]);
4975         break;
4976     case 2:
4977         retval = syscall(a[0],a[1]);
4978         break;
4979     case 3:
4980         retval = syscall(a[0],a[1],a[2]);
4981         break;
4982     case 4:
4983         retval = syscall(a[0],a[1],a[2],a[3]);
4984         break;
4985     case 5:
4986         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4987         break;
4988     case 6:
4989         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4990         break;
4991     case 7:
4992         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4993         break;
4994     case 8:
4995         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4996         break;
4997 #ifdef atarist
4998     case 9:
4999         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5000         break;
5001     case 10:
5002         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5003         break;
5004     case 11:
5005         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5006           a[10]);
5007         break;
5008     case 12:
5009         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5010           a[10],a[11]);
5011         break;
5012     case 13:
5013         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5014           a[10],a[11],a[12]);
5015         break;
5016     case 14:
5017         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5018           a[10],a[11],a[12],a[13]);
5019         break;
5020 #endif /* atarist */
5021     }
5022     SP = ORIGMARK;
5023     PUSHi(retval);
5024     RETURN;
5025 #else
5026     DIE(aTHX_ PL_no_func, "syscall");
5027 #endif
5028 }
5029
5030 #ifdef FCNTL_EMULATE_FLOCK
5031
5032 /*  XXX Emulate flock() with fcntl().
5033     What's really needed is a good file locking module.
5034 */
5035
5036 static int
5037 fcntl_emulate_flock(int fd, int operation)
5038 {
5039     struct flock flock;
5040
5041     switch (operation & ~LOCK_NB) {
5042     case LOCK_SH:
5043         flock.l_type = F_RDLCK;
5044         break;
5045     case LOCK_EX:
5046         flock.l_type = F_WRLCK;
5047         break;
5048     case LOCK_UN:
5049         flock.l_type = F_UNLCK;
5050         break;
5051     default:
5052         errno = EINVAL;
5053         return -1;
5054     }
5055     flock.l_whence = SEEK_SET;
5056     flock.l_start = flock.l_len = (Off_t)0;
5057
5058     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5059 }
5060
5061 #endif /* FCNTL_EMULATE_FLOCK */
5062
5063 #ifdef LOCKF_EMULATE_FLOCK
5064
5065 /*  XXX Emulate flock() with lockf().  This is just to increase
5066     portability of scripts.  The calls are not completely
5067     interchangeable.  What's really needed is a good file
5068     locking module.
5069 */
5070
5071 /*  The lockf() constants might have been defined in <unistd.h>.
5072     Unfortunately, <unistd.h> causes troubles on some mixed
5073     (BSD/POSIX) systems, such as SunOS 4.1.3.
5074
5075    Further, the lockf() constants aren't POSIX, so they might not be
5076    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5077    just stick in the SVID values and be done with it.  Sigh.
5078 */
5079
5080 # ifndef F_ULOCK
5081 #  define F_ULOCK       0       /* Unlock a previously locked region */
5082 # endif
5083 # ifndef F_LOCK
5084 #  define F_LOCK        1       /* Lock a region for exclusive use */
5085 # endif
5086 # ifndef F_TLOCK
5087 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5088 # endif
5089 # ifndef F_TEST
5090 #  define F_TEST        3       /* Test a region for other processes locks */
5091 # endif
5092
5093 static int
5094 lockf_emulate_flock(int fd, int operation)
5095 {
5096     int i;
5097     int save_errno;
5098     Off_t pos;
5099
5100     /* flock locks entire file so for lockf we need to do the same      */
5101     save_errno = errno;
5102     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5103     if (pos > 0)        /* is seekable and needs to be repositioned     */
5104         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5105             pos = -1;   /* seek failed, so don't seek back afterwards   */
5106     errno = save_errno;
5107
5108     switch (operation) {
5109
5110         /* LOCK_SH - get a shared lock */
5111         case LOCK_SH:
5112         /* LOCK_EX - get an exclusive lock */
5113         case LOCK_EX:
5114             i = lockf (fd, F_LOCK, 0);
5115             break;
5116
5117         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5118         case LOCK_SH|LOCK_NB:
5119         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5120         case LOCK_EX|LOCK_NB:
5121             i = lockf (fd, F_TLOCK, 0);
5122             if (i == -1)
5123                 if ((errno == EAGAIN) || (errno == EACCES))
5124                     errno = EWOULDBLOCK;
5125             break;
5126
5127         /* LOCK_UN - unlock (non-blocking is a no-op) */
5128         case LOCK_UN:
5129         case LOCK_UN|LOCK_NB:
5130             i = lockf (fd, F_ULOCK, 0);
5131             break;
5132
5133         /* Default - can't decipher operation */
5134         default:
5135             i = -1;
5136             errno = EINVAL;
5137             break;
5138     }
5139
5140     if (pos > 0)      /* need to restore position of the handle */
5141         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5142
5143     return (i);
5144 }
5145
5146 #endif /* LOCKF_EMULATE_FLOCK */