pp_sys.c

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