pp_sys.c

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