pp_sys.c

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