pp_sys.c

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