pp_sys.c

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