pp_sys.c

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