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