pp_sys.c

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