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