pp_sys.c

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