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