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