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