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