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