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