pp_sys.c

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