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