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