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