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