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