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