pp_sys.c

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