contrib/perl5/pp_sys.c

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