pp_sys.c

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