pp_sys.c

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