pp_sys.c

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