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