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