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