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