pp_sys.c

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