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