pp_sys.c

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