pp_sys.c

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