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