pp_sys.c

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