pp_sys.c

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