pp_sys.c

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