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