pp_sys.c

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