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