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         (void)SvUPGRADE(ERRSV, SVt_PV);
 294         if (SvPOK(ERRSV) && SvCUR(ERRSV))
 295             sv_catpv(ERRSV, "\t...caught");
 296         tmps = SvPV(ERRSV, na);
 297     }
 298     if (!tmps || !*tmps)
 299         tmps = "Warning: something's wrong";
 300     warn("%s", tmps);
 301     RETSETYES;
 302 }
 303
 304 PP(pp_die)
 305 {
 306     djSP; dMARK;
 307     char *tmps;
 308     if (SP - MARK != 1) {
 309         dTARGET;
 310         do_join(TARG, &sv_no, MARK, SP);
 311         tmps = SvPV(TARG, na);
 312         SP = MARK + 1;
 313     }
 314     else {
 315         tmps = SvPV(TOPs, na);
 316     }
 317     if (!tmps || !*tmps) {
 318         (void)SvUPGRADE(ERRSV, SVt_PV);
 319         if (SvPOK(ERRSV) && SvCUR(ERRSV))
 320             sv_catpv(ERRSV, "\t...propagated");
 321         tmps = SvPV(ERRSV, na);
 322     }
 323     if (!tmps || !*tmps)
 324         tmps = "Died";
 325     DIE("%s", tmps);
 326 }
 327
 328 /* I/O. */
 329
 330 PP(pp_open)
 331 {
 332     djSP; dTARGET;
 333     GV *gv;
 334     SV *sv;
 335     char *tmps;
 336     STRLEN len;
 337
 338     if (MAXARG > 1)
 339         sv = POPs;
 340     if (!isGV(TOPs))
 341         DIE(no_usym, "filehandle");
 342     if (MAXARG <= 1)
 343         sv = GvSV(TOPs);
 344     gv = (GV*)POPs;
 345     if (!isGV(gv))
 346         DIE(no_usym, "filehandle");
 347     if (GvIOp(gv))
 348         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 349     tmps = SvPV(sv, len);
 350     if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
 351         PUSHi( (I32)forkprocess );
 352     else if (forkprocess == 0)          /* we are a new child */
 353         PUSHi(0);
 354     else
 355         RETPUSHUNDEF;
 356     RETURN;
 357 }
 358
 359 PP(pp_close)
 360 {
 361     djSP;
 362     GV *gv;
 363     MAGIC *mg;
 364
 365     if (MAXARG == 0)
 366         gv = defoutgv;
 367     else
 368         gv = (GV*)POPs;
 369
 370     if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
 371         PUSHMARK(SP);
 372         XPUSHs(mg->mg_obj);
 373         PUTBACK;
 374         ENTER;
 375         perl_call_method("CLOSE", G_SCALAR);
 376         LEAVE;
 377         SPAGAIN;
 378         RETURN;
 379     }
 380     EXTEND(SP, 1);
 381     PUSHs(boolSV(do_close(gv, TRUE)));
 382     RETURN;
 383 }
 384
 385 PP(pp_pipe_op)
 386 {
 387     djSP;
 388 #ifdef HAS_PIPE
 389     GV *rgv;
 390     GV *wgv;
 391     register IO *rstio;
 392     register IO *wstio;
 393     int fd[2];
 394
 395     wgv = (GV*)POPs;
 396     rgv = (GV*)POPs;
 397
 398     if (!rgv || !wgv)
 399         goto badexit;
 400
 401     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
 402         DIE(no_usym, "filehandle");
 403     rstio = GvIOn(rgv);
 404     wstio = GvIOn(wgv);
 405
 406     if (IoIFP(rstio))
 407         do_close(rgv, FALSE);
 408     if (IoIFP(wstio))
 409         do_close(wgv, FALSE);
 410
 411     if (PerlProc_pipe(fd) < 0)
 412         goto badexit;
 413
 414     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 415     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 416     IoIFP(wstio) = IoOFP(wstio);
 417     IoTYPE(rstio) = '<';
 418     IoTYPE(wstio) = '>';
 419
 420     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 421         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 422         else PerlLIO_close(fd[0]);
 423         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 424         else PerlLIO_close(fd[1]);
 425         goto badexit;
 426     }
 427
 428     RETPUSHYES;
 429
 430 badexit:
 431     RETPUSHUNDEF;
 432 #else
 433     DIE(no_func, "pipe");
 434 #endif
 435 }
 436
 437 PP(pp_fileno)
 438 {
 439     djSP; dTARGET;
 440     GV *gv;
 441     IO *io;
 442     PerlIO *fp;
 443     if (MAXARG < 1)
 444         RETPUSHUNDEF;
 445     gv = (GV*)POPs;
 446     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
 447         RETPUSHUNDEF;
 448     PUSHi(PerlIO_fileno(fp));
 449     RETURN;
 450 }
 451
 452 PP(pp_umask)
 453 {
 454     djSP; dTARGET;
 455     int anum;
 456
 457 #ifdef HAS_UMASK
 458     if (MAXARG < 1) {
 459         anum = PerlLIO_umask(0);
 460         (void)PerlLIO_umask(anum);
 461     }
 462     else
 463         anum = PerlLIO_umask(POPi);
 464     TAINT_PROPER("umask");
 465     XPUSHi(anum);
 466 #else
 467     DIE(no_func, "Unsupported function umask");
 468 #endif
 469     RETURN;
 470 }
 471
 472 PP(pp_binmode)
 473 {
 474     djSP;
 475     GV *gv;
 476     IO *io;
 477     PerlIO *fp;
 478
 479     if (MAXARG < 1)
 480         RETPUSHUNDEF;
 481
 482     gv = (GV*)POPs;
 483
 484     EXTEND(SP, 1);
 485     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
 486         RETPUSHUNDEF;
 487
 488 #ifdef DOSISH
 489 #ifdef atarist
 490     if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
 491         RETPUSHYES;
 492     else
 493         RETPUSHUNDEF;
 494 #else
 495     if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
 496 #if defined(WIN32) && defined(__BORLANDC__)
 497         /* The translation mode of the stream is maintained independent
 498          * of the translation mode of the fd in the Borland RTL (heavy
 499          * digging through their runtime sources reveal).  User has to
 500          * set the mode explicitly for the stream (though they don't
 501          * document this anywhere). GSAR 97-5-24
 502          */
 503         PerlIO_seek(fp,0L,0);
 504         fp->flags |= _F_BIN;
 505 #endif
 506         RETPUSHYES;
 507     }
 508     else
 509         RETPUSHUNDEF;
 510 #endif
 511 #else
 512 #if defined(USEMYBINMODE)
 513     if (my_binmode(fp,IoTYPE(io)) != NULL)
 514         RETPUSHYES;
 515         else
 516         RETPUSHUNDEF;
 517 #else
 518     RETPUSHYES;
 519 #endif
 520 #endif
 521
 522 }
 523
 524
 525 PP(pp_tie)
 526 {
 527     djSP;
 528     dMARK;
 529     SV *varsv;
 530     HV* stash;
 531     GV *gv;
 532     SV *sv;
 533     I32 markoff = MARK - stack_base;
 534     char *methname;
 535     int how = 'P';
 536     U32 items;
 537
 538     varsv = *++MARK;
 539     switch(SvTYPE(varsv)) {
 540         case SVt_PVHV:
 541             methname = "TIEHASH";
 542             break;
 543         case SVt_PVAV:
 544             methname = "TIEARRAY";
 545             break;
 546         case SVt_PVGV:
 547             methname = "TIEHANDLE";
 548             how = 'q';
 549             break;
 550         default:
 551             methname = "TIESCALAR";
 552             how = 'q';
 553             break;
 554     }
 555     items = SP - MARK++;
 556     if (sv_isobject(*MARK)) {
 557         ENTER;
 558         PUSHSTACK(SI_MAGIC);
 559         PUSHMARK(SP);
 560         EXTEND(SP,items);
 561         while (items--)
 562             PUSHs(*MARK++);
 563         PUTBACK;
 564         perl_call_method(methname, G_SCALAR);
 565     }
 566     else {
 567         /* Not clear why we don't call perl_call_method here too.
 568          * perhaps to get different error message ?
 569          */
 570         stash = gv_stashsv(*MARK, FALSE);
 571         if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 572             DIE("Can't locate object method \"%s\" via package \"%s\"",
 573                  methname, SvPV(*MARK,na));
 574         }
 575         ENTER;
 576         PUSHSTACK(SI_MAGIC);
 577         PUSHMARK(SP);
 578         EXTEND(SP,items);
 579         while (items--)
 580             PUSHs(*MARK++);
 581         PUTBACK;
 582         perl_call_sv((SV*)GvCV(gv), G_SCALAR);
 583     }
 584     SPAGAIN;
 585
 586     sv = TOPs;
 587     POPSTACK();
 588     if (sv_isobject(sv)) {
 589         sv_unmagic(varsv, how);
 590         sv_magic(varsv, sv, how, Nullch, 0);
 591     }
 592     LEAVE;
 593     SP = stack_base + markoff;
 594     PUSHs(sv);
 595     RETURN;
 596 }
 597
 598 PP(pp_untie)
 599 {
 600     djSP;
 601     SV * sv ;
 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 = 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)(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     TAINT_PROPER("chdir");
2607     PUSHi( PerlDir_chdir(tmps) >= 0 );
2608 #ifdef VMS
2609     /* Clear the DEFAULT element of ENV so we'll get the new value
2610      * in the future. */
2611     hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD);
2612 #endif
2613     RETURN;
2614 }
2615
2616 PP(pp_chown)
2617 {
2618     djSP; dMARK; dTARGET;
2619     I32 value;
2620 #ifdef HAS_CHOWN
2621     value = (I32)apply(op->op_type, MARK, SP);
2622     SP = MARK;
2623     PUSHi(value);
2624     RETURN;
2625 #else
2626     DIE(no_func, "Unsupported function chown");
2627 #endif
2628 }
2629
2630 PP(pp_chroot)
2631 {
2632     djSP; dTARGET;
2633     char *tmps;
2634 #ifdef HAS_CHROOT
2635     tmps = POPp;
2636     TAINT_PROPER("chroot");
2637     PUSHi( chroot(tmps) >= 0 );
2638     RETURN;
2639 #else
2640     DIE(no_func, "chroot");
2641 #endif
2642 }
2643
2644 PP(pp_unlink)
2645 {
2646     djSP; dMARK; dTARGET;
2647     I32 value;
2648     value = (I32)apply(op->op_type, MARK, SP);
2649     SP = MARK;
2650     PUSHi(value);
2651     RETURN;
2652 }
2653
2654 PP(pp_chmod)
2655 {
2656     djSP; dMARK; dTARGET;
2657     I32 value;
2658     value = (I32)apply(op->op_type, MARK, SP);
2659     SP = MARK;
2660     PUSHi(value);
2661     RETURN;
2662 }
2663
2664 PP(pp_utime)
2665 {
2666     djSP; dMARK; dTARGET;
2667     I32 value;
2668     value = (I32)apply(op->op_type, MARK, SP);
2669     SP = MARK;
2670     PUSHi(value);
2671     RETURN;
2672 }
2673
2674 PP(pp_rename)
2675 {
2676     djSP; dTARGET;
2677     int anum;
2678
2679     char *tmps2 = POPp;
2680     char *tmps = SvPV(TOPs, na);
2681     TAINT_PROPER("rename");
2682 #ifdef HAS_RENAME
2683     anum = rename(tmps, tmps2);
2684 #else
2685     if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
2686         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
2687             anum = 1;
2688         else {
2689             if (euid || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
2690                 (void)UNLINK(tmps2);
2691             if (!(anum = link(tmps, tmps2)))
2692                 anum = UNLINK(tmps);
2693         }
2694     }
2695 #endif
2696     SETi( anum >= 0 );
2697     RETURN;
2698 }
2699
2700 PP(pp_link)
2701 {
2702     djSP; dTARGET;
2703 #ifdef HAS_LINK
2704     char *tmps2 = POPp;
2705     char *tmps = SvPV(TOPs, na);
2706     TAINT_PROPER("link");
2707     SETi( link(tmps, tmps2) >= 0 );
2708 #else
2709     DIE(no_func, "Unsupported function link");
2710 #endif
2711     RETURN;
2712 }
2713
2714 PP(pp_symlink)
2715 {
2716     djSP; dTARGET;
2717 #ifdef HAS_SYMLINK
2718     char *tmps2 = POPp;
2719     char *tmps = SvPV(TOPs, na);
2720     TAINT_PROPER("symlink");
2721     SETi( symlink(tmps, tmps2) >= 0 );
2722     RETURN;
2723 #else
2724     DIE(no_func, "symlink");
2725 #endif
2726 }
2727
2728 PP(pp_readlink)
2729 {
2730     djSP; dTARGET;
2731 #ifdef HAS_SYMLINK
2732     char *tmps;
2733     char buf[MAXPATHLEN];
2734     int len;
2735
2736 #ifndef INCOMPLETE_TAINTS
2737     TAINT;
2738 #endif
2739     tmps = POPp;
2740     len = readlink(tmps, buf, sizeof buf);
2741     EXTEND(SP, 1);
2742     if (len < 0)
2743         RETPUSHUNDEF;
2744     PUSHp(buf, len);
2745     RETURN;
2746 #else
2747     EXTEND(SP, 1);
2748     RETSETUNDEF;                /* just pretend it's a normal file */
2749 #endif
2750 }
2751
2752 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2753 static int
2754 dooneliner(cmd, filename)
2755 char *cmd;
2756 char *filename;
2757 {
2758     char *save_filename = filename;
2759     char *cmdline;
2760     char *s;
2761     PerlIO *myfp;
2762     int anum = 1;
2763
2764     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2765     strcpy(cmdline, cmd);
2766     strcat(cmdline, " ");
2767     for (s = cmdline + strlen(cmdline); *filename; ) {
2768         *s++ = '\\';
2769         *s++ = *filename++;
2770     }
2771     strcpy(s, " 2>&1");
2772     myfp = PerlProc_popen(cmdline, "r");
2773     Safefree(cmdline);
2774
2775     if (myfp) {
2776         SV *tmpsv = sv_newmortal();
2777         /* Need to save/restore 'rs' ?? */
2778         s = sv_gets(tmpsv, myfp, 0);
2779         (void)PerlProc_pclose(myfp);
2780         if (s != Nullch) {
2781             int e;
2782             for (e = 1;
2783 #ifdef HAS_SYS_ERRLIST
2784                  e <= sys_nerr
2785 #endif
2786                  ; e++)
2787             {
2788                 /* you don't see this */
2789                 char *errmsg =
2790 #ifdef HAS_SYS_ERRLIST
2791                     sys_errlist[e]
2792 #else
2793                     strerror(e)
2794 #endif
2795                     ;
2796                 if (!errmsg)
2797                     break;
2798                 if (instr(s, errmsg)) {
2799                     SETERRNO(e,0);
2800                     return 0;
2801                 }
2802             }
2803             SETERRNO(0,0);
2804 #ifndef EACCES
2805 #define EACCES EPERM
2806 #endif
2807             if (instr(s, "cannot make"))
2808                 SETERRNO(EEXIST,RMS$_FEX);
2809             else if (instr(s, "existing file"))
2810                 SETERRNO(EEXIST,RMS$_FEX);
2811             else if (instr(s, "ile exists"))
2812                 SETERRNO(EEXIST,RMS$_FEX);
2813             else if (instr(s, "non-exist"))
2814                 SETERRNO(ENOENT,RMS$_FNF);
2815             else if (instr(s, "does not exist"))
2816                 SETERRNO(ENOENT,RMS$_FNF);
2817             else if (instr(s, "not empty"))
2818                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
2819             else if (instr(s, "cannot access"))
2820                 SETERRNO(EACCES,RMS$_PRV);
2821             else
2822                 SETERRNO(EPERM,RMS$_PRV);
2823             return 0;
2824         }
2825         else {  /* some mkdirs return no failure indication */
2826             anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
2827             if (op->op_type == OP_RMDIR)
2828                 anum = !anum;
2829             if (anum)
2830                 SETERRNO(0,0);
2831             else
2832                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
2833         }
2834         return anum;
2835     }
2836     else
2837         return 0;
2838 }
2839 #endif
2840
2841 PP(pp_mkdir)
2842 {
2843     djSP; dTARGET;
2844     int mode = POPi;
2845 #ifndef HAS_MKDIR
2846     int oldumask;
2847 #endif
2848     char *tmps = SvPV(TOPs, na);
2849
2850     TAINT_PROPER("mkdir");
2851 #ifdef HAS_MKDIR
2852     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
2853 #else
2854     SETi( dooneliner("mkdir", tmps) );
2855     oldumask = PerlLIO_umask(0);
2856     PerlLIO_umask(oldumask);
2857     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
2858 #endif
2859     RETURN;
2860 }
2861
2862 PP(pp_rmdir)
2863 {
2864     djSP; dTARGET;
2865     char *tmps;
2866
2867     tmps = POPp;
2868     TAINT_PROPER("rmdir");
2869 #ifdef HAS_RMDIR
2870     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
2871 #else
2872     XPUSHi( dooneliner("rmdir", tmps) );
2873 #endif
2874     RETURN;
2875 }
2876
2877 /* Directory calls. */
2878
2879 PP(pp_open_dir)
2880 {
2881     djSP;
2882 #if defined(Direntry_t) && defined(HAS_READDIR)
2883     char *dirname = POPp;
2884     GV *gv = (GV*)POPs;
2885     register IO *io = GvIOn(gv);
2886
2887     if (!io)
2888         goto nope;
2889
2890     if (IoDIRP(io))
2891         PerlDir_close(IoDIRP(io));
2892     if (!(IoDIRP(io) = PerlDir_open(dirname)))
2893         goto nope;
2894
2895     RETPUSHYES;
2896 nope:
2897     if (!errno)
2898         SETERRNO(EBADF,RMS$_DIR);
2899     RETPUSHUNDEF;
2900 #else
2901     DIE(no_dir_func, "opendir");
2902 #endif
2903 }
2904
2905 PP(pp_readdir)
2906 {
2907     djSP;
2908 #if defined(Direntry_t) && defined(HAS_READDIR)
2909 #ifndef I_DIRENT
2910     Direntry_t *readdir _((DIR *));
2911 #endif
2912     register Direntry_t *dp;
2913     GV *gv = (GV*)POPs;
2914     register IO *io = GvIOn(gv);
2915     SV *sv;
2916
2917     if (!io || !IoDIRP(io))
2918         goto nope;
2919
2920     if (GIMME == G_ARRAY) {
2921         /*SUPPRESS 560*/
2922         while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
2923 #ifdef DIRNAMLEN
2924             sv = newSVpv(dp->d_name, dp->d_namlen);
2925 #else
2926             sv = newSVpv(dp->d_name, 0);
2927 #endif
2928 #ifndef INCOMPLETE_TAINTS
2929             SvTAINTED_on(sv);
2930 #endif
2931             XPUSHs(sv_2mortal(sv));
2932         }
2933     }
2934     else {
2935         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
2936             goto nope;
2937 #ifdef DIRNAMLEN
2938         sv = newSVpv(dp->d_name, dp->d_namlen);
2939 #else
2940         sv = newSVpv(dp->d_name, 0);
2941 #endif
2942 #ifndef INCOMPLETE_TAINTS
2943         SvTAINTED_on(sv);
2944 #endif
2945         XPUSHs(sv_2mortal(sv));
2946     }
2947     RETURN;
2948
2949 nope:
2950     if (!errno)
2951         SETERRNO(EBADF,RMS$_ISI);
2952     if (GIMME == G_ARRAY)
2953         RETURN;
2954     else
2955         RETPUSHUNDEF;
2956 #else
2957     DIE(no_dir_func, "readdir");
2958 #endif
2959 }
2960
2961 PP(pp_telldir)
2962 {
2963     djSP; dTARGET;
2964 #if defined(HAS_TELLDIR) || defined(telldir)
2965 # ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
2966     long telldir _((DIR *));
2967 # endif
2968     GV *gv = (GV*)POPs;
2969     register IO *io = GvIOn(gv);
2970
2971     if (!io || !IoDIRP(io))
2972         goto nope;
2973
2974     PUSHi( PerlDir_tell(IoDIRP(io)) );
2975     RETURN;
2976 nope:
2977     if (!errno)
2978         SETERRNO(EBADF,RMS$_ISI);
2979     RETPUSHUNDEF;
2980 #else
2981     DIE(no_dir_func, "telldir");
2982 #endif
2983 }
2984
2985 PP(pp_seekdir)
2986 {
2987     djSP;
2988 #if defined(HAS_SEEKDIR) || defined(seekdir)
2989     long along = POPl;
2990     GV *gv = (GV*)POPs;
2991     register IO *io = GvIOn(gv);
2992
2993     if (!io || !IoDIRP(io))
2994         goto nope;
2995
2996     (void)PerlDir_seek(IoDIRP(io), along);
2997
2998     RETPUSHYES;
2999 nope:
3000     if (!errno)
3001         SETERRNO(EBADF,RMS$_ISI);
3002     RETPUSHUNDEF;
3003 #else
3004     DIE(no_dir_func, "seekdir");
3005 #endif
3006 }
3007
3008 PP(pp_rewinddir)
3009 {
3010     djSP;
3011 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3012     GV *gv = (GV*)POPs;
3013     register IO *io = GvIOn(gv);
3014
3015     if (!io || !IoDIRP(io))
3016         goto nope;
3017
3018     (void)PerlDir_rewind(IoDIRP(io));
3019     RETPUSHYES;
3020 nope:
3021     if (!errno)
3022         SETERRNO(EBADF,RMS$_ISI);
3023     RETPUSHUNDEF;
3024 #else
3025     DIE(no_dir_func, "rewinddir");
3026 #endif
3027 }
3028
3029 PP(pp_closedir)
3030 {
3031     djSP;
3032 #if defined(Direntry_t) && defined(HAS_READDIR)
3033     GV *gv = (GV*)POPs;
3034     register IO *io = GvIOn(gv);
3035
3036     if (!io || !IoDIRP(io))
3037         goto nope;
3038
3039 #ifdef VOID_CLOSEDIR
3040     PerlDir_close(IoDIRP(io));
3041 #else
3042     if (PerlDir_close(IoDIRP(io)) < 0) {
3043         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3044         goto nope;
3045     }
3046 #endif
3047     IoDIRP(io) = 0;
3048
3049     RETPUSHYES;
3050 nope:
3051     if (!errno)
3052         SETERRNO(EBADF,RMS$_IFI);
3053     RETPUSHUNDEF;
3054 #else
3055     DIE(no_dir_func, "closedir");
3056 #endif
3057 }
3058
3059 /* Process control. */
3060
3061 PP(pp_fork)
3062 {
3063 #ifdef HAS_FORK
3064     djSP; dTARGET;
3065     int childpid;
3066     GV *tmpgv;
3067
3068     EXTEND(SP, 1);
3069     childpid = fork();
3070     if (childpid < 0)
3071         RETSETUNDEF;
3072     if (!childpid) {
3073         /*SUPPRESS 560*/
3074         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3075             sv_setiv(GvSV(tmpgv), (IV)getpid());
3076         hv_clear(pidstatus);    /* no kids, so don't wait for 'em */
3077     }
3078     PUSHi(childpid);
3079     RETURN;
3080 #else
3081     DIE(no_func, "Unsupported function fork");
3082 #endif
3083 }
3084
3085 PP(pp_wait)
3086 {
3087 #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
3088     djSP; dTARGET;
3089     int childpid;
3090     int argflags;
3091
3092     childpid = wait4pid(-1, &argflags, 0);
3093     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3094     XPUSHi(childpid);
3095     RETURN;
3096 #else
3097     DIE(no_func, "Unsupported function wait");
3098 #endif
3099 }
3100
3101 PP(pp_waitpid)
3102 {
3103 #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
3104     djSP; dTARGET;
3105     int childpid;
3106     int optype;
3107     int argflags;
3108
3109     optype = POPi;
3110     childpid = TOPi;
3111     childpid = wait4pid(childpid, &argflags, optype);
3112     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3113     SETi(childpid);
3114     RETURN;
3115 #else
3116     DIE(no_func, "Unsupported function waitpid");
3117 #endif
3118 }
3119
3120 PP(pp_system)
3121 {
3122     djSP; dMARK; dORIGMARK; dTARGET;
3123     I32 value;
3124     int childpid;
3125     int result;
3126     int status;
3127     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3128
3129     if (SP - MARK == 1) {
3130         if (tainting) {
3131             char *junk = SvPV(TOPs, na);
3132             TAINT_ENV();
3133             TAINT_PROPER("system");
3134         }
3135     }
3136 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3137     while ((childpid = vfork()) == -1) {
3138         if (errno != EAGAIN) {
3139             value = -1;
3140             SP = ORIGMARK;
3141             PUSHi(value);
3142             RETURN;
3143         }
3144         sleep(5);
3145     }
3146     if (childpid > 0) {
3147         rsignal_save(SIGINT, SIG_IGN, &ihand);
3148         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3149         do {
3150             result = wait4pid(childpid, &status, 0);
3151         } while (result == -1 && errno == EINTR);
3152         (void)rsignal_restore(SIGINT, &ihand);
3153         (void)rsignal_restore(SIGQUIT, &qhand);
3154         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3155         do_execfree();  /* free any memory child malloced on vfork */
3156         SP = ORIGMARK;
3157         PUSHi(STATUS_CURRENT);
3158         RETURN;
3159     }
3160     if (op->op_flags & OPf_STACKED) {
3161         SV *really = *++MARK;
3162         value = (I32)do_aexec(really, MARK, SP);
3163     }
3164     else if (SP - MARK != 1)
3165         value = (I32)do_aexec(Nullsv, MARK, SP);
3166     else {
3167         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3168     }
3169     PerlProc__exit(-1);
3170 #else /* ! FORK or VMS or OS/2 */
3171     if (op->op_flags & OPf_STACKED) {
3172         SV *really = *++MARK;
3173         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3174     }
3175     else if (SP - MARK != 1)
3176         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3177     else {
3178         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
3179     }
3180     STATUS_NATIVE_SET(value);
3181     do_execfree();
3182     SP = ORIGMARK;
3183     PUSHi(STATUS_CURRENT);
3184 #endif /* !FORK or VMS */
3185     RETURN;
3186 }
3187
3188 PP(pp_exec)
3189 {
3190     djSP; dMARK; dORIGMARK; dTARGET;
3191     I32 value;
3192
3193     if (op->op_flags & OPf_STACKED) {
3194         SV *really = *++MARK;
3195         value = (I32)do_aexec(really, MARK, SP);
3196     }
3197     else if (SP - MARK != 1)
3198 #ifdef VMS
3199         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3200 #else
3201         value = (I32)do_aexec(Nullsv, MARK, SP);
3202 #endif
3203     else {
3204         if (tainting) {
3205             char *junk = SvPV(*SP, na);
3206             TAINT_ENV();
3207             TAINT_PROPER("exec");
3208         }
3209 #ifdef VMS
3210         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na));
3211 #else
3212         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3213 #endif
3214     }
3215     SP = ORIGMARK;
3216     PUSHi(value);
3217     RETURN;
3218 }
3219
3220 PP(pp_kill)
3221 {
3222     djSP; dMARK; dTARGET;
3223     I32 value;
3224 #ifdef HAS_KILL
3225     value = (I32)apply(op->op_type, MARK, SP);
3226     SP = MARK;
3227     PUSHi(value);
3228     RETURN;
3229 #else
3230     DIE(no_func, "Unsupported function kill");
3231 #endif
3232 }
3233
3234 PP(pp_getppid)
3235 {
3236 #ifdef HAS_GETPPID
3237     djSP; dTARGET;
3238     XPUSHi( getppid() );
3239     RETURN;
3240 #else
3241     DIE(no_func, "getppid");
3242 #endif
3243 }
3244
3245 PP(pp_getpgrp)
3246 {
3247 #ifdef HAS_GETPGRP
3248     djSP; dTARGET;
3249     int pid;
3250     I32 value;
3251
3252     if (MAXARG < 1)
3253         pid = 0;
3254     else
3255         pid = SvIVx(POPs);
3256 #ifdef BSD_GETPGRP
3257     value = (I32)BSD_GETPGRP(pid);
3258 #else
3259     if (pid != 0 && pid != getpid())
3260         DIE("POSIX getpgrp can't take an argument");
3261     value = (I32)getpgrp();
3262 #endif
3263     XPUSHi(value);
3264     RETURN;
3265 #else
3266     DIE(no_func, "getpgrp()");
3267 #endif
3268 }
3269
3270 PP(pp_setpgrp)
3271 {
3272 #ifdef HAS_SETPGRP
3273     djSP; dTARGET;
3274     int pgrp;
3275     int pid;
3276     if (MAXARG < 2) {
3277         pgrp = 0;
3278         pid = 0;
3279     }
3280     else {
3281         pgrp = POPi;
3282         pid = TOPi;
3283     }
3284
3285     TAINT_PROPER("setpgrp");
3286 #ifdef BSD_SETPGRP
3287     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3288 #else
3289     if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
3290         DIE("POSIX setpgrp can't take an argument");
3291     SETi( setpgrp() >= 0 );
3292 #endif /* USE_BSDPGRP */
3293     RETURN;
3294 #else
3295     DIE(no_func, "setpgrp()");
3296 #endif
3297 }
3298
3299 PP(pp_getpriority)
3300 {
3301     djSP; dTARGET;
3302     int which;
3303     int who;
3304 #ifdef HAS_GETPRIORITY
3305     who = POPi;
3306     which = TOPi;
3307     SETi( getpriority(which, who) );
3308     RETURN;
3309 #else
3310     DIE(no_func, "getpriority()");
3311 #endif
3312 }
3313
3314 PP(pp_setpriority)
3315 {
3316     djSP; dTARGET;
3317     int which;
3318     int who;
3319     int niceval;
3320 #ifdef HAS_SETPRIORITY
3321     niceval = POPi;
3322     who = POPi;
3323     which = TOPi;
3324     TAINT_PROPER("setpriority");
3325     SETi( setpriority(which, who, niceval) >= 0 );
3326     RETURN;
3327 #else
3328     DIE(no_func, "setpriority()");
3329 #endif
3330 }
3331
3332 /* Time calls. */
3333
3334 PP(pp_time)
3335 {
3336     djSP; dTARGET;
3337 #ifdef BIG_TIME
3338     XPUSHn( time(Null(Time_t*)) );
3339 #else
3340     XPUSHi( time(Null(Time_t*)) );
3341 #endif
3342     RETURN;
3343 }
3344
3345 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3346    to HZ.  Probably.  For now, assume that if the system
3347    defines HZ, it does so correctly.  (Will this break
3348    on VMS?)
3349    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3350    it's supported.    --AD  9/96.
3351 */
3352
3353 #ifndef HZ
3354 #  ifdef CLK_TCK
3355 #    define HZ CLK_TCK
3356 #  else
3357 #    define HZ 60
3358 #  endif
3359 #endif
3360
3361 PP(pp_tms)
3362 {
3363     djSP;
3364
3365 #ifndef HAS_TIMES
3366     DIE("times not implemented");
3367 #else
3368     EXTEND(SP, 4);
3369
3370 #ifndef VMS
3371     (void)times(&timesbuf);
3372 #else
3373     (void)times((tbuffer_t *)&timesbuf);  /* time.h uses different name for */
3374                                           /* struct tms, though same data   */
3375                                           /* is returned.                   */
3376 #endif
3377
3378     PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
3379     if (GIMME == G_ARRAY) {
3380         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
3381         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
3382         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
3383     }
3384     RETURN;
3385 #endif /* HAS_TIMES */
3386 }
3387
3388 PP(pp_localtime)
3389 {
3390     return pp_gmtime(ARGS);
3391 }
3392
3393 PP(pp_gmtime)
3394 {
3395     djSP;
3396     Time_t when;
3397     struct tm *tmbuf;
3398     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3399     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3400                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3401
3402     if (MAXARG < 1)
3403         (void)time(&when);
3404     else
3405 #ifdef BIG_TIME
3406         when = (Time_t)SvNVx(POPs);
3407 #else
3408         when = (Time_t)SvIVx(POPs);
3409 #endif
3410
3411     if (op->op_type == OP_LOCALTIME)
3412         tmbuf = localtime(&when);
3413     else
3414         tmbuf = gmtime(&when);
3415
3416     EXTEND(SP, 9);
3417     EXTEND_MORTAL(9);
3418     if (GIMME != G_ARRAY) {
3419         dTARGET;
3420         SV *tsv;
3421         if (!tmbuf)
3422             RETPUSHUNDEF;
3423         tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3424                        dayname[tmbuf->tm_wday],
3425                        monname[tmbuf->tm_mon],
3426                        tmbuf->tm_mday,
3427                        tmbuf->tm_hour,
3428                        tmbuf->tm_min,
3429                        tmbuf->tm_sec,
3430                        tmbuf->tm_year + 1900);
3431         PUSHs(sv_2mortal(tsv));
3432     }
3433     else if (tmbuf) {
3434         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3435         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3436         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3437         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3438         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3439         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3440         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3441         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3442         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3443     }
3444     RETURN;
3445 }
3446
3447 PP(pp_alarm)
3448 {
3449     djSP; dTARGET;
3450     int anum;
3451 #ifdef HAS_ALARM
3452     anum = POPi;
3453     anum = alarm((unsigned int)anum);
3454     EXTEND(SP, 1);
3455     if (anum < 0)
3456         RETPUSHUNDEF;
3457     PUSHi((I32)anum);
3458     RETURN;
3459 #else
3460     DIE(no_func, "Unsupported function alarm");
3461 #endif
3462 }
3463
3464 PP(pp_sleep)
3465 {
3466     djSP; dTARGET;
3467     I32 duration;
3468     Time_t lasttime;
3469     Time_t when;
3470
3471     (void)time(&lasttime);
3472     if (MAXARG < 1)
3473         Pause();
3474     else {
3475         duration = POPi;
3476         sleep((unsigned int)duration);
3477     }
3478     (void)time(&when);
3479     XPUSHi(when - lasttime);
3480     RETURN;
3481 }
3482
3483 /* Shared memory. */
3484
3485 PP(pp_shmget)
3486 {
3487     return pp_semget(ARGS);
3488 }
3489
3490 PP(pp_shmctl)
3491 {
3492     return pp_semctl(ARGS);
3493 }
3494
3495 PP(pp_shmread)
3496 {
3497     return pp_shmwrite(ARGS);
3498 }
3499
3500 PP(pp_shmwrite)
3501 {
3502 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3503     djSP; dMARK; dTARGET;
3504     I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
3505     SP = MARK;
3506     PUSHi(value);
3507     RETURN;
3508 #else
3509     return pp_semget(ARGS);
3510 #endif
3511 }
3512
3513 /* Message passing. */
3514
3515 PP(pp_msgget)
3516 {
3517     return pp_semget(ARGS);
3518 }
3519
3520 PP(pp_msgctl)
3521 {
3522     return pp_semctl(ARGS);
3523 }
3524
3525 PP(pp_msgsnd)
3526 {
3527 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3528     djSP; dMARK; dTARGET;
3529     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3530     SP = MARK;
3531     PUSHi(value);
3532     RETURN;
3533 #else
3534     return pp_semget(ARGS);
3535 #endif
3536 }
3537
3538 PP(pp_msgrcv)
3539 {
3540 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3541     djSP; dMARK; dTARGET;
3542     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3543     SP = MARK;
3544     PUSHi(value);
3545     RETURN;
3546 #else
3547     return pp_semget(ARGS);
3548 #endif
3549 }
3550
3551 /* Semaphores. */
3552
3553 PP(pp_semget)
3554 {
3555 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3556     djSP; dMARK; dTARGET;
3557     int anum = do_ipcget(op->op_type, MARK, SP);
3558     SP = MARK;
3559     if (anum == -1)
3560         RETPUSHUNDEF;
3561     PUSHi(anum);
3562     RETURN;
3563 #else
3564     DIE("System V IPC is not implemented on this machine");
3565 #endif
3566 }
3567
3568 PP(pp_semctl)
3569 {
3570 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3571     djSP; dMARK; dTARGET;
3572     int anum = do_ipcctl(op->op_type, MARK, SP);
3573     SP = MARK;
3574     if (anum == -1)
3575         RETSETUNDEF;
3576     if (anum != 0) {
3577         PUSHi(anum);
3578     }
3579     else {
3580         PUSHp(zero_but_true, ZBTLEN);
3581     }
3582     RETURN;
3583 #else
3584     return pp_semget(ARGS);
3585 #endif
3586 }
3587
3588 PP(pp_semop)
3589 {
3590 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3591     djSP; dMARK; dTARGET;
3592     I32 value = (I32)(do_semop(MARK, SP) >= 0);
3593     SP = MARK;
3594     PUSHi(value);
3595     RETURN;
3596 #else
3597     return pp_semget(ARGS);
3598 #endif
3599 }
3600
3601 /* Get system info. */
3602
3603 PP(pp_ghbyname)
3604 {
3605 #ifdef HAS_GETHOSTBYNAME
3606     return pp_ghostent(ARGS);
3607 #else
3608     DIE(no_sock_func, "gethostbyname");
3609 #endif
3610 }
3611
3612 PP(pp_ghbyaddr)
3613 {
3614 #ifdef HAS_GETHOSTBYADDR
3615     return pp_ghostent(ARGS);
3616 #else
3617     DIE(no_sock_func, "gethostbyaddr");
3618 #endif
3619 }
3620
3621 PP(pp_ghostent)
3622 {
3623     djSP;
3624 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
3625     I32 which = op->op_type;
3626     register char **elem;
3627     register SV *sv;
3628 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
3629     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
3630     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
3631     struct hostent *PerlSock_gethostent(void);
3632 #endif
3633     struct hostent *hent;
3634     unsigned long len;
3635
3636     EXTEND(SP, 10);
3637     if (which == OP_GHBYNAME)
3638 #ifdef HAS_GETHOSTBYNAME
3639         hent = PerlSock_gethostbyname(POPp);
3640 #else
3641         DIE(no_sock_func, "gethostbyname");
3642 #endif
3643     else if (which == OP_GHBYADDR) {
3644 #ifdef HAS_GETHOSTBYADDR
3645         int addrtype = POPi;
3646         SV *addrsv = POPs;
3647         STRLEN addrlen;
3648         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
3649
3650         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
3651 #else
3652         DIE(no_sock_func, "gethostbyaddr");
3653 #endif
3654     }
3655     else
3656 #ifdef HAS_GETHOSTENT
3657         hent = PerlSock_gethostent();
3658 #else
3659         DIE(no_sock_func, "gethostent");
3660 #endif
3661
3662 #ifdef HOST_NOT_FOUND
3663     if (!hent)
3664         STATUS_NATIVE_SET(h_errno);
3665 #endif
3666
3667     if (GIMME != G_ARRAY) {
3668         PUSHs(sv = sv_newmortal());
3669         if (hent) {
3670             if (which == OP_GHBYNAME) {
3671                 if (hent->h_addr)
3672                     sv_setpvn(sv, hent->h_addr, hent->h_length);
3673             }
3674             else
3675                 sv_setpv(sv, (char*)hent->h_name);
3676         }
3677         RETURN;
3678     }
3679
3680     if (hent) {
3681         PUSHs(sv = sv_mortalcopy(&sv_no));
3682         sv_setpv(sv, (char*)hent->h_name);
3683         PUSHs(sv = sv_mortalcopy(&sv_no));
3684         for (elem = hent->h_aliases; elem && *elem; elem++) {
3685             sv_catpv(sv, *elem);
3686             if (elem[1])
3687                 sv_catpvn(sv, " ", 1);
3688         }
3689         PUSHs(sv = sv_mortalcopy(&sv_no));
3690         sv_setiv(sv, (IV)hent->h_addrtype);
3691         PUSHs(sv = sv_mortalcopy(&sv_no));
3692         len = hent->h_length;
3693         sv_setiv(sv, (IV)len);
3694 #ifdef h_addr
3695         for (elem = hent->h_addr_list; elem && *elem; elem++) {
3696             XPUSHs(sv = sv_mortalcopy(&sv_no));
3697             sv_setpvn(sv, *elem, len);
3698         }
3699 #else
3700         PUSHs(sv = sv_mortalcopy(&sv_no));
3701         if (hent->h_addr)
3702             sv_setpvn(sv, hent->h_addr, len);
3703 #endif /* h_addr */
3704     }
3705     RETURN;
3706 #else
3707     DIE(no_sock_func, "gethostent");
3708 #endif
3709 }
3710
3711 PP(pp_gnbyname)
3712 {
3713 #ifdef HAS_GETNETBYNAME
3714     return pp_gnetent(ARGS);
3715 #else
3716     DIE(no_sock_func, "getnetbyname");
3717 #endif
3718 }
3719
3720 PP(pp_gnbyaddr)
3721 {
3722 #ifdef HAS_GETNETBYADDR
3723     return pp_gnetent(ARGS);
3724 #else
3725     DIE(no_sock_func, "getnetbyaddr");
3726 #endif
3727 }
3728
3729 PP(pp_gnetent)
3730 {
3731     djSP;
3732 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
3733     I32 which = op->op_type;
3734     register char **elem;
3735     register SV *sv;
3736 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
3737     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
3738     struct netent *PerlSock_getnetbyname(Netdb_name_t);
3739     struct netent *PerlSock_getnetent(void);
3740 #endif
3741     struct netent *nent;
3742
3743     if (which == OP_GNBYNAME)
3744 #ifdef HAS_GETNETBYNAME
3745         nent = PerlSock_getnetbyname(POPp);
3746 #else
3747         DIE(no_sock_func, "getnetbyname");
3748 #endif
3749     else if (which == OP_GNBYADDR) {
3750 #ifdef HAS_GETNETBYADDR
3751         int addrtype = POPi;
3752         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
3753         nent = PerlSock_getnetbyaddr(addr, addrtype);
3754 #else
3755         DIE(no_sock_func, "getnetbyaddr");
3756 #endif
3757     }
3758     else
3759 #ifdef HAS_GETNETENT
3760         nent = PerlSock_getnetent();
3761 #else
3762         DIE(no_sock_func, "getnetent");
3763 #endif
3764
3765     EXTEND(SP, 4);
3766     if (GIMME != G_ARRAY) {
3767         PUSHs(sv = sv_newmortal());
3768         if (nent) {
3769             if (which == OP_GNBYNAME)
3770                 sv_setiv(sv, (IV)nent->n_net);
3771             else
3772                 sv_setpv(sv, nent->n_name);
3773         }
3774         RETURN;
3775     }
3776
3777     if (nent) {
3778         PUSHs(sv = sv_mortalcopy(&sv_no));
3779         sv_setpv(sv, nent->n_name);
3780         PUSHs(sv = sv_mortalcopy(&sv_no));
3781         for (elem = nent->n_aliases; elem && *elem; elem++) {
3782             sv_catpv(sv, *elem);
3783             if (elem[1])
3784                 sv_catpvn(sv, " ", 1);
3785         }
3786         PUSHs(sv = sv_mortalcopy(&sv_no));
3787         sv_setiv(sv, (IV)nent->n_addrtype);
3788         PUSHs(sv = sv_mortalcopy(&sv_no));
3789         sv_setiv(sv, (IV)nent->n_net);
3790     }
3791
3792     RETURN;
3793 #else
3794     DIE(no_sock_func, "getnetent");
3795 #endif
3796 }
3797
3798 PP(pp_gpbyname)
3799 {
3800 #ifdef HAS_GETPROTOBYNAME
3801     return pp_gprotoent(ARGS);
3802 #else
3803     DIE(no_sock_func, "getprotobyname");
3804 #endif
3805 }
3806
3807 PP(pp_gpbynumber)
3808 {
3809 #ifdef HAS_GETPROTOBYNUMBER
3810     return pp_gprotoent(ARGS);
3811 #else
3812     DIE(no_sock_func, "getprotobynumber");
3813 #endif
3814 }
3815
3816 PP(pp_gprotoent)
3817 {
3818     djSP;
3819 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
3820     I32 which = op->op_type;
3821     register char **elem;
3822     register SV *sv;
3823 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
3824     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
3825     struct protoent *PerlSock_getprotobynumber(int);
3826     struct protoent *PerlSock_getprotoent(void);
3827 #endif
3828     struct protoent *pent;
3829
3830     if (which == OP_GPBYNAME)
3831 #ifdef HAS_GETPROTOBYNAME
3832         pent = PerlSock_getprotobyname(POPp);
3833 #else
3834         DIE(no_sock_func, "getprotobyname");
3835 #endif
3836     else if (which == OP_GPBYNUMBER)
3837 #ifdef HAS_GETPROTOBYNUMBER
3838         pent = PerlSock_getprotobynumber(POPi);
3839 #else
3840     DIE(no_sock_func, "getprotobynumber");
3841 #endif
3842     else
3843 #ifdef HAS_GETPROTOENT
3844         pent = PerlSock_getprotoent();
3845 #else
3846         DIE(no_sock_func, "getprotoent");
3847 #endif
3848
3849     EXTEND(SP, 3);
3850     if (GIMME != G_ARRAY) {
3851         PUSHs(sv = sv_newmortal());
3852         if (pent) {
3853             if (which == OP_GPBYNAME)
3854                 sv_setiv(sv, (IV)pent->p_proto);
3855             else
3856                 sv_setpv(sv, pent->p_name);
3857         }
3858         RETURN;
3859     }
3860
3861     if (pent) {
3862         PUSHs(sv = sv_mortalcopy(&sv_no));
3863         sv_setpv(sv, pent->p_name);
3864         PUSHs(sv = sv_mortalcopy(&sv_no));
3865         for (elem = pent->p_aliases; elem && *elem; elem++) {
3866             sv_catpv(sv, *elem);
3867             if (elem[1])
3868                 sv_catpvn(sv, " ", 1);
3869         }
3870         PUSHs(sv = sv_mortalcopy(&sv_no));
3871         sv_setiv(sv, (IV)pent->p_proto);
3872     }
3873
3874     RETURN;
3875 #else
3876     DIE(no_sock_func, "getprotoent");
3877 #endif
3878 }
3879
3880 PP(pp_gsbyname)
3881 {
3882 #ifdef HAS_GETSERVBYNAME
3883     return pp_gservent(ARGS);
3884 #else
3885     DIE(no_sock_func, "getservbyname");
3886 #endif
3887 }
3888
3889 PP(pp_gsbyport)
3890 {
3891 #ifdef HAS_GETSERVBYPORT
3892     return pp_gservent(ARGS);
3893 #else
3894     DIE(no_sock_func, "getservbyport");
3895 #endif
3896 }
3897
3898 PP(pp_gservent)
3899 {
3900     djSP;
3901 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
3902     I32 which = op->op_type;
3903     register char **elem;
3904     register SV *sv;
3905 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
3906     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
3907     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
3908     struct servent *PerlSock_getservent(void);
3909 #endif
3910     struct servent *sent;
3911
3912     if (which == OP_GSBYNAME) {
3913 #ifdef HAS_GETSERVBYNAME
3914         char *proto = POPp;
3915         char *name = POPp;
3916
3917         if (proto && !*proto)
3918             proto = Nullch;
3919
3920         sent = PerlSock_getservbyname(name, proto);
3921 #else
3922         DIE(no_sock_func, "getservbyname");
3923 #endif
3924     }
3925     else if (which == OP_GSBYPORT) {
3926 #ifdef HAS_GETSERVBYPORT
3927         char *proto = POPp;
3928         unsigned short port = POPu;
3929
3930 #ifdef HAS_HTONS
3931         port = PerlSock_htons(port);
3932 #endif
3933         sent = PerlSock_getservbyport(port, proto);
3934 #else
3935         DIE(no_sock_func, "getservbyport");
3936 #endif
3937     }
3938     else
3939 #ifdef HAS_GETSERVENT
3940         sent = PerlSock_getservent();
3941 #else
3942         DIE(no_sock_func, "getservent");
3943 #endif
3944
3945     EXTEND(SP, 4);
3946     if (GIMME != G_ARRAY) {
3947         PUSHs(sv = sv_newmortal());
3948         if (sent) {
3949             if (which == OP_GSBYNAME) {
3950 #ifdef HAS_NTOHS
3951                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
3952 #else
3953                 sv_setiv(sv, (IV)(sent->s_port));
3954 #endif
3955             }
3956             else
3957                 sv_setpv(sv, sent->s_name);
3958         }
3959         RETURN;
3960     }
3961
3962     if (sent) {
3963         PUSHs(sv = sv_mortalcopy(&sv_no));
3964         sv_setpv(sv, sent->s_name);
3965         PUSHs(sv = sv_mortalcopy(&sv_no));
3966         for (elem = sent->s_aliases; elem && *elem; elem++) {
3967             sv_catpv(sv, *elem);
3968             if (elem[1])
3969                 sv_catpvn(sv, " ", 1);
3970         }
3971         PUSHs(sv = sv_mortalcopy(&sv_no));
3972 #ifdef HAS_NTOHS
3973         sv_setiv(sv, (IV)ntohs(sent->s_port));
3974 #else
3975         sv_setiv(sv, (IV)(sent->s_port));
3976 #endif
3977         PUSHs(sv = sv_mortalcopy(&sv_no));
3978         sv_setpv(sv, sent->s_proto);
3979     }
3980
3981     RETURN;
3982 #else
3983     DIE(no_sock_func, "getservent");
3984 #endif
3985 }
3986
3987 PP(pp_shostent)
3988 {
3989     djSP;
3990 #ifdef HAS_SETHOSTENT
3991     sethostent(TOPi);
3992     RETSETYES;
3993 #else
3994     DIE(no_sock_func, "sethostent");
3995 #endif
3996 }
3997
3998 PP(pp_snetent)
3999 {
4000     djSP;
4001 #ifdef HAS_SETNETENT
4002     setnetent(TOPi);
4003     RETSETYES;
4004 #else
4005     DIE(no_sock_func, "setnetent");
4006 #endif
4007 }
4008
4009 PP(pp_sprotoent)
4010 {
4011     djSP;
4012 #ifdef HAS_SETPROTOENT
4013     setprotoent(TOPi);
4014     RETSETYES;
4015 #else
4016     DIE(no_sock_func, "setprotoent");
4017 #endif
4018 }
4019
4020 PP(pp_sservent)
4021 {
4022     djSP;
4023 #ifdef HAS_SETSERVENT
4024     setservent(TOPi);
4025     RETSETYES;
4026 #else
4027     DIE(no_sock_func, "setservent");
4028 #endif
4029 }
4030
4031 PP(pp_ehostent)
4032 {
4033     djSP;
4034 #ifdef HAS_ENDHOSTENT
4035     PerlSock_endhostent();
4036     EXTEND(SP,1);
4037     RETPUSHYES;
4038 #else
4039     DIE(no_sock_func, "endhostent");
4040 #endif
4041 }
4042
4043 PP(pp_enetent)
4044 {
4045     djSP;
4046 #ifdef HAS_ENDNETENT
4047     PerlSock_endnetent();
4048     EXTEND(SP,1);
4049     RETPUSHYES;
4050 #else
4051     DIE(no_sock_func, "endnetent");
4052 #endif
4053 }
4054
4055 PP(pp_eprotoent)
4056 {
4057     djSP;
4058 #ifdef HAS_ENDPROTOENT
4059     PerlSock_endprotoent();
4060     EXTEND(SP,1);
4061     RETPUSHYES;
4062 #else
4063     DIE(no_sock_func, "endprotoent");
4064 #endif
4065 }
4066
4067 PP(pp_eservent)
4068 {
4069     djSP;
4070 #ifdef HAS_ENDSERVENT
4071     PerlSock_endservent();
4072     EXTEND(SP,1);
4073     RETPUSHYES;
4074 #else
4075     DIE(no_sock_func, "endservent");
4076 #endif
4077 }
4078
4079 PP(pp_gpwnam)
4080 {
4081 #ifdef HAS_PASSWD
4082     return pp_gpwent(ARGS);
4083 #else
4084     DIE(no_func, "getpwnam");
4085 #endif
4086 }
4087
4088 PP(pp_gpwuid)
4089 {
4090 #ifdef HAS_PASSWD
4091     return pp_gpwent(ARGS);
4092 #else
4093     DIE(no_func, "getpwuid");
4094 #endif
4095 }
4096
4097 PP(pp_gpwent)
4098 {
4099     djSP;
4100 #ifdef HAS_PASSWD
4101     I32 which = op->op_type;
4102     register SV *sv;
4103     struct passwd *pwent;
4104
4105     if (which == OP_GPWNAM)
4106         pwent = getpwnam(POPp);
4107     else if (which == OP_GPWUID)
4108         pwent = getpwuid(POPi);
4109     else
4110         pwent = (struct passwd *)getpwent();
4111
4112     EXTEND(SP, 10);
4113     if (GIMME != G_ARRAY) {
4114         PUSHs(sv = sv_newmortal());
4115         if (pwent) {
4116             if (which == OP_GPWNAM)
4117                 sv_setiv(sv, (IV)pwent->pw_uid);
4118             else
4119                 sv_setpv(sv, pwent->pw_name);
4120         }
4121         RETURN;
4122     }
4123
4124     if (pwent) {
4125         PUSHs(sv = sv_mortalcopy(&sv_no));
4126         sv_setpv(sv, pwent->pw_name);
4127         PUSHs(sv = sv_mortalcopy(&sv_no));
4128         sv_setpv(sv, pwent->pw_passwd);
4129         PUSHs(sv = sv_mortalcopy(&sv_no));
4130         sv_setiv(sv, (IV)pwent->pw_uid);
4131         PUSHs(sv = sv_mortalcopy(&sv_no));
4132         sv_setiv(sv, (IV)pwent->pw_gid);
4133         PUSHs(sv = sv_mortalcopy(&sv_no));
4134 #ifdef PWCHANGE
4135         sv_setiv(sv, (IV)pwent->pw_change);
4136 #else
4137 #ifdef PWQUOTA
4138         sv_setiv(sv, (IV)pwent->pw_quota);
4139 #else
4140 #ifdef PWAGE
4141         sv_setpv(sv, pwent->pw_age);
4142 #endif
4143 #endif
4144 #endif
4145         PUSHs(sv = sv_mortalcopy(&sv_no));
4146 #ifdef PWCLASS
4147         sv_setpv(sv, pwent->pw_class);
4148 #else
4149 #ifdef PWCOMMENT
4150         sv_setpv(sv, pwent->pw_comment);
4151 #endif
4152 #endif
4153         PUSHs(sv = sv_mortalcopy(&sv_no));
4154         sv_setpv(sv, pwent->pw_gecos);
4155 #ifndef INCOMPLETE_TAINTS
4156         SvTAINTED_on(sv);
4157 #endif
4158         PUSHs(sv = sv_mortalcopy(&sv_no));
4159         sv_setpv(sv, pwent->pw_dir);
4160         PUSHs(sv = sv_mortalcopy(&sv_no));
4161         sv_setpv(sv, pwent->pw_shell);
4162 #ifdef PWEXPIRE
4163         PUSHs(sv = sv_mortalcopy(&sv_no));
4164         sv_setiv(sv, (IV)pwent->pw_expire);
4165 #endif
4166     }
4167     RETURN;
4168 #else
4169     DIE(no_func, "getpwent");
4170 #endif
4171 }
4172
4173 PP(pp_spwent)
4174 {
4175     djSP;
4176 #if defined(HAS_PASSWD) && !defined(CYGWIN32)
4177     setpwent();
4178     RETPUSHYES;
4179 #else
4180     DIE(no_func, "setpwent");
4181 #endif
4182 }
4183
4184 PP(pp_epwent)
4185 {
4186     djSP;
4187 #ifdef HAS_PASSWD
4188     endpwent();
4189     RETPUSHYES;
4190 #else
4191     DIE(no_func, "endpwent");
4192 #endif
4193 }
4194
4195 PP(pp_ggrnam)
4196 {
4197 #ifdef HAS_GROUP
4198     return pp_ggrent(ARGS);
4199 #else
4200     DIE(no_func, "getgrnam");
4201 #endif
4202 }
4203
4204 PP(pp_ggrgid)
4205 {
4206 #ifdef HAS_GROUP
4207     return pp_ggrent(ARGS);
4208 #else
4209     DIE(no_func, "getgrgid");
4210 #endif
4211 }
4212
4213 PP(pp_ggrent)
4214 {
4215     djSP;
4216 #ifdef HAS_GROUP
4217     I32 which = op->op_type;
4218     register char **elem;
4219     register SV *sv;
4220     struct group *grent;
4221
4222     if (which == OP_GGRNAM)
4223         grent = (struct group *)getgrnam(POPp);
4224     else if (which == OP_GGRGID)
4225         grent = (struct group *)getgrgid(POPi);
4226     else
4227         grent = (struct group *)getgrent();
4228
4229     EXTEND(SP, 4);
4230     if (GIMME != G_ARRAY) {
4231         PUSHs(sv = sv_newmortal());
4232         if (grent) {
4233             if (which == OP_GGRNAM)
4234                 sv_setiv(sv, (IV)grent->gr_gid);
4235             else
4236                 sv_setpv(sv, grent->gr_name);
4237         }
4238         RETURN;
4239     }
4240
4241     if (grent) {
4242         PUSHs(sv = sv_mortalcopy(&sv_no));
4243         sv_setpv(sv, grent->gr_name);
4244         PUSHs(sv = sv_mortalcopy(&sv_no));
4245         sv_setpv(sv, grent->gr_passwd);
4246         PUSHs(sv = sv_mortalcopy(&sv_no));
4247         sv_setiv(sv, (IV)grent->gr_gid);
4248         PUSHs(sv = sv_mortalcopy(&sv_no));
4249         for (elem = grent->gr_mem; elem && *elem; elem++) {
4250             sv_catpv(sv, *elem);
4251             if (elem[1])
4252                 sv_catpvn(sv, " ", 1);
4253         }
4254     }
4255
4256     RETURN;
4257 #else
4258     DIE(no_func, "getgrent");
4259 #endif
4260 }
4261
4262 PP(pp_sgrent)
4263 {
4264     djSP;
4265 #ifdef HAS_GROUP
4266     setgrent();
4267     RETPUSHYES;
4268 #else
4269     DIE(no_func, "setgrent");
4270 #endif
4271 }
4272
4273 PP(pp_egrent)
4274 {
4275     djSP;
4276 #ifdef HAS_GROUP
4277     endgrent();
4278     RETPUSHYES;
4279 #else
4280     DIE(no_func, "endgrent");
4281 #endif
4282 }
4283
4284 PP(pp_getlogin)
4285 {
4286     djSP; dTARGET;
4287 #ifdef HAS_GETLOGIN
4288     char *tmps;
4289     EXTEND(SP, 1);
4290     if (!(tmps = getlogin()))
4291         RETPUSHUNDEF;
4292     PUSHp(tmps, strlen(tmps));
4293     RETURN;
4294 #else
4295     DIE(no_func, "getlogin");
4296 #endif
4297 }
4298
4299 /* Miscellaneous. */
4300
4301 PP(pp_syscall)
4302 {
4303 #ifdef HAS_SYSCALL
4304     djSP; dMARK; dORIGMARK; dTARGET;
4305     register I32 items = SP - MARK;
4306     unsigned long a[20];
4307     register I32 i = 0;
4308     I32 retval = -1;
4309     MAGIC *mg;
4310
4311     if (tainting) {
4312         while (++MARK <= SP) {
4313             if (SvTAINTED(*MARK)) {
4314                 TAINT;
4315                 break;
4316             }
4317         }
4318         MARK = ORIGMARK;
4319         TAINT_PROPER("syscall");
4320     }
4321
4322     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4323      * or where sizeof(long) != sizeof(char*).  But such machines will
4324      * not likely have syscall implemented either, so who cares?
4325      */
4326     while (++MARK <= SP) {
4327         if (SvNIOK(*MARK) || !i)
4328             a[i++] = SvIV(*MARK);
4329         else if (*MARK == &sv_undef)
4330             a[i++] = 0;
4331         else
4332             a[i++] = (unsigned long)SvPV_force(*MARK, na);
4333         if (i > 15)
4334             break;
4335     }
4336     switch (items) {
4337     default:
4338         DIE("Too many args to syscall");
4339     case 0:
4340         DIE("Too few args to syscall");
4341     case 1:
4342         retval = syscall(a[0]);
4343         break;
4344     case 2:
4345         retval = syscall(a[0],a[1]);
4346         break;
4347     case 3:
4348         retval = syscall(a[0],a[1],a[2]);
4349         break;
4350     case 4:
4351         retval = syscall(a[0],a[1],a[2],a[3]);
4352         break;
4353     case 5:
4354         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4355         break;
4356     case 6:
4357         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4358         break;
4359     case 7:
4360         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4361         break;
4362     case 8:
4363         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4364         break;
4365 #ifdef atarist
4366     case 9:
4367         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4368         break;
4369     case 10:
4370         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4371         break;
4372     case 11:
4373         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4374           a[10]);
4375         break;
4376     case 12:
4377         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4378           a[10],a[11]);
4379         break;
4380     case 13:
4381         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4382           a[10],a[11],a[12]);
4383         break;
4384     case 14:
4385         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4386           a[10],a[11],a[12],a[13]);
4387         break;
4388 #endif /* atarist */
4389     }
4390     SP = ORIGMARK;
4391     PUSHi(retval);
4392     RETURN;
4393 #else
4394     DIE(no_func, "syscall");
4395 #endif
4396 }
4397
4398 #ifdef FCNTL_EMULATE_FLOCK
4399
4400 /*  XXX Emulate flock() with fcntl().
4401     What's really needed is a good file locking module.
4402 */
4403
4404 static int
4405 fcntl_emulate_flock(int fd, int operation)
4406 {
4407     struct flock flock;
4408
4409     switch (operation & ~LOCK_NB) {
4410     case LOCK_SH:
4411         flock.l_type = F_RDLCK;
4412         break;
4413     case LOCK_EX:
4414         flock.l_type = F_WRLCK;
4415         break;
4416     case LOCK_UN:
4417         flock.l_type = F_UNLCK;
4418         break;
4419     default:
4420         errno = EINVAL;
4421         return -1;
4422     }
4423     flock.l_whence = SEEK_SET;
4424     flock.l_start = flock.l_len = 0L;
4425
4426     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4427 }
4428
4429 #endif /* FCNTL_EMULATE_FLOCK */
4430
4431 #ifdef LOCKF_EMULATE_FLOCK
4432
4433 /*  XXX Emulate flock() with lockf().  This is just to increase
4434     portability of scripts.  The calls are not completely
4435     interchangeable.  What's really needed is a good file
4436     locking module.
4437 */
4438
4439 /*  The lockf() constants might have been defined in <unistd.h>.
4440     Unfortunately, <unistd.h> causes troubles on some mixed
4441     (BSD/POSIX) systems, such as SunOS 4.1.3.
4442
4443    Further, the lockf() constants aren't POSIX, so they might not be
4444    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
4445    just stick in the SVID values and be done with it.  Sigh.
4446 */
4447
4448 # ifndef F_ULOCK
4449 #  define F_ULOCK       0       /* Unlock a previously locked region */
4450 # endif
4451 # ifndef F_LOCK
4452 #  define F_LOCK        1       /* Lock a region for exclusive use */
4453 # endif
4454 # ifndef F_TLOCK
4455 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
4456 # endif
4457 # ifndef F_TEST
4458 #  define F_TEST        3       /* Test a region for other processes locks */
4459 # endif
4460
4461 static int
4462 lockf_emulate_flock (fd, operation)
4463 int fd;
4464 int operation;
4465 {
4466     int i;
4467     int save_errno;
4468     Off_t pos;
4469
4470     /* flock locks entire file so for lockf we need to do the same      */
4471     save_errno = errno;
4472     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
4473     if (pos > 0)        /* is seekable and needs to be repositioned     */
4474         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
4475             pos = -1;   /* seek failed, so don't seek back afterwards   */
4476     errno = save_errno;
4477
4478     switch (operation) {
4479
4480         /* LOCK_SH - get a shared lock */
4481         case LOCK_SH:
4482         /* LOCK_EX - get an exclusive lock */
4483         case LOCK_EX:
4484             i = lockf (fd, F_LOCK, 0);
4485             break;
4486
4487         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4488         case LOCK_SH|LOCK_NB:
4489         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4490         case LOCK_EX|LOCK_NB:
4491             i = lockf (fd, F_TLOCK, 0);
4492             if (i == -1)
4493                 if ((errno == EAGAIN) || (errno == EACCES))
4494                     errno = EWOULDBLOCK;
4495             break;
4496
4497         /* LOCK_UN - unlock (non-blocking is a no-op) */
4498         case LOCK_UN:
4499         case LOCK_UN|LOCK_NB:
4500             i = lockf (fd, F_ULOCK, 0);
4501             break;
4502
4503         /* Default - can't decipher operation */
4504         default:
4505             i = -1;
4506             errno = EINVAL;
4507             break;
4508     }
4509
4510     if (pos > 0)      /* need to restore position of the handle */
4511         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
4512
4513     return (i);
4514 }
4515
4516 #endif /* LOCKF_EMULATE_FLOCK */
4517