pp_sys.c

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