pp_sys.c

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