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