pp_sys.c

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