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