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