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