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