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