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