pp_sys.c

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