pp_sys.c

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