pp_sys.c

   1 /*    pp_sys.c
   2  *
   3  *    Copyright (c) 1991-2000, 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) && !defined(__CYGWIN__)
  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_ "%"SVf, 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_ "%"SVf, 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             if (IoIFP(io)) {
1275                 SV* sv = sv_newmortal();
1276                 gv_efullname3(sv, gv, Nullch);
1277                 Perl_warner(aTHX_ WARN_IO,
1278                             "Filehandle %s opened only for input",
1279                             SvPV_nolen(sv));
1280             }
1281             else if (ckWARN(WARN_CLOSED))
1282                 report_closed_fh(gv, io, "write", "filehandle");
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             if (IoIFP(io)) {
1356                 gv_efullname3(sv, gv, Nullch);
1357                 Perl_warner(aTHX_ WARN_IO,
1358                             "Filehandle %s opened only for input",
1359                             SvPV(sv,n_a));
1360             }
1361             else if (ckWARN(WARN_CLOSED))
1362                 report_closed_fh(gv, io, "printf", "filehandle");
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                 report_closed_fh(gv, io, "syswrite", "filehandle");
1633             else
1634                 report_closed_fh(gv, io, "send", "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 #if LSEEKSIZE > IVSIZE
1795         XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1796 #else
1797         XPUSHs(sv_2mortal(newSViv((IV) offset)));
1798 #endif
1799         XPUSHs(sv_2mortal(newSViv((IV) whence)));
1800         PUTBACK;
1801         ENTER;
1802         call_method("SEEK", G_SCALAR);
1803         LEAVE;
1804         SPAGAIN;
1805         RETURN;
1806     }
1807
1808     if (PL_op->op_type == OP_SEEK)
1809         PUSHs(boolSV(do_seek(gv, offset, whence)));
1810     else {
1811         Off_t n = do_sysseek(gv, offset, whence);
1812         if (n < 0)
1813             PUSHs(&PL_sv_undef);
1814         else {
1815             SV* sv = n ?
1816 #if LSEEKSIZE > IVSIZE
1817                 newSVnv((NV)n)
1818 #else
1819                 newSViv((IV)n)
1820 #endif
1821                 : newSVpvn(zero_but_true, ZBTLEN);
1822             PUSHs(sv_2mortal(sv));
1823         }
1824     }
1825     RETURN;
1826 }
1827
1828 PP(pp_truncate)
1829 {
1830     djSP;
1831     Off_t len = (Off_t)POPn;
1832     int result = 1;
1833     GV *tmpgv;
1834     STRLEN n_a;
1835
1836     SETERRNO(0,0);
1837 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
1838     if (PL_op->op_flags & OPf_SPECIAL) {
1839         tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
1840     do_ftruncate:
1841         TAINT_PROPER("truncate");
1842         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
1843             result = 0;
1844         else {
1845             PerlIO_flush(IoIFP(GvIOp(tmpgv)));
1846 #ifdef HAS_TRUNCATE
1847             if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1848 #else
1849             if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1850 #endif
1851                 result = 0;
1852         }
1853     }
1854     else {
1855         SV *sv = POPs;
1856         char *name;
1857         STRLEN n_a;
1858
1859         if (SvTYPE(sv) == SVt_PVGV) {
1860             tmpgv = (GV*)sv;            /* *main::FRED for example */
1861             goto do_ftruncate;
1862         }
1863         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1864             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
1865             goto do_ftruncate;
1866         }
1867
1868         name = SvPV(sv, n_a);
1869         TAINT_PROPER("truncate");
1870 #ifdef HAS_TRUNCATE
1871         if (truncate(name, len) < 0)
1872             result = 0;
1873 #else
1874         {
1875             int tmpfd;
1876             if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
1877                 result = 0;
1878             else {
1879                 if (my_chsize(tmpfd, len) < 0)
1880                     result = 0;
1881                 PerlLIO_close(tmpfd);
1882             }
1883         }
1884 #endif
1885     }
1886
1887     if (result)
1888         RETPUSHYES;
1889     if (!errno)
1890         SETERRNO(EBADF,RMS$_IFI);
1891     RETPUSHUNDEF;
1892 #else
1893     DIE(aTHX_ "truncate not implemented");
1894 #endif
1895 }
1896
1897 PP(pp_fcntl)
1898 {
1899     return pp_ioctl();
1900 }
1901
1902 PP(pp_ioctl)
1903 {
1904     djSP; dTARGET;
1905     SV *argsv = POPs;
1906     unsigned int func = U_I(POPn);
1907     int optype = PL_op->op_type;
1908     char *s;
1909     IV retval;
1910     GV *gv = (GV*)POPs;
1911     IO *io = GvIOn(gv);
1912
1913     if (!io || !argsv || !IoIFP(io)) {
1914         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
1915         RETPUSHUNDEF;
1916     }
1917
1918     if (SvPOK(argsv) || !SvNIOK(argsv)) {
1919         STRLEN len;
1920         STRLEN need;
1921         s = SvPV_force(argsv, len);
1922         need = IOCPARM_LEN(func);
1923         if (len < need) {
1924             s = Sv_Grow(argsv, need + 1);
1925             SvCUR_set(argsv, need);
1926         }
1927
1928         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
1929     }
1930     else {
1931         retval = SvIV(argsv);
1932         s = INT2PTR(char*,retval);              /* ouch */
1933     }
1934
1935     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1936
1937     if (optype == OP_IOCTL)
1938 #ifdef HAS_IOCTL
1939         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1940 #else
1941         DIE(aTHX_ "ioctl is not implemented");
1942 #endif
1943     else
1944 #ifdef HAS_FCNTL
1945 #if defined(OS2) && defined(__EMX__)
1946         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1947 #else
1948         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1949 #endif
1950 #else
1951         DIE(aTHX_ "fcntl is not implemented");
1952 #endif
1953
1954     if (SvPOK(argsv)) {
1955         if (s[SvCUR(argsv)] != 17)
1956             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
1957                 PL_op_name[optype]);
1958         s[SvCUR(argsv)] = 0;            /* put our null back */
1959         SvSETMAGIC(argsv);              /* Assume it has changed */
1960     }
1961
1962     if (retval == -1)
1963         RETPUSHUNDEF;
1964     if (retval != 0) {
1965         PUSHi(retval);
1966     }
1967     else {
1968         PUSHp(zero_but_true, ZBTLEN);
1969     }
1970     RETURN;
1971 }
1972
1973 PP(pp_flock)
1974 {
1975     djSP; dTARGET;
1976     I32 value;
1977     int argtype;
1978     GV *gv;
1979     PerlIO *fp;
1980
1981 #ifdef FLOCK
1982     argtype = POPi;
1983     if (MAXARG <= 0)
1984         gv = PL_last_in_gv;
1985     else
1986         gv = (GV*)POPs;
1987     if (gv && GvIO(gv))
1988         fp = IoIFP(GvIOp(gv));
1989     else
1990         fp = Nullfp;
1991     if (fp) {
1992         (void)PerlIO_flush(fp);
1993         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
1994     }
1995     else {
1996         value = 0;
1997         SETERRNO(EBADF,RMS$_IFI);
1998         if (ckWARN(WARN_CLOSED))
1999             report_closed_fh(gv, GvIO(gv), "flock", "filehandle");
2000     }
2001     PUSHi(value);
2002     RETURN;
2003 #else
2004     DIE(aTHX_ PL_no_func, "flock()");
2005 #endif
2006 }
2007
2008 /* Sockets. */
2009
2010 PP(pp_socket)
2011 {
2012     djSP;
2013 #ifdef HAS_SOCKET
2014     GV *gv;
2015     register IO *io;
2016     int protocol = POPi;
2017     int type = POPi;
2018     int domain = POPi;
2019     int fd;
2020
2021     gv = (GV*)POPs;
2022
2023     if (!gv) {
2024         SETERRNO(EBADF,LIB$_INVARG);
2025         RETPUSHUNDEF;
2026     }
2027
2028     io = GvIOn(gv);
2029     if (IoIFP(io))
2030         do_close(gv, FALSE);
2031
2032     TAINT_PROPER("socket");
2033     fd = PerlSock_socket(domain, type, protocol);
2034     if (fd < 0)
2035         RETPUSHUNDEF;
2036     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2037     IoOFP(io) = PerlIO_fdopen(fd, "w");
2038     IoTYPE(io) = 's';
2039     if (!IoIFP(io) || !IoOFP(io)) {
2040         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2041         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2042         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2043         RETPUSHUNDEF;
2044     }
2045
2046     RETPUSHYES;
2047 #else
2048     DIE(aTHX_ PL_no_sock_func, "socket");
2049 #endif
2050 }
2051
2052 PP(pp_sockpair)
2053 {
2054     djSP;
2055 #ifdef HAS_SOCKETPAIR
2056     GV *gv1;
2057     GV *gv2;
2058     register IO *io1;
2059     register IO *io2;
2060     int protocol = POPi;
2061     int type = POPi;
2062     int domain = POPi;
2063     int fd[2];
2064
2065     gv2 = (GV*)POPs;
2066     gv1 = (GV*)POPs;
2067     if (!gv1 || !gv2)
2068         RETPUSHUNDEF;
2069
2070     io1 = GvIOn(gv1);
2071     io2 = GvIOn(gv2);
2072     if (IoIFP(io1))
2073         do_close(gv1, FALSE);
2074     if (IoIFP(io2))
2075         do_close(gv2, FALSE);
2076
2077     TAINT_PROPER("socketpair");
2078     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2079         RETPUSHUNDEF;
2080     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2081     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2082     IoTYPE(io1) = 's';
2083     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2084     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2085     IoTYPE(io2) = 's';
2086     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2087         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2088         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2089         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2090         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2091         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2092         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2093         RETPUSHUNDEF;
2094     }
2095
2096     RETPUSHYES;
2097 #else
2098     DIE(aTHX_ PL_no_sock_func, "socketpair");
2099 #endif
2100 }
2101
2102 PP(pp_bind)
2103 {
2104     djSP;
2105 #ifdef HAS_SOCKET
2106 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2107     extern GETPRIVMODE();
2108     extern GETUSERMODE();
2109 #endif
2110     SV *addrsv = POPs;
2111     char *addr;
2112     GV *gv = (GV*)POPs;
2113     register IO *io = GvIOn(gv);
2114     STRLEN len;
2115     int bind_ok = 0;
2116 #ifdef MPE
2117     int mpeprivmode = 0;
2118 #endif
2119
2120     if (!io || !IoIFP(io))
2121         goto nuts;
2122
2123     addr = SvPV(addrsv, len);
2124     TAINT_PROPER("bind");
2125 #ifdef MPE /* Deal with MPE bind() peculiarities */
2126     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2127         /* The address *MUST* stupidly be zero. */
2128         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2129         /* PRIV mode is required to bind() to ports < 1024. */
2130         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2131             ((struct sockaddr_in *)addr)->sin_port > 0) {
2132             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2133             mpeprivmode = 1;
2134         }
2135     }
2136 #endif /* MPE */
2137     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2138                       (struct sockaddr *)addr, len) >= 0)
2139         bind_ok = 1;
2140
2141 #ifdef MPE /* Switch back to USER mode */
2142     if (mpeprivmode)
2143         GETUSERMODE();
2144 #endif /* MPE */
2145
2146     if (bind_ok)
2147         RETPUSHYES;
2148     else
2149         RETPUSHUNDEF;
2150
2151 nuts:
2152     if (ckWARN(WARN_CLOSED))
2153         report_closed_fh(gv, io, "bind", "socket");
2154     SETERRNO(EBADF,SS$_IVCHAN);
2155     RETPUSHUNDEF;
2156 #else
2157     DIE(aTHX_ PL_no_sock_func, "bind");
2158 #endif
2159 }
2160
2161 PP(pp_connect)
2162 {
2163     djSP;
2164 #ifdef HAS_SOCKET
2165     SV *addrsv = POPs;
2166     char *addr;
2167     GV *gv = (GV*)POPs;
2168     register IO *io = GvIOn(gv);
2169     STRLEN len;
2170
2171     if (!io || !IoIFP(io))
2172         goto nuts;
2173
2174     addr = SvPV(addrsv, len);
2175     TAINT_PROPER("connect");
2176     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2177         RETPUSHYES;
2178     else
2179         RETPUSHUNDEF;
2180
2181 nuts:
2182     if (ckWARN(WARN_CLOSED))
2183         report_closed_fh(gv, io, "connect", "socket");
2184     SETERRNO(EBADF,SS$_IVCHAN);
2185     RETPUSHUNDEF;
2186 #else
2187     DIE(aTHX_ PL_no_sock_func, "connect");
2188 #endif
2189 }
2190
2191 PP(pp_listen)
2192 {
2193     djSP;
2194 #ifdef HAS_SOCKET
2195     int backlog = POPi;
2196     GV *gv = (GV*)POPs;
2197     register IO *io = GvIOn(gv);
2198
2199     if (!io || !IoIFP(io))
2200         goto nuts;
2201
2202     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2203         RETPUSHYES;
2204     else
2205         RETPUSHUNDEF;
2206
2207 nuts:
2208     if (ckWARN(WARN_CLOSED))
2209         report_closed_fh(gv, io, "listen", "socket");
2210     SETERRNO(EBADF,SS$_IVCHAN);
2211     RETPUSHUNDEF;
2212 #else
2213     DIE(aTHX_ PL_no_sock_func, "listen");
2214 #endif
2215 }
2216
2217 PP(pp_accept)
2218 {
2219     djSP; dTARGET;
2220 #ifdef HAS_SOCKET
2221     GV *ngv;
2222     GV *ggv;
2223     register IO *nstio;
2224     register IO *gstio;
2225     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2226     Sock_size_t len = sizeof saddr;
2227     int fd;
2228
2229     ggv = (GV*)POPs;
2230     ngv = (GV*)POPs;
2231
2232     if (!ngv)
2233         goto badexit;
2234     if (!ggv)
2235         goto nuts;
2236
2237     gstio = GvIO(ggv);
2238     if (!gstio || !IoIFP(gstio))
2239         goto nuts;
2240
2241     nstio = GvIOn(ngv);
2242     if (IoIFP(nstio))
2243         do_close(ngv, FALSE);
2244
2245     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2246     if (fd < 0)
2247         goto badexit;
2248     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2249     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2250     IoTYPE(nstio) = 's';
2251     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2252         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2253         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2254         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2255         goto badexit;
2256     }
2257
2258     PUSHp((char *)&saddr, len);
2259     RETURN;
2260
2261 nuts:
2262     if (ckWARN(WARN_CLOSED))
2263         report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket");
2264     SETERRNO(EBADF,SS$_IVCHAN);
2265
2266 badexit:
2267     RETPUSHUNDEF;
2268
2269 #else
2270     DIE(aTHX_ PL_no_sock_func, "accept");
2271 #endif
2272 }
2273
2274 PP(pp_shutdown)
2275 {
2276     djSP; dTARGET;
2277 #ifdef HAS_SOCKET
2278     int how = POPi;
2279     GV *gv = (GV*)POPs;
2280     register IO *io = GvIOn(gv);
2281
2282     if (!io || !IoIFP(io))
2283         goto nuts;
2284
2285     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2286     RETURN;
2287
2288 nuts:
2289     if (ckWARN(WARN_CLOSED))
2290         report_closed_fh(gv, io, "shutdown", "socket");
2291     SETERRNO(EBADF,SS$_IVCHAN);
2292     RETPUSHUNDEF;
2293 #else
2294     DIE(aTHX_ PL_no_sock_func, "shutdown");
2295 #endif
2296 }
2297
2298 PP(pp_gsockopt)
2299 {
2300 #ifdef HAS_SOCKET
2301     return pp_ssockopt();
2302 #else
2303     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2304 #endif
2305 }
2306
2307 PP(pp_ssockopt)
2308 {
2309     djSP;
2310 #ifdef HAS_SOCKET
2311     int optype = PL_op->op_type;
2312     SV *sv;
2313     int fd;
2314     unsigned int optname;
2315     unsigned int lvl;
2316     GV *gv;
2317     register IO *io;
2318     Sock_size_t len;
2319
2320     if (optype == OP_GSOCKOPT)
2321         sv = sv_2mortal(NEWSV(22, 257));
2322     else
2323         sv = POPs;
2324     optname = (unsigned int) POPi;
2325     lvl = (unsigned int) POPi;
2326
2327     gv = (GV*)POPs;
2328     io = GvIOn(gv);
2329     if (!io || !IoIFP(io))
2330         goto nuts;
2331
2332     fd = PerlIO_fileno(IoIFP(io));
2333     switch (optype) {
2334     case OP_GSOCKOPT:
2335         SvGROW(sv, 257);
2336         (void)SvPOK_only(sv);
2337         SvCUR_set(sv,256);
2338         *SvEND(sv) ='\0';
2339         len = SvCUR(sv);
2340         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2341             goto nuts2;
2342         SvCUR_set(sv, len);
2343         *SvEND(sv) ='\0';
2344         PUSHs(sv);
2345         break;
2346     case OP_SSOCKOPT: {
2347             char *buf;
2348             int aint;
2349             if (SvPOKp(sv)) {
2350                 STRLEN l;
2351                 buf = SvPV(sv, l);
2352                 len = l;
2353             }
2354             else {
2355                 aint = (int)SvIV(sv);
2356                 buf = (char*)&aint;
2357                 len = sizeof(int);
2358             }
2359             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2360                 goto nuts2;
2361             PUSHs(&PL_sv_yes);
2362         }
2363         break;
2364     }
2365     RETURN;
2366
2367 nuts:
2368     if (ckWARN(WARN_CLOSED))
2369         report_closed_fh(gv, io,
2370                          optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt",
2371                          "socket");
2372     SETERRNO(EBADF,SS$_IVCHAN);
2373 nuts2:
2374     RETPUSHUNDEF;
2375
2376 #else
2377     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2378 #endif
2379 }
2380
2381 PP(pp_getsockname)
2382 {
2383 #ifdef HAS_SOCKET
2384     return pp_getpeername();
2385 #else
2386     DIE(aTHX_ PL_no_sock_func, "getsockname");
2387 #endif
2388 }
2389
2390 PP(pp_getpeername)
2391 {
2392     djSP;
2393 #ifdef HAS_SOCKET
2394     int optype = PL_op->op_type;
2395     SV *sv;
2396     int fd;
2397     GV *gv = (GV*)POPs;
2398     register IO *io = GvIOn(gv);
2399     Sock_size_t len;
2400
2401     if (!io || !IoIFP(io))
2402         goto nuts;
2403
2404     sv = sv_2mortal(NEWSV(22, 257));
2405     (void)SvPOK_only(sv);
2406     len = 256;
2407     SvCUR_set(sv, len);
2408     *SvEND(sv) ='\0';
2409     fd = PerlIO_fileno(IoIFP(io));
2410     switch (optype) {
2411     case OP_GETSOCKNAME:
2412         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2413             goto nuts2;
2414         break;
2415     case OP_GETPEERNAME:
2416         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2417             goto nuts2;
2418 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2419         {
2420             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";
2421             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2422             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2423                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2424                         sizeof(u_short) + sizeof(struct in_addr))) {
2425                 goto nuts2;
2426             }
2427         }
2428 #endif
2429         break;
2430     }
2431 #ifdef BOGUS_GETNAME_RETURN
2432     /* Interactive Unix, getpeername() and getsockname()
2433       does not return valid namelen */
2434     if (len == BOGUS_GETNAME_RETURN)
2435         len = sizeof(struct sockaddr);
2436 #endif
2437     SvCUR_set(sv, len);
2438     *SvEND(sv) ='\0';
2439     PUSHs(sv);
2440     RETURN;
2441
2442 nuts:
2443     if (ckWARN(WARN_CLOSED))
2444         report_closed_fh(gv, io,
2445                          optype == OP_GETSOCKNAME ? "getsockname"
2446                                                   : "getpeername",
2447                          "socket");
2448     SETERRNO(EBADF,SS$_IVCHAN);
2449 nuts2:
2450     RETPUSHUNDEF;
2451
2452 #else
2453     DIE(aTHX_ PL_no_sock_func, "getpeername");
2454 #endif
2455 }
2456
2457 /* Stat calls. */
2458
2459 PP(pp_lstat)
2460 {
2461     return pp_stat();
2462 }
2463
2464 PP(pp_stat)
2465 {
2466     djSP;
2467     GV *tmpgv;
2468     I32 gimme;
2469     I32 max = 13;
2470     STRLEN n_a;
2471
2472     if (PL_op->op_flags & OPf_REF) {
2473         tmpgv = cGVOP_gv;
2474       do_fstat:
2475         if (tmpgv != PL_defgv) {
2476             PL_laststype = OP_STAT;
2477             PL_statgv = tmpgv;
2478             sv_setpv(PL_statname, "");
2479             PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2480                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
2481         }
2482         if (PL_laststatval < 0)
2483             max = 0;
2484     }
2485     else {
2486         SV* sv = POPs;
2487         if (SvTYPE(sv) == SVt_PVGV) {
2488             tmpgv = (GV*)sv;
2489             goto do_fstat;
2490         }
2491         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2492             tmpgv = (GV*)SvRV(sv);
2493             goto do_fstat;
2494         }
2495         sv_setpv(PL_statname, SvPV(sv,n_a));
2496         PL_statgv = Nullgv;
2497 #ifdef HAS_LSTAT
2498         PL_laststype = PL_op->op_type;
2499         if (PL_op->op_type == OP_LSTAT)
2500             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2501         else
2502 #endif
2503             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2504         if (PL_laststatval < 0) {
2505             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2506                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2507             max = 0;
2508         }
2509     }
2510
2511     gimme = GIMME_V;
2512     if (gimme != G_ARRAY) {
2513         if (gimme != G_VOID)
2514             XPUSHs(boolSV(max));
2515         RETURN;
2516     }
2517     if (max) {
2518         EXTEND(SP, max);
2519         EXTEND_MORTAL(max);
2520         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2521         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2522         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode)));
2523         PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink)));
2524 #if Uid_t_size > IVSIZE
2525         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2526 #else
2527         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2528 #endif
2529 #if Gid_t_size > IVSIZE
2530         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2531 #else
2532         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2533 #endif
2534 #ifdef USE_STAT_RDEV
2535         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2536 #else
2537         PUSHs(sv_2mortal(newSVpvn("", 0)));
2538 #endif
2539 #if Off_t_size > IVSIZE
2540         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2541 #else
2542         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2543 #endif
2544 #ifdef BIG_TIME
2545         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2546         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2547         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2548 #else
2549         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2550         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2551         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2552 #endif
2553 #ifdef USE_STAT_BLOCKS
2554         PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize)));
2555         PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks)));
2556 #else
2557         PUSHs(sv_2mortal(newSVpvn("", 0)));
2558         PUSHs(sv_2mortal(newSVpvn("", 0)));
2559 #endif
2560     }
2561     RETURN;
2562 }
2563
2564 PP(pp_ftrread)
2565 {
2566     I32 result;
2567     djSP;
2568 #if defined(HAS_ACCESS) && defined(R_OK)
2569     STRLEN n_a;
2570     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2571         result = access(TOPpx, R_OK);
2572         if (result == 0)
2573             RETPUSHYES;
2574         if (result < 0)
2575             RETPUSHUNDEF;
2576         RETPUSHNO;
2577     }
2578     else
2579         result = my_stat();
2580 #else
2581     result = my_stat();
2582 #endif
2583     SPAGAIN;
2584     if (result < 0)
2585         RETPUSHUNDEF;
2586     if (cando(S_IRUSR, 0, &PL_statcache))
2587         RETPUSHYES;
2588     RETPUSHNO;
2589 }
2590
2591 PP(pp_ftrwrite)
2592 {
2593     I32 result;
2594     djSP;
2595 #if defined(HAS_ACCESS) && defined(W_OK)
2596     STRLEN n_a;
2597     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2598         result = access(TOPpx, W_OK);
2599         if (result == 0)
2600             RETPUSHYES;
2601         if (result < 0)
2602             RETPUSHUNDEF;
2603         RETPUSHNO;
2604     }
2605     else
2606         result = my_stat();
2607 #else
2608     result = my_stat();
2609 #endif
2610     SPAGAIN;
2611     if (result < 0)
2612         RETPUSHUNDEF;
2613     if (cando(S_IWUSR, 0, &PL_statcache))
2614         RETPUSHYES;
2615     RETPUSHNO;
2616 }
2617
2618 PP(pp_ftrexec)
2619 {
2620     I32 result;
2621     djSP;
2622 #if defined(HAS_ACCESS) && defined(X_OK)
2623     STRLEN n_a;
2624     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2625         result = access(TOPpx, X_OK);
2626         if (result == 0)
2627             RETPUSHYES;
2628         if (result < 0)
2629             RETPUSHUNDEF;
2630         RETPUSHNO;
2631     }
2632     else
2633         result = my_stat();
2634 #else
2635     result = my_stat();
2636 #endif
2637     SPAGAIN;
2638     if (result < 0)
2639         RETPUSHUNDEF;
2640     if (cando(S_IXUSR, 0, &PL_statcache))
2641         RETPUSHYES;
2642     RETPUSHNO;
2643 }
2644
2645 PP(pp_fteread)
2646 {
2647     I32 result;
2648     djSP;
2649 #ifdef PERL_EFF_ACCESS_R_OK
2650     STRLEN n_a;
2651     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2652         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2653         if (result == 0)
2654             RETPUSHYES;
2655         if (result < 0)
2656             RETPUSHUNDEF;
2657         RETPUSHNO;
2658     }
2659     else
2660         result = my_stat();
2661 #else
2662     result = my_stat();
2663 #endif
2664     SPAGAIN;
2665     if (result < 0)
2666         RETPUSHUNDEF;
2667     if (cando(S_IRUSR, 1, &PL_statcache))
2668         RETPUSHYES;
2669     RETPUSHNO;
2670 }
2671
2672 PP(pp_ftewrite)
2673 {
2674     I32 result;
2675     djSP;
2676 #ifdef PERL_EFF_ACCESS_W_OK
2677     STRLEN n_a;
2678     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2679         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2680         if (result == 0)
2681             RETPUSHYES;
2682         if (result < 0)
2683             RETPUSHUNDEF;
2684         RETPUSHNO;
2685     }
2686     else
2687         result = my_stat();
2688 #else
2689     result = my_stat();
2690 #endif
2691     SPAGAIN;
2692     if (result < 0)
2693         RETPUSHUNDEF;
2694     if (cando(S_IWUSR, 1, &PL_statcache))
2695         RETPUSHYES;
2696     RETPUSHNO;
2697 }
2698
2699 PP(pp_fteexec)
2700 {
2701     I32 result;
2702     djSP;
2703 #ifdef PERL_EFF_ACCESS_X_OK
2704     STRLEN n_a;
2705     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2706         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2707         if (result == 0)
2708             RETPUSHYES;
2709         if (result < 0)
2710             RETPUSHUNDEF;
2711         RETPUSHNO;
2712     }
2713     else
2714         result = my_stat();
2715 #else
2716     result = my_stat();
2717 #endif
2718     SPAGAIN;
2719     if (result < 0)
2720         RETPUSHUNDEF;
2721     if (cando(S_IXUSR, 1, &PL_statcache))
2722         RETPUSHYES;
2723     RETPUSHNO;
2724 }
2725
2726 PP(pp_ftis)
2727 {
2728     I32 result = my_stat();
2729     djSP;
2730     if (result < 0)
2731         RETPUSHUNDEF;
2732     RETPUSHYES;
2733 }
2734
2735 PP(pp_fteowned)
2736 {
2737     return pp_ftrowned();
2738 }
2739
2740 PP(pp_ftrowned)
2741 {
2742     I32 result = my_stat();
2743     djSP;
2744     if (result < 0)
2745         RETPUSHUNDEF;
2746     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2747                                 PL_euid : PL_uid) )
2748         RETPUSHYES;
2749     RETPUSHNO;
2750 }
2751
2752 PP(pp_ftzero)
2753 {
2754     I32 result = my_stat();
2755     djSP;
2756     if (result < 0)
2757         RETPUSHUNDEF;
2758     if (PL_statcache.st_size == 0)
2759         RETPUSHYES;
2760     RETPUSHNO;
2761 }
2762
2763 PP(pp_ftsize)
2764 {
2765     I32 result = my_stat();
2766     djSP; dTARGET;
2767     if (result < 0)
2768         RETPUSHUNDEF;
2769 #if Off_t_size > IVSIZE
2770     PUSHn(PL_statcache.st_size);
2771 #else
2772     PUSHi(PL_statcache.st_size);
2773 #endif
2774     RETURN;
2775 }
2776
2777 PP(pp_ftmtime)
2778 {
2779     I32 result = my_stat();
2780     djSP; dTARGET;
2781     if (result < 0)
2782         RETPUSHUNDEF;
2783     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
2784     RETURN;
2785 }
2786
2787 PP(pp_ftatime)
2788 {
2789     I32 result = my_stat();
2790     djSP; dTARGET;
2791     if (result < 0)
2792         RETPUSHUNDEF;
2793     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
2794     RETURN;
2795 }
2796
2797 PP(pp_ftctime)
2798 {
2799     I32 result = my_stat();
2800     djSP; dTARGET;
2801     if (result < 0)
2802         RETPUSHUNDEF;
2803     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
2804     RETURN;
2805 }
2806
2807 PP(pp_ftsock)
2808 {
2809     I32 result = my_stat();
2810     djSP;
2811     if (result < 0)
2812         RETPUSHUNDEF;
2813     if (S_ISSOCK(PL_statcache.st_mode))
2814         RETPUSHYES;
2815     RETPUSHNO;
2816 }
2817
2818 PP(pp_ftchr)
2819 {
2820     I32 result = my_stat();
2821     djSP;
2822     if (result < 0)
2823         RETPUSHUNDEF;
2824     if (S_ISCHR(PL_statcache.st_mode))
2825         RETPUSHYES;
2826     RETPUSHNO;
2827 }
2828
2829 PP(pp_ftblk)
2830 {
2831     I32 result = my_stat();
2832     djSP;
2833     if (result < 0)
2834         RETPUSHUNDEF;
2835     if (S_ISBLK(PL_statcache.st_mode))
2836         RETPUSHYES;
2837     RETPUSHNO;
2838 }
2839
2840 PP(pp_ftfile)
2841 {
2842     I32 result = my_stat();
2843     djSP;
2844     if (result < 0)
2845         RETPUSHUNDEF;
2846     if (S_ISREG(PL_statcache.st_mode))
2847         RETPUSHYES;
2848     RETPUSHNO;
2849 }
2850
2851 PP(pp_ftdir)
2852 {
2853     I32 result = my_stat();
2854     djSP;
2855     if (result < 0)
2856         RETPUSHUNDEF;
2857     if (S_ISDIR(PL_statcache.st_mode))
2858         RETPUSHYES;
2859     RETPUSHNO;
2860 }
2861
2862 PP(pp_ftpipe)
2863 {
2864     I32 result = my_stat();
2865     djSP;
2866     if (result < 0)
2867         RETPUSHUNDEF;
2868     if (S_ISFIFO(PL_statcache.st_mode))
2869         RETPUSHYES;
2870     RETPUSHNO;
2871 }
2872
2873 PP(pp_ftlink)
2874 {
2875     I32 result = my_lstat();
2876     djSP;
2877     if (result < 0)
2878         RETPUSHUNDEF;
2879     if (S_ISLNK(PL_statcache.st_mode))
2880         RETPUSHYES;
2881     RETPUSHNO;
2882 }
2883
2884 PP(pp_ftsuid)
2885 {
2886     djSP;
2887 #ifdef S_ISUID
2888     I32 result = my_stat();
2889     SPAGAIN;
2890     if (result < 0)
2891         RETPUSHUNDEF;
2892     if (PL_statcache.st_mode & S_ISUID)
2893         RETPUSHYES;
2894 #endif
2895     RETPUSHNO;
2896 }
2897
2898 PP(pp_ftsgid)
2899 {
2900     djSP;
2901 #ifdef S_ISGID
2902     I32 result = my_stat();
2903     SPAGAIN;
2904     if (result < 0)
2905         RETPUSHUNDEF;
2906     if (PL_statcache.st_mode & S_ISGID)
2907         RETPUSHYES;
2908 #endif
2909     RETPUSHNO;
2910 }
2911
2912 PP(pp_ftsvtx)
2913 {
2914     djSP;
2915 #ifdef S_ISVTX
2916     I32 result = my_stat();
2917     SPAGAIN;
2918     if (result < 0)
2919         RETPUSHUNDEF;
2920     if (PL_statcache.st_mode & S_ISVTX)
2921         RETPUSHYES;
2922 #endif
2923     RETPUSHNO;
2924 }
2925
2926 PP(pp_fttty)
2927 {
2928     djSP;
2929     int fd;
2930     GV *gv;
2931     char *tmps = Nullch;
2932     STRLEN n_a;
2933
2934     if (PL_op->op_flags & OPf_REF)
2935         gv = cGVOP_gv;
2936     else if (isGV(TOPs))
2937         gv = (GV*)POPs;
2938     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2939         gv = (GV*)SvRV(POPs);
2940     else
2941         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
2942
2943     if (GvIO(gv) && IoIFP(GvIOp(gv)))
2944         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2945     else if (tmps && isDIGIT(*tmps))
2946         fd = atoi(tmps);
2947     else
2948         RETPUSHUNDEF;
2949     if (PerlLIO_isatty(fd))
2950         RETPUSHYES;
2951     RETPUSHNO;
2952 }
2953
2954 #if defined(atarist) /* this will work with atariST. Configure will
2955                         make guesses for other systems. */
2956 # define FILE_base(f) ((f)->_base)
2957 # define FILE_ptr(f) ((f)->_ptr)
2958 # define FILE_cnt(f) ((f)->_cnt)
2959 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2960 #endif
2961
2962 PP(pp_fttext)
2963 {
2964     djSP;
2965     I32 i;
2966     I32 len;
2967     I32 odd = 0;
2968     STDCHAR tbuf[512];
2969     register STDCHAR *s;
2970     register IO *io;
2971     register SV *sv;
2972     GV *gv;
2973     STRLEN n_a;
2974     PerlIO *fp;
2975
2976     if (PL_op->op_flags & OPf_REF)
2977         gv = cGVOP_gv;
2978     else if (isGV(TOPs))
2979         gv = (GV*)POPs;
2980     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2981         gv = (GV*)SvRV(POPs);
2982     else
2983         gv = Nullgv;
2984
2985     if (gv) {
2986         EXTEND(SP, 1);
2987         if (gv == PL_defgv) {
2988             if (PL_statgv)
2989                 io = GvIO(PL_statgv);
2990             else {
2991                 sv = PL_statname;
2992                 goto really_filename;
2993             }
2994         }
2995         else {
2996             PL_statgv = gv;
2997             PL_laststatval = -1;
2998             sv_setpv(PL_statname, "");
2999             io = GvIO(PL_statgv);
3000         }
3001         if (io && IoIFP(io)) {
3002             if (! PerlIO_has_base(IoIFP(io)))
3003                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3004             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3005             if (PL_laststatval < 0)
3006                 RETPUSHUNDEF;
3007             if (S_ISDIR(PL_statcache.st_mode))  /* handle NFS glitch */
3008                 if (PL_op->op_type == OP_FTTEXT)
3009                     RETPUSHNO;
3010                 else
3011                     RETPUSHYES;
3012             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3013                 i = PerlIO_getc(IoIFP(io));
3014                 if (i != EOF)
3015                     (void)PerlIO_ungetc(IoIFP(io),i);
3016             }
3017             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3018                 RETPUSHYES;
3019             len = PerlIO_get_bufsiz(IoIFP(io));
3020             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3021             /* sfio can have large buffers - limit to 512 */
3022             if (len > 512)
3023                 len = 512;
3024         }
3025         else {
3026             if (ckWARN(WARN_UNOPENED)) {
3027                 gv = cGVOP_gv;
3028                 Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
3029                             GvENAME(gv));
3030             }
3031             SETERRNO(EBADF,RMS$_IFI);
3032             RETPUSHUNDEF;
3033         }
3034     }
3035     else {
3036         sv = POPs;
3037       really_filename:
3038         PL_statgv = Nullgv;
3039         PL_laststatval = -1;
3040         sv_setpv(PL_statname, SvPV(sv, n_a));
3041         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3042             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3043                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3044             RETPUSHUNDEF;
3045         }
3046         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3047         if (PL_laststatval < 0) {
3048             (void)PerlIO_close(fp);
3049             RETPUSHUNDEF;
3050         }
3051         do_binmode(fp, '<', TRUE);
3052         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3053         (void)PerlIO_close(fp);
3054         if (len <= 0) {
3055             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3056                 RETPUSHNO;              /* special case NFS directories */
3057             RETPUSHYES;         /* null file is anything */
3058         }
3059         s = tbuf;
3060     }
3061
3062     /* now scan s to look for textiness */
3063     /*   XXX ASCII dependent code */
3064
3065 #if defined(DOSISH) || defined(USEMYBINMODE)
3066     /* ignore trailing ^Z on short files */
3067     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3068         --len;
3069 #endif
3070
3071     for (i = 0; i < len; i++, s++) {
3072         if (!*s) {                      /* null never allowed in text */
3073             odd += len;
3074             break;
3075         }
3076 #ifdef EBCDIC
3077         else if (!(isPRINT(*s) || isSPACE(*s)))
3078             odd++;
3079 #else
3080         else if (*s & 128) {
3081 #ifdef USE_LOCALE
3082             if (!(PL_op->op_private & OPpLOCALE) || !isALPHA_LC(*s))
3083 #endif
3084                 odd++;
3085         }
3086         else if (*s < 32 &&
3087           *s != '\n' && *s != '\r' && *s != '\b' &&
3088           *s != '\t' && *s != '\f' && *s != 27)
3089             odd++;
3090 #endif
3091     }
3092
3093     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3094         RETPUSHNO;
3095     else
3096         RETPUSHYES;
3097 }
3098
3099 PP(pp_ftbinary)
3100 {
3101     return pp_fttext();
3102 }
3103
3104 /* File calls. */
3105
3106 PP(pp_chdir)
3107 {
3108     djSP; dTARGET;
3109     char *tmps;
3110     SV **svp;
3111     STRLEN n_a;
3112
3113     if (MAXARG < 1)
3114         tmps = Nullch;
3115     else
3116         tmps = POPpx;
3117     if (!tmps || !*tmps) {
3118         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3119         if (svp)
3120             tmps = SvPV(*svp, n_a);
3121     }
3122     if (!tmps || !*tmps) {
3123         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3124         if (svp)
3125             tmps = SvPV(*svp, n_a);
3126     }
3127 #ifdef VMS
3128     if (!tmps || !*tmps) {
3129        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3130        if (svp)
3131            tmps = SvPV(*svp, n_a);
3132     }
3133 #endif
3134     TAINT_PROPER("chdir");
3135     PUSHi( PerlDir_chdir(tmps) >= 0 );
3136 #ifdef VMS
3137     /* Clear the DEFAULT element of ENV so we'll get the new value
3138      * in the future. */
3139     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3140 #endif
3141     RETURN;
3142 }
3143
3144 PP(pp_chown)
3145 {
3146     djSP; dMARK; dTARGET;
3147     I32 value;
3148 #ifdef HAS_CHOWN
3149     value = (I32)apply(PL_op->op_type, MARK, SP);
3150     SP = MARK;
3151     PUSHi(value);
3152     RETURN;
3153 #else
3154     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3155 #endif
3156 }
3157
3158 PP(pp_chroot)
3159 {
3160     djSP; dTARGET;
3161     char *tmps;
3162 #ifdef HAS_CHROOT
3163     STRLEN n_a;
3164     tmps = POPpx;
3165     TAINT_PROPER("chroot");
3166     PUSHi( chroot(tmps) >= 0 );
3167     RETURN;
3168 #else
3169     DIE(aTHX_ PL_no_func, "chroot");
3170 #endif
3171 }
3172
3173 PP(pp_unlink)
3174 {
3175     djSP; dMARK; dTARGET;
3176     I32 value;
3177     value = (I32)apply(PL_op->op_type, MARK, SP);
3178     SP = MARK;
3179     PUSHi(value);
3180     RETURN;
3181 }
3182
3183 PP(pp_chmod)
3184 {
3185     djSP; dMARK; dTARGET;
3186     I32 value;
3187     value = (I32)apply(PL_op->op_type, MARK, SP);
3188     SP = MARK;
3189     PUSHi(value);
3190     RETURN;
3191 }
3192
3193 PP(pp_utime)
3194 {
3195     djSP; dMARK; dTARGET;
3196     I32 value;
3197     value = (I32)apply(PL_op->op_type, MARK, SP);
3198     SP = MARK;
3199     PUSHi(value);
3200     RETURN;
3201 }
3202
3203 PP(pp_rename)
3204 {
3205     djSP; dTARGET;
3206     int anum;
3207     STRLEN n_a;
3208
3209     char *tmps2 = POPpx;
3210     char *tmps = SvPV(TOPs, n_a);
3211     TAINT_PROPER("rename");
3212 #ifdef HAS_RENAME
3213     anum = PerlLIO_rename(tmps, tmps2);
3214 #else
3215     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3216         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3217             anum = 1;
3218         else {
3219             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3220                 (void)UNLINK(tmps2);
3221             if (!(anum = link(tmps, tmps2)))
3222                 anum = UNLINK(tmps);
3223         }
3224     }
3225 #endif
3226     SETi( anum >= 0 );
3227     RETURN;
3228 }
3229
3230 PP(pp_link)
3231 {
3232     djSP; dTARGET;
3233 #ifdef HAS_LINK
3234     STRLEN n_a;
3235     char *tmps2 = POPpx;
3236     char *tmps = SvPV(TOPs, n_a);
3237     TAINT_PROPER("link");
3238     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3239 #else
3240     DIE(aTHX_ PL_no_func, "Unsupported function link");
3241 #endif
3242     RETURN;
3243 }
3244
3245 PP(pp_symlink)
3246 {
3247     djSP; dTARGET;
3248 #ifdef HAS_SYMLINK
3249     STRLEN n_a;
3250     char *tmps2 = POPpx;
3251     char *tmps = SvPV(TOPs, n_a);
3252     TAINT_PROPER("symlink");
3253     SETi( symlink(tmps, tmps2) >= 0 );
3254     RETURN;
3255 #else
3256     DIE(aTHX_ PL_no_func, "symlink");
3257 #endif
3258 }
3259
3260 PP(pp_readlink)
3261 {
3262     djSP; dTARGET;
3263 #ifdef HAS_SYMLINK
3264     char *tmps;
3265     char buf[MAXPATHLEN];
3266     int len;
3267     STRLEN n_a;
3268
3269 #ifndef INCOMPLETE_TAINTS
3270     TAINT;
3271 #endif
3272     tmps = POPpx;
3273     len = readlink(tmps, buf, sizeof buf);
3274     EXTEND(SP, 1);
3275     if (len < 0)
3276         RETPUSHUNDEF;
3277     PUSHp(buf, len);
3278     RETURN;
3279 #else
3280     EXTEND(SP, 1);
3281     RETSETUNDEF;                /* just pretend it's a normal file */
3282 #endif
3283 }
3284
3285 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3286 STATIC int
3287 S_dooneliner(pTHX_ char *cmd, char *filename)
3288 {
3289     char *save_filename = filename;
3290     char *cmdline;
3291     char *s;
3292     PerlIO *myfp;
3293     int anum = 1;
3294
3295     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3296     strcpy(cmdline, cmd);
3297     strcat(cmdline, " ");
3298     for (s = cmdline + strlen(cmdline); *filename; ) {
3299         *s++ = '\\';
3300         *s++ = *filename++;
3301     }
3302     strcpy(s, " 2>&1");
3303     myfp = PerlProc_popen(cmdline, "r");
3304     Safefree(cmdline);
3305
3306     if (myfp) {
3307         SV *tmpsv = sv_newmortal();
3308         /* Need to save/restore 'PL_rs' ?? */
3309         s = sv_gets(tmpsv, myfp, 0);
3310         (void)PerlProc_pclose(myfp);
3311         if (s != Nullch) {
3312             int e;
3313             for (e = 1;
3314 #ifdef HAS_SYS_ERRLIST
3315                  e <= sys_nerr
3316 #endif
3317                  ; e++)
3318             {
3319                 /* you don't see this */
3320                 char *errmsg =
3321 #ifdef HAS_SYS_ERRLIST
3322                     sys_errlist[e]
3323 #else
3324                     strerror(e)
3325 #endif
3326                     ;
3327                 if (!errmsg)
3328                     break;
3329                 if (instr(s, errmsg)) {
3330                     SETERRNO(e,0);
3331                     return 0;
3332                 }
3333             }
3334             SETERRNO(0,0);
3335 #ifndef EACCES
3336 #define EACCES EPERM
3337 #endif
3338             if (instr(s, "cannot make"))
3339                 SETERRNO(EEXIST,RMS$_FEX);
3340             else if (instr(s, "existing file"))
3341                 SETERRNO(EEXIST,RMS$_FEX);
3342             else if (instr(s, "ile exists"))
3343                 SETERRNO(EEXIST,RMS$_FEX);
3344             else if (instr(s, "non-exist"))
3345                 SETERRNO(ENOENT,RMS$_FNF);
3346             else if (instr(s, "does not exist"))
3347                 SETERRNO(ENOENT,RMS$_FNF);
3348             else if (instr(s, "not empty"))
3349                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3350             else if (instr(s, "cannot access"))
3351                 SETERRNO(EACCES,RMS$_PRV);
3352             else
3353                 SETERRNO(EPERM,RMS$_PRV);
3354             return 0;
3355         }
3356         else {  /* some mkdirs return no failure indication */
3357             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3358             if (PL_op->op_type == OP_RMDIR)
3359                 anum = !anum;
3360             if (anum)
3361                 SETERRNO(0,0);
3362             else
3363                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3364         }
3365         return anum;
3366     }
3367     else
3368         return 0;
3369 }
3370 #endif
3371
3372 PP(pp_mkdir)
3373 {
3374     djSP; dTARGET;
3375     int mode = POPi;
3376 #ifndef HAS_MKDIR
3377     int oldumask;
3378 #endif
3379     STRLEN n_a;
3380     char *tmps = SvPV(TOPs, n_a);
3381
3382     TAINT_PROPER("mkdir");
3383 #ifdef HAS_MKDIR
3384     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3385 #else
3386     SETi( dooneliner("mkdir", tmps) );
3387     oldumask = PerlLIO_umask(0);
3388     PerlLIO_umask(oldumask);
3389     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3390 #endif
3391     RETURN;
3392 }
3393
3394 PP(pp_rmdir)
3395 {
3396     djSP; dTARGET;
3397     char *tmps;
3398     STRLEN n_a;
3399
3400     tmps = POPpx;
3401     TAINT_PROPER("rmdir");
3402 #ifdef HAS_RMDIR
3403     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3404 #else
3405     XPUSHi( dooneliner("rmdir", tmps) );
3406 #endif
3407     RETURN;
3408 }
3409
3410 /* Directory calls. */
3411
3412 PP(pp_open_dir)
3413 {
3414     djSP;
3415 #if defined(Direntry_t) && defined(HAS_READDIR)
3416     STRLEN n_a;
3417     char *dirname = POPpx;
3418     GV *gv = (GV*)POPs;
3419     register IO *io = GvIOn(gv);
3420
3421     if (!io)
3422         goto nope;
3423
3424     if (IoDIRP(io))
3425         PerlDir_close(IoDIRP(io));
3426     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3427         goto nope;
3428
3429     RETPUSHYES;
3430 nope:
3431     if (!errno)
3432         SETERRNO(EBADF,RMS$_DIR);
3433     RETPUSHUNDEF;
3434 #else
3435     DIE(aTHX_ PL_no_dir_func, "opendir");
3436 #endif
3437 }
3438
3439 PP(pp_readdir)
3440 {
3441     djSP;
3442 #if defined(Direntry_t) && defined(HAS_READDIR)
3443 #ifndef I_DIRENT
3444     Direntry_t *readdir (DIR *);
3445 #endif
3446     register Direntry_t *dp;
3447     GV *gv = (GV*)POPs;
3448     register IO *io = GvIOn(gv);
3449     SV *sv;
3450
3451     if (!io || !IoDIRP(io))
3452         goto nope;
3453
3454     if (GIMME == G_ARRAY) {
3455         /*SUPPRESS 560*/
3456         while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
3457 #ifdef DIRNAMLEN
3458             sv = newSVpvn(dp->d_name, dp->d_namlen);
3459 #else
3460             sv = newSVpv(dp->d_name, 0);
3461 #endif
3462 #ifndef INCOMPLETE_TAINTS
3463             SvTAINTED_on(sv);
3464 #endif
3465             XPUSHs(sv_2mortal(sv));
3466         }
3467     }
3468     else {
3469         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3470             goto nope;
3471 #ifdef DIRNAMLEN
3472         sv = newSVpvn(dp->d_name, dp->d_namlen);
3473 #else
3474         sv = newSVpv(dp->d_name, 0);
3475 #endif
3476 #ifndef INCOMPLETE_TAINTS
3477         SvTAINTED_on(sv);
3478 #endif
3479         XPUSHs(sv_2mortal(sv));
3480     }
3481     RETURN;
3482
3483 nope:
3484     if (!errno)
3485         SETERRNO(EBADF,RMS$_ISI);
3486     if (GIMME == G_ARRAY)
3487         RETURN;
3488     else
3489         RETPUSHUNDEF;
3490 #else
3491     DIE(aTHX_ PL_no_dir_func, "readdir");
3492 #endif
3493 }
3494
3495 PP(pp_telldir)
3496 {
3497     djSP; dTARGET;
3498 #if defined(HAS_TELLDIR) || defined(telldir)
3499  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3500  /* XXX netbsd still seemed to.
3501     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3502     --JHI 1999-Feb-02 */
3503 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3504     long telldir (DIR *);
3505 # endif
3506     GV *gv = (GV*)POPs;
3507     register IO *io = GvIOn(gv);
3508
3509     if (!io || !IoDIRP(io))
3510         goto nope;
3511
3512     PUSHi( PerlDir_tell(IoDIRP(io)) );
3513     RETURN;
3514 nope:
3515     if (!errno)
3516         SETERRNO(EBADF,RMS$_ISI);
3517     RETPUSHUNDEF;
3518 #else
3519     DIE(aTHX_ PL_no_dir_func, "telldir");
3520 #endif
3521 }
3522
3523 PP(pp_seekdir)
3524 {
3525     djSP;
3526 #if defined(HAS_SEEKDIR) || defined(seekdir)
3527     long along = POPl;
3528     GV *gv = (GV*)POPs;
3529     register IO *io = GvIOn(gv);
3530
3531     if (!io || !IoDIRP(io))
3532         goto nope;
3533
3534     (void)PerlDir_seek(IoDIRP(io), along);
3535
3536     RETPUSHYES;
3537 nope:
3538     if (!errno)
3539         SETERRNO(EBADF,RMS$_ISI);
3540     RETPUSHUNDEF;
3541 #else
3542     DIE(aTHX_ PL_no_dir_func, "seekdir");
3543 #endif
3544 }
3545
3546 PP(pp_rewinddir)
3547 {
3548     djSP;
3549 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3550     GV *gv = (GV*)POPs;
3551     register IO *io = GvIOn(gv);
3552
3553     if (!io || !IoDIRP(io))
3554         goto nope;
3555
3556     (void)PerlDir_rewind(IoDIRP(io));
3557     RETPUSHYES;
3558 nope:
3559     if (!errno)
3560         SETERRNO(EBADF,RMS$_ISI);
3561     RETPUSHUNDEF;
3562 #else
3563     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3564 #endif
3565 }
3566
3567 PP(pp_closedir)
3568 {
3569     djSP;
3570 #if defined(Direntry_t) && defined(HAS_READDIR)
3571     GV *gv = (GV*)POPs;
3572     register IO *io = GvIOn(gv);
3573
3574     if (!io || !IoDIRP(io))
3575         goto nope;
3576
3577 #ifdef VOID_CLOSEDIR
3578     PerlDir_close(IoDIRP(io));
3579 #else
3580     if (PerlDir_close(IoDIRP(io)) < 0) {
3581         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3582         goto nope;
3583     }
3584 #endif
3585     IoDIRP(io) = 0;
3586
3587     RETPUSHYES;
3588 nope:
3589     if (!errno)
3590         SETERRNO(EBADF,RMS$_IFI);
3591     RETPUSHUNDEF;
3592 #else
3593     DIE(aTHX_ PL_no_dir_func, "closedir");
3594 #endif
3595 }
3596
3597 /* Process control. */
3598
3599 PP(pp_fork)
3600 {
3601 #ifdef HAS_FORK
3602     djSP; dTARGET;
3603     Pid_t childpid;
3604     GV *tmpgv;
3605
3606     EXTEND(SP, 1);
3607     PERL_FLUSHALL_FOR_CHILD;
3608     childpid = fork();
3609     if (childpid < 0)
3610         RETSETUNDEF;
3611     if (!childpid) {
3612         /*SUPPRESS 560*/
3613         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3614             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3615         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3616     }
3617     PUSHi(childpid);
3618     RETURN;
3619 #else
3620 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3621     djSP; dTARGET;
3622     Pid_t childpid;
3623
3624     EXTEND(SP, 1);
3625     PERL_FLUSHALL_FOR_CHILD;
3626     childpid = PerlProc_fork();
3627     PUSHi(childpid);
3628     RETURN;
3629 #  else
3630     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3631 #  endif
3632 #endif
3633 }
3634
3635 PP(pp_wait)
3636 {
3637 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3638     djSP; dTARGET;
3639     Pid_t childpid;
3640     int argflags;
3641
3642     childpid = wait4pid(-1, &argflags, 0);
3643     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3644     XPUSHi(childpid);
3645     RETURN;
3646 #else
3647     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3648 #endif
3649 }
3650
3651 PP(pp_waitpid)
3652 {
3653 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3654     djSP; dTARGET;
3655     Pid_t childpid;
3656     int optype;
3657     int argflags;
3658
3659     optype = POPi;
3660     childpid = TOPi;
3661     childpid = wait4pid(childpid, &argflags, optype);
3662     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3663     SETi(childpid);
3664     RETURN;
3665 #else
3666     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3667 #endif
3668 }
3669
3670 PP(pp_system)
3671 {
3672     djSP; dMARK; dORIGMARK; dTARGET;
3673     I32 value;
3674     Pid_t childpid;
3675     int result;
3676     int status;
3677     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3678     STRLEN n_a;
3679     I32 did_pipes = 0;
3680     int pp[2];
3681
3682     if (SP - MARK == 1) {
3683         if (PL_tainting) {
3684             char *junk = SvPV(TOPs, n_a);
3685             TAINT_ENV();
3686             TAINT_PROPER("system");
3687         }
3688     }
3689     PERL_FLUSHALL_FOR_CHILD;
3690 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3691     if (PerlProc_pipe(pp) >= 0)
3692         did_pipes = 1;
3693     while ((childpid = vfork()) == -1) {
3694         if (errno != EAGAIN) {
3695             value = -1;
3696             SP = ORIGMARK;
3697             PUSHi(value);
3698             if (did_pipes) {
3699                 PerlLIO_close(pp[0]);
3700                 PerlLIO_close(pp[1]);
3701             }
3702             RETURN;
3703         }
3704         sleep(5);
3705     }
3706     if (childpid > 0) {
3707         if (did_pipes)
3708             PerlLIO_close(pp[1]);
3709         rsignal_save(SIGINT, SIG_IGN, &ihand);
3710         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3711         do {
3712             result = wait4pid(childpid, &status, 0);
3713         } while (result == -1 && errno == EINTR);
3714         (void)rsignal_restore(SIGINT, &ihand);
3715         (void)rsignal_restore(SIGQUIT, &qhand);
3716         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3717         do_execfree();  /* free any memory child malloced on vfork */
3718         SP = ORIGMARK;
3719         if (did_pipes) {
3720             int errkid;
3721             int n = 0, n1;
3722
3723             while (n < sizeof(int)) {
3724                 n1 = PerlLIO_read(pp[0],
3725                                   (void*)(((char*)&errkid)+n),
3726                                   (sizeof(int)) - n);
3727                 if (n1 <= 0)
3728                     break;
3729                 n += n1;
3730             }
3731             PerlLIO_close(pp[0]);
3732             if (n) {                    /* Error */
3733                 if (n != sizeof(int))
3734                     DIE(aTHX_ "panic: kid popen errno read");
3735                 errno = errkid;         /* Propagate errno from kid */
3736                 STATUS_CURRENT = -1;
3737             }
3738         }
3739         PUSHi(STATUS_CURRENT);
3740         RETURN;
3741     }
3742     if (did_pipes) {
3743         PerlLIO_close(pp[0]);
3744 #if defined(HAS_FCNTL) && defined(F_SETFD)
3745         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3746 #endif
3747     }
3748     if (PL_op->op_flags & OPf_STACKED) {
3749         SV *really = *++MARK;
3750         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
3751     }
3752     else if (SP - MARK != 1)
3753         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
3754     else {
3755         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
3756     }
3757     PerlProc__exit(-1);
3758 #else /* ! FORK or VMS or OS/2 */
3759     if (PL_op->op_flags & OPf_STACKED) {
3760         SV *really = *++MARK;
3761         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3762     }
3763     else if (SP - MARK != 1)
3764         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3765     else {
3766         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3767     }
3768     STATUS_NATIVE_SET(value);
3769     do_execfree();
3770     SP = ORIGMARK;
3771     PUSHi(STATUS_CURRENT);
3772 #endif /* !FORK or VMS */
3773     RETURN;
3774 }
3775
3776 PP(pp_exec)
3777 {
3778     djSP; dMARK; dORIGMARK; dTARGET;
3779     I32 value;
3780     STRLEN n_a;
3781
3782     PERL_FLUSHALL_FOR_CHILD;
3783     if (PL_op->op_flags & OPf_STACKED) {
3784         SV *really = *++MARK;
3785         value = (I32)do_aexec(really, MARK, SP);
3786     }
3787     else if (SP - MARK != 1)
3788 #ifdef VMS
3789         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3790 #else
3791 #  ifdef __OPEN_VM
3792         {
3793            (void ) do_aspawn(Nullsv, MARK, SP);
3794            value = 0;
3795         }
3796 #  else
3797         value = (I32)do_aexec(Nullsv, MARK, SP);
3798 #  endif
3799 #endif
3800     else {
3801         if (PL_tainting) {
3802             char *junk = SvPV(*SP, n_a);
3803             TAINT_ENV();
3804             TAINT_PROPER("exec");
3805         }
3806 #ifdef VMS
3807         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3808 #else
3809 #  ifdef __OPEN_VM
3810         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3811         value = 0;
3812 #  else
3813         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3814 #  endif
3815 #endif
3816     }
3817
3818 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3819     if (value >= 0)
3820         my_exit(value);
3821 #endif
3822
3823     SP = ORIGMARK;
3824     PUSHi(value);
3825     RETURN;
3826 }
3827
3828 PP(pp_kill)
3829 {
3830     djSP; dMARK; dTARGET;
3831     I32 value;
3832 #ifdef HAS_KILL
3833     value = (I32)apply(PL_op->op_type, MARK, SP);
3834     SP = MARK;
3835     PUSHi(value);
3836     RETURN;
3837 #else
3838     DIE(aTHX_ PL_no_func, "Unsupported function kill");
3839 #endif
3840 }
3841
3842 PP(pp_getppid)
3843 {
3844 #ifdef HAS_GETPPID
3845     djSP; dTARGET;
3846     XPUSHi( getppid() );
3847     RETURN;
3848 #else
3849     DIE(aTHX_ PL_no_func, "getppid");
3850 #endif
3851 }
3852
3853 PP(pp_getpgrp)
3854 {
3855 #ifdef HAS_GETPGRP
3856     djSP; dTARGET;
3857     Pid_t pid;
3858     Pid_t pgrp;
3859
3860     if (MAXARG < 1)
3861         pid = 0;
3862     else
3863         pid = SvIVx(POPs);
3864 #ifdef BSD_GETPGRP
3865     pgrp = (I32)BSD_GETPGRP(pid);
3866 #else
3867     if (pid != 0 && pid != PerlProc_getpid())
3868         DIE(aTHX_ "POSIX getpgrp can't take an argument");
3869     pgrp = getpgrp();
3870 #endif
3871     XPUSHi(pgrp);
3872     RETURN;
3873 #else
3874     DIE(aTHX_ PL_no_func, "getpgrp()");
3875 #endif
3876 }
3877
3878 PP(pp_setpgrp)
3879 {
3880 #ifdef HAS_SETPGRP
3881     djSP; dTARGET;
3882     Pid_t pgrp;
3883     Pid_t pid;
3884     if (MAXARG < 2) {
3885         pgrp = 0;
3886         pid = 0;
3887     }
3888     else {
3889         pgrp = POPi;
3890         pid = TOPi;
3891     }
3892
3893     TAINT_PROPER("setpgrp");
3894 #ifdef BSD_SETPGRP
3895     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3896 #else
3897     if ((pgrp != 0 && pgrp != PerlProc_getpid())
3898         || (pid != 0 && pid != PerlProc_getpid()))
3899     {
3900         DIE(aTHX_ "setpgrp can't take arguments");
3901     }
3902     SETi( setpgrp() >= 0 );
3903 #endif /* USE_BSDPGRP */
3904     RETURN;
3905 #else
3906     DIE(aTHX_ PL_no_func, "setpgrp()");
3907 #endif
3908 }
3909
3910 PP(pp_getpriority)
3911 {
3912     djSP; dTARGET;
3913     int which;
3914     int who;
3915 #ifdef HAS_GETPRIORITY
3916     who = POPi;
3917     which = TOPi;
3918     SETi( getpriority(which, who) );
3919     RETURN;
3920 #else
3921     DIE(aTHX_ PL_no_func, "getpriority()");
3922 #endif
3923 }
3924
3925 PP(pp_setpriority)
3926 {
3927     djSP; dTARGET;
3928     int which;
3929     int who;
3930     int niceval;
3931 #ifdef HAS_SETPRIORITY
3932     niceval = POPi;
3933     who = POPi;
3934     which = TOPi;
3935     TAINT_PROPER("setpriority");
3936     SETi( setpriority(which, who, niceval) >= 0 );
3937     RETURN;
3938 #else
3939     DIE(aTHX_ PL_no_func, "setpriority()");
3940 #endif
3941 }
3942
3943 /* Time calls. */
3944
3945 PP(pp_time)
3946 {
3947     djSP; dTARGET;
3948 #ifdef BIG_TIME
3949     XPUSHn( time(Null(Time_t*)) );
3950 #else
3951     XPUSHi( time(Null(Time_t*)) );
3952 #endif
3953     RETURN;
3954 }
3955
3956 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3957    to HZ.  Probably.  For now, assume that if the system
3958    defines HZ, it does so correctly.  (Will this break
3959    on VMS?)
3960    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3961    it's supported.    --AD  9/96.
3962 */
3963
3964 #ifndef HZ
3965 #  ifdef CLK_TCK
3966 #    define HZ CLK_TCK
3967 #  else
3968 #    define HZ 60
3969 #  endif
3970 #endif
3971
3972 PP(pp_tms)
3973 {
3974     djSP;
3975
3976 #ifndef HAS_TIMES
3977     DIE(aTHX_ "times not implemented");
3978 #else
3979     EXTEND(SP, 4);
3980
3981 #ifndef VMS
3982     (void)PerlProc_times(&PL_timesbuf);
3983 #else
3984     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
3985                                                    /* struct tms, though same data   */
3986                                                    /* is returned.                   */
3987 #endif
3988
3989     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
3990     if (GIMME == G_ARRAY) {
3991         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
3992         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
3993         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
3994     }
3995     RETURN;
3996 #endif /* HAS_TIMES */
3997 }
3998
3999 PP(pp_localtime)
4000 {
4001     return pp_gmtime();
4002 }
4003
4004 PP(pp_gmtime)
4005 {
4006     djSP;
4007     Time_t when;
4008     struct tm *tmbuf;
4009     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4010     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4011                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4012
4013     if (MAXARG < 1)
4014         (void)time(&when);
4015     else
4016 #ifdef BIG_TIME
4017         when = (Time_t)SvNVx(POPs);
4018 #else
4019         when = (Time_t)SvIVx(POPs);
4020 #endif
4021
4022     if (PL_op->op_type == OP_LOCALTIME)
4023         tmbuf = localtime(&when);
4024     else
4025         tmbuf = gmtime(&when);
4026
4027     EXTEND(SP, 9);
4028     EXTEND_MORTAL(9);
4029     if (GIMME != G_ARRAY) {
4030         dTARGET;
4031         SV *tsv;
4032         if (!tmbuf)
4033             RETPUSHUNDEF;
4034         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4035                             dayname[tmbuf->tm_wday],
4036                             monname[tmbuf->tm_mon],
4037                             tmbuf->tm_mday,
4038                             tmbuf->tm_hour,
4039                             tmbuf->tm_min,
4040                             tmbuf->tm_sec,
4041                             tmbuf->tm_year + 1900);
4042         PUSHs(sv_2mortal(tsv));
4043     }
4044     else if (tmbuf) {
4045         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4046         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4047         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4048         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4049         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4050         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4051         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4052         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4053         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4054     }
4055     RETURN;
4056 }
4057
4058 PP(pp_alarm)
4059 {
4060     djSP; dTARGET;
4061     int anum;
4062 #ifdef HAS_ALARM
4063     anum = POPi;
4064     anum = alarm((unsigned int)anum);
4065     EXTEND(SP, 1);
4066     if (anum < 0)
4067         RETPUSHUNDEF;
4068     PUSHi(anum);
4069     RETURN;
4070 #else
4071     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4072 #endif
4073 }
4074
4075 PP(pp_sleep)
4076 {
4077     djSP; dTARGET;
4078     I32 duration;
4079     Time_t lasttime;
4080     Time_t when;
4081
4082     (void)time(&lasttime);
4083     if (MAXARG < 1)
4084         PerlProc_pause();
4085     else {
4086         duration = POPi;
4087         PerlProc_sleep((unsigned int)duration);
4088     }
4089     (void)time(&when);
4090     XPUSHi(when - lasttime);
4091     RETURN;
4092 }
4093
4094 /* Shared memory. */
4095
4096 PP(pp_shmget)
4097 {
4098     return pp_semget();
4099 }
4100
4101 PP(pp_shmctl)
4102 {
4103     return pp_semctl();
4104 }
4105
4106 PP(pp_shmread)
4107 {
4108     return pp_shmwrite();
4109 }
4110
4111 PP(pp_shmwrite)
4112 {
4113 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4114     djSP; dMARK; dTARGET;
4115     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4116     SP = MARK;
4117     PUSHi(value);
4118     RETURN;
4119 #else
4120     return pp_semget();
4121 #endif
4122 }
4123
4124 /* Message passing. */
4125
4126 PP(pp_msgget)
4127 {
4128     return pp_semget();
4129 }
4130
4131 PP(pp_msgctl)
4132 {
4133     return pp_semctl();
4134 }
4135
4136 PP(pp_msgsnd)
4137 {
4138 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4139     djSP; dMARK; dTARGET;
4140     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4141     SP = MARK;
4142     PUSHi(value);
4143     RETURN;
4144 #else
4145     return pp_semget();
4146 #endif
4147 }
4148
4149 PP(pp_msgrcv)
4150 {
4151 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4152     djSP; dMARK; dTARGET;
4153     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4154     SP = MARK;
4155     PUSHi(value);
4156     RETURN;
4157 #else
4158     return pp_semget();
4159 #endif
4160 }
4161
4162 /* Semaphores. */
4163
4164 PP(pp_semget)
4165 {
4166 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4167     djSP; dMARK; dTARGET;
4168     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4169     SP = MARK;
4170     if (anum == -1)
4171         RETPUSHUNDEF;
4172     PUSHi(anum);
4173     RETURN;
4174 #else
4175     DIE(aTHX_ "System V IPC is not implemented on this machine");
4176 #endif
4177 }
4178
4179 PP(pp_semctl)
4180 {
4181 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4182     djSP; dMARK; dTARGET;
4183     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4184     SP = MARK;
4185     if (anum == -1)
4186         RETSETUNDEF;
4187     if (anum != 0) {
4188         PUSHi(anum);
4189     }
4190     else {
4191         PUSHp(zero_but_true, ZBTLEN);
4192     }
4193     RETURN;
4194 #else
4195     return pp_semget();
4196 #endif
4197 }
4198
4199 PP(pp_semop)
4200 {
4201 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4202     djSP; dMARK; dTARGET;
4203     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4204     SP = MARK;
4205     PUSHi(value);
4206     RETURN;
4207 #else
4208     return pp_semget();
4209 #endif
4210 }
4211
4212 /* Get system info. */
4213
4214 PP(pp_ghbyname)
4215 {
4216 #ifdef HAS_GETHOSTBYNAME
4217     return pp_ghostent();
4218 #else
4219     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4220 #endif
4221 }
4222
4223 PP(pp_ghbyaddr)
4224 {
4225 #ifdef HAS_GETHOSTBYADDR
4226     return pp_ghostent();
4227 #else
4228     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4229 #endif
4230 }
4231
4232 PP(pp_ghostent)
4233 {
4234     djSP;
4235 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4236     I32 which = PL_op->op_type;
4237     register char **elem;
4238     register SV *sv;
4239 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4240     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4241     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4242     struct hostent *PerlSock_gethostent(void);
4243 #endif
4244     struct hostent *hent;
4245     unsigned long len;
4246     STRLEN n_a;
4247
4248     EXTEND(SP, 10);
4249     if (which == OP_GHBYNAME)
4250 #ifdef HAS_GETHOSTBYNAME
4251         hent = PerlSock_gethostbyname(POPpx);
4252 #else
4253         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4254 #endif
4255     else if (which == OP_GHBYADDR) {
4256 #ifdef HAS_GETHOSTBYADDR
4257         int addrtype = POPi;
4258         SV *addrsv = POPs;
4259         STRLEN addrlen;
4260         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
4261
4262         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4263 #else
4264         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4265 #endif
4266     }
4267     else
4268 #ifdef HAS_GETHOSTENT
4269         hent = PerlSock_gethostent();
4270 #else
4271         DIE(aTHX_ PL_no_sock_func, "gethostent");
4272 #endif
4273
4274 #ifdef HOST_NOT_FOUND
4275     if (!hent)
4276         STATUS_NATIVE_SET(h_errno);
4277 #endif
4278
4279     if (GIMME != G_ARRAY) {
4280         PUSHs(sv = sv_newmortal());
4281         if (hent) {
4282             if (which == OP_GHBYNAME) {
4283                 if (hent->h_addr)
4284                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4285             }
4286             else
4287                 sv_setpv(sv, (char*)hent->h_name);
4288         }
4289         RETURN;
4290     }
4291
4292     if (hent) {
4293         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4294         sv_setpv(sv, (char*)hent->h_name);
4295         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4296         for (elem = hent->h_aliases; elem && *elem; elem++) {
4297             sv_catpv(sv, *elem);
4298             if (elem[1])
4299                 sv_catpvn(sv, " ", 1);
4300         }
4301         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4302         sv_setiv(sv, (IV)hent->h_addrtype);
4303         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4304         len = hent->h_length;
4305         sv_setiv(sv, (IV)len);
4306 #ifdef h_addr
4307         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4308             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4309             sv_setpvn(sv, *elem, len);
4310         }
4311 #else
4312         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4313         if (hent->h_addr)
4314             sv_setpvn(sv, hent->h_addr, len);
4315 #endif /* h_addr */
4316     }
4317     RETURN;
4318 #else
4319     DIE(aTHX_ PL_no_sock_func, "gethostent");
4320 #endif
4321 }
4322
4323 PP(pp_gnbyname)
4324 {
4325 #ifdef HAS_GETNETBYNAME
4326     return pp_gnetent();
4327 #else
4328     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4329 #endif
4330 }
4331
4332 PP(pp_gnbyaddr)
4333 {
4334 #ifdef HAS_GETNETBYADDR
4335     return pp_gnetent();
4336 #else
4337     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4338 #endif
4339 }
4340
4341 PP(pp_gnetent)
4342 {
4343     djSP;
4344 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4345     I32 which = PL_op->op_type;
4346     register char **elem;
4347     register SV *sv;
4348 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4349     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4350     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4351     struct netent *PerlSock_getnetent(void);
4352 #endif
4353     struct netent *nent;
4354     STRLEN n_a;
4355
4356     if (which == OP_GNBYNAME)
4357 #ifdef HAS_GETNETBYNAME
4358         nent = PerlSock_getnetbyname(POPpx);
4359 #else
4360         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4361 #endif
4362     else if (which == OP_GNBYADDR) {
4363 #ifdef HAS_GETNETBYADDR
4364         int addrtype = POPi;
4365         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4366         nent = PerlSock_getnetbyaddr(addr, addrtype);
4367 #else
4368         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4369 #endif
4370     }
4371     else
4372 #ifdef HAS_GETNETENT
4373         nent = PerlSock_getnetent();
4374 #else
4375         DIE(aTHX_ PL_no_sock_func, "getnetent");
4376 #endif
4377
4378     EXTEND(SP, 4);
4379     if (GIMME != G_ARRAY) {
4380         PUSHs(sv = sv_newmortal());
4381         if (nent) {
4382             if (which == OP_GNBYNAME)
4383                 sv_setiv(sv, (IV)nent->n_net);
4384             else
4385                 sv_setpv(sv, nent->n_name);
4386         }
4387         RETURN;
4388     }
4389
4390     if (nent) {
4391         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4392         sv_setpv(sv, nent->n_name);
4393         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4394         for (elem = nent->n_aliases; elem && *elem; elem++) {
4395             sv_catpv(sv, *elem);
4396             if (elem[1])
4397                 sv_catpvn(sv, " ", 1);
4398         }
4399         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4400         sv_setiv(sv, (IV)nent->n_addrtype);
4401         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4402         sv_setiv(sv, (IV)nent->n_net);
4403     }
4404
4405     RETURN;
4406 #else
4407     DIE(aTHX_ PL_no_sock_func, "getnetent");
4408 #endif
4409 }
4410
4411 PP(pp_gpbyname)
4412 {
4413 #ifdef HAS_GETPROTOBYNAME
4414     return pp_gprotoent();
4415 #else
4416     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4417 #endif
4418 }
4419
4420 PP(pp_gpbynumber)
4421 {
4422 #ifdef HAS_GETPROTOBYNUMBER
4423     return pp_gprotoent();
4424 #else
4425     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4426 #endif
4427 }
4428
4429 PP(pp_gprotoent)
4430 {
4431     djSP;
4432 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4433     I32 which = PL_op->op_type;
4434     register char **elem;
4435     register SV *sv;
4436 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4437     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4438     struct protoent *PerlSock_getprotobynumber(int);
4439     struct protoent *PerlSock_getprotoent(void);
4440 #endif
4441     struct protoent *pent;
4442     STRLEN n_a;
4443
4444     if (which == OP_GPBYNAME)
4445 #ifdef HAS_GETPROTOBYNAME
4446         pent = PerlSock_getprotobyname(POPpx);
4447 #else
4448         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4449 #endif
4450     else if (which == OP_GPBYNUMBER)
4451 #ifdef HAS_GETPROTOBYNUMBER
4452         pent = PerlSock_getprotobynumber(POPi);
4453 #else
4454     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4455 #endif
4456     else
4457 #ifdef HAS_GETPROTOENT
4458         pent = PerlSock_getprotoent();
4459 #else
4460         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4461 #endif
4462
4463     EXTEND(SP, 3);
4464     if (GIMME != G_ARRAY) {
4465         PUSHs(sv = sv_newmortal());
4466         if (pent) {
4467             if (which == OP_GPBYNAME)
4468                 sv_setiv(sv, (IV)pent->p_proto);
4469             else
4470                 sv_setpv(sv, pent->p_name);
4471         }
4472         RETURN;
4473     }
4474
4475     if (pent) {
4476         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4477         sv_setpv(sv, pent->p_name);
4478         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4479         for (elem = pent->p_aliases; elem && *elem; elem++) {
4480             sv_catpv(sv, *elem);
4481             if (elem[1])
4482                 sv_catpvn(sv, " ", 1);
4483         }
4484         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4485         sv_setiv(sv, (IV)pent->p_proto);
4486     }
4487
4488     RETURN;
4489 #else
4490     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4491 #endif
4492 }
4493
4494 PP(pp_gsbyname)
4495 {
4496 #ifdef HAS_GETSERVBYNAME
4497     return pp_gservent();
4498 #else
4499     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4500 #endif
4501 }
4502
4503 PP(pp_gsbyport)
4504 {
4505 #ifdef HAS_GETSERVBYPORT
4506     return pp_gservent();
4507 #else
4508     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4509 #endif
4510 }
4511
4512 PP(pp_gservent)
4513 {
4514     djSP;
4515 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4516     I32 which = PL_op->op_type;
4517     register char **elem;
4518     register SV *sv;
4519 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4520     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4521     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4522     struct servent *PerlSock_getservent(void);
4523 #endif
4524     struct servent *sent;
4525     STRLEN n_a;
4526
4527     if (which == OP_GSBYNAME) {
4528 #ifdef HAS_GETSERVBYNAME
4529         char *proto = POPpx;
4530         char *name = POPpx;
4531
4532         if (proto && !*proto)
4533             proto = Nullch;
4534
4535         sent = PerlSock_getservbyname(name, proto);
4536 #else
4537         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4538 #endif
4539     }
4540     else if (which == OP_GSBYPORT) {
4541 #ifdef HAS_GETSERVBYPORT
4542         char *proto = POPpx;
4543         unsigned short port = POPu;
4544
4545 #ifdef HAS_HTONS
4546         port = PerlSock_htons(port);
4547 #endif
4548         sent = PerlSock_getservbyport(port, proto);
4549 #else
4550         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4551 #endif
4552     }
4553     else
4554 #ifdef HAS_GETSERVENT
4555         sent = PerlSock_getservent();
4556 #else
4557         DIE(aTHX_ PL_no_sock_func, "getservent");
4558 #endif
4559
4560     EXTEND(SP, 4);
4561     if (GIMME != G_ARRAY) {
4562         PUSHs(sv = sv_newmortal());
4563         if (sent) {
4564             if (which == OP_GSBYNAME) {
4565 #ifdef HAS_NTOHS
4566                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4567 #else
4568                 sv_setiv(sv, (IV)(sent->s_port));
4569 #endif
4570             }
4571             else
4572                 sv_setpv(sv, sent->s_name);
4573         }
4574         RETURN;
4575     }
4576
4577     if (sent) {
4578         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4579         sv_setpv(sv, sent->s_name);
4580         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4581         for (elem = sent->s_aliases; elem && *elem; elem++) {
4582             sv_catpv(sv, *elem);
4583             if (elem[1])
4584                 sv_catpvn(sv, " ", 1);
4585         }
4586         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4587 #ifdef HAS_NTOHS
4588         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4589 #else
4590         sv_setiv(sv, (IV)(sent->s_port));
4591 #endif
4592         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4593         sv_setpv(sv, sent->s_proto);
4594     }
4595
4596     RETURN;
4597 #else
4598     DIE(aTHX_ PL_no_sock_func, "getservent");
4599 #endif
4600 }
4601
4602 PP(pp_shostent)
4603 {
4604     djSP;
4605 #ifdef HAS_SETHOSTENT
4606     PerlSock_sethostent(TOPi);
4607     RETSETYES;
4608 #else
4609     DIE(aTHX_ PL_no_sock_func, "sethostent");
4610 #endif
4611 }
4612
4613 PP(pp_snetent)
4614 {
4615     djSP;
4616 #ifdef HAS_SETNETENT
4617     PerlSock_setnetent(TOPi);
4618     RETSETYES;
4619 #else
4620     DIE(aTHX_ PL_no_sock_func, "setnetent");
4621 #endif
4622 }
4623
4624 PP(pp_sprotoent)
4625 {
4626     djSP;
4627 #ifdef HAS_SETPROTOENT
4628     PerlSock_setprotoent(TOPi);
4629     RETSETYES;
4630 #else
4631     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4632 #endif
4633 }
4634
4635 PP(pp_sservent)
4636 {
4637     djSP;
4638 #ifdef HAS_SETSERVENT
4639     PerlSock_setservent(TOPi);
4640     RETSETYES;
4641 #else
4642     DIE(aTHX_ PL_no_sock_func, "setservent");
4643 #endif
4644 }
4645
4646 PP(pp_ehostent)
4647 {
4648     djSP;
4649 #ifdef HAS_ENDHOSTENT
4650     PerlSock_endhostent();
4651     EXTEND(SP,1);
4652     RETPUSHYES;
4653 #else
4654     DIE(aTHX_ PL_no_sock_func, "endhostent");
4655 #endif
4656 }
4657
4658 PP(pp_enetent)
4659 {
4660     djSP;
4661 #ifdef HAS_ENDNETENT
4662     PerlSock_endnetent();
4663     EXTEND(SP,1);
4664     RETPUSHYES;
4665 #else
4666     DIE(aTHX_ PL_no_sock_func, "endnetent");
4667 #endif
4668 }
4669
4670 PP(pp_eprotoent)
4671 {
4672     djSP;
4673 #ifdef HAS_ENDPROTOENT
4674     PerlSock_endprotoent();
4675     EXTEND(SP,1);
4676     RETPUSHYES;
4677 #else
4678     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4679 #endif
4680 }
4681
4682 PP(pp_eservent)
4683 {
4684     djSP;
4685 #ifdef HAS_ENDSERVENT
4686     PerlSock_endservent();
4687     EXTEND(SP,1);
4688     RETPUSHYES;
4689 #else
4690     DIE(aTHX_ PL_no_sock_func, "endservent");
4691 #endif
4692 }
4693
4694 PP(pp_gpwnam)
4695 {
4696 #ifdef HAS_PASSWD
4697     return pp_gpwent();
4698 #else
4699     DIE(aTHX_ PL_no_func, "getpwnam");
4700 #endif
4701 }
4702
4703 PP(pp_gpwuid)
4704 {
4705 #ifdef HAS_PASSWD
4706     return pp_gpwent();
4707 #else
4708     DIE(aTHX_ PL_no_func, "getpwuid");
4709 #endif
4710 }
4711
4712 PP(pp_gpwent)
4713 {
4714     djSP;
4715 #if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
4716     I32 which = PL_op->op_type;
4717     register SV *sv;
4718     struct passwd *pwent;
4719     STRLEN n_a;
4720 #if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
4721     struct spwd *spwent = NULL;
4722 #endif
4723
4724     if (which == OP_GPWNAM)
4725         pwent = getpwnam(POPpx);
4726     else if (which == OP_GPWUID)
4727         pwent = getpwuid(POPi);
4728     else
4729         pwent = (struct passwd *)getpwent();
4730
4731 #ifdef HAS_GETSPNAM
4732     if (which == OP_GPWNAM) {
4733         if (pwent)
4734             spwent = getspnam(pwent->pw_name);
4735     }
4736 #  ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
4737     else if (which == OP_GPWUID) {
4738         if (pwent)
4739             spwent = getspnam(pwent->pw_name);
4740     }
4741 #  endif
4742 #  ifdef HAS_GETSPENT
4743     else
4744         spwent = (struct spwd *)getspent();
4745 #  endif
4746 #endif
4747
4748     EXTEND(SP, 10);
4749     if (GIMME != G_ARRAY) {
4750         PUSHs(sv = sv_newmortal());
4751         if (pwent) {
4752             if (which == OP_GPWNAM)
4753                 sv_setiv(sv, (IV)pwent->pw_uid);
4754             else
4755                 sv_setpv(sv, pwent->pw_name);
4756         }
4757         RETURN;
4758     }
4759
4760     if (pwent) {
4761         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4762         sv_setpv(sv, pwent->pw_name);
4763
4764         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4765 #ifdef PWPASSWD
4766 #   if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
4767       if (spwent)
4768               sv_setpv(sv, spwent->sp_pwdp);
4769       else
4770               sv_setpv(sv, pwent->pw_passwd);
4771 #   else
4772         sv_setpv(sv, pwent->pw_passwd);
4773 #   endif
4774 #endif
4775
4776         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4777         sv_setiv(sv, (IV)pwent->pw_uid);
4778
4779         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4780         sv_setiv(sv, (IV)pwent->pw_gid);
4781
4782         /* pw_change, pw_quota, and pw_age are mutually exclusive. */
4783         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4784 #ifdef PWCHANGE
4785         sv_setiv(sv, (IV)pwent->pw_change);
4786 #else
4787 #   ifdef PWQUOTA
4788         sv_setiv(sv, (IV)pwent->pw_quota);
4789 #   else
4790 #       ifdef PWAGE
4791         sv_setpv(sv, pwent->pw_age);
4792 #       endif
4793 #   endif
4794 #endif
4795
4796         /* pw_class and pw_comment are mutually exclusive. */
4797         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4798 #ifdef PWCLASS
4799         sv_setpv(sv, pwent->pw_class);
4800 #else
4801 #   ifdef PWCOMMENT
4802         sv_setpv(sv, pwent->pw_comment);
4803 #   endif
4804 #endif
4805
4806         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4807 #ifdef PWGECOS
4808         sv_setpv(sv, pwent->pw_gecos);
4809 #endif
4810 #ifndef INCOMPLETE_TAINTS
4811         /* pw_gecos is tainted because user himself can diddle with it. */
4812         SvTAINTED_on(sv);
4813 #endif
4814
4815         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4816         sv_setpv(sv, pwent->pw_dir);
4817
4818         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4819         sv_setpv(sv, pwent->pw_shell);
4820
4821 #ifdef PWEXPIRE
4822         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4823         sv_setiv(sv, (IV)pwent->pw_expire);
4824 #endif
4825     }
4826     RETURN;
4827 #else
4828     DIE(aTHX_ PL_no_func, "getpwent");
4829 #endif
4830 }
4831
4832 PP(pp_spwent)
4833 {
4834     djSP;
4835 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
4836     setpwent();
4837 #   ifdef HAS_SETSPENT
4838     setspent();
4839 #   endif
4840     RETPUSHYES;
4841 #else
4842     DIE(aTHX_ PL_no_func, "setpwent");
4843 #endif
4844 }
4845
4846 PP(pp_epwent)
4847 {
4848     djSP;
4849 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
4850     endpwent();
4851 #   ifdef HAS_ENDSPENT
4852     endspent();
4853 #   endif
4854     RETPUSHYES;
4855 #else
4856     DIE(aTHX_ PL_no_func, "endpwent");
4857 #endif
4858 }
4859
4860 PP(pp_ggrnam)
4861 {
4862 #ifdef HAS_GROUP
4863     return pp_ggrent();
4864 #else
4865     DIE(aTHX_ PL_no_func, "getgrnam");
4866 #endif
4867 }
4868
4869 PP(pp_ggrgid)
4870 {
4871 #ifdef HAS_GROUP
4872     return pp_ggrent();
4873 #else
4874     DIE(aTHX_ PL_no_func, "getgrgid");
4875 #endif
4876 }
4877
4878 PP(pp_ggrent)
4879 {
4880     djSP;
4881 #if defined(HAS_GROUP) && defined(HAS_GETGRENT)
4882     I32 which = PL_op->op_type;
4883     register char **elem;
4884     register SV *sv;
4885     struct group *grent;
4886     STRLEN n_a;
4887
4888     if (which == OP_GGRNAM)
4889         grent = (struct group *)getgrnam(POPpx);
4890     else if (which == OP_GGRGID)
4891         grent = (struct group *)getgrgid(POPi);
4892     else
4893         grent = (struct group *)getgrent();
4894
4895     EXTEND(SP, 4);
4896     if (GIMME != G_ARRAY) {
4897         PUSHs(sv = sv_newmortal());
4898         if (grent) {
4899             if (which == OP_GGRNAM)
4900                 sv_setiv(sv, (IV)grent->gr_gid);
4901             else
4902                 sv_setpv(sv, grent->gr_name);
4903         }
4904         RETURN;
4905     }
4906
4907     if (grent) {
4908         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4909         sv_setpv(sv, grent->gr_name);
4910
4911         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4912 #ifdef GRPASSWD
4913         sv_setpv(sv, grent->gr_passwd);
4914 #endif
4915
4916         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4917         sv_setiv(sv, (IV)grent->gr_gid);
4918
4919         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4920         for (elem = grent->gr_mem; elem && *elem; elem++) {
4921             sv_catpv(sv, *elem);
4922             if (elem[1])
4923                 sv_catpvn(sv, " ", 1);
4924         }
4925     }
4926
4927     RETURN;
4928 #else
4929     DIE(aTHX_ PL_no_func, "getgrent");
4930 #endif
4931 }
4932
4933 PP(pp_sgrent)
4934 {
4935     djSP;
4936 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
4937     setgrent();
4938     RETPUSHYES;
4939 #else
4940     DIE(aTHX_ PL_no_func, "setgrent");
4941 #endif
4942 }
4943
4944 PP(pp_egrent)
4945 {
4946     djSP;
4947 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
4948     endgrent();
4949     RETPUSHYES;
4950 #else
4951     DIE(aTHX_ PL_no_func, "endgrent");
4952 #endif
4953 }
4954
4955 PP(pp_getlogin)
4956 {
4957     djSP; dTARGET;
4958 #ifdef HAS_GETLOGIN
4959     char *tmps;
4960     EXTEND(SP, 1);
4961     if (!(tmps = PerlProc_getlogin()))
4962         RETPUSHUNDEF;
4963     PUSHp(tmps, strlen(tmps));
4964     RETURN;
4965 #else
4966     DIE(aTHX_ PL_no_func, "getlogin");
4967 #endif
4968 }
4969
4970 /* Miscellaneous. */
4971
4972 PP(pp_syscall)
4973 {
4974 #ifdef HAS_SYSCALL
4975     djSP; dMARK; dORIGMARK; dTARGET;
4976     register I32 items = SP - MARK;
4977     unsigned long a[20];
4978     register I32 i = 0;
4979     I32 retval = -1;
4980     MAGIC *mg;
4981     STRLEN n_a;
4982
4983     if (PL_tainting) {
4984         while (++MARK <= SP) {
4985             if (SvTAINTED(*MARK)) {
4986                 TAINT;
4987                 break;
4988             }
4989         }
4990         MARK = ORIGMARK;
4991         TAINT_PROPER("syscall");
4992     }
4993
4994     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4995      * or where sizeof(long) != sizeof(char*).  But such machines will
4996      * not likely have syscall implemented either, so who cares?
4997      */
4998     while (++MARK <= SP) {
4999         if (SvNIOK(*MARK) || !i)
5000             a[i++] = SvIV(*MARK);
5001         else if (*MARK == &PL_sv_undef)
5002             a[i++] = 0;
5003         else
5004             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5005         if (i > 15)
5006             break;
5007     }
5008     switch (items) {
5009     default:
5010         DIE(aTHX_ "Too many args to syscall");
5011     case 0:
5012         DIE(aTHX_ "Too few args to syscall");
5013     case 1:
5014         retval = syscall(a[0]);
5015         break;
5016     case 2:
5017         retval = syscall(a[0],a[1]);
5018         break;
5019     case 3:
5020         retval = syscall(a[0],a[1],a[2]);
5021         break;
5022     case 4:
5023         retval = syscall(a[0],a[1],a[2],a[3]);
5024         break;
5025     case 5:
5026         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5027         break;
5028     case 6:
5029         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5030         break;
5031     case 7:
5032         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5033         break;
5034     case 8:
5035         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5036         break;
5037 #ifdef atarist
5038     case 9:
5039         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5040         break;
5041     case 10:
5042         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5043         break;
5044     case 11:
5045         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5046           a[10]);
5047         break;
5048     case 12:
5049         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5050           a[10],a[11]);
5051         break;
5052     case 13:
5053         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5054           a[10],a[11],a[12]);
5055         break;
5056     case 14:
5057         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5058           a[10],a[11],a[12],a[13]);
5059         break;
5060 #endif /* atarist */
5061     }
5062     SP = ORIGMARK;
5063     PUSHi(retval);
5064     RETURN;
5065 #else
5066     DIE(aTHX_ PL_no_func, "syscall");
5067 #endif
5068 }
5069
5070 #ifdef FCNTL_EMULATE_FLOCK
5071
5072 /*  XXX Emulate flock() with fcntl().
5073     What's really needed is a good file locking module.
5074 */
5075
5076 static int
5077 fcntl_emulate_flock(int fd, int operation)
5078 {
5079     struct flock flock;
5080
5081     switch (operation & ~LOCK_NB) {
5082     case LOCK_SH:
5083         flock.l_type = F_RDLCK;
5084         break;
5085     case LOCK_EX:
5086         flock.l_type = F_WRLCK;
5087         break;
5088     case LOCK_UN:
5089         flock.l_type = F_UNLCK;
5090         break;
5091     default:
5092         errno = EINVAL;
5093         return -1;
5094     }
5095     flock.l_whence = SEEK_SET;
5096     flock.l_start = flock.l_len = (Off_t)0;
5097
5098     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5099 }
5100
5101 #endif /* FCNTL_EMULATE_FLOCK */
5102
5103 #ifdef LOCKF_EMULATE_FLOCK
5104
5105 /*  XXX Emulate flock() with lockf().  This is just to increase
5106     portability of scripts.  The calls are not completely
5107     interchangeable.  What's really needed is a good file
5108     locking module.
5109 */
5110
5111 /*  The lockf() constants might have been defined in <unistd.h>.
5112     Unfortunately, <unistd.h> causes troubles on some mixed
5113     (BSD/POSIX) systems, such as SunOS 4.1.3.
5114
5115    Further, the lockf() constants aren't POSIX, so they might not be
5116    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5117    just stick in the SVID values and be done with it.  Sigh.
5118 */
5119
5120 # ifndef F_ULOCK
5121 #  define F_ULOCK       0       /* Unlock a previously locked region */
5122 # endif
5123 # ifndef F_LOCK
5124 #  define F_LOCK        1       /* Lock a region for exclusive use */
5125 # endif
5126 # ifndef F_TLOCK
5127 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5128 # endif
5129 # ifndef F_TEST
5130 #  define F_TEST        3       /* Test a region for other processes locks */
5131 # endif
5132
5133 static int
5134 lockf_emulate_flock(int fd, int operation)
5135 {
5136     int i;
5137     int save_errno;
5138     Off_t pos;
5139
5140     /* flock locks entire file so for lockf we need to do the same      */
5141     save_errno = errno;
5142     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5143     if (pos > 0)        /* is seekable and needs to be repositioned     */
5144         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5145             pos = -1;   /* seek failed, so don't seek back afterwards   */
5146     errno = save_errno;
5147
5148     switch (operation) {
5149
5150         /* LOCK_SH - get a shared lock */
5151         case LOCK_SH:
5152         /* LOCK_EX - get an exclusive lock */
5153         case LOCK_EX:
5154             i = lockf (fd, F_LOCK, 0);
5155             break;
5156
5157         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5158         case LOCK_SH|LOCK_NB:
5159         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5160         case LOCK_EX|LOCK_NB:
5161             i = lockf (fd, F_TLOCK, 0);
5162             if (i == -1)
5163                 if ((errno == EAGAIN) || (errno == EACCES))
5164                     errno = EWOULDBLOCK;
5165             break;
5166
5167         /* LOCK_UN - unlock (non-blocking is a no-op) */
5168         case LOCK_UN:
5169         case LOCK_UN|LOCK_NB:
5170             i = lockf (fd, F_ULOCK, 0);
5171             break;
5172
5173         /* Default - can't decipher operation */
5174         default:
5175             i = -1;
5176             errno = EINVAL;
5177             break;
5178     }
5179
5180     if (pos > 0)      /* need to restore position of the handle */
5181         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5182
5183     return (i);
5184 }
5185
5186 #endif /* LOCKF_EMULATE_FLOCK */