pp_sys.c

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