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 #endif
3083                 odd++;
3084         }
3085         else if (*s < 32 &&
3086           *s != '\n' && *s != '\r' && *s != '\b' &&
3087           *s != '\t' && *s != '\f' && *s != 27)
3088             odd++;
3089 #endif
3090     }
3091
3092     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3093         RETPUSHNO;
3094     else
3095         RETPUSHYES;
3096 }
3097
3098 PP(pp_ftbinary)
3099 {
3100     return pp_fttext();
3101 }
3102
3103 /* File calls. */
3104
3105 PP(pp_chdir)
3106 {
3107     djSP; dTARGET;
3108     char *tmps;
3109     SV **svp;
3110     STRLEN n_a;
3111
3112     if (MAXARG < 1)
3113         tmps = Nullch;
3114     else
3115         tmps = POPpx;
3116     if (!tmps || !*tmps) {
3117         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3118         if (svp)
3119             tmps = SvPV(*svp, n_a);
3120     }
3121     if (!tmps || !*tmps) {
3122         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3123         if (svp)
3124             tmps = SvPV(*svp, n_a);
3125     }
3126 #ifdef VMS
3127     if (!tmps || !*tmps) {
3128        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3129        if (svp)
3130            tmps = SvPV(*svp, n_a);
3131     }
3132 #endif
3133     TAINT_PROPER("chdir");
3134     PUSHi( PerlDir_chdir(tmps) >= 0 );
3135 #ifdef VMS
3136     /* Clear the DEFAULT element of ENV so we'll get the new value
3137      * in the future. */
3138     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3139 #endif
3140     RETURN;
3141 }
3142
3143 PP(pp_chown)
3144 {
3145     djSP; dMARK; dTARGET;
3146     I32 value;
3147 #ifdef HAS_CHOWN
3148     value = (I32)apply(PL_op->op_type, MARK, SP);
3149     SP = MARK;
3150     PUSHi(value);
3151     RETURN;
3152 #else
3153     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3154 #endif
3155 }
3156
3157 PP(pp_chroot)
3158 {
3159     djSP; dTARGET;
3160     char *tmps;
3161 #ifdef HAS_CHROOT
3162     STRLEN n_a;
3163     tmps = POPpx;
3164     TAINT_PROPER("chroot");
3165     PUSHi( chroot(tmps) >= 0 );
3166     RETURN;
3167 #else
3168     DIE(aTHX_ PL_no_func, "chroot");
3169 #endif
3170 }
3171
3172 PP(pp_unlink)
3173 {
3174     djSP; dMARK; dTARGET;
3175     I32 value;
3176     value = (I32)apply(PL_op->op_type, MARK, SP);
3177     SP = MARK;
3178     PUSHi(value);
3179     RETURN;
3180 }
3181
3182 PP(pp_chmod)
3183 {
3184     djSP; dMARK; dTARGET;
3185     I32 value;
3186     value = (I32)apply(PL_op->op_type, MARK, SP);
3187     SP = MARK;
3188     PUSHi(value);
3189     RETURN;
3190 }
3191
3192 PP(pp_utime)
3193 {
3194     djSP; dMARK; dTARGET;
3195     I32 value;
3196     value = (I32)apply(PL_op->op_type, MARK, SP);
3197     SP = MARK;
3198     PUSHi(value);
3199     RETURN;
3200 }
3201
3202 PP(pp_rename)
3203 {
3204     djSP; dTARGET;
3205     int anum;
3206     STRLEN n_a;
3207
3208     char *tmps2 = POPpx;
3209     char *tmps = SvPV(TOPs, n_a);
3210     TAINT_PROPER("rename");
3211 #ifdef HAS_RENAME
3212     anum = PerlLIO_rename(tmps, tmps2);
3213 #else
3214     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3215         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3216             anum = 1;
3217         else {
3218             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3219                 (void)UNLINK(tmps2);
3220             if (!(anum = link(tmps, tmps2)))
3221                 anum = UNLINK(tmps);
3222         }
3223     }
3224 #endif
3225     SETi( anum >= 0 );
3226     RETURN;
3227 }
3228
3229 PP(pp_link)
3230 {
3231     djSP; dTARGET;
3232 #ifdef HAS_LINK
3233     STRLEN n_a;
3234     char *tmps2 = POPpx;
3235     char *tmps = SvPV(TOPs, n_a);
3236     TAINT_PROPER("link");
3237     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3238 #else
3239     DIE(aTHX_ PL_no_func, "Unsupported function link");
3240 #endif
3241     RETURN;
3242 }
3243
3244 PP(pp_symlink)
3245 {
3246     djSP; dTARGET;
3247 #ifdef HAS_SYMLINK
3248     STRLEN n_a;
3249     char *tmps2 = POPpx;
3250     char *tmps = SvPV(TOPs, n_a);
3251     TAINT_PROPER("symlink");
3252     SETi( symlink(tmps, tmps2) >= 0 );
3253     RETURN;
3254 #else
3255     DIE(aTHX_ PL_no_func, "symlink");
3256 #endif
3257 }
3258
3259 PP(pp_readlink)
3260 {
3261     djSP; dTARGET;
3262 #ifdef HAS_SYMLINK
3263     char *tmps;
3264     char buf[MAXPATHLEN];
3265     int len;
3266     STRLEN n_a;
3267
3268 #ifndef INCOMPLETE_TAINTS
3269     TAINT;
3270 #endif
3271     tmps = POPpx;
3272     len = readlink(tmps, buf, sizeof buf);
3273     EXTEND(SP, 1);
3274     if (len < 0)
3275         RETPUSHUNDEF;
3276     PUSHp(buf, len);
3277     RETURN;
3278 #else
3279     EXTEND(SP, 1);
3280     RETSETUNDEF;                /* just pretend it's a normal file */
3281 #endif
3282 }
3283
3284 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3285 STATIC int
3286 S_dooneliner(pTHX_ char *cmd, char *filename)
3287 {
3288     char *save_filename = filename;
3289     char *cmdline;
3290     char *s;
3291     PerlIO *myfp;
3292     int anum = 1;
3293
3294     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3295     strcpy(cmdline, cmd);
3296     strcat(cmdline, " ");
3297     for (s = cmdline + strlen(cmdline); *filename; ) {
3298         *s++ = '\\';
3299         *s++ = *filename++;
3300     }
3301     strcpy(s, " 2>&1");
3302     myfp = PerlProc_popen(cmdline, "r");
3303     Safefree(cmdline);
3304
3305     if (myfp) {
3306         SV *tmpsv = sv_newmortal();
3307         /* Need to save/restore 'PL_rs' ?? */
3308         s = sv_gets(tmpsv, myfp, 0);
3309         (void)PerlProc_pclose(myfp);
3310         if (s != Nullch) {
3311             int e;
3312             for (e = 1;
3313 #ifdef HAS_SYS_ERRLIST
3314                  e <= sys_nerr
3315 #endif
3316                  ; e++)
3317             {
3318                 /* you don't see this */
3319                 char *errmsg =
3320 #ifdef HAS_SYS_ERRLIST
3321                     sys_errlist[e]
3322 #else
3323                     strerror(e)
3324 #endif
3325                     ;
3326                 if (!errmsg)
3327                     break;
3328                 if (instr(s, errmsg)) {
3329                     SETERRNO(e,0);
3330                     return 0;
3331                 }
3332             }
3333             SETERRNO(0,0);
3334 #ifndef EACCES
3335 #define EACCES EPERM
3336 #endif
3337             if (instr(s, "cannot make"))
3338                 SETERRNO(EEXIST,RMS$_FEX);
3339             else if (instr(s, "existing file"))
3340                 SETERRNO(EEXIST,RMS$_FEX);
3341             else if (instr(s, "ile exists"))
3342                 SETERRNO(EEXIST,RMS$_FEX);
3343             else if (instr(s, "non-exist"))
3344                 SETERRNO(ENOENT,RMS$_FNF);
3345             else if (instr(s, "does not exist"))
3346                 SETERRNO(ENOENT,RMS$_FNF);
3347             else if (instr(s, "not empty"))
3348                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3349             else if (instr(s, "cannot access"))
3350                 SETERRNO(EACCES,RMS$_PRV);
3351             else
3352                 SETERRNO(EPERM,RMS$_PRV);
3353             return 0;
3354         }
3355         else {  /* some mkdirs return no failure indication */
3356             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3357             if (PL_op->op_type == OP_RMDIR)
3358                 anum = !anum;
3359             if (anum)
3360                 SETERRNO(0,0);
3361             else
3362                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3363         }
3364         return anum;
3365     }
3366     else
3367         return 0;
3368 }
3369 #endif
3370
3371 PP(pp_mkdir)
3372 {
3373     djSP; dTARGET;
3374     int mode;
3375 #ifndef HAS_MKDIR
3376     int oldumask;
3377 #endif
3378     STRLEN n_a;
3379     char *tmps;
3380
3381     if (MAXARG > 1)
3382         mode = POPi;
3383     else
3384         mode = 0777;
3385
3386     tmps = SvPV(TOPs, n_a);
3387
3388     TAINT_PROPER("mkdir");
3389 #ifdef HAS_MKDIR
3390     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3391 #else
3392     SETi( dooneliner("mkdir", tmps) );
3393     oldumask = PerlLIO_umask(0);
3394     PerlLIO_umask(oldumask);
3395     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3396 #endif
3397     RETURN;
3398 }
3399
3400 PP(pp_rmdir)
3401 {
3402     djSP; dTARGET;
3403     char *tmps;
3404     STRLEN n_a;
3405
3406     tmps = POPpx;
3407     TAINT_PROPER("rmdir");
3408 #ifdef HAS_RMDIR
3409     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3410 #else
3411     XPUSHi( dooneliner("rmdir", tmps) );
3412 #endif
3413     RETURN;
3414 }
3415
3416 /* Directory calls. */
3417
3418 PP(pp_open_dir)
3419 {
3420     djSP;
3421 #if defined(Direntry_t) && defined(HAS_READDIR)
3422     STRLEN n_a;
3423     char *dirname = POPpx;
3424     GV *gv = (GV*)POPs;
3425     register IO *io = GvIOn(gv);
3426
3427     if (!io)
3428         goto nope;
3429
3430     if (IoDIRP(io))
3431         PerlDir_close(IoDIRP(io));
3432     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3433         goto nope;
3434
3435     RETPUSHYES;
3436 nope:
3437     if (!errno)
3438         SETERRNO(EBADF,RMS$_DIR);
3439     RETPUSHUNDEF;
3440 #else
3441     DIE(aTHX_ PL_no_dir_func, "opendir");
3442 #endif
3443 }
3444
3445 PP(pp_readdir)
3446 {
3447     djSP;
3448 #if defined(Direntry_t) && defined(HAS_READDIR)
3449 #ifndef I_DIRENT
3450     Direntry_t *readdir (DIR *);
3451 #endif
3452     register Direntry_t *dp;
3453     GV *gv = (GV*)POPs;
3454     register IO *io = GvIOn(gv);
3455     SV *sv;
3456
3457     if (!io || !IoDIRP(io))
3458         goto nope;
3459
3460     if (GIMME == G_ARRAY) {
3461         /*SUPPRESS 560*/
3462         while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
3463 #ifdef DIRNAMLEN
3464             sv = newSVpvn(dp->d_name, dp->d_namlen);
3465 #else
3466             sv = newSVpv(dp->d_name, 0);
3467 #endif
3468 #ifndef INCOMPLETE_TAINTS
3469             if (!(IoFLAGS(io) & IOf_UNTAINT))
3470                 SvTAINTED_on(sv);
3471 #endif
3472             XPUSHs(sv_2mortal(sv));
3473         }
3474     }
3475     else {
3476         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3477             goto nope;
3478 #ifdef DIRNAMLEN
3479         sv = newSVpvn(dp->d_name, dp->d_namlen);
3480 #else
3481         sv = newSVpv(dp->d_name, 0);
3482 #endif
3483 #ifndef INCOMPLETE_TAINTS
3484         if (!(IoFLAGS(io) & IOf_UNTAINT))
3485             SvTAINTED_on(sv);
3486 #endif
3487         XPUSHs(sv_2mortal(sv));
3488     }
3489     RETURN;
3490
3491 nope:
3492     if (!errno)
3493         SETERRNO(EBADF,RMS$_ISI);
3494     if (GIMME == G_ARRAY)
3495         RETURN;
3496     else
3497         RETPUSHUNDEF;
3498 #else
3499     DIE(aTHX_ PL_no_dir_func, "readdir");
3500 #endif
3501 }
3502
3503 PP(pp_telldir)
3504 {
3505     djSP; dTARGET;
3506 #if defined(HAS_TELLDIR) || defined(telldir)
3507  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3508  /* XXX netbsd still seemed to.
3509     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3510     --JHI 1999-Feb-02 */
3511 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3512     long telldir (DIR *);
3513 # endif
3514     GV *gv = (GV*)POPs;
3515     register IO *io = GvIOn(gv);
3516
3517     if (!io || !IoDIRP(io))
3518         goto nope;
3519
3520     PUSHi( PerlDir_tell(IoDIRP(io)) );
3521     RETURN;
3522 nope:
3523     if (!errno)
3524         SETERRNO(EBADF,RMS$_ISI);
3525     RETPUSHUNDEF;
3526 #else
3527     DIE(aTHX_ PL_no_dir_func, "telldir");
3528 #endif
3529 }
3530
3531 PP(pp_seekdir)
3532 {
3533     djSP;
3534 #if defined(HAS_SEEKDIR) || defined(seekdir)
3535     long along = POPl;
3536     GV *gv = (GV*)POPs;
3537     register IO *io = GvIOn(gv);
3538
3539     if (!io || !IoDIRP(io))
3540         goto nope;
3541
3542     (void)PerlDir_seek(IoDIRP(io), along);
3543
3544     RETPUSHYES;
3545 nope:
3546     if (!errno)
3547         SETERRNO(EBADF,RMS$_ISI);
3548     RETPUSHUNDEF;
3549 #else
3550     DIE(aTHX_ PL_no_dir_func, "seekdir");
3551 #endif
3552 }
3553
3554 PP(pp_rewinddir)
3555 {
3556     djSP;
3557 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3558     GV *gv = (GV*)POPs;
3559     register IO *io = GvIOn(gv);
3560
3561     if (!io || !IoDIRP(io))
3562         goto nope;
3563
3564     (void)PerlDir_rewind(IoDIRP(io));
3565     RETPUSHYES;
3566 nope:
3567     if (!errno)
3568         SETERRNO(EBADF,RMS$_ISI);
3569     RETPUSHUNDEF;
3570 #else
3571     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3572 #endif
3573 }
3574
3575 PP(pp_closedir)
3576 {
3577     djSP;
3578 #if defined(Direntry_t) && defined(HAS_READDIR)
3579     GV *gv = (GV*)POPs;
3580     register IO *io = GvIOn(gv);
3581
3582     if (!io || !IoDIRP(io))
3583         goto nope;
3584
3585 #ifdef VOID_CLOSEDIR
3586     PerlDir_close(IoDIRP(io));
3587 #else
3588     if (PerlDir_close(IoDIRP(io)) < 0) {
3589         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3590         goto nope;
3591     }
3592 #endif
3593     IoDIRP(io) = 0;
3594
3595     RETPUSHYES;
3596 nope:
3597     if (!errno)
3598         SETERRNO(EBADF,RMS$_IFI);
3599     RETPUSHUNDEF;
3600 #else
3601     DIE(aTHX_ PL_no_dir_func, "closedir");
3602 #endif
3603 }
3604
3605 /* Process control. */
3606
3607 PP(pp_fork)
3608 {
3609 #ifdef HAS_FORK
3610     djSP; dTARGET;
3611     Pid_t childpid;
3612     GV *tmpgv;
3613
3614     EXTEND(SP, 1);
3615     PERL_FLUSHALL_FOR_CHILD;
3616     childpid = fork();
3617     if (childpid < 0)
3618         RETSETUNDEF;
3619     if (!childpid) {
3620         /*SUPPRESS 560*/
3621         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3622             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3623         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3624     }
3625     PUSHi(childpid);
3626     RETURN;
3627 #else
3628 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3629     djSP; dTARGET;
3630     Pid_t childpid;
3631
3632     EXTEND(SP, 1);
3633     PERL_FLUSHALL_FOR_CHILD;
3634     childpid = PerlProc_fork();
3635     PUSHi(childpid);
3636     RETURN;
3637 #  else
3638     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3639 #  endif
3640 #endif
3641 }
3642
3643 PP(pp_wait)
3644 {
3645 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3646     djSP; dTARGET;
3647     Pid_t childpid;
3648     int argflags;
3649
3650     childpid = wait4pid(-1, &argflags, 0);
3651     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3652     XPUSHi(childpid);
3653     RETURN;
3654 #else
3655     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3656 #endif
3657 }
3658
3659 PP(pp_waitpid)
3660 {
3661 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3662     djSP; dTARGET;
3663     Pid_t childpid;
3664     int optype;
3665     int argflags;
3666
3667     optype = POPi;
3668     childpid = TOPi;
3669     childpid = wait4pid(childpid, &argflags, optype);
3670     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3671     SETi(childpid);
3672     RETURN;
3673 #else
3674     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3675 #endif
3676 }
3677
3678 PP(pp_system)
3679 {
3680     djSP; dMARK; dORIGMARK; dTARGET;
3681     I32 value;
3682     Pid_t childpid;
3683     int result;
3684     int status;
3685     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3686     STRLEN n_a;
3687     I32 did_pipes = 0;
3688     int pp[2];
3689
3690     if (SP - MARK == 1) {
3691         if (PL_tainting) {
3692             char *junk = SvPV(TOPs, n_a);
3693             TAINT_ENV();
3694             TAINT_PROPER("system");
3695         }
3696     }
3697     PERL_FLUSHALL_FOR_CHILD;
3698 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3699     if (PerlProc_pipe(pp) >= 0)
3700         did_pipes = 1;
3701     while ((childpid = vfork()) == -1) {
3702         if (errno != EAGAIN) {
3703             value = -1;
3704             SP = ORIGMARK;
3705             PUSHi(value);
3706             if (did_pipes) {
3707                 PerlLIO_close(pp[0]);
3708                 PerlLIO_close(pp[1]);
3709             }
3710             RETURN;
3711         }
3712         sleep(5);
3713     }
3714     if (childpid > 0) {
3715         if (did_pipes)
3716             PerlLIO_close(pp[1]);
3717         rsignal_save(SIGINT, SIG_IGN, &ihand);
3718         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3719         do {
3720             result = wait4pid(childpid, &status, 0);
3721         } while (result == -1 && errno == EINTR);
3722         (void)rsignal_restore(SIGINT, &ihand);
3723         (void)rsignal_restore(SIGQUIT, &qhand);
3724         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3725         do_execfree();  /* free any memory child malloced on vfork */
3726         SP = ORIGMARK;
3727         if (did_pipes) {
3728             int errkid;
3729             int n = 0, n1;
3730
3731             while (n < sizeof(int)) {
3732                 n1 = PerlLIO_read(pp[0],
3733                                   (void*)(((char*)&errkid)+n),
3734                                   (sizeof(int)) - n);
3735                 if (n1 <= 0)
3736                     break;
3737                 n += n1;
3738             }
3739             PerlLIO_close(pp[0]);
3740             if (n) {                    /* Error */
3741                 if (n != sizeof(int))
3742                     DIE(aTHX_ "panic: kid popen errno read");
3743                 errno = errkid;         /* Propagate errno from kid */
3744                 STATUS_CURRENT = -1;
3745             }
3746         }
3747         PUSHi(STATUS_CURRENT);
3748         RETURN;
3749     }
3750     if (did_pipes) {
3751         PerlLIO_close(pp[0]);
3752 #if defined(HAS_FCNTL) && defined(F_SETFD)
3753         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3754 #endif
3755     }
3756     if (PL_op->op_flags & OPf_STACKED) {
3757         SV *really = *++MARK;
3758         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
3759     }
3760     else if (SP - MARK != 1)
3761         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
3762     else {
3763         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
3764     }
3765     PerlProc__exit(-1);
3766 #else /* ! FORK or VMS or OS/2 */
3767     if (PL_op->op_flags & OPf_STACKED) {
3768         SV *really = *++MARK;
3769         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3770     }
3771     else if (SP - MARK != 1)
3772         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3773     else {
3774         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3775     }
3776     STATUS_NATIVE_SET(value);
3777     do_execfree();
3778     SP = ORIGMARK;
3779     PUSHi(STATUS_CURRENT);
3780 #endif /* !FORK or VMS */
3781     RETURN;
3782 }
3783
3784 PP(pp_exec)
3785 {
3786     djSP; dMARK; dORIGMARK; dTARGET;
3787     I32 value;
3788     STRLEN n_a;
3789
3790     PERL_FLUSHALL_FOR_CHILD;
3791     if (PL_op->op_flags & OPf_STACKED) {
3792         SV *really = *++MARK;
3793         value = (I32)do_aexec(really, MARK, SP);
3794     }
3795     else if (SP - MARK != 1)
3796 #ifdef VMS
3797         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3798 #else
3799 #  ifdef __OPEN_VM
3800         {
3801            (void ) do_aspawn(Nullsv, MARK, SP);
3802            value = 0;
3803         }
3804 #  else
3805         value = (I32)do_aexec(Nullsv, MARK, SP);
3806 #  endif
3807 #endif
3808     else {
3809         if (PL_tainting) {
3810             char *junk = SvPV(*SP, n_a);
3811             TAINT_ENV();
3812             TAINT_PROPER("exec");
3813         }
3814 #ifdef VMS
3815         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3816 #else
3817 #  ifdef __OPEN_VM
3818         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3819         value = 0;
3820 #  else
3821         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3822 #  endif
3823 #endif
3824     }
3825
3826 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3827     if (value >= 0)
3828         my_exit(value);
3829 #endif
3830
3831     SP = ORIGMARK;
3832     PUSHi(value);
3833     RETURN;
3834 }
3835
3836 PP(pp_kill)
3837 {
3838     djSP; dMARK; dTARGET;
3839     I32 value;
3840 #ifdef HAS_KILL
3841     value = (I32)apply(PL_op->op_type, MARK, SP);
3842     SP = MARK;
3843     PUSHi(value);
3844     RETURN;
3845 #else
3846     DIE(aTHX_ PL_no_func, "Unsupported function kill");
3847 #endif
3848 }
3849
3850 PP(pp_getppid)
3851 {
3852 #ifdef HAS_GETPPID
3853     djSP; dTARGET;
3854     XPUSHi( getppid() );
3855     RETURN;
3856 #else
3857     DIE(aTHX_ PL_no_func, "getppid");
3858 #endif
3859 }
3860
3861 PP(pp_getpgrp)
3862 {
3863 #ifdef HAS_GETPGRP
3864     djSP; dTARGET;
3865     Pid_t pid;
3866     Pid_t pgrp;
3867
3868     if (MAXARG < 1)
3869         pid = 0;
3870     else
3871         pid = SvIVx(POPs);
3872 #ifdef BSD_GETPGRP
3873     pgrp = (I32)BSD_GETPGRP(pid);
3874 #else
3875     if (pid != 0 && pid != PerlProc_getpid())
3876         DIE(aTHX_ "POSIX getpgrp can't take an argument");
3877     pgrp = getpgrp();
3878 #endif
3879     XPUSHi(pgrp);
3880     RETURN;
3881 #else
3882     DIE(aTHX_ PL_no_func, "getpgrp()");
3883 #endif
3884 }
3885
3886 PP(pp_setpgrp)
3887 {
3888 #ifdef HAS_SETPGRP
3889     djSP; dTARGET;
3890     Pid_t pgrp;
3891     Pid_t pid;
3892     if (MAXARG < 2) {
3893         pgrp = 0;
3894         pid = 0;
3895     }
3896     else {
3897         pgrp = POPi;
3898         pid = TOPi;
3899     }
3900
3901     TAINT_PROPER("setpgrp");
3902 #ifdef BSD_SETPGRP
3903     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3904 #else
3905     if ((pgrp != 0 && pgrp != PerlProc_getpid())
3906         || (pid != 0 && pid != PerlProc_getpid()))
3907     {
3908         DIE(aTHX_ "setpgrp can't take arguments");
3909     }
3910     SETi( setpgrp() >= 0 );
3911 #endif /* USE_BSDPGRP */
3912     RETURN;
3913 #else
3914     DIE(aTHX_ PL_no_func, "setpgrp()");
3915 #endif
3916 }
3917
3918 PP(pp_getpriority)
3919 {
3920     djSP; dTARGET;
3921     int which;
3922     int who;
3923 #ifdef HAS_GETPRIORITY
3924     who = POPi;
3925     which = TOPi;
3926     SETi( getpriority(which, who) );
3927     RETURN;
3928 #else
3929     DIE(aTHX_ PL_no_func, "getpriority()");
3930 #endif
3931 }
3932
3933 PP(pp_setpriority)
3934 {
3935     djSP; dTARGET;
3936     int which;
3937     int who;
3938     int niceval;
3939 #ifdef HAS_SETPRIORITY
3940     niceval = POPi;
3941     who = POPi;
3942     which = TOPi;
3943     TAINT_PROPER("setpriority");
3944     SETi( setpriority(which, who, niceval) >= 0 );
3945     RETURN;
3946 #else
3947     DIE(aTHX_ PL_no_func, "setpriority()");
3948 #endif
3949 }
3950
3951 /* Time calls. */
3952
3953 PP(pp_time)
3954 {
3955     djSP; dTARGET;
3956 #ifdef BIG_TIME
3957     XPUSHn( time(Null(Time_t*)) );
3958 #else
3959     XPUSHi( time(Null(Time_t*)) );
3960 #endif
3961     RETURN;
3962 }
3963
3964 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3965    to HZ.  Probably.  For now, assume that if the system
3966    defines HZ, it does so correctly.  (Will this break
3967    on VMS?)
3968    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3969    it's supported.    --AD  9/96.
3970 */
3971
3972 #ifndef HZ
3973 #  ifdef CLK_TCK
3974 #    define HZ CLK_TCK
3975 #  else
3976 #    define HZ 60
3977 #  endif
3978 #endif
3979
3980 PP(pp_tms)
3981 {
3982     djSP;
3983
3984 #ifndef HAS_TIMES
3985     DIE(aTHX_ "times not implemented");
3986 #else
3987     EXTEND(SP, 4);
3988
3989 #ifndef VMS
3990     (void)PerlProc_times(&PL_timesbuf);
3991 #else
3992     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
3993                                                    /* struct tms, though same data   */
3994                                                    /* is returned.                   */
3995 #endif
3996
3997     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
3998     if (GIMME == G_ARRAY) {
3999         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4000         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4001         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4002     }
4003     RETURN;
4004 #endif /* HAS_TIMES */
4005 }
4006
4007 PP(pp_localtime)
4008 {
4009     return pp_gmtime();
4010 }
4011
4012 PP(pp_gmtime)
4013 {
4014     djSP;
4015     Time_t when;
4016     struct tm *tmbuf;
4017     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4018     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4019                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4020
4021     if (MAXARG < 1)
4022         (void)time(&when);
4023     else
4024 #ifdef BIG_TIME
4025         when = (Time_t)SvNVx(POPs);
4026 #else
4027         when = (Time_t)SvIVx(POPs);
4028 #endif
4029
4030     if (PL_op->op_type == OP_LOCALTIME)
4031         tmbuf = localtime(&when);
4032     else
4033         tmbuf = gmtime(&when);
4034
4035     EXTEND(SP, 9);
4036     EXTEND_MORTAL(9);
4037     if (GIMME != G_ARRAY) {
4038         dTARGET;
4039         SV *tsv;
4040         if (!tmbuf)
4041             RETPUSHUNDEF;
4042         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4043                             dayname[tmbuf->tm_wday],
4044                             monname[tmbuf->tm_mon],
4045                             tmbuf->tm_mday,
4046                             tmbuf->tm_hour,
4047                             tmbuf->tm_min,
4048                             tmbuf->tm_sec,
4049                             tmbuf->tm_year + 1900);
4050         PUSHs(sv_2mortal(tsv));
4051     }
4052     else if (tmbuf) {
4053         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4054         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4055         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4056         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4057         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4058         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4059         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4060         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4061         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4062     }
4063     RETURN;
4064 }
4065
4066 PP(pp_alarm)
4067 {
4068     djSP; dTARGET;
4069     int anum;
4070 #ifdef HAS_ALARM
4071     anum = POPi;
4072     anum = alarm((unsigned int)anum);
4073     EXTEND(SP, 1);
4074     if (anum < 0)
4075         RETPUSHUNDEF;
4076     PUSHi(anum);
4077     RETURN;
4078 #else
4079     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4080 #endif
4081 }
4082
4083 PP(pp_sleep)
4084 {
4085     djSP; dTARGET;
4086     I32 duration;
4087     Time_t lasttime;
4088     Time_t when;
4089
4090     (void)time(&lasttime);
4091     if (MAXARG < 1)
4092         PerlProc_pause();
4093     else {
4094         duration = POPi;
4095         PerlProc_sleep((unsigned int)duration);
4096     }
4097     (void)time(&when);
4098     XPUSHi(when - lasttime);
4099     RETURN;
4100 }
4101
4102 /* Shared memory. */
4103
4104 PP(pp_shmget)
4105 {
4106     return pp_semget();
4107 }
4108
4109 PP(pp_shmctl)
4110 {
4111     return pp_semctl();
4112 }
4113
4114 PP(pp_shmread)
4115 {
4116     return pp_shmwrite();
4117 }
4118
4119 PP(pp_shmwrite)
4120 {
4121 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4122     djSP; dMARK; dTARGET;
4123     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4124     SP = MARK;
4125     PUSHi(value);
4126     RETURN;
4127 #else
4128     return pp_semget();
4129 #endif
4130 }
4131
4132 /* Message passing. */
4133
4134 PP(pp_msgget)
4135 {
4136     return pp_semget();
4137 }
4138
4139 PP(pp_msgctl)
4140 {
4141     return pp_semctl();
4142 }
4143
4144 PP(pp_msgsnd)
4145 {
4146 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4147     djSP; dMARK; dTARGET;
4148     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4149     SP = MARK;
4150     PUSHi(value);
4151     RETURN;
4152 #else
4153     return pp_semget();
4154 #endif
4155 }
4156
4157 PP(pp_msgrcv)
4158 {
4159 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4160     djSP; dMARK; dTARGET;
4161     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4162     SP = MARK;
4163     PUSHi(value);
4164     RETURN;
4165 #else
4166     return pp_semget();
4167 #endif
4168 }
4169
4170 /* Semaphores. */
4171
4172 PP(pp_semget)
4173 {
4174 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4175     djSP; dMARK; dTARGET;
4176     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4177     SP = MARK;
4178     if (anum == -1)
4179         RETPUSHUNDEF;
4180     PUSHi(anum);
4181     RETURN;
4182 #else
4183     DIE(aTHX_ "System V IPC is not implemented on this machine");
4184 #endif
4185 }
4186
4187 PP(pp_semctl)
4188 {
4189 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4190     djSP; dMARK; dTARGET;
4191     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4192     SP = MARK;
4193     if (anum == -1)
4194         RETSETUNDEF;
4195     if (anum != 0) {
4196         PUSHi(anum);
4197     }
4198     else {
4199         PUSHp(zero_but_true, ZBTLEN);
4200     }
4201     RETURN;
4202 #else
4203     return pp_semget();
4204 #endif
4205 }
4206
4207 PP(pp_semop)
4208 {
4209 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4210     djSP; dMARK; dTARGET;
4211     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4212     SP = MARK;
4213     PUSHi(value);
4214     RETURN;
4215 #else
4216     return pp_semget();
4217 #endif
4218 }
4219
4220 /* Get system info. */
4221
4222 PP(pp_ghbyname)
4223 {
4224 #ifdef HAS_GETHOSTBYNAME
4225     return pp_ghostent();
4226 #else
4227     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4228 #endif
4229 }
4230
4231 PP(pp_ghbyaddr)
4232 {
4233 #ifdef HAS_GETHOSTBYADDR
4234     return pp_ghostent();
4235 #else
4236     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4237 #endif
4238 }
4239
4240 PP(pp_ghostent)
4241 {
4242     djSP;
4243 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4244     I32 which = PL_op->op_type;
4245     register char **elem;
4246     register SV *sv;
4247 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4248     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4249     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4250     struct hostent *PerlSock_gethostent(void);
4251 #endif
4252     struct hostent *hent;
4253     unsigned long len;
4254     STRLEN n_a;
4255
4256     EXTEND(SP, 10);
4257     if (which == OP_GHBYNAME)
4258 #ifdef HAS_GETHOSTBYNAME
4259         hent = PerlSock_gethostbyname(POPpx);
4260 #else
4261         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4262 #endif
4263     else if (which == OP_GHBYADDR) {
4264 #ifdef HAS_GETHOSTBYADDR
4265         int addrtype = POPi;
4266         SV *addrsv = POPs;
4267         STRLEN addrlen;
4268         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
4269
4270         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4271 #else
4272         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4273 #endif
4274     }
4275     else
4276 #ifdef HAS_GETHOSTENT
4277         hent = PerlSock_gethostent();
4278 #else
4279         DIE(aTHX_ PL_no_sock_func, "gethostent");
4280 #endif
4281
4282 #ifdef HOST_NOT_FOUND
4283     if (!hent)
4284         STATUS_NATIVE_SET(h_errno);
4285 #endif
4286
4287     if (GIMME != G_ARRAY) {
4288         PUSHs(sv = sv_newmortal());
4289         if (hent) {
4290             if (which == OP_GHBYNAME) {
4291                 if (hent->h_addr)
4292                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4293             }
4294             else
4295                 sv_setpv(sv, (char*)hent->h_name);
4296         }
4297         RETURN;
4298     }
4299
4300     if (hent) {
4301         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4302         sv_setpv(sv, (char*)hent->h_name);
4303         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4304         for (elem = hent->h_aliases; elem && *elem; elem++) {
4305             sv_catpv(sv, *elem);
4306             if (elem[1])
4307                 sv_catpvn(sv, " ", 1);
4308         }
4309         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4310         sv_setiv(sv, (IV)hent->h_addrtype);
4311         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4312         len = hent->h_length;
4313         sv_setiv(sv, (IV)len);
4314 #ifdef h_addr
4315         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4316             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4317             sv_setpvn(sv, *elem, len);
4318         }
4319 #else
4320         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4321         if (hent->h_addr)
4322             sv_setpvn(sv, hent->h_addr, len);
4323 #endif /* h_addr */
4324     }
4325     RETURN;
4326 #else
4327     DIE(aTHX_ PL_no_sock_func, "gethostent");
4328 #endif
4329 }
4330
4331 PP(pp_gnbyname)
4332 {
4333 #ifdef HAS_GETNETBYNAME
4334     return pp_gnetent();
4335 #else
4336     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4337 #endif
4338 }
4339
4340 PP(pp_gnbyaddr)
4341 {
4342 #ifdef HAS_GETNETBYADDR
4343     return pp_gnetent();
4344 #else
4345     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4346 #endif
4347 }
4348
4349 PP(pp_gnetent)
4350 {
4351     djSP;
4352 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4353     I32 which = PL_op->op_type;
4354     register char **elem;
4355     register SV *sv;
4356 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4357     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4358     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4359     struct netent *PerlSock_getnetent(void);
4360 #endif
4361     struct netent *nent;
4362     STRLEN n_a;
4363
4364     if (which == OP_GNBYNAME)
4365 #ifdef HAS_GETNETBYNAME
4366         nent = PerlSock_getnetbyname(POPpx);
4367 #else
4368         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4369 #endif
4370     else if (which == OP_GNBYADDR) {
4371 #ifdef HAS_GETNETBYADDR
4372         int addrtype = POPi;
4373         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4374         nent = PerlSock_getnetbyaddr(addr, addrtype);
4375 #else
4376         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4377 #endif
4378     }
4379     else
4380 #ifdef HAS_GETNETENT
4381         nent = PerlSock_getnetent();
4382 #else
4383         DIE(aTHX_ PL_no_sock_func, "getnetent");
4384 #endif
4385
4386     EXTEND(SP, 4);
4387     if (GIMME != G_ARRAY) {
4388         PUSHs(sv = sv_newmortal());
4389         if (nent) {
4390             if (which == OP_GNBYNAME)
4391                 sv_setiv(sv, (IV)nent->n_net);
4392             else
4393                 sv_setpv(sv, nent->n_name);
4394         }
4395         RETURN;
4396     }
4397
4398     if (nent) {
4399         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4400         sv_setpv(sv, nent->n_name);
4401         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4402         for (elem = nent->n_aliases; elem && *elem; elem++) {
4403             sv_catpv(sv, *elem);
4404             if (elem[1])
4405                 sv_catpvn(sv, " ", 1);
4406         }
4407         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4408         sv_setiv(sv, (IV)nent->n_addrtype);
4409         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4410         sv_setiv(sv, (IV)nent->n_net);
4411     }
4412
4413     RETURN;
4414 #else
4415     DIE(aTHX_ PL_no_sock_func, "getnetent");
4416 #endif
4417 }
4418
4419 PP(pp_gpbyname)
4420 {
4421 #ifdef HAS_GETPROTOBYNAME
4422     return pp_gprotoent();
4423 #else
4424     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4425 #endif
4426 }
4427
4428 PP(pp_gpbynumber)
4429 {
4430 #ifdef HAS_GETPROTOBYNUMBER
4431     return pp_gprotoent();
4432 #else
4433     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4434 #endif
4435 }
4436
4437 PP(pp_gprotoent)
4438 {
4439     djSP;
4440 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4441     I32 which = PL_op->op_type;
4442     register char **elem;
4443     register SV *sv;
4444 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4445     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4446     struct protoent *PerlSock_getprotobynumber(int);
4447     struct protoent *PerlSock_getprotoent(void);
4448 #endif
4449     struct protoent *pent;
4450     STRLEN n_a;
4451
4452     if (which == OP_GPBYNAME)
4453 #ifdef HAS_GETPROTOBYNAME
4454         pent = PerlSock_getprotobyname(POPpx);
4455 #else
4456         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4457 #endif
4458     else if (which == OP_GPBYNUMBER)
4459 #ifdef HAS_GETPROTOBYNUMBER
4460         pent = PerlSock_getprotobynumber(POPi);
4461 #else
4462     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4463 #endif
4464     else
4465 #ifdef HAS_GETPROTOENT
4466         pent = PerlSock_getprotoent();
4467 #else
4468         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4469 #endif
4470
4471     EXTEND(SP, 3);
4472     if (GIMME != G_ARRAY) {
4473         PUSHs(sv = sv_newmortal());
4474         if (pent) {
4475             if (which == OP_GPBYNAME)
4476                 sv_setiv(sv, (IV)pent->p_proto);
4477             else
4478                 sv_setpv(sv, pent->p_name);
4479         }
4480         RETURN;
4481     }
4482
4483     if (pent) {
4484         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4485         sv_setpv(sv, pent->p_name);
4486         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4487         for (elem = pent->p_aliases; elem && *elem; elem++) {
4488             sv_catpv(sv, *elem);
4489             if (elem[1])
4490                 sv_catpvn(sv, " ", 1);
4491         }
4492         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4493         sv_setiv(sv, (IV)pent->p_proto);
4494     }
4495
4496     RETURN;
4497 #else
4498     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4499 #endif
4500 }
4501
4502 PP(pp_gsbyname)
4503 {
4504 #ifdef HAS_GETSERVBYNAME
4505     return pp_gservent();
4506 #else
4507     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4508 #endif
4509 }
4510
4511 PP(pp_gsbyport)
4512 {
4513 #ifdef HAS_GETSERVBYPORT
4514     return pp_gservent();
4515 #else
4516     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4517 #endif
4518 }
4519
4520 PP(pp_gservent)
4521 {
4522     djSP;
4523 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4524     I32 which = PL_op->op_type;
4525     register char **elem;
4526     register SV *sv;
4527 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4528     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4529     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4530     struct servent *PerlSock_getservent(void);
4531 #endif
4532     struct servent *sent;
4533     STRLEN n_a;
4534
4535     if (which == OP_GSBYNAME) {
4536 #ifdef HAS_GETSERVBYNAME
4537         char *proto = POPpx;
4538         char *name = POPpx;
4539
4540         if (proto && !*proto)
4541             proto = Nullch;
4542
4543         sent = PerlSock_getservbyname(name, proto);
4544 #else
4545         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4546 #endif
4547     }
4548     else if (which == OP_GSBYPORT) {
4549 #ifdef HAS_GETSERVBYPORT
4550         char *proto = POPpx;
4551         unsigned short port = POPu;
4552
4553 #ifdef HAS_HTONS
4554         port = PerlSock_htons(port);
4555 #endif
4556         sent = PerlSock_getservbyport(port, proto);
4557 #else
4558         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4559 #endif
4560     }
4561     else
4562 #ifdef HAS_GETSERVENT
4563         sent = PerlSock_getservent();
4564 #else
4565         DIE(aTHX_ PL_no_sock_func, "getservent");
4566 #endif
4567
4568     EXTEND(SP, 4);
4569     if (GIMME != G_ARRAY) {
4570         PUSHs(sv = sv_newmortal());
4571         if (sent) {
4572             if (which == OP_GSBYNAME) {
4573 #ifdef HAS_NTOHS
4574                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4575 #else
4576                 sv_setiv(sv, (IV)(sent->s_port));
4577 #endif
4578             }
4579             else
4580                 sv_setpv(sv, sent->s_name);
4581         }
4582         RETURN;
4583     }
4584
4585     if (sent) {
4586         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4587         sv_setpv(sv, sent->s_name);
4588         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4589         for (elem = sent->s_aliases; elem && *elem; elem++) {
4590             sv_catpv(sv, *elem);
4591             if (elem[1])
4592                 sv_catpvn(sv, " ", 1);
4593         }
4594         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4595 #ifdef HAS_NTOHS
4596         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4597 #else
4598         sv_setiv(sv, (IV)(sent->s_port));
4599 #endif
4600         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4601         sv_setpv(sv, sent->s_proto);
4602     }
4603
4604     RETURN;
4605 #else
4606     DIE(aTHX_ PL_no_sock_func, "getservent");
4607 #endif
4608 }
4609
4610 PP(pp_shostent)
4611 {
4612     djSP;
4613 #ifdef HAS_SETHOSTENT
4614     PerlSock_sethostent(TOPi);
4615     RETSETYES;
4616 #else
4617     DIE(aTHX_ PL_no_sock_func, "sethostent");
4618 #endif
4619 }
4620
4621 PP(pp_snetent)
4622 {
4623     djSP;
4624 #ifdef HAS_SETNETENT
4625     PerlSock_setnetent(TOPi);
4626     RETSETYES;
4627 #else
4628     DIE(aTHX_ PL_no_sock_func, "setnetent");
4629 #endif
4630 }
4631
4632 PP(pp_sprotoent)
4633 {
4634     djSP;
4635 #ifdef HAS_SETPROTOENT
4636     PerlSock_setprotoent(TOPi);
4637     RETSETYES;
4638 #else
4639     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4640 #endif
4641 }
4642
4643 PP(pp_sservent)
4644 {
4645     djSP;
4646 #ifdef HAS_SETSERVENT
4647     PerlSock_setservent(TOPi);
4648     RETSETYES;
4649 #else
4650     DIE(aTHX_ PL_no_sock_func, "setservent");
4651 #endif
4652 }
4653
4654 PP(pp_ehostent)
4655 {
4656     djSP;
4657 #ifdef HAS_ENDHOSTENT
4658     PerlSock_endhostent();
4659     EXTEND(SP,1);
4660     RETPUSHYES;
4661 #else
4662     DIE(aTHX_ PL_no_sock_func, "endhostent");
4663 #endif
4664 }
4665
4666 PP(pp_enetent)
4667 {
4668     djSP;
4669 #ifdef HAS_ENDNETENT
4670     PerlSock_endnetent();
4671     EXTEND(SP,1);
4672     RETPUSHYES;
4673 #else
4674     DIE(aTHX_ PL_no_sock_func, "endnetent");
4675 #endif
4676 }
4677
4678 PP(pp_eprotoent)
4679 {
4680     djSP;
4681 #ifdef HAS_ENDPROTOENT
4682     PerlSock_endprotoent();
4683     EXTEND(SP,1);
4684     RETPUSHYES;
4685 #else
4686     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4687 #endif
4688 }
4689
4690 PP(pp_eservent)
4691 {
4692     djSP;
4693 #ifdef HAS_ENDSERVENT
4694     PerlSock_endservent();
4695     EXTEND(SP,1);
4696     RETPUSHYES;
4697 #else
4698     DIE(aTHX_ PL_no_sock_func, "endservent");
4699 #endif
4700 }
4701
4702 PP(pp_gpwnam)
4703 {
4704 #ifdef HAS_PASSWD
4705     return pp_gpwent();
4706 #else
4707     DIE(aTHX_ PL_no_func, "getpwnam");
4708 #endif
4709 }
4710
4711 PP(pp_gpwuid)
4712 {
4713 #ifdef HAS_PASSWD
4714     return pp_gpwent();
4715 #else
4716     DIE(aTHX_ PL_no_func, "getpwuid");
4717 #endif
4718 }
4719
4720 PP(pp_gpwent)
4721 {
4722     djSP;
4723 #ifdef HAS_PASSWD
4724     I32 which = PL_op->op_type;
4725     register SV *sv;
4726     struct passwd *pwent;
4727     STRLEN n_a;
4728 #if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
4729     struct spwd *spwent = NULL;
4730 #endif
4731
4732     if (which == OP_GPWNAM)
4733         pwent = getpwnam(POPpx);
4734     else if (which == OP_GPWUID)
4735         pwent = getpwuid(POPi);
4736     else
4737 #ifdef HAS_GETPWENT
4738         pwent = (struct passwd *)getpwent();
4739 #else
4740         DIE(aTHX_ PL_no_func, "getpwent");
4741 #endif
4742
4743 #ifdef HAS_GETSPNAM
4744     if (which == OP_GPWNAM) {
4745         if (pwent)
4746             spwent = getspnam(pwent->pw_name);
4747     }
4748 #  ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
4749     else if (which == OP_GPWUID) {
4750         if (pwent)
4751             spwent = getspnam(pwent->pw_name);
4752     }
4753 #  endif
4754 #  ifdef HAS_GETSPENT
4755     else
4756         spwent = (struct spwd *)getspent();
4757 #  endif
4758 #endif
4759
4760     EXTEND(SP, 10);
4761     if (GIMME != G_ARRAY) {
4762         PUSHs(sv = sv_newmortal());
4763         if (pwent) {
4764             if (which == OP_GPWNAM)
4765                 sv_setiv(sv, (IV)pwent->pw_uid);
4766             else
4767                 sv_setpv(sv, pwent->pw_name);
4768         }
4769         RETURN;
4770     }
4771
4772     if (pwent) {
4773         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4774         sv_setpv(sv, pwent->pw_name);
4775
4776         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4777 #ifdef PWPASSWD
4778 #   if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
4779       if (spwent)
4780               sv_setpv(sv, spwent->sp_pwdp);
4781       else
4782               sv_setpv(sv, pwent->pw_passwd);
4783 #   else
4784         sv_setpv(sv, pwent->pw_passwd);
4785 #   endif
4786 #endif
4787
4788         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4789         sv_setiv(sv, (IV)pwent->pw_uid);
4790
4791         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4792         sv_setiv(sv, (IV)pwent->pw_gid);
4793
4794         /* pw_change, pw_quota, and pw_age are mutually exclusive. */
4795         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4796 #ifdef PWCHANGE
4797         sv_setiv(sv, (IV)pwent->pw_change);
4798 #else
4799 #   ifdef PWQUOTA
4800         sv_setiv(sv, (IV)pwent->pw_quota);
4801 #   else
4802 #       ifdef PWAGE
4803         sv_setpv(sv, pwent->pw_age);
4804 #       endif
4805 #   endif
4806 #endif
4807
4808         /* pw_class and pw_comment are mutually exclusive. */
4809         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4810 #ifdef PWCLASS
4811         sv_setpv(sv, pwent->pw_class);
4812 #else
4813 #   ifdef PWCOMMENT
4814         sv_setpv(sv, pwent->pw_comment);
4815 #   endif
4816 #endif
4817
4818         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4819 #ifdef PWGECOS
4820         sv_setpv(sv, pwent->pw_gecos);
4821 #endif
4822 #ifndef INCOMPLETE_TAINTS
4823         /* pw_gecos is tainted because user himself can diddle with it. */
4824         SvTAINTED_on(sv);
4825 #endif
4826
4827         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4828         sv_setpv(sv, pwent->pw_dir);
4829
4830         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4831         sv_setpv(sv, pwent->pw_shell);
4832
4833 #ifdef PWEXPIRE
4834         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4835         sv_setiv(sv, (IV)pwent->pw_expire);
4836 #endif
4837     }
4838     RETURN;
4839 #else
4840     DIE(aTHX_ PL_no_func, "getpwent");
4841 #endif
4842 }
4843
4844 PP(pp_spwent)
4845 {
4846     djSP;
4847 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
4848     setpwent();
4849 #   ifdef HAS_SETSPENT
4850     setspent();
4851 #   endif
4852     RETPUSHYES;
4853 #else
4854     DIE(aTHX_ PL_no_func, "setpwent");
4855 #endif
4856 }
4857
4858 PP(pp_epwent)
4859 {
4860     djSP;
4861 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
4862     endpwent();
4863 #   ifdef HAS_ENDSPENT
4864     endspent();
4865 #   endif
4866     RETPUSHYES;
4867 #else
4868     DIE(aTHX_ PL_no_func, "endpwent");
4869 #endif
4870 }
4871
4872 PP(pp_ggrnam)
4873 {
4874 #ifdef HAS_GROUP
4875     return pp_ggrent();
4876 #else
4877     DIE(aTHX_ PL_no_func, "getgrnam");
4878 #endif
4879 }
4880
4881 PP(pp_ggrgid)
4882 {
4883 #ifdef HAS_GROUP
4884     return pp_ggrent();
4885 #else
4886     DIE(aTHX_ PL_no_func, "getgrgid");
4887 #endif
4888 }
4889
4890 PP(pp_ggrent)
4891 {
4892     djSP;
4893 #ifdef HAS_GROUP
4894     I32 which = PL_op->op_type;
4895     register char **elem;
4896     register SV *sv;
4897     struct group *grent;
4898     STRLEN n_a;
4899
4900     if (which == OP_GGRNAM)
4901         grent = (struct group *)getgrnam(POPpx);
4902     else if (which == OP_GGRGID)
4903         grent = (struct group *)getgrgid(POPi);
4904     else
4905 #ifdef HAS_GETGRENT
4906         grent = (struct group *)getgrent();
4907 #else
4908         DIE(aTHX_ PL_no_func, "getgrent");
4909 #endif
4910
4911     EXTEND(SP, 4);
4912     if (GIMME != G_ARRAY) {
4913         PUSHs(sv = sv_newmortal());
4914         if (grent) {
4915             if (which == OP_GGRNAM)
4916                 sv_setiv(sv, (IV)grent->gr_gid);
4917             else
4918                 sv_setpv(sv, grent->gr_name);
4919         }
4920         RETURN;
4921     }
4922
4923     if (grent) {
4924         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4925         sv_setpv(sv, grent->gr_name);
4926
4927         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4928 #ifdef GRPASSWD
4929         sv_setpv(sv, grent->gr_passwd);
4930 #endif
4931
4932         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4933         sv_setiv(sv, (IV)grent->gr_gid);
4934
4935         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4936         for (elem = grent->gr_mem; elem && *elem; elem++) {
4937             sv_catpv(sv, *elem);
4938             if (elem[1])
4939                 sv_catpvn(sv, " ", 1);
4940         }
4941     }
4942
4943     RETURN;
4944 #else
4945     DIE(aTHX_ PL_no_func, "getgrent");
4946 #endif
4947 }
4948
4949 PP(pp_sgrent)
4950 {
4951     djSP;
4952 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
4953     setgrent();
4954     RETPUSHYES;
4955 #else
4956     DIE(aTHX_ PL_no_func, "setgrent");
4957 #endif
4958 }
4959
4960 PP(pp_egrent)
4961 {
4962     djSP;
4963 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
4964     endgrent();
4965     RETPUSHYES;
4966 #else
4967     DIE(aTHX_ PL_no_func, "endgrent");
4968 #endif
4969 }
4970
4971 PP(pp_getlogin)
4972 {
4973     djSP; dTARGET;
4974 #ifdef HAS_GETLOGIN
4975     char *tmps;
4976     EXTEND(SP, 1);
4977     if (!(tmps = PerlProc_getlogin()))
4978         RETPUSHUNDEF;
4979     PUSHp(tmps, strlen(tmps));
4980     RETURN;
4981 #else
4982     DIE(aTHX_ PL_no_func, "getlogin");
4983 #endif
4984 }
4985
4986 /* Miscellaneous. */
4987
4988 PP(pp_syscall)
4989 {
4990 #ifdef HAS_SYSCALL
4991     djSP; dMARK; dORIGMARK; dTARGET;
4992     register I32 items = SP - MARK;
4993     unsigned long a[20];
4994     register I32 i = 0;
4995     I32 retval = -1;
4996     MAGIC *mg;
4997     STRLEN n_a;
4998
4999     if (PL_tainting) {
5000         while (++MARK <= SP) {
5001             if (SvTAINTED(*MARK)) {
5002                 TAINT;
5003                 break;
5004             }
5005         }
5006         MARK = ORIGMARK;
5007         TAINT_PROPER("syscall");
5008     }
5009
5010     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5011      * or where sizeof(long) != sizeof(char*).  But such machines will
5012      * not likely have syscall implemented either, so who cares?
5013      */
5014     while (++MARK <= SP) {
5015         if (SvNIOK(*MARK) || !i)
5016             a[i++] = SvIV(*MARK);
5017         else if (*MARK == &PL_sv_undef)
5018             a[i++] = 0;
5019         else
5020             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5021         if (i > 15)
5022             break;
5023     }
5024     switch (items) {
5025     default:
5026         DIE(aTHX_ "Too many args to syscall");
5027     case 0:
5028         DIE(aTHX_ "Too few args to syscall");
5029     case 1:
5030         retval = syscall(a[0]);
5031         break;
5032     case 2:
5033         retval = syscall(a[0],a[1]);
5034         break;
5035     case 3:
5036         retval = syscall(a[0],a[1],a[2]);
5037         break;
5038     case 4:
5039         retval = syscall(a[0],a[1],a[2],a[3]);
5040         break;
5041     case 5:
5042         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5043         break;
5044     case 6:
5045         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5046         break;
5047     case 7:
5048         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5049         break;
5050     case 8:
5051         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5052         break;
5053 #ifdef atarist
5054     case 9:
5055         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5056         break;
5057     case 10:
5058         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5059         break;
5060     case 11:
5061         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5062           a[10]);
5063         break;
5064     case 12:
5065         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5066           a[10],a[11]);
5067         break;
5068     case 13:
5069         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5070           a[10],a[11],a[12]);
5071         break;
5072     case 14:
5073         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5074           a[10],a[11],a[12],a[13]);
5075         break;
5076 #endif /* atarist */
5077     }
5078     SP = ORIGMARK;
5079     PUSHi(retval);
5080     RETURN;
5081 #else
5082     DIE(aTHX_ PL_no_func, "syscall");
5083 #endif
5084 }
5085
5086 #ifdef FCNTL_EMULATE_FLOCK
5087
5088 /*  XXX Emulate flock() with fcntl().
5089     What's really needed is a good file locking module.
5090 */
5091
5092 static int
5093 fcntl_emulate_flock(int fd, int operation)
5094 {
5095     struct flock flock;
5096
5097     switch (operation & ~LOCK_NB) {
5098     case LOCK_SH:
5099         flock.l_type = F_RDLCK;
5100         break;
5101     case LOCK_EX:
5102         flock.l_type = F_WRLCK;
5103         break;
5104     case LOCK_UN:
5105         flock.l_type = F_UNLCK;
5106         break;
5107     default:
5108         errno = EINVAL;
5109         return -1;
5110     }
5111     flock.l_whence = SEEK_SET;
5112     flock.l_start = flock.l_len = (Off_t)0;
5113
5114     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5115 }
5116
5117 #endif /* FCNTL_EMULATE_FLOCK */
5118
5119 #ifdef LOCKF_EMULATE_FLOCK
5120
5121 /*  XXX Emulate flock() with lockf().  This is just to increase
5122     portability of scripts.  The calls are not completely
5123     interchangeable.  What's really needed is a good file
5124     locking module.
5125 */
5126
5127 /*  The lockf() constants might have been defined in <unistd.h>.
5128     Unfortunately, <unistd.h> causes troubles on some mixed
5129     (BSD/POSIX) systems, such as SunOS 4.1.3.
5130
5131    Further, the lockf() constants aren't POSIX, so they might not be
5132    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5133    just stick in the SVID values and be done with it.  Sigh.
5134 */
5135
5136 # ifndef F_ULOCK
5137 #  define F_ULOCK       0       /* Unlock a previously locked region */
5138 # endif
5139 # ifndef F_LOCK
5140 #  define F_LOCK        1       /* Lock a region for exclusive use */
5141 # endif
5142 # ifndef F_TLOCK
5143 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5144 # endif
5145 # ifndef F_TEST
5146 #  define F_TEST        3       /* Test a region for other processes locks */
5147 # endif
5148
5149 static int
5150 lockf_emulate_flock(int fd, int operation)
5151 {
5152     int i;
5153     int save_errno;
5154     Off_t pos;
5155
5156     /* flock locks entire file so for lockf we need to do the same      */
5157     save_errno = errno;
5158     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5159     if (pos > 0)        /* is seekable and needs to be repositioned     */
5160         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5161             pos = -1;   /* seek failed, so don't seek back afterwards   */
5162     errno = save_errno;
5163
5164     switch (operation) {
5165
5166         /* LOCK_SH - get a shared lock */
5167         case LOCK_SH:
5168         /* LOCK_EX - get an exclusive lock */
5169         case LOCK_EX:
5170             i = lockf (fd, F_LOCK, 0);
5171             break;
5172
5173         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5174         case LOCK_SH|LOCK_NB:
5175         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5176         case LOCK_EX|LOCK_NB:
5177             i = lockf (fd, F_TLOCK, 0);
5178             if (i == -1)
5179                 if ((errno == EAGAIN) || (errno == EACCES))
5180                     errno = EWOULDBLOCK;
5181             break;
5182
5183         /* LOCK_UN - unlock (non-blocking is a no-op) */
5184         case LOCK_UN:
5185         case LOCK_UN|LOCK_NB:
5186             i = lockf (fd, F_ULOCK, 0);
5187             break;
5188
5189         /* Default - can't decipher operation */
5190         default:
5191             i = -1;
5192             errno = EINVAL;
5193             break;
5194     }
5195
5196     if (pos > 0)      /* need to restore position of the handle */
5197         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5198
5199     return (i);
5200 }
5201
5202 #endif /* LOCKF_EMULATE_FLOCK */