X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=e1c6125dc97b038cb5b0943679df05ddb8f33f5a;hb=41c686de0da47eeb5df94342ffc739979e9aa57d;hp=0183325cb949949e6d9cee868a612c219dce47cf;hpb=40d98b499c15c6fadd7a92e47cf92625dad3fb51;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 0183325..e1c6125 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1,6 +1,7 @@ /* pp_sys.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -14,6 +15,15 @@ * a rumour and a trouble as of great engines throbbing and labouring. */ +/* This file contains system pp ("push/pop") functions that + * execute the opcodes that make up a perl program. A typical pp function + * expects to find its arguments on the stack, and usually pushes its + * results onto the stack, hence the 'pp' terminology. Each OP structure + * contains a pointer to the relevant pp_foo() function. + * + * By 'system', we mean ops which interact with the OS, such as pp_open(). + */ + #include "EXTERN.h" #define PERL_IN_PP_SYS_C #include "perl.h" @@ -35,12 +45,6 @@ # include #endif -#ifdef HAS_SYSCALL -#ifdef __cplusplus -extern "C" int syscall(unsigned long,...); -#endif -#endif - #ifdef I_SYS_WAIT # include #endif @@ -83,7 +87,7 @@ extern int h_errno; #ifndef getpwent struct passwd *getpwent (void); #elif defined (VMS) && defined (my_getpwent) - struct passwd *Perl_my_getpwent (void); + struct passwd *Perl_my_getpwent (pTHX); #endif # endif #endif @@ -115,6 +119,12 @@ extern int h_errno; # undef my_chsize # endif # define my_chsize PerlLIO_chsize +#else +# ifdef HAS_TRUNCATE +# define my_chsize PerlLIO_chsize +# else +I32 my_chsize(int fd, Off_t length); +# endif #endif #ifdef HAS_FLOCK @@ -163,7 +173,7 @@ extern int h_errno; #endif /* no flock() */ #define ZBTLEN 10 -static char zero_but_true[ZBTLEN + 1] = "0 but true"; +static const char zero_but_true[ZBTLEN + 1] = "0 but true"; #if defined(I_SYS_ACCESS) && !defined(R_OK) # include @@ -173,54 +183,68 @@ static char zero_but_true[ZBTLEN + 1] = "0 but true"; # define FD_CLOEXEC 1 /* NeXT needs this */ #endif -#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */ -#undef PERL_EFF_ACCESS_W_OK -#undef PERL_EFF_ACCESS_X_OK +#include "reentr.h" + +#ifdef __Lynx__ +/* Missing protos on LynxOS */ +void sethostent(int); +void endhostent(void); +void setnetent(int); +void endnetent(void); +void setprotoent(int); +void endprotoent(void); +void setservent(int); +void endservent(void); +#endif + +#undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */ + +/* AIX 5.2 and below use mktime for localtime, and defines the edge case + * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64 + * available in the 32bit environment, which could warrant Configure + * checks in the future. + */ +#ifdef _AIX +#define LOCALTIME_EDGECASE_BROKEN +#endif /* F_OK unused: if stat() cannot find it... */ -#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK) +#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK) /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */ -# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK)) -# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK)) -# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK)) +# define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK)) #endif -#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS) +#if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS) # ifdef I_SYS_SECURITY # include # endif # ifdef ACC_SELF /* HP SecureWare */ -# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF)) -# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF)) -# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF)) +# define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF)) # else /* SCO */ -# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK)) -# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK)) -# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK)) +# define PERL_EFF_ACCESS(p,f) (eaccess((p), (f))) # endif #endif -#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF) +#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF) /* AIX */ -# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF)) -# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF)) -# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF)) +# define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF)) #endif -#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \ + +#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \ && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \ || defined(HAS_SETREGID) || defined(HAS_SETRESGID)) /* The Hard Way. */ STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) { - Uid_t ruid = getuid(); - Uid_t euid = geteuid(); - Gid_t rgid = getgid(); - Gid_t egid = getegid(); + const Uid_t ruid = getuid(); + const Uid_t euid = geteuid(); + const Gid_t rgid = getgid(); + const Gid_t egid = getegid(); int res; LOCK_CRED_MUTEX; @@ -273,18 +297,18 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) return res; } -# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK)) -# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK)) -# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK)) +# define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f))) #endif -#if !defined(PERL_EFF_ACCESS_R_OK) +#if !defined(PERL_EFF_ACCESS) /* With it or without it: anyway you get a warning: either that it is unused, or it is declared static and never defined. */ STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) { + (void)path; + (void)mode; Perl_croak(aTHX_ "switching effective uid is not implemented"); /*NOTREACHED*/ return -1; @@ -293,12 +317,11 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) PP(pp_backtick) { - dSP; dTARGET; + dVAR; dSP; dTARGET; PerlIO *fp; - STRLEN n_a; - char *tmps = POPpx; - I32 gimme = GIMME_V; - char *mode = "r"; + const char * const tmps = POPpconstx; + const I32 gimme = GIMME_V; + const char *mode = "r"; TAINT_PROPER("``"); if (PL_op->op_private & OPpOPEN_IN_RAW) @@ -307,49 +330,45 @@ PP(pp_backtick) mode = "rt"; fp = PerlProc_popen(tmps, mode); if (fp) { - char *type = NULL; - if (PL_curcop->cop_io) { - type = SvPV_nolen(PL_curcop->cop_io); - } + const char * const type = PL_curcop->cop_io ? SvPV_nolen_const(PL_curcop->cop_io) : NULL; if (type && *type) PerlIO_apply_layers(aTHX_ fp,mode,type); if (gimme == G_VOID) { char tmpbuf[256]; while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) - /*SUPPRESS 530*/ ; } else if (gimme == G_SCALAR) { - sv_setpv(TARG, ""); /* note that this preserves previous buffer */ + ENTER; + SAVESPTR(PL_rs); + PL_rs = &PL_sv_undef; + sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch) - /*SUPPRESS 530*/ ; + LEAVE; XPUSHs(TARG); SvTAINTED_on(TARG); } else { - SV *sv; - for (;;) { - sv = NEWSV(56, 79); + SV * const sv = NEWSV(56, 79); if (sv_gets(sv, fp, 0) == Nullch) { SvREFCNT_dec(sv); break; } XPUSHs(sv_2mortal(sv)); if (SvLEN(sv) - SvCUR(sv) > 20) { - SvLEN_set(sv, SvCUR(sv)+1); - Renew(SvPVX(sv), SvLEN(sv), char); + SvPV_shrink_to_cur(sv); } SvTAINTED_on(sv); } } - STATUS_NATIVE_SET(PerlProc_pclose(fp)); + STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp)); TAINT; /* "I believe that this is not gratuitous!" */ } else { - STATUS_NATIVE_SET(-1); + STATUS_NATIVE_CHILD_SET(-1); if (gimme == G_SCALAR) RETPUSHUNDEF; } @@ -359,6 +378,7 @@ PP(pp_backtick) PP(pp_glob) { + dVAR; OP *result; tryAMAGICunTARGET(iter, -1); @@ -383,7 +403,7 @@ PP(pp_glob) PL_last_in_gv = (GV*)*PL_stack_sp--; SAVESPTR(PL_rs); /* This is not permanent, either. */ - PL_rs = sv_2mortal(newSVpvn("\000", 1)); + PL_rs = sv_2mortal(newSVpvs("\000")); #ifndef DOSISH #ifndef CSH *SvPVX(PL_rs) = '\n'; @@ -397,36 +417,41 @@ PP(pp_glob) PP(pp_rcatline) { + dVAR; PL_last_in_gv = cGVOP_gv; return do_readline(); } PP(pp_warn) { - dSP; dMARK; + dVAR; dSP; dMARK; SV *tmpsv; - char *tmps; + const char *tmps; STRLEN len; - if (SP - MARK != 1) { + if (SP - MARK > 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); tmpsv = TARG; SP = MARK + 1; } + else if (SP == MARK) { + tmpsv = &PL_sv_no; + EXTEND(SP, 1); + } else { tmpsv = TOPs; } - tmps = SvPV(tmpsv, len); - if (!tmps || !len) { - SV *error = ERRSV; - (void)SvUPGRADE(error, SVt_PV); + tmps = SvPV_const(tmpsv, len); + if ((!tmps || !len) && PL_errgv) { + SV * const error = ERRSV; + SvUPGRADE(error, SVt_PV); if (SvPOK(error) && SvCUR(error)) - sv_catpv(error, "\t...caught"); + sv_catpvs(error, "\t...caught"); tmpsv = error; - tmps = SvPV(tmpsv, len); + tmps = SvPV_const(tmpsv, len); } if (!tmps || !len) - tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26)); + tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong")); Perl_warn(aTHX_ "%"SVf, tmpsv); RETSETYES; @@ -434,8 +459,8 @@ PP(pp_warn) PP(pp_die) { - dSP; dMARK; - char *tmps; + dVAR; dSP; dMARK; + const char *tmps; SV *tmpsv; STRLEN len; bool multiarg = 0; @@ -446,26 +471,26 @@ PP(pp_die) dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); tmpsv = TARG; - tmps = SvPV(tmpsv, len); + tmps = SvPV_const(tmpsv, len); multiarg = 1; SP = MARK + 1; } else { tmpsv = TOPs; - tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len); + tmps = SvROK(tmpsv) ? Nullch : SvPV_const(tmpsv, len); } if (!tmps || !len) { - SV *error = ERRSV; - (void)SvUPGRADE(error, SVt_PV); + SV * const error = ERRSV; + SvUPGRADE(error, SVt_PV); if (multiarg ? SvROK(error) : SvROK(tmpsv)) { if (!multiarg) SvSetSV(error,tmpsv); else if (sv_isobject(error)) { - HV *stash = SvSTASH(SvRV(error)); - GV *gv = gv_fetchmethod(stash, "PROPAGATE"); + HV * const stash = SvSTASH(SvRV(error)); + GV * const gv = gv_fetchmethod(stash, "PROPAGATE"); if (gv) { - SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); - SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); + SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); + SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); EXTEND(SP, 3); PUSHMARK(SP); PUSHs(error); @@ -477,17 +502,20 @@ PP(pp_die) sv_setsv(error,*PL_stack_sp--); } } - DIE(aTHX_ Nullformat); + DIE(aTHX_ Nullch); } else { if (SvPOK(error) && SvCUR(error)) - sv_catpv(error, "\t...propagated"); + sv_catpvs(error, "\t...propagated"); tmpsv = error; - tmps = SvPV(tmpsv, len); + if (SvOK(tmpsv)) + tmps = SvPV_const(tmpsv, len); + else + tmps = Nullch; } } if (!tmps || !len) - tmpsv = sv_2mortal(newSVpvn("Died", 4)); + tmpsv = sv_2mortal(newSVpvs("Died")); DIE(aTHX_ "%"SVf, tmpsv); } @@ -496,44 +524,46 @@ PP(pp_die) PP(pp_open) { - dSP; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; - GV *gv; SV *sv; IO *io; - char *tmps; + const char *tmps; STRLEN len; - MAGIC *mg; bool ok; - gv = (GV *)*++MARK; + GV * const gv = (GV *)*++MARK; + if (!isGV(gv)) DIE(aTHX_ PL_no_usym, "filehandle"); if ((io = GvIOp(gv))) IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; - if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { - /* Method's args are same as ours ... */ - /* ... except handle is replaced by the object */ - *MARK-- = SvTIED_obj((SV*)io, mg); - PUSHMARK(MARK); - PUTBACK; - ENTER; - call_method("OPEN", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + if (io) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + /* Method's args are same as ours ... */ + /* ... except handle is replaced by the object */ + *MARK-- = SvTIED_obj((SV*)io, mg); + PUSHMARK(MARK); + PUTBACK; + ENTER; + call_method("OPEN", G_SCALAR); + LEAVE; + SPAGAIN; + RETURN; + } } if (MARK < SP) { sv = *++MARK; } else { - sv = GvSV(gv); + sv = GvSVn(gv); } - tmps = SvPV(sv, len); + tmps = SvPV_const(sv, len); ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK)); SP = ORIGMARK; if (ok) @@ -547,15 +577,10 @@ PP(pp_open) PP(pp_close) { - dSP; - GV *gv; + dVAR; dSP; IO *io; MAGIC *mg; - - if (MAXARG == 0) - gv = PL_defoutgv; - else - gv = (GV*)POPs; + GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs; if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) @@ -577,15 +602,14 @@ PP(pp_close) PP(pp_pipe_op) { #ifdef HAS_PIPE + dVAR; dSP; - GV *rgv; - GV *wgv; register IO *rstio; register IO *wstio; int fd[2]; - wgv = (GV*)POPs; - rgv = (GV*)POPs; + GV * const wgv = (GV*)POPs; + GV * const rgv = (GV*)POPs; if (!rgv || !wgv) goto badexit; @@ -603,8 +627,9 @@ PP(pp_pipe_op) if (PerlProc_pipe(fd) < 0) goto badexit; - IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); - IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); + IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE); + IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE); + IoOFP(rstio) = IoIFP(rstio); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = IoTYPE_RDONLY; IoTYPE(wstio) = IoTYPE_WRONLY; @@ -631,7 +656,7 @@ badexit: PP(pp_fileno) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -669,8 +694,10 @@ PP(pp_fileno) PP(pp_umask) { - dSP; dTARGET; + dVAR; + dSP; #ifdef HAS_UMASK + dTARGET; Mode_t anum; if (MAXARG < 1) { @@ -682,7 +709,7 @@ PP(pp_umask) TAINT_PROPER("umask"); XPUSHi(anum); #else - /* Only DIE if trying to restrict permissions on `user' (self). + /* Only DIE if trying to restrict permissions on "user" (self). * Otherwise it's harmless and more useful to just return undef * since 'group' and 'other' concepts probably don't exist here. */ if (MAXARG >= 1 && (POPi & 0700)) @@ -694,7 +721,7 @@ PP(pp_umask) PP(pp_binmode) { - dSP; + dVAR; dSP; GV *gv; IO *io; PerlIO *fp; @@ -728,12 +755,21 @@ PP(pp_binmode) if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } PUTBACK; if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), - (discp) ? SvPV_nolen(discp) : Nullch)) { + (discp) ? SvPV_nolen_const(discp) : Nullch)) { + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { + if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io), + mode_from_discipline(discp), + (discp) ? SvPV_nolen_const(discp) : Nullch)) { + SPAGAIN; + RETPUSHUNDEF; + } + } SPAGAIN; RETPUSHYES; } @@ -745,23 +781,20 @@ PP(pp_binmode) PP(pp_tie) { - dSP; - dMARK; - SV *varsv; + dVAR; dSP; dMARK; HV* stash; GV *gv; SV *sv; - I32 markoff = MARK - PL_stack_base; - char *methname; + const I32 markoff = MARK - PL_stack_base; + const char *methname; int how = PERL_MAGIC_tied; U32 items; - STRLEN n_a; + SV *varsv = *++MARK; - varsv = *++MARK; switch(SvTYPE(varsv)) { case SVt_PVHV: methname = "TIEHASH"; - HvEITER((HV *)varsv) = Null(HE *); + HvEITER_set((HV *)varsv, 0); break; case SVt_PVAV: methname = "TIEARRAY"; @@ -802,8 +835,8 @@ PP(pp_tie) */ stash = gv_stashsv(*MARK, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { - DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(*MARK,n_a)); + DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", + methname, *MARK); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -822,11 +855,11 @@ PP(pp_tie) sv_unmagic(varsv, how); /* Croak if a self-tie on an aggregate is attempted. */ if (varsv == SvRV(sv) && - (SvTYPE(sv) == SVt_PVAV || - SvTYPE(sv) == SVt_PVHV)) + (SvTYPE(varsv) == SVt_PVAV || + SvTYPE(varsv) == SVt_PVHV)) Perl_croak(aTHX_ "Self-ties of arrays and hashes are not supported"); - sv_magic(varsv, sv, how, Nullch, 0); + sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0); } LEAVE; SP = PL_stack_base + markoff; @@ -836,22 +869,21 @@ PP(pp_tie) PP(pp_untie) { - dSP; + dVAR; dSP; MAGIC *mg; SV *sv = POPs; - char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) + const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) RETPUSHYES; if ((mg = SvTIED_mg(sv, how))) { - SV *obj = SvRV(mg->mg_obj); - GV *gv; - CV *cv = NULL; + SV * const obj = SvRV(SvTIED_obj(sv, mg)); if (obj) { - if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) && - isGV(gv) && (cv = GvCV(gv))) { + GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE); + CV *cv; + if (gv && isGV(gv) && (cv = GvCV(gv))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)gv, mg)); XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1))); @@ -861,24 +893,24 @@ PP(pp_untie) LEAVE; SPAGAIN; } - else if (ckWARN(WARN_UNTIE)) { - if (mg && SvREFCNT(obj) > 1) + else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) { Perl_warner(aTHX_ packWARN(WARN_UNTIE), "untie attempted while %"UVuf" inner references still exist", (UV)SvREFCNT(obj) - 1 ) ; - } + } } - sv_unmagic(sv, how) ; } + sv_unmagic(sv, how) ; RETPUSHYES; } PP(pp_tied) { + dVAR; dSP; - MAGIC *mg; + const MAGIC *mg; SV *sv = POPs; - char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) + const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) @@ -896,16 +928,14 @@ PP(pp_tied) PP(pp_dbmopen) { - dSP; - HV *hv; + dVAR; dSP; dPOPPOPssrl; HV* stash; GV *gv; - SV *sv; - hv = (HV*)POPs; + HV * const hv = (HV*)POPs; + SV * const sv = sv_mortalcopy(&PL_sv_no); - sv = sv_mortalcopy(&PL_sv_no); sv_setpv(sv, "AnyDBM_File"); stash = gv_stashsv(sv, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) { @@ -951,15 +981,10 @@ PP(pp_dbmopen) RETURN; } -PP(pp_dbmclose) -{ - return pp_untie(); -} - PP(pp_sselect) { #ifdef HAS_SELECT - dSP; dTARGET; + dVAR; dSP; dTARGET; register I32 i; register I32 j; register char *s; @@ -971,7 +996,6 @@ PP(pp_sselect) struct timeval *tbuf = &timebuf; I32 growsize; char *fd_sets[4]; - STRLEN n_a; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 I32 masksize; I32 offset; @@ -987,9 +1011,21 @@ PP(pp_sselect) SP -= 4; for (i = 1; i <= 3; i++) { - if (!SvPOK(SP[i])) + SV * const sv = SP[i]; + if (!SvOK(sv)) continue; - j = SvCUR(SP[i]); + if (SvREADONLY(sv)) { + if (SvIsCOW(sv)) + sv_force_normal_flags(sv, 0); + if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0)) + DIE(aTHX_ PL_no_modify); + } + if (!SvPOK(sv)) { + if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); + SvPV_force_nolen(sv); /* force string conversion */ + } + j = SvCUR(sv); if (maxlen < j) maxlen = j; } @@ -1009,15 +1045,19 @@ PP(pp_sselect) Zero(&fd_sets[0], 4, char*); #endif -# if SELECT_MIN_BITS > 1 +# if SELECT_MIN_BITS == 1 + growsize = sizeof(fd_set); +# else +# if defined(__GLIBC__) && defined(__FD_SETSIZE) +# undef SELECT_MIN_BITS +# define SELECT_MIN_BITS __FD_SETSIZE +# endif /* If SELECT_MIN_BITS is greater than one we most probably will want * to align the sizes with SELECT_MIN_BITS/8 because for example * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates * on (sets/tests/clears bits) is 32 bits. */ growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); -# else - growsize = sizeof(fd_set); # endif sv = SP[4]; @@ -1034,12 +1074,11 @@ PP(pp_sselect) for (i = 1; i <= 3; i++) { sv = SP[i]; - if (!SvOK(sv)) { + if (!SvOK(sv) || SvCUR(sv) == 0) { fd_sets[i] = 0; continue; } - else if (!SvPOK(sv)) - SvPV_force(sv,n_a); /* force string conversion */ + assert(SvPOK(sv)); j = SvLEN(sv); if (j < growsize) { Sv_Grow(sv, growsize); @@ -1052,7 +1091,7 @@ PP(pp_sselect) #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 s = SvPVX(sv); - New(403, fd_sets[i], growsize, char); + Newx(fd_sets[i], growsize, char); for (offset = 0; offset < growsize; offset += masksize) { for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) fd_sets[i][j+offset] = s[(k % masksize) + offset]; @@ -1062,12 +1101,23 @@ PP(pp_sselect) #endif } +#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST + /* Can't make just the (void*) conditional because that would be + * cpp #if within cpp macro, and not all compilers like that. */ + nfound = PerlSock_select( + maxlen * 8, + (Select_fd_set_t) fd_sets[1], + (Select_fd_set_t) fd_sets[2], + (Select_fd_set_t) fd_sets[3], + (void*) tbuf); /* Workaround for compiler bug. */ +#else nfound = PerlSock_select( maxlen * 8, (Select_fd_set_t) fd_sets[1], (Select_fd_set_t) fd_sets[2], (Select_fd_set_t) fd_sets[3], tbuf); +#endif for (i = 1; i <= 3; i++) { if (fd_sets[i]) { sv = SP[i]; @@ -1099,6 +1149,7 @@ PP(pp_sselect) void Perl_setdefout(pTHX_ GV *gv) { + dVAR; if (gv) (void)SvREFCNT_inc(gv); if (PL_defoutgv) @@ -1108,20 +1159,18 @@ Perl_setdefout(pTHX_ GV *gv) PP(pp_select) { - dSP; dTARGET; - GV *newdefout, *egv; + dVAR; dSP; dTARGET; HV *hv; + GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL; + GV * egv = GvEGV(PL_defoutgv); - newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL; - - egv = GvEGV(PL_defoutgv); if (!egv) egv = PL_defoutgv; hv = GvSTASH(egv); if (! hv) XPUSHs(&PL_sv_undef); else { - GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); + GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); if (gvp && *gvp == egv) { gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE); XPUSHTARG; @@ -1142,20 +1191,15 @@ PP(pp_select) PP(pp_getc) { - dSP; dTARGET; - GV *gv; + dVAR; dSP; dTARGET; IO *io = NULL; MAGIC *mg; - - if (MAXARG == 0) - gv = PL_stdingv; - else - gv = (GV*)POPs; + GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs; if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; @@ -1168,17 +1212,18 @@ PP(pp_getc) RETURN; } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED) - && (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))) + if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) + && ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } TAINT; - sv_setpv(TARG, " "); + sv_setpvn(TARG, " ", 1); *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) { /* Find out how many bytes the char needs */ - Size_t len = UTF8SKIP(SvPVX(TARG)); + Size_t len = UTF8SKIP(SvPVX_const(TARG)); if (len > 1) { SvGROW(TARG,len+1); len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1); @@ -1190,27 +1235,21 @@ PP(pp_getc) RETURN; } -PP(pp_read) -{ - return pp_sysread(); -} - STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { + dVAR; register PERL_CONTEXT *cx; - I32 gimme = GIMME_V; - AV* padlist = CvPADLIST(cv); - SV** svp = AvARRAY(padlist); + const I32 gimme = GIMME_V; ENTER; SAVETMPS; - push_return(retop); PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx); - SAVEVPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)svp[1]); + cx->blk_sub.retop = retop; + SAVECOMPPAD(); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); @@ -1218,6 +1257,7 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PP(pp_enterwrite) { + dVAR; dSP; register GV *gv; register IO *io; @@ -1243,14 +1283,14 @@ PP(pp_enterwrite) cv = GvFORM(fgv); if (!cv) { - char *name = NULL; if (fgv) { - SV *tmpsv = sv_newmortal(); + SV * const tmpsv = sv_newmortal(); + const char *name; gv_efullname4(tmpsv, fgv, Nullch, FALSE); - name = SvPV_nolen(tmpsv); + name = SvPV_nolen_const(tmpsv); + if (name && *name) + DIE(aTHX_ "Undefined format \"%s\" called", name); } - if (name && *name) - DIE(aTHX_ "Undefined format \"%s\" called", name); DIE(aTHX_ "Not a format reference"); } if (CvCLONE(cv)) @@ -1262,10 +1302,10 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dSP; - GV *gv = cxstack[cxstack_ix].blk_sub.gv; - register IO *io = GvIOp(gv); - PerlIO *ofp = IoOFP(io); + dVAR; dSP; + GV * const gv = cxstack[cxstack_ix].blk_sub.gv; + register IO * const io = GvIOp(gv); + PerlIO * const ofp = IoOFP(io); PerlIO *fp; SV **newsp; I32 gimme; @@ -1282,29 +1322,29 @@ PP(pp_leavewrite) CV *cv; if (!IoTOP_GV(io)) { GV *topgv; - SV *topname; if (!IoTOP_NAME(io)) { + SV *topname; if (!IoFMT_NAME(io)) IoFMT_NAME(io) = savepv(GvNAME(gv)); - topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io))); - topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM); + topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv))); + topgv = gv_fetchsv(topname, 0, SVt_PVFM); if ((topgv && GvFORM(topgv)) || - !gv_fetchpv("top",FALSE,SVt_PVFM)) - IoTOP_NAME(io) = savepv(SvPVX(topname)); + !gv_fetchpv("top", 0, SVt_PVFM)) + IoTOP_NAME(io) = savesvpv(topname); else - IoTOP_NAME(io) = savepv("top"); + IoTOP_NAME(io) = savepvs("top"); } - topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM); + topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM); if (!topgv || !GvFORM(topgv)) { - IoLINES_LEFT(io) = 100000000; + IoLINES_LEFT(io) = IoPAGE_LEN(io); goto forget_top; } IoTOP_GV(io) = topgv; } if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */ I32 lines = IoLINES_LEFT(io); - char *s = SvPVX(PL_formtarget); + const char *s = SvPVX_const(PL_formtarget); if (lines <= 0) /* Yow, header didn't even fit!!! */ goto forget_top; while (lines-- > 0) { @@ -1314,8 +1354,8 @@ PP(pp_leavewrite) s++; } if (s) { - STRLEN save = SvCUR(PL_formtarget); - SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget)); + const STRLEN save = SvCUR(PL_formtarget); + SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget)); do_print(PL_formtarget, ofp); SvCUR_set(PL_formtarget, save); sv_chop(PL_formtarget, s); @@ -1332,20 +1372,18 @@ PP(pp_leavewrite) if (!fgv) DIE(aTHX_ "bad top format reference"); cv = GvFORM(fgv); - { - char *name = NULL; - if (!cv) { - SV *sv = sv_newmortal(); - gv_efullname4(sv, fgv, Nullch, FALSE); - name = SvPV_nolen(sv); - } + if (!cv) { + SV * const sv = sv_newmortal(); + const char *name; + gv_efullname4(sv, fgv, Nullch, FALSE); + name = SvPV_nolen_const(sv); if (name && *name) - DIE(aTHX_ "Undefined top format \"%s\" called",name); - /* why no: - else - DIE(aTHX_ "Undefined top format called"); - ?*/ + DIE(aTHX_ "Undefined top format \"%s\" called",name); } + /* why no: + else + DIE(aTHX_ "Undefined top format called"); + ?*/ if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); return doform(cv,gv,PL_op); @@ -1359,21 +1397,8 @@ PP(pp_leavewrite) fp = IoOFP(io); if (!fp) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { - if (IoIFP(io)) { - /* integrate with report_evil_fh()? */ - char *name = NULL; - if (isGV(gv)) { - SV* sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for input", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for input"); - } + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } @@ -1398,22 +1423,20 @@ PP(pp_leavewrite) /* bad_ofp: */ PL_formtarget = PL_bodytarget; PUTBACK; - return pop_return(); + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + return cx->blk_sub.retop; } PP(pp_prtf) { - dSP; dMARK; dORIGMARK; - GV *gv; + dVAR; dSP; dMARK; dORIGMARK; IO *io; PerlIO *fp; SV *sv; MAGIC *mg; - if (PL_op->op_flags & OPf_STACKED) - gv = (GV*)*++MARK; - else - gv = PL_defoutgv; + GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv; if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) @@ -1441,29 +1464,17 @@ PP(pp_prtf) if (!(io = GvIO(gv))) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { - /* integrate with report_evil_fh()? */ - if (IoIFP(io)) { - char *name = NULL; - if (isGV(gv)) { - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for input", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for input"); - } + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } - SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); + SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); goto just_say_no; } else { @@ -1489,24 +1500,17 @@ PP(pp_prtf) PP(pp_sysopen) { + dVAR; dSP; - GV *gv; - SV *sv; - char *tmps; + const int perm = (MAXARG > 3) ? POPi : 0666; + const int mode = POPi; + SV * const sv = POPs; + GV * const gv = (GV *)POPs; STRLEN len; - int mode, perm; - - if (MAXARG > 3) - perm = POPi; - else - perm = 0666; - mode = POPi; - sv = POPs; - gv = (GV *)POPs; /* Need TIEHANDLE method ? */ - - tmps = SvPV(sv, len); + const char * const tmps = SvPV_const(sv, len); + /* FIXME? do_open should do const */ if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) { IoLINES(GvIOp(gv)) = 0; PUSHs(&PL_sv_yes); @@ -1519,9 +1523,8 @@ PP(pp_sysopen) PP(pp_sysread) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; int offset; - GV *gv; IO *io; char *buffer; SSize_t length; @@ -1529,31 +1532,33 @@ PP(pp_sysread) Sock_size_t bufsize; SV *bufsv; STRLEN blen; - MAGIC *mg; int fp_utf8; + int buffer_utf8; + SV *read_target; Size_t got = 0; Size_t wanted; bool charstart = FALSE; STRLEN charskip = 0; STRLEN skip = 0; - gv = (GV*)*++MARK; + GV * const gv = (GV*)*++MARK; if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) - && gv && (io = GvIO(gv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + && gv && (io = GvIO(gv)) ) { - SV *sv; - - PUSHMARK(MARK-1); - *MARK = SvTIED_obj((SV*)io, mg); - ENTER; - call_method("READ", G_SCALAR); - LEAVE; - SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); - RETURN; + const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + SV *sv; + PUSHMARK(MARK-1); + *MARK = SvTIED_obj((SV*)io, mg); + ENTER; + call_method("READ", G_SCALAR); + LEAVE; + SPAGAIN; + sv = POPs; + SP = ORIGMARK; + PUSHs(sv); + RETURN; + } } if (!gv) @@ -1568,15 +1573,21 @@ PP(pp_sysread) else offset = 0; io = GvIO(gv); - if (!io || !IoIFP(io)) + if (!io || !IoIFP(io)) { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); goto say_undef; + } if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { buffer = SvPVutf8_force(bufsv, blen); - /* UTF8 may not have been set if they are all low bytes */ + /* UTF-8 may not have been set if they are all low bytes */ SvUTF8_on(bufsv); + buffer_utf8 = 0; } else { buffer = SvPV_force(bufsv, blen); + buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); } if (length < 0) DIE(aTHX_ "Negative length"); @@ -1637,15 +1648,37 @@ PP(pp_sysread) } if (DO_UTF8(bufsv)) { /* convert offset-as-chars to offset-as-bytes */ - offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; + if (offset >= (int)blen) + offset += SvCUR(bufsv) - blen; + else + offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; } more_bytes: bufsize = SvCUR(bufsv); + /* Allocating length + offset + 1 isn't perfect in the case of reading + bytes from a byte file handle into a UTF8 buffer, but it won't harm us + unduly. + (should be 2 * length + offset + 1, or possibly something longer if + PL_encoding is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); - if (offset > bufsize) { /* Zero any newly allocated space */ + if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */ Zero(buffer+bufsize, offset-bufsize, char); } buffer = buffer + offset; + if (!buffer_utf8) { + read_target = bufsv; + } else { + /* Best to read the bytes into a new SV, upgrade that to UTF8, then + concatenate it to the current buffer. */ + + /* Truncate the existing buffer to the start of where we will be + reading to: */ + SvCUR_set(bufsv, offset); + + read_target = sv_newmortal(); + SvUPGRADE(read_target, SVt_PV); + buffer = SvGROW(read_target, (STRLEN)(length + 1)); + } if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV @@ -1682,29 +1715,15 @@ PP(pp_sysread) } if (count < 0) { if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO)) - { - /* integrate with report_evil_fh()? */ - char *name = NULL; - if (isGV(gv)) { - SV* sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for output", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for output"); - } + report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); goto say_undef; } - SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv))); - *SvEND(bufsv) = '\0'; - (void)SvPOK_only(bufsv); + SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target))); + *SvEND(read_target) = '\0'; + (void)SvPOK_only(read_target); if (fp_utf8 && !IN_BYTES) { /* Look at utf8 we got back and count the characters */ - char *bend = buffer + count; + const char *bend = buffer + count; while (buffer < bend) { if (charstart) { skip = UTF8SKIP(buffer); @@ -1713,7 +1732,7 @@ PP(pp_sysread) if (buffer - charskip + skip > bend) { /* partial character - try for rest of it */ length = skip - (bend-buffer); - offset = bend - SvPVX(bufsv); + offset = bend - SvPVX_const(bufsv); charstart = FALSE; charskip += count; goto more_bytes; @@ -1730,13 +1749,18 @@ PP(pp_sysread) */ if (got < wanted && count == length) { length = wanted - got; - offset = bend - SvPVX(bufsv); + offset = bend - SvPVX_const(bufsv); goto more_bytes; } /* return value is character count */ count = got; SvUTF8_on(bufsv); } + else if (buffer_utf8) { + /* Let svcatsv upgrade the bytes we read in to utf8. + The buffer is a mortal so will be freed soon. */ + sv_catsv_nomg(bufsv, read_target); + } SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ if (!(IoFLAGS(io) & IOf_UNTAINT)) @@ -1750,41 +1774,34 @@ PP(pp_sysread) RETPUSHUNDEF; } -PP(pp_syswrite) -{ - dSP; - int items = (SP - PL_stack_base) - TOPMARK; - if (items == 2) { - SV *sv; - EXTEND(SP, 1); - sv = sv_2mortal(newSViv(sv_len(*SP))); - PUSHs(sv); - PUTBACK; - } - return pp_send(); -} - PP(pp_send) { - dSP; dMARK; dORIGMARK; dTARGET; - GV *gv; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; IO *io; SV *bufsv; - char *buffer; - Size_t length; + const char *buffer; + Size_t length = 0; SSize_t retval; STRLEN blen; MAGIC *mg; - - gv = (GV*)*++MARK; + const int op_type = PL_op->op_type; + + GV *const gv = (GV*)*++MARK; if (PL_op->op_type == OP_SYSWRITE && gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { SV *sv; + + if (MARK == SP - 1) { + EXTEND(SP, 1000); + sv = sv_2mortal(newSViv(sv_len(*SP))); + PUSHs(sv); + PUTBACK; + } - PUSHMARK(MARK-1); - *MARK = SvTIED_obj((SV*)io, mg); + PUSHMARK(ORIGMARK); + *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg); ENTER; call_method("WRITE", G_SCALAR); LEAVE; @@ -1796,33 +1813,49 @@ PP(pp_send) } if (!gv) goto say_undef; + bufsv = *++MARK; + + if (op_type == OP_SYSWRITE) { + if (MARK >= SP) { + length = (Size_t) sv_len(bufsv); + } else { #if Size_t_size > IVSIZE - length = (Size_t)SvNVx(*++MARK); + length = (Size_t)SvNVx(*++MARK); #else - length = (Size_t)SvIVx(*++MARK); + length = (Size_t)SvIVx(*++MARK); #endif - if ((SSize_t)length < 0) - DIE(aTHX_ "Negative length"); + if ((SSize_t)length < 0) + DIE(aTHX_ "Negative length"); + } + } SETERRNO(0,0); io = GvIO(gv); if (!io || !IoIFP(io)) { retval = -1; if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); goto say_undef; } if (PerlIO_isutf8(IoIFP(io))) { - buffer = SvPVutf8(bufsv, blen); + if (!SvUTF8(bufsv)) { + bufsv = sv_2mortal(newSVsv(bufsv)); + buffer = sv_2pvutf8(bufsv, &blen); + } else + buffer = SvPV_const(bufsv, blen); } else { - if (DO_UTF8(bufsv)) - sv_utf8_downgrade(bufsv, FALSE); - buffer = SvPV(bufsv, blen); + if (DO_UTF8(bufsv)) { + /* Not modifying source SV, so making a temporary copy. */ + bufsv = sv_2mortal(newSVsv(bufsv)); + sv_utf8_downgrade(bufsv, FALSE); + } + buffer = SvPV_const(bufsv, blen); } - if (PL_op->op_type == OP_SYSWRITE) { + if (op_type == OP_SYSWRITE) { IV offset; if (DO_UTF8(bufsv)) { /* length and offset are in chars */ @@ -1841,7 +1874,7 @@ PP(pp_send) if (length > blen - offset) length = blen - offset; if (DO_UTF8(bufsv)) { - buffer = (char*)utf8_hop((U8 *)buffer, offset); + buffer = (const char*)utf8_hop((const U8 *)buffer, offset); length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; } else { @@ -1861,17 +1894,19 @@ PP(pp_send) } } #ifdef HAS_SOCKET - else if (SP > MARK) { - char *sockbuf; - STRLEN mlen; - sockbuf = SvPVx(*++MARK, mlen); - /* length is really flags */ - retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, - length, (struct sockaddr *)sockbuf, mlen); + else { + const int flags = SvIVx(*++MARK); + if (SP > MARK) { + STRLEN mlen; + char * const sockbuf = SvPVx(*++MARK, mlen); + retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, + flags, (struct sockaddr *)sockbuf, mlen); + } + else { + retval + = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags); + } } - else - /* length is really flags */ - retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length); #else else DIE(aTHX_ PL_no_sock_func, "send"); @@ -1893,14 +1928,9 @@ PP(pp_send) RETPUSHUNDEF; } -PP(pp_recv) -{ - return pp_sysread(); -} - PP(pp_eof) { - dSP; + dVAR; dSP; GV *gv; IO *io; MAGIC *mg; @@ -1947,15 +1977,14 @@ PP(pp_eof) PP(pp_tell) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io; MAGIC *mg; - if (MAXARG == 0) - gv = PL_last_in_gv; - else - gv = PL_last_in_gv = (GV*)POPs; + if (MAXARG != 0) + PL_last_in_gv = (GV*)POPs; + gv = PL_last_in_gv; if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) @@ -1978,25 +2007,19 @@ PP(pp_tell) RETURN; } -PP(pp_seek) -{ - return pp_sysseek(); -} - PP(pp_sysseek) { - dSP; - GV *gv; + dVAR; dSP; IO *io; - int whence = POPi; + const int whence = POPi; #if LSEEKSIZE > IVSIZE - Off_t offset = (Off_t)SvNVx(POPs); + const Off_t offset = (Off_t)SvNVx(POPs); #else - Off_t offset = (Off_t)SvIVx(POPs); + const Off_t offset = (Off_t)SvIVx(POPs); #endif MAGIC *mg; - gv = PL_last_in_gv = (GV*)POPs; + GV * const gv = PL_last_in_gv = (GV*)POPs; if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) @@ -2020,11 +2043,11 @@ PP(pp_sysseek) if (PL_op->op_type == OP_SEEK) PUSHs(boolSV(do_seek(gv, offset, whence))); else { - Off_t sought = do_sysseek(gv, offset, whence); + const Off_t sought = do_sysseek(gv, offset, whence); if (sought < 0) PUSHs(&PL_sv_undef); else { - SV* sv = sought ? + SV* const sv = sought ? #if LSEEKSIZE > IVSIZE newSVnv((NV)sought) #else @@ -2039,6 +2062,7 @@ PP(pp_sysseek) PP(pp_truncate) { + dVAR; dSP; /* There seems to be no consensus on the length type of truncate() * and ftruncate(), both off_t and size_t have supporters. In @@ -2047,7 +2071,7 @@ PP(pp_truncate) /* XXX Configure probe for the length type of *truncate() needed XXX */ Off_t len; -#if Size_t_size > IVSIZE +#if Off_t_size > IVSIZE len = (Off_t)POPn; #else len = (Off_t)POPi; @@ -2056,52 +2080,63 @@ PP(pp_truncate) * might not be signed: if it is not, clever compilers will moan. */ /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ SETERRNO(0,0); -#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP) { - STRLEN n_a; int result = 1; GV *tmpgv; - + IO *io; + if (PL_op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO); + tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO); - do_ftruncate: - TAINT_PROPER("truncate"); - if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv))) - result = 0; + do_ftruncate_gv: + if (!GvIO(tmpgv)) + result = 0; else { - PerlIO_flush(IoIFP(GvIOp(tmpgv))); + PerlIO *fp; + io = GvIOp(tmpgv); + do_ftruncate_io: + TAINT_PROPER("truncate"); + if (!(fp = IoIFP(io))) { + result = 0; + } + else { + PerlIO_flush(fp); #ifdef HAS_TRUNCATE - if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + if (ftruncate(PerlIO_fileno(fp), len) < 0) #else - if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + if (my_chsize(PerlIO_fileno(fp), len) < 0) #endif - result = 0; + result = 0; + } } } else { - SV *sv = POPs; - char *name; - + SV * const sv = POPs; + const char *name; + if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; /* *main::FRED for example */ - goto do_ftruncate; + goto do_ftruncate_gv; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */ - goto do_ftruncate; + goto do_ftruncate_gv; + } + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */ + goto do_ftruncate_io; } - name = SvPV(sv, n_a); + name = SvPV_nolen_const(sv); TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE if (truncate(name, len) < 0) result = 0; #else { - int tmpfd; + const int tmpfd = PerlLIO_open(name, O_RDWR); - if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0) + if (tmpfd < 0) result = 0; else { if (my_chsize(tmpfd, len) < 0) @@ -2115,34 +2150,26 @@ PP(pp_truncate) if (result) RETPUSHYES; if (!errno) - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } -#else - DIE(aTHX_ "truncate not implemented"); -#endif -} - -PP(pp_fcntl) -{ - return pp_ioctl(); } PP(pp_ioctl) { - dSP; dTARGET; - SV *argsv = POPs; - unsigned int func = POPu; - int optype = PL_op->op_type; + dVAR; dSP; dTARGET; + SV * const argsv = POPs; + const unsigned int func = POPu; + const int optype = PL_op->op_type; + GV * const gv = (GV*)POPs; + IO * const io = gv ? GvIOn(gv) : Null(IO*); char *s; IV retval; - GV *gv = (GV*)POPs; - IO *io = gv ? GvIOn(gv) : 0; if (!io || !argsv || !IoIFP(io)) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */ + SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ RETPUSHUNDEF; } @@ -2163,7 +2190,7 @@ PP(pp_ioctl) s = INT2PTR(char*,retval); /* ouch */ } - TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl"); + TAINT_PROPER(PL_op_desc[optype]); if (optype == OP_IOCTL) #ifdef HAS_IOCTL @@ -2172,16 +2199,17 @@ PP(pp_ioctl) DIE(aTHX_ "ioctl is not implemented"); #endif else -#ifdef HAS_FCNTL +#ifndef HAS_FCNTL + DIE(aTHX_ "fcntl is not implemented"); +#else #if defined(OS2) && defined(__EMX__) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); #else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); #endif -#else - DIE(aTHX_ "fcntl is not implemented"); #endif +#if defined(HAS_IOCTL) || defined(HAS_FCNTL) if (SvPOK(argsv)) { if (s[SvCUR(argsv)] != 17) DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", @@ -2198,30 +2226,27 @@ PP(pp_ioctl) else { PUSHp(zero_but_true, ZBTLEN); } +#endif RETURN; } PP(pp_flock) { #ifdef FLOCK - dSP; dTARGET; + dVAR; dSP; dTARGET; I32 value; - int argtype; - GV *gv; IO *io = NULL; PerlIO *fp; + const int argtype = POPi; + GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs; - argtype = POPi; - if (MAXARG == 0) - gv = PL_last_in_gv; - else - gv = (GV*)POPs; if (gv && (io = GvIO(gv))) fp = IoIFP(io); else { fp = Nullfp; io = NULL; } + /* XXX Looks to me like io is always NULL at this point */ if (fp) { (void)PerlIO_flush(fp); value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); @@ -2230,7 +2255,7 @@ PP(pp_flock) if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); value = 0; - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); } PUSHi(value); RETURN; @@ -2244,23 +2269,20 @@ PP(pp_flock) PP(pp_socket) { #ifdef HAS_SOCKET - dSP; - GV *gv; - register IO *io; - int protocol = POPi; - int type = POPi; - int domain = POPi; + dVAR; dSP; + const int protocol = POPi; + const int type = POPi; + const int domain = POPi; + GV * const gv = (GV*)POPs; + register IO * const io = gv ? GvIOn(gv) : NULL; int fd; - gv = (GV*)POPs; - io = gv ? GvIOn(gv) : NULL; - if (!gv || !io) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); if (IoIFP(io)) do_close(gv, FALSE); - SETERRNO(EBADF,LIB$_INVARG); + SETERRNO(EBADF,LIB_INVARG); RETPUSHUNDEF; } @@ -2271,8 +2293,8 @@ PP(pp_socket) fd = PerlSock_socket(domain, type, protocol); if (fd < 0) RETPUSHUNDEF; - IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */ - IoOFP(io) = PerlIO_fdopen(fd, "w"); + IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ + IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); IoTYPE(io) = IoTYPE_SOCKET; if (!IoIFP(io) || !IoOFP(io)) { if (IoIFP(io)) PerlIO_close(IoIFP(io)); @@ -2297,20 +2319,16 @@ PP(pp_socket) PP(pp_sockpair) { #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) - dSP; - GV *gv1; - GV *gv2; - register IO *io1; - register IO *io2; - int protocol = POPi; - int type = POPi; - int domain = POPi; + dVAR; dSP; + const int protocol = POPi; + const int type = POPi; + const int domain = POPi; + GV * const gv2 = (GV*)POPs; + GV * const gv1 = (GV*)POPs; + register IO * const io1 = gv1 ? GvIOn(gv1) : NULL; + register IO * const io2 = gv2 ? GvIOn(gv2) : NULL; int fd[2]; - gv2 = (GV*)POPs; - gv1 = (GV*)POPs; - io1 = gv1 ? GvIOn(gv1) : NULL; - io2 = gv2 ? GvIOn(gv2) : NULL; if (!gv1 || !gv2 || !io1 || !io2) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { if (!gv1 || !io1) @@ -2333,11 +2351,11 @@ PP(pp_sockpair) TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; - IoIFP(io1) = PerlIO_fdopen(fd[0], "r"); - IoOFP(io1) = PerlIO_fdopen(fd[0], "w"); + IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE); + IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE); IoTYPE(io1) = IoTYPE_SOCKET; - IoIFP(io2) = PerlIO_fdopen(fd[1], "r"); - IoOFP(io2) = PerlIO_fdopen(fd[1], "w"); + IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE); + IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE); IoTYPE(io2) = IoTYPE_SOCKET; if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); @@ -2362,15 +2380,16 @@ PP(pp_sockpair) PP(pp_bind) { #ifdef HAS_SOCKET - dSP; + dVAR; dSP; #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */ extern void GETPRIVMODE(); extern void GETUSERMODE(); #endif - SV *addrsv = POPs; - char *addr; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); + SV * const addrsv = POPs; + /* OK, so on what platform does bind modify addr? */ + const char *addr; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); STRLEN len; int bind_ok = 0; #ifdef MPE @@ -2380,7 +2399,7 @@ PP(pp_bind) if (!io || !IoIFP(io)) goto nuts; - addr = SvPV(addrsv, len); + addr = SvPV_const(addrsv, len); TAINT_PROPER("bind"); #ifdef MPE /* Deal with MPE bind() peculiarities */ if (((struct sockaddr *)addr)->sa_family == AF_INET) { @@ -2411,7 +2430,7 @@ PP(pp_bind) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "bind"); @@ -2421,17 +2440,17 @@ nuts: PP(pp_connect) { #ifdef HAS_SOCKET - dSP; - SV *addrsv = POPs; - char *addr; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); + dVAR; dSP; + SV * const addrsv = POPs; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); + const char *addr; STRLEN len; if (!io || !IoIFP(io)) goto nuts; - addr = SvPV(addrsv, len); + addr = SvPV_const(addrsv, len); TAINT_PROPER("connect"); if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; @@ -2441,7 +2460,7 @@ PP(pp_connect) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "connect"); @@ -2451,10 +2470,10 @@ nuts: PP(pp_listen) { #ifdef HAS_SOCKET - dSP; - int backlog = POPi; - GV *gv = (GV*)POPs; - register IO *io = gv ? GvIOn(gv) : NULL; + dVAR; dSP; + const int backlog = POPi; + GV * const gv = (GV*)POPs; + register IO * const io = gv ? GvIOn(gv) : NULL; if (!gv || !io || !IoIFP(io)) goto nuts; @@ -2467,7 +2486,7 @@ PP(pp_listen) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); @@ -2477,18 +2496,18 @@ nuts: PP(pp_accept) { #ifdef HAS_SOCKET - dSP; dTARGET; - GV *ngv; - GV *ggv; + dVAR; dSP; dTARGET; register IO *nstio; register IO *gstio; - struct sockaddr saddr; /* use a struct to avoid alignment problems */ - Sock_size_t len = sizeof saddr; + char namebuf[MAXPATHLEN]; +#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) + Sock_size_t len = sizeof (struct sockaddr_in); +#else + Sock_size_t len = sizeof namebuf; +#endif + GV * const ggv = (GV*)POPs; + GV * const ngv = (GV*)POPs; int fd; - int fd2; - - ggv = (GV*)POPs; - ngv = (GV*)POPs; if (!ngv) goto badexit; @@ -2500,17 +2519,13 @@ PP(pp_accept) goto nuts; nstio = GvIOn(ngv); - fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len); + fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); if (fd < 0) goto badexit; if (IoIFP(nstio)) do_close(ngv, FALSE); - IoIFP(nstio) = PerlIO_fdopen(fd, "r"); - /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit - fclose of IoOFP's FILE * - and hence leak memory. - Special treatment of _this_ case of IoIFP != IoOFP seems wrong. - */ - IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w"); + IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); + IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); IoTYPE(nstio) = IoTYPE_SOCKET; if (!IoIFP(nstio) || !IoOFP(nstio)) { if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); @@ -2520,21 +2535,23 @@ PP(pp_accept) } #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ - fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd); /* ensure close-on-exec */ #endif #ifdef EPOC - len = sizeof saddr; /* EPOC somehow truncates info */ + len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */ setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */ #endif +#ifdef __SCO_VERSION__ + len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ +#endif - PUSHp((char *)&saddr, len); + PUSHp(namebuf, len); RETURN; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); badexit: RETPUSHUNDEF; @@ -2547,10 +2564,10 @@ badexit: PP(pp_shutdown) { #ifdef HAS_SOCKET - dSP; dTARGET; - int how = POPi; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); + dVAR; dSP; dTARGET; + const int how = POPi; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); if (!io || !IoIFP(io)) goto nuts; @@ -2561,44 +2578,26 @@ PP(pp_shutdown) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); #endif } -PP(pp_gsockopt) -{ -#ifdef HAS_SOCKET - return pp_ssockopt(); -#else - DIE(aTHX_ PL_no_sock_func, "getsockopt"); -#endif -} - PP(pp_ssockopt) { #ifdef HAS_SOCKET - dSP; - int optype = PL_op->op_type; - SV *sv; + dVAR; dSP; + const int optype = PL_op->op_type; + SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(NEWSV(22, 257)) : POPs; + const unsigned int optname = (unsigned int) POPi; + const unsigned int lvl = (unsigned int) POPi; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); int fd; - unsigned int optname; - unsigned int lvl; - GV *gv; - register IO *io; Sock_size_t len; - if (optype == OP_GSOCKOPT) - sv = sv_2mortal(NEWSV(22, 257)); - else - sv = POPs; - optname = (unsigned int) POPi; - lvl = (unsigned int) POPi; - - gv = (GV*)POPs; - io = GvIOn(gv); if (!io || !IoIFP(io)) goto nuts; @@ -2617,16 +2616,30 @@ PP(pp_ssockopt) PUSHs(sv); break; case OP_SSOCKOPT: { - char *buf; +#if defined(__SYMBIAN32__) +# define SETSOCKOPT_OPTION_VALUE_T void * +#else +# define SETSOCKOPT_OPTION_VALUE_T const char * +#endif + /* XXX TODO: We need to have a proper type (a Configure probe, + * etc.) for what the C headers think of the third argument of + * setsockopt(), the option_value read-only buffer: is it + * a "char *", or a "void *", const or not. Some compilers + * don't take kindly to e.g. assuming that "char *" implicitly + * promotes to a "void *", or to explicitly promoting/demoting + * consts to non/vice versa. The "const void *" is the SUS + * definition, but that does not fly everywhere for the above + * reasons. */ + SETSOCKOPT_OPTION_VALUE_T buf; int aint; if (SvPOKp(sv)) { STRLEN l; - buf = SvPV(sv, l); + buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l); len = l; } else { aint = (int)SvIV(sv); - buf = (char*)&aint; + buf = (SETSOCKOPT_OPTION_VALUE_T) &aint; len = sizeof(int); } if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) @@ -2640,34 +2653,25 @@ PP(pp_ssockopt) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, optype); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; #else - DIE(aTHX_ PL_no_sock_func, "setsockopt"); -#endif -} - -PP(pp_getsockname) -{ -#ifdef HAS_SOCKET - return pp_getpeername(); -#else - DIE(aTHX_ PL_no_sock_func, "getsockname"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif } PP(pp_getpeername) { #ifdef HAS_SOCKET - dSP; - int optype = PL_op->op_type; + dVAR; dSP; + const int optype = PL_op->op_type; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); + Sock_size_t len; SV *sv; int fd; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - Sock_size_t len; if (!io || !IoIFP(io)) goto nuts; @@ -2690,8 +2694,8 @@ PP(pp_getpeername) { 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"; /* If the call succeeded, make sure we don't have a zeroed port/addr */ - if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET && - !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere, + if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET && + !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere, sizeof(u_short) + sizeof(struct in_addr))) { goto nuts2; } @@ -2713,34 +2717,30 @@ PP(pp_getpeername) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, optype); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; #else - DIE(aTHX_ PL_no_sock_func, "getpeername"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif } /* Stat calls. */ -PP(pp_lstat) -{ - return pp_stat(); -} - PP(pp_stat) { + dVAR; dSP; GV *gv; I32 gimme; I32 max = 13; - STRLEN n_a; if (PL_op->op_flags & OPf_REF) { gv = cGVOP_gv; if (PL_op->op_type == OP_LSTAT) { if (gv != PL_defgv) { + do_fstat_warning_check: if (ckWARN(WARN_IO)) Perl_warner(aTHX_ packWARN(WARN_IO), "lstat() on filehandle %s", GvENAME(gv)); @@ -2752,7 +2752,7 @@ PP(pp_stat) if (gv != PL_defgv) { PL_laststype = OP_STAT; PL_statgv = gv; - sv_setpv(PL_statname, ""); + sv_setpvn(PL_statname, "", 0); PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv)) ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1); } @@ -2763,29 +2763,26 @@ PP(pp_stat) } } else { - SV* sv = POPs; + SV* const sv = POPs; if (SvTYPE(sv) == SVt_PVGV) { gv = (GV*)sv; goto do_fstat; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { gv = (GV*)SvRV(sv); - if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO)) - Perl_warner(aTHX_ packWARN(WARN_IO), - "lstat() on filehandle %s", GvENAME(gv)); + if (PL_op->op_type == OP_LSTAT) + goto do_fstat_warning_check; goto do_fstat; } - sv_setpv(PL_statname, SvPV(sv,n_a)); + sv_setpv(PL_statname, SvPV_nolen_const(sv)); PL_statgv = Nullgv; -#ifdef HAS_LSTAT PL_laststype = PL_op->op_type; if (PL_op->op_type == OP_LSTAT) - PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache); + PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache); else -#endif - PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache); + PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache); if (PL_laststatval < 0) { - if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n')) + if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); max = 0; } @@ -2825,10 +2822,10 @@ PP(pp_stat) #ifdef USE_STAT_RDEV PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev))); #else - PUSHs(sv_2mortal(newSVpvn("", 0))); + PUSHs(sv_2mortal(newSVpvs(""))); #endif #if Off_t_size > IVSIZE - PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size))); + PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size))); #else PUSHs(sv_2mortal(newSViv(PL_statcache.st_size))); #endif @@ -2845,382 +2842,279 @@ PP(pp_stat) PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize))); PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks))); #else - PUSHs(sv_2mortal(newSVpvn("", 0))); - PUSHs(sv_2mortal(newSVpvn("", 0))); + PUSHs(sv_2mortal(newSVpvs(""))); + PUSHs(sv_2mortal(newSVpvs(""))); #endif } RETURN; } +/* This macro is used by the stacked filetest operators : + * if the previous filetest failed, short-circuit and pass its value. + * Else, discard it from the stack and continue. --rgs + */ +#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \ + if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \ + else { (void)POPs; PUTBACK; } \ + } + PP(pp_ftrread) { + dVAR; I32 result; - dSP; -#if defined(HAS_ACCESS) && defined(R_OK) - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, R_OK); - if (result == 0) - RETPUSHYES; - if (result < 0) - RETPUSHUNDEF; - RETPUSHNO; - } - else - result = my_stat(); + /* Not const, because things tweak this below. Not bool, because there's + no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */ +#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) + I32 use_access = PL_op->op_private & OPpFT_ACCESS; + /* Giving some sort of initial value silences compilers. */ +# ifdef R_OK + int access_mode = R_OK; +# else + int access_mode = 0; +# endif #else - result = my_stat(); + /* access_mode is never used, but leaving use_access in makes the + conditional compiling below much clearer. */ + I32 use_access = 0; #endif - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IRUSR, 0, &PL_statcache)) - RETPUSHYES; - RETPUSHNO; -} + int stat_mode = S_IRUSR; -PP(pp_ftrwrite) -{ - I32 result; + bool effective = FALSE; dSP; + + STACKED_FTEST_CHECK; + + switch (PL_op->op_type) { + case OP_FTRREAD: +#if !(defined(HAS_ACCESS) && defined(R_OK)) + use_access = 0; +#endif + break; + + case OP_FTRWRITE: #if defined(HAS_ACCESS) && defined(W_OK) - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, W_OK); - if (result == 0) - RETPUSHYES; - if (result < 0) - RETPUSHUNDEF; - RETPUSHNO; - } - else - result = my_stat(); + access_mode = W_OK; #else - result = my_stat(); + use_access = 0; #endif - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IWUSR, 0, &PL_statcache)) - RETPUSHYES; - RETPUSHNO; -} + stat_mode = S_IWUSR; + break; -PP(pp_ftrexec) -{ - I32 result; - dSP; + case OP_FTREXEC: #if defined(HAS_ACCESS) && defined(X_OK) - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, X_OK); - if (result == 0) - RETPUSHYES; - if (result < 0) - RETPUSHUNDEF; - RETPUSHNO; - } - else - result = my_stat(); + access_mode = X_OK; #else - result = my_stat(); + use_access = 0; #endif - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IXUSR, 0, &PL_statcache)) - RETPUSHYES; - RETPUSHNO; -} + stat_mode = S_IXUSR; + break; -PP(pp_fteread) -{ - I32 result; - dSP; -#ifdef PERL_EFF_ACCESS_R_OK - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_R_OK(TOPpx); - if (result == 0) - RETPUSHYES; - if (result < 0) - RETPUSHUNDEF; - RETPUSHNO; - } - else - result = my_stat(); -#else - result = my_stat(); + case OP_FTEWRITE: +#ifdef PERL_EFF_ACCESS + access_mode = W_OK; #endif - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IRUSR, 1, &PL_statcache)) - RETPUSHYES; - RETPUSHNO; -} + stat_mode = S_IWUSR; + /* Fall through */ -PP(pp_ftewrite) -{ - I32 result; - dSP; -#ifdef PERL_EFF_ACCESS_W_OK - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_W_OK(TOPpx); - if (result == 0) - RETPUSHYES; - if (result < 0) - RETPUSHUNDEF; - RETPUSHNO; - } - else - result = my_stat(); + case OP_FTEREAD: +#ifndef PERL_EFF_ACCESS + use_access = 0; +#endif + effective = TRUE; + break; + + + case OP_FTEEXEC: +#ifdef PERL_EFF_ACCESS + access_mode = W_OK; #else - result = my_stat(); + use_access = 0; #endif - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IWUSR, 1, &PL_statcache)) - RETPUSHYES; - RETPUSHNO; -} + stat_mode = S_IXUSR; + effective = TRUE; + break; + } -PP(pp_fteexec) -{ - I32 result; - dSP; -#ifdef PERL_EFF_ACCESS_X_OK - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_X_OK(TOPpx); + if (use_access) { +#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) + const char *const name = POPpx; + if (effective) { +# ifdef PERL_EFF_ACCESS + result = PERL_EFF_ACCESS(name, access_mode); +# else + DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s", + OP_NAME(PL_op)); +# endif + } + else { +# ifdef HAS_ACCESS + result = access(name, access_mode); +# else + DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op)); +# endif + } if (result == 0) RETPUSHYES; if (result < 0) RETPUSHUNDEF; RETPUSHNO; +#endif } - else - result = my_stat(); -#else + result = my_stat(); -#endif SPAGAIN; if (result < 0) RETPUSHUNDEF; - if (cando(S_IXUSR, 1, &PL_statcache)) + if (cando(stat_mode, effective, &PL_statcache)) RETPUSHYES; RETPUSHNO; } PP(pp_ftis) { - I32 result = my_stat(); - dSP; - if (result < 0) - RETPUSHUNDEF; - RETPUSHYES; -} - -PP(pp_fteowned) -{ - return pp_ftrowned(); -} - -PP(pp_ftrowned) -{ - I32 result = my_stat(); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? - PL_euid : PL_uid) ) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftzero) -{ - I32 result = my_stat(); + dVAR; + I32 result; + const int op_type = PL_op->op_type; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; - if (PL_statcache.st_size == 0) + if (op_type == OP_FTIS) RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftsize) -{ - I32 result = my_stat(); - dSP; dTARGET; - if (result < 0) - RETPUSHUNDEF; + { + /* You can't dTARGET inside OP_FTIS, because you'll get + "panic: pad_sv po" - the op is not flagged to have a target. */ + dTARGET; + switch (op_type) { + case OP_FTSIZE: #if Off_t_size > IVSIZE - PUSHn(PL_statcache.st_size); + PUSHn(PL_statcache.st_size); #else - PUSHi(PL_statcache.st_size); + PUSHi(PL_statcache.st_size); #endif + break; + case OP_FTMTIME: + PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 ); + break; + case OP_FTATIME: + PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 ); + break; + case OP_FTCTIME: + PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 ); + break; + } + } RETURN; } -PP(pp_ftmtime) -{ - I32 result = my_stat(); - dSP; dTARGET; - if (result < 0) - RETPUSHUNDEF; - PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 ); - RETURN; -} - -PP(pp_ftatime) -{ - I32 result = my_stat(); - dSP; dTARGET; - if (result < 0) - RETPUSHUNDEF; - PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 ); - RETURN; -} - -PP(pp_ftctime) -{ - I32 result = my_stat(); - dSP; dTARGET; - if (result < 0) - RETPUSHUNDEF; - PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 ); - RETURN; -} - -PP(pp_ftsock) -{ - I32 result = my_stat(); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISSOCK(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftchr) -{ - I32 result = my_stat(); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISCHR(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftblk) -{ - I32 result = my_stat(); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISBLK(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftfile) -{ - I32 result = my_stat(); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISREG(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftdir) -{ - I32 result = my_stat(); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISDIR(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftpipe) +PP(pp_ftrowned) { - I32 result = my_stat(); + dVAR; + I32 result; dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISFIFO(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} -PP(pp_ftlink) -{ - I32 result = my_lstat(); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISLNK(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} + /* I believe that all these three are likely to be defined on most every + system these days. */ +#ifndef S_ISUID + if(PL_op->op_type == OP_FTSUID) + RETPUSHNO; +#endif +#ifndef S_ISGID + if(PL_op->op_type == OP_FTSGID) + RETPUSHNO; +#endif +#ifndef S_ISVTX + if(PL_op->op_type == OP_FTSVTX) + RETPUSHNO; +#endif -PP(pp_ftsuid) -{ - dSP; -#ifdef S_ISUID - I32 result = my_stat(); + STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; - if (PL_statcache.st_mode & S_ISUID) - RETPUSHYES; + switch (PL_op->op_type) { + case OP_FTROWNED: + if (PL_statcache.st_uid == PL_uid) + RETPUSHYES; + break; + case OP_FTEOWNED: + if (PL_statcache.st_uid == PL_euid) + RETPUSHYES; + break; + case OP_FTZERO: + if (PL_statcache.st_size == 0) + RETPUSHYES; + break; + case OP_FTSOCK: + if (S_ISSOCK(PL_statcache.st_mode)) + RETPUSHYES; + break; + case OP_FTCHR: + if (S_ISCHR(PL_statcache.st_mode)) + RETPUSHYES; + break; + case OP_FTBLK: + if (S_ISBLK(PL_statcache.st_mode)) + RETPUSHYES; + break; + case OP_FTFILE: + if (S_ISREG(PL_statcache.st_mode)) + RETPUSHYES; + break; + case OP_FTDIR: + if (S_ISDIR(PL_statcache.st_mode)) + RETPUSHYES; + break; + case OP_FTPIPE: + if (S_ISFIFO(PL_statcache.st_mode)) + RETPUSHYES; + break; +#ifdef S_ISUID + case OP_FTSUID: + if (PL_statcache.st_mode & S_ISUID) + RETPUSHYES; + break; #endif - RETPUSHNO; -} - -PP(pp_ftsgid) -{ - dSP; #ifdef S_ISGID - I32 result = my_stat(); - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (PL_statcache.st_mode & S_ISGID) - RETPUSHYES; + case OP_FTSGID: + if (PL_statcache.st_mode & S_ISGID) + RETPUSHYES; + break; +#endif +#ifdef S_ISVTX + case OP_FTSVTX: + if (PL_statcache.st_mode & S_ISVTX) + RETPUSHYES; + break; #endif + } RETPUSHNO; } -PP(pp_ftsvtx) +PP(pp_ftlink) { + dVAR; + I32 result = my_lstat(); dSP; -#ifdef S_ISVTX - I32 result = my_stat(); - SPAGAIN; if (result < 0) RETPUSHUNDEF; - if (PL_statcache.st_mode & S_ISVTX) + if (S_ISLNK(PL_statcache.st_mode)) RETPUSHYES; -#endif RETPUSHNO; } PP(pp_fttty) { + dVAR; dSP; int fd; GV *gv; - char *tmps = Nullch; - STRLEN n_a; + SV *tmpsv = Nullsv; + + STACKED_FTEST_CHECK; if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; @@ -3229,12 +3123,17 @@ PP(pp_fttty) else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = (GV*)SvRV(POPs); else - gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO); + gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); - else if (tmps && isDIGIT(*tmps)) - fd = atoi(tmps); + else if (tmpsv && SvOK(tmpsv)) { + const char *tmps = SvPV_nolen_const(tmpsv); + if (isDIGIT(*tmps)) + fd = atoi(tmps); + else + RETPUSHUNDEF; + } else RETPUSHUNDEF; if (PerlLIO_isatty(fd)) @@ -3252,6 +3151,7 @@ PP(pp_fttty) PP(pp_fttext) { + dVAR; dSP; I32 i; I32 len; @@ -3261,9 +3161,10 @@ PP(pp_fttext) register IO *io; register SV *sv; GV *gv; - STRLEN n_a; PerlIO *fp; + STACKED_FTEST_CHECK; + if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; else if (isGV(TOPs)) @@ -3286,7 +3187,7 @@ PP(pp_fttext) else { PL_statgv = gv; PL_laststatval = -1; - sv_setpv(PL_statname, ""); + sv_setpvn(PL_statname, "", 0); io = GvIO(PL_statgv); } if (io && IoIFP(io)) { @@ -3319,7 +3220,7 @@ PP(pp_fttext) gv = cGVOP_gv; report_evil_fh(gv, GvIO(gv), PL_op->op_type); } - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } } @@ -3327,11 +3228,11 @@ PP(pp_fttext) sv = POPs; really_filename: PL_statgv = Nullgv; - PL_laststatval = -1; PL_laststype = OP_STAT; - sv_setpv(PL_statname, SvPV(sv, n_a)); - if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) { - if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) + sv_setpv(PL_statname, SvPV_nolen_const(sv)); + if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { + if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), + '\n')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); RETPUSHUNDEF; } @@ -3405,36 +3306,41 @@ PP(pp_fttext) RETPUSHYES; } -PP(pp_ftbinary) -{ - return pp_fttext(); -} - /* File calls. */ PP(pp_chdir) { - dSP; dTARGET; - char *tmps; - SV **svp; - STRLEN n_a; + dVAR; dSP; dTARGET; + const char *tmps = NULL; + GV *gv = NULL; - if( MAXARG == 1 ) - tmps = POPpx; - else - tmps = 0; + if( MAXARG == 1 ) { + SV * const sv = POPs; + if (SvTYPE(sv) == SVt_PVGV) { + gv = (GV*)sv; + } + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + gv = (GV*)SvRV(sv); + } + else { + tmps = SvPVx_nolen_const(sv); + } + } + + if( !gv && (!tmps || !*tmps) ) { + HV * const table = GvHVn(PL_envgv); + SV **svp; - if( !tmps || !*tmps ) { - if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE)) - || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE)) + if ( (svp = hv_fetchs(table, "HOME", FALSE)) + || (svp = hv_fetchs(table, "LOGDIR", FALSE)) #ifdef VMS - || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE)) + || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE)) #endif ) { if( MAXARG == 1 ) deprecate("chdir('') or chdir(undef) as chdir()"); - tmps = SvPV(*svp, n_a); + tmps = SvPV_nolen_const(*svp); } else { PUSHi(0); @@ -3444,7 +3350,33 @@ PP(pp_chdir) } TAINT_PROPER("chdir"); - PUSHi( PerlDir_chdir(tmps) >= 0 ); + if (gv) { +#ifdef HAS_FCHDIR + IO* const io = GvIO(gv); + if (io) { + if (IoIFP(io)) { + PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); + } + else if (IoDIRP(io)) { +#ifdef HAS_DIRFD + PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0); +#else + DIE(aTHX_ PL_no_func, "dirfd"); +#endif + } + else { + PUSHi(0); + } + } + else { + PUSHi(0); + } +#else + DIE(aTHX_ PL_no_func, "fchdir"); +#endif + } + else + PUSHi( PerlDir_chdir(tmps) >= 0 ); #ifdef VMS /* Clear the DEFAULT element of ENV so we'll get the new value * in the future. */ @@ -3455,24 +3387,19 @@ PP(pp_chdir) PP(pp_chown) { -#ifdef HAS_CHOWN - dSP; dMARK; dTARGET; - I32 value = (I32)apply(PL_op->op_type, MARK, SP); + dVAR; dSP; dMARK; dTARGET; + const I32 value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; - PUSHi(value); + XPUSHi(value); RETURN; -#else - DIE(aTHX_ PL_no_func, "chown"); -#endif } PP(pp_chroot) { #ifdef HAS_CHROOT - dSP; dTARGET; - STRLEN n_a; - char *tmps = POPpx; + dVAR; dSP; dTARGET; + char * const tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); RETURN; @@ -3481,44 +3408,12 @@ PP(pp_chroot) #endif } -PP(pp_unlink) -{ - dSP; dMARK; dTARGET; - I32 value; - value = (I32)apply(PL_op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); - RETURN; -} - -PP(pp_chmod) -{ - dSP; dMARK; dTARGET; - I32 value; - value = (I32)apply(PL_op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); - RETURN; -} - -PP(pp_utime) -{ - dSP; dMARK; dTARGET; - I32 value; - value = (I32)apply(PL_op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); - RETURN; -} - PP(pp_rename) { - dSP; dTARGET; + dVAR; dSP; dTARGET; int anum; - STRLEN n_a; - - char *tmps2 = POPpx; - char *tmps = SvPV(TOPs, n_a); + const char * const tmps2 = POPpconstx; + const char * const tmps = SvPV_nolen_const(TOPs); TAINT_PROPER("rename"); #ifdef HAS_RENAME anum = PerlLIO_rename(tmps, tmps2); @@ -3538,50 +3433,69 @@ PP(pp_rename) RETURN; } +#if defined(HAS_LINK) || defined(HAS_SYMLINK) PP(pp_link) { -#ifdef HAS_LINK - dSP; dTARGET; - STRLEN n_a; - char *tmps2 = POPpx; - char *tmps = SvPV(TOPs, n_a); - TAINT_PROPER("link"); - SETi( PerlLIO_link(tmps, tmps2) >= 0 ); - RETURN; -#else - DIE(aTHX_ PL_no_func, "link"); -#endif -} + dVAR; dSP; dTARGET; + const int op_type = PL_op->op_type; + int result; -PP(pp_symlink) -{ -#ifdef HAS_SYMLINK - dSP; dTARGET; - STRLEN n_a; - char *tmps2 = POPpx; - char *tmps = SvPV(TOPs, n_a); - TAINT_PROPER("symlink"); - SETi( symlink(tmps, tmps2) >= 0 ); +# ifndef HAS_LINK + if (op_type == OP_LINK) + DIE(aTHX_ PL_no_func, "link"); +# endif +# ifndef HAS_SYMLINK + if (op_type == OP_SYMLINK) + DIE(aTHX_ PL_no_func, "symlink"); +# endif + + { + const char * const tmps2 = POPpconstx; + const char * const tmps = SvPV_nolen_const(TOPs); + TAINT_PROPER(PL_op_desc[op_type]); + result = +# if defined(HAS_LINK) +# if defined(HAS_SYMLINK) + /* Both present - need to choose which. */ + (op_type == OP_LINK) ? + PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2); +# else + /* Only have link, so calls to pp_symlink will have DIE()d above. */ + PerlLIO_link(tmps, tmps2); +# endif +# else +# if defined(HAS_SYMLINK) + /* Only have symlink, so calls to pp_link will have DIE()d above. */ + symlink(tmps, tmps2); +# endif +# endif + } + + SETi( result >= 0 ); RETURN; +} #else - DIE(aTHX_ PL_no_func, "symlink"); -#endif +PP(pp_link) +{ + /* Have neither. */ + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); } +#endif PP(pp_readlink) { + dVAR; dSP; #ifdef HAS_SYMLINK dTARGET; - char *tmps; + const char *tmps; char buf[MAXPATHLEN]; int len; - STRLEN n_a; #ifndef INCOMPLETE_TAINTS TAINT; #endif - tmps = POPpx; + tmps = POPpconstx; len = readlink(tmps, buf, sizeof(buf) - 1); EXTEND(SP, 1); if (len < 0) @@ -3596,15 +3510,15 @@ PP(pp_readlink) #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) STATIC int -S_dooneliner(pTHX_ char *cmd, char *filename) +S_dooneliner(pTHX_ const char *cmd, const char *filename) { - char *save_filename = filename; + char * const save_filename = filename; char *cmdline; char *s; PerlIO *myfp; int anum = 1; - New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char); + Newx(cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char); strcpy(cmdline, cmd); strcat(cmdline, " "); for (s = cmdline + strlen(cmdline); *filename; ) { @@ -3616,7 +3530,7 @@ S_dooneliner(pTHX_ char *cmd, char *filename) Safefree(cmdline); if (myfp) { - SV *tmpsv = sv_newmortal(); + SV * const tmpsv = sv_newmortal(); /* Need to save/restore 'PL_rs' ?? */ s = sv_gets(tmpsv, myfp, 0); (void)PerlProc_pclose(myfp); @@ -3648,21 +3562,21 @@ S_dooneliner(pTHX_ char *cmd, char *filename) #define EACCES EPERM #endif if (instr(s, "cannot make")) - SETERRNO(EEXIST,RMS$_FEX); + SETERRNO(EEXIST,RMS_FEX); else if (instr(s, "existing file")) - SETERRNO(EEXIST,RMS$_FEX); + SETERRNO(EEXIST,RMS_FEX); else if (instr(s, "ile exists")) - SETERRNO(EEXIST,RMS$_FEX); + SETERRNO(EEXIST,RMS_FEX); else if (instr(s, "non-exist")) - SETERRNO(ENOENT,RMS$_FNF); + SETERRNO(ENOENT,RMS_FNF); else if (instr(s, "does not exist")) - SETERRNO(ENOENT,RMS$_FNF); + SETERRNO(ENOENT,RMS_FNF); else if (instr(s, "not empty")) - SETERRNO(EBUSY,SS$_DEVOFFLINE); + SETERRNO(EBUSY,SS_DEVOFFLINE); else if (instr(s, "cannot access")) - SETERRNO(EACCES,RMS$_PRV); + SETERRNO(EACCES,RMS_PRV); else - SETERRNO(EPERM,RMS$_PRV); + SETERRNO(EPERM,RMS_PRV); return 0; } else { /* some mkdirs return no failure indication */ @@ -3672,7 +3586,7 @@ S_dooneliner(pTHX_ char *cmd, char *filename) if (anum) SETERRNO(0,0); else - SETERRNO(EACCES,RMS$_PRV); /* a guess */ + SETERRNO(EACCES,RMS_PRV); /* a guess */ } return anum; } @@ -3681,47 +3595,47 @@ S_dooneliner(pTHX_ char *cmd, char *filename) } #endif +/* This macro removes trailing slashes from a directory name. + * Different operating and file systems take differently to + * trailing slashes. According to POSIX 1003.1 1996 Edition + * any number of trailing slashes should be allowed. + * Thusly we snip them away so that even non-conforming + * systems are happy. + * We should probably do this "filtering" for all + * the functions that expect (potentially) directory names: + * -d, chdir(), chmod(), chown(), chroot(), fcntl()?, + * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */ + +#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \ + if ((len) > 1 && (tmps)[(len)-1] == '/') { \ + do { \ + (len)--; \ + } while ((len) > 1 && (tmps)[(len)-1] == '/'); \ + (tmps) = savepvn((tmps), (len)); \ + (copy) = TRUE; \ + } + PP(pp_mkdir) { - dSP; dTARGET; - int mode; -#ifndef HAS_MKDIR - int oldumask; -#endif + dVAR; dSP; dTARGET; STRLEN len; - char *tmps; + const char *tmps; bool copy = FALSE; + const int mode = (MAXARG > 1) ? POPi : 0777; - if (MAXARG > 1) - mode = POPi; - else - mode = 0777; - - tmps = SvPV(TOPs, len); - /* Different operating and file systems take differently to - * trailing slashes. According to POSIX 1003.1 1996 Edition - * any number of trailing slashes should be allowed. - * Thusly we snip them away so that even non-conforming - * systems are happy. */ - /* We should probably do this "filtering" for all - * the functions that expect (potentially) directory names: - * -d, chdir(), chmod(), chown(), chroot(), fcntl()?, - * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */ - if (len > 1 && tmps[len-1] == '/') { - while (tmps[len] == '/' && len > 1) - len--; - tmps = savepvn(tmps, len); - copy = TRUE; - } + TRIMSLASHES(tmps,len,copy); TAINT_PROPER("mkdir"); #ifdef HAS_MKDIR SETi( PerlDir_mkdir(tmps, mode) >= 0 ); #else + { + int oldumask; SETi( dooneliner("mkdir", tmps) ); oldumask = PerlLIO_umask(0); PerlLIO_umask(oldumask); PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777); + } #endif if (copy) Safefree(tmps); @@ -3730,17 +3644,20 @@ PP(pp_mkdir) PP(pp_rmdir) { - dSP; dTARGET; - char *tmps; - STRLEN n_a; + dVAR; dSP; dTARGET; + STRLEN len; + const char *tmps; + bool copy = FALSE; - tmps = POPpx; + TRIMSLASHES(tmps,len,copy); TAINT_PROPER("rmdir"); #ifdef HAS_RMDIR - XPUSHi( PerlDir_rmdir(tmps) >= 0 ); + SETi( PerlDir_rmdir(tmps) >= 0 ); #else - XPUSHi( dooneliner("rmdir", tmps) ); + SETi( dooneliner("rmdir", tmps) ); #endif + if (copy) + Safefree(tmps); RETURN; } @@ -3749,11 +3666,10 @@ PP(pp_rmdir) PP(pp_open_dir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dSP; - STRLEN n_a; - char *dirname = POPpx; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); + dVAR; dSP; + const char * const dirname = POPpconstx; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); if (!io) goto nope; @@ -3766,7 +3682,7 @@ PP(pp_open_dir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS$_DIR); + SETERRNO(EBADF,RMS_DIR); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); @@ -3775,66 +3691,65 @@ nope: PP(pp_readdir) { -#if defined(Direntry_t) && defined(HAS_READDIR) - dSP; +#if !defined(Direntry_t) || !defined(HAS_READDIR) + DIE(aTHX_ PL_no_dir_func, "readdir"); +#else #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif - register Direntry_t *dp; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - SV *sv; - - if (!io || !IoDIRP(io)) - goto nope; + dVAR; + dSP; - if (GIMME == G_ARRAY) { - /*SUPPRESS 560*/ - while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) { -#ifdef DIRNAMLEN - sv = newSVpvn(dp->d_name, dp->d_namlen); -#else - sv = newSVpv(dp->d_name, 0); -#endif -#ifndef INCOMPLETE_TAINTS - if (!(IoFLAGS(io) & IOf_UNTAINT)) - SvTAINTED_on(sv); -#endif - XPUSHs(sv_2mortal(sv)); - } + SV *sv; + const I32 gimme = GIMME; + GV * const gv = (GV *)POPs; + register const Direntry_t *dp; + register IO * const io = GvIOn(gv); + + if (!io || !IoDIRP(io)) { + if(ckWARN(WARN_IO)) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "readdir() attempted on invalid dirhandle %s", GvENAME(gv)); + } + goto nope; } - else { - if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) - goto nope; + + do { + dp = (Direntry_t *)PerlDir_read(IoDIRP(io)); + if (!dp) + break; #ifdef DIRNAMLEN - sv = newSVpvn(dp->d_name, dp->d_namlen); + sv = newSVpvn(dp->d_name, dp->d_namlen); #else - sv = newSVpv(dp->d_name, 0); + sv = newSVpv(dp->d_name, 0); #endif #ifndef INCOMPLETE_TAINTS - if (!(IoFLAGS(io) & IOf_UNTAINT)) - SvTAINTED_on(sv); + if (!(IoFLAGS(io) & IOf_UNTAINT)) + SvTAINTED_on(sv); #endif - XPUSHs(sv_2mortal(sv)); + XPUSHs(sv_2mortal(sv)); } + while (gimme == G_ARRAY); + + if (!dp && gimme != G_ARRAY) + goto nope; + RETURN; nope: if (!errno) - SETERRNO(EBADF,RMS$_ISI); + SETERRNO(EBADF,RMS_ISI); if (GIMME == G_ARRAY) RETURN; else RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_dir_func, "readdir"); #endif } PP(pp_telldir) { #if defined(HAS_TELLDIR) || defined(telldir) - dSP; dTARGET; + dVAR; dSP; dTARGET; /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. @@ -3842,17 +3757,22 @@ PP(pp_telldir) # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO) long telldir (DIR *); # endif - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) - goto nope; + if (!io || !IoDIRP(io)) { + if(ckWARN(WARN_IO)) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "telldir() attempted on invalid dirhandle %s", GvENAME(gv)); + } + goto nope; + } PUSHi( PerlDir_tell(IoDIRP(io)) ); RETURN; nope: if (!errno) - SETERRNO(EBADF,RMS$_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); @@ -3862,20 +3782,24 @@ nope: PP(pp_seekdir) { #if defined(HAS_SEEKDIR) || defined(seekdir) - dSP; - long along = POPl; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoDIRP(io)) - goto nope; - + dVAR; dSP; + const long along = POPl; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); + + if (!io || !IoDIRP(io)) { + if(ckWARN(WARN_IO)) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "seekdir() attempted on invalid dirhandle %s", GvENAME(gv)); + } + goto nope; + } (void)PerlDir_seek(IoDIRP(io), along); RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS$_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); @@ -3885,18 +3809,22 @@ nope: PP(pp_rewinddir) { #if defined(HAS_REWINDDIR) || defined(rewinddir) - dSP; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoDIRP(io)) + dVAR; dSP; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); + + if (!io || !IoDIRP(io)) { + if(ckWARN(WARN_IO)) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv)); + } goto nope; - + } (void)PerlDir_rewind(IoDIRP(io)); RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS$_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); @@ -3906,13 +3834,17 @@ nope: PP(pp_closedir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dSP; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoDIRP(io)) - goto nope; - + dVAR; dSP; + GV * const gv = (GV*)POPs; + register IO * const io = GvIOn(gv); + + if (!io || !IoDIRP(io)) { + if(ckWARN(WARN_IO)) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "closedir() attempted on invalid dirhandle %s", GvENAME(gv)); + } + goto nope; + } #ifdef VOID_CLOSEDIR PerlDir_close(IoDIRP(io)); #else @@ -3926,7 +3858,7 @@ PP(pp_closedir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); @@ -3938,9 +3870,8 @@ nope: PP(pp_fork) { #ifdef HAS_FORK - dSP; dTARGET; + dVAR; dSP; dTARGET; Pid_t childpid; - GV *tmpgv; EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; @@ -3948,13 +3879,18 @@ PP(pp_fork) if (childpid < 0) RETSETUNDEF; if (!childpid) { - /*SUPPRESS 560*/ - if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) { + GV * const tmpgv = gv_fetchpv("$", GV_ADD, SVt_PV); + if (tmpgv) { SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); SvREADONLY_on(GvSV(tmpgv)); } +#ifdef THREADS_HAVE_PIDS + PL_ppid = (IV)getppid(); +#endif +#ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ +#endif } PUSHi(childpid); RETURN; @@ -3979,22 +3915,23 @@ PP(pp_fork) PP(pp_wait) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) - dSP; dTARGET; + dVAR; dSP; dTARGET; Pid_t childpid; int argflags; -#ifdef PERL_OLD_SIGNALS - childpid = wait4pid(-1, &argflags, 0); -#else - while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) { - PERL_ASYNC_CHECK(); + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + childpid = wait4pid(-1, &argflags, 0); + else { + while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && + errno == EINTR) { + PERL_ASYNC_CHECK(); + } } -#endif # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ - STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1); + STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1); # else - STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); + STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1); # endif XPUSHi(childpid); RETURN; @@ -4006,27 +3943,27 @@ PP(pp_wait) PP(pp_waitpid) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) - dSP; dTARGET; - Pid_t childpid; - int optype; + dVAR; dSP; dTARGET; + const int optype = POPi; + const Pid_t pid = TOPi; + Pid_t result; int argflags; - optype = POPi; - childpid = TOPi; -#ifdef PERL_OLD_SIGNALS - childpid = wait4pid(childpid, &argflags, optype); -#else - while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) { - PERL_ASYNC_CHECK(); + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + result = wait4pid(pid, &argflags, optype); + else { + while ((result = wait4pid(pid, &argflags, optype)) == -1 && + errno == EINTR) { + PERL_ASYNC_CHECK(); + } } -#endif # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ - STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1); + STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1); # else - STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); + STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1); # endif - SETi(childpid); + SETi(result); RETURN; #else DIE(aTHX_ PL_no_func, "waitpid"); @@ -4035,34 +3972,26 @@ PP(pp_waitpid) PP(pp_system) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; I32 value; - STRLEN n_a; int result; - I32 did_pipes = 0; if (PL_tainting) { TAINT_ENV(); while (++MARK <= SP) { - (void)SvPV_nolen(*MARK); /* stringify for taint check */ + (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ if (PL_tainted) break; } MARK = ORIGMARK; - /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */ - if (SP - MARK == 1) { - TAINT_PROPER("system"); - } - else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED), - "Use of tainted arguments in %s is deprecated", "system"); - } + TAINT_PROPER("system"); } PERL_FLUSHALL_FOR_CHILD; #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) { Pid_t childpid; int pp[2]; + I32 did_pipes = 0; if (PerlProc_pipe(pp) >= 0) did_pipes = 1; @@ -4070,7 +3999,7 @@ PP(pp_system) if (errno != EAGAIN) { value = -1; SP = ORIGMARK; - PUSHi(value); + XPUSHi(value); if (did_pipes) { PerlLIO_close(pp[0]); PerlLIO_close(pp[1]); @@ -4086,8 +4015,8 @@ PP(pp_system) if (did_pipes) PerlLIO_close(pp[1]); #ifndef PERL_MICRO - rsignal_save(SIGINT, SIG_IGN, &ihand); - rsignal_save(SIGQUIT, SIG_IGN, &qhand); + rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand); + rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); #endif do { result = wait4pid(childpid, &status, 0); @@ -4096,7 +4025,7 @@ PP(pp_system) (void)rsignal_restore(SIGINT, &ihand); (void)rsignal_restore(SIGQUIT, &qhand); #endif - STATUS_NATIVE_SET(result == -1 ? -1 : status); + STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); do_execfree(); /* free any memory child malloced on fork */ SP = ORIGMARK; if (did_pipes) { @@ -4116,10 +4045,10 @@ PP(pp_system) if (n != sizeof(int)) DIE(aTHX_ "panic: kid popen errno read"); errno = errkid; /* Propagate errno from kid */ - STATUS_CURRENT = -1; + STATUS_NATIVE_CHILD_SET(-1); } } - PUSHi(STATUS_CURRENT); + XPUSHi(STATUS_CURRENT); RETURN; } if (did_pipes) { @@ -4129,13 +4058,13 @@ PP(pp_system) #endif } if (PL_op->op_flags & OPf_STACKED) { - SV *really = *++MARK; + SV * const really = *++MARK; value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); } else if (SP - MARK != 1) value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes); else { - value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes); + value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes); } PerlProc__exit(-1); } @@ -4143,50 +4072,51 @@ PP(pp_system) PL_statusvalue = 0; result = 0; if (PL_op->op_flags & OPf_STACKED) { - SV *really = *++MARK; + SV * const really = *++MARK; +# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) + value = (I32)do_aspawn(really, MARK, SP); +# else value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); +# endif } - else if (SP - MARK != 1) + else if (SP - MARK != 1) { +# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) + value = (I32)do_aspawn(Nullsv, MARK, SP); +# else value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); +# endif + } else { - value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); + value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); } if (PL_statusvalue == -1) /* hint that value must be returned as is */ result = 1; - STATUS_NATIVE_SET(value); + STATUS_NATIVE_CHILD_SET(value); do_execfree(); SP = ORIGMARK; - PUSHi(result ? value : STATUS_CURRENT); + XPUSHi(result ? value : STATUS_CURRENT); #endif /* !FORK or VMS */ RETURN; } PP(pp_exec) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; I32 value; - STRLEN n_a; if (PL_tainting) { TAINT_ENV(); while (++MARK <= SP) { - (void)SvPV_nolen(*MARK); /* stringify for taint check */ + (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ if (PL_tainted) break; } MARK = ORIGMARK; - /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */ - if (SP - MARK == 1) { - TAINT_PROPER("exec"); - } - else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED), - "Use of tainted arguments in %s is deprecated", "exec"); - } + TAINT_PROPER("exec"); } PERL_FLUSHALL_FOR_CHILD; if (PL_op->op_flags & OPf_STACKED) { - SV *really = *++MARK; + SV * const really = *++MARK; value = (I32)do_aexec(really, MARK, SP); } else if (SP - MARK != 1) @@ -4204,41 +4134,34 @@ PP(pp_exec) #endif else { #ifdef VMS - value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); + value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #else # ifdef __OPEN_VM - (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); + (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); value = 0; # else - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); + value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); # endif #endif } SP = ORIGMARK; - PUSHi(value); - RETURN; -} - -PP(pp_kill) -{ -#ifdef HAS_KILL - dSP; dMARK; dTARGET; - I32 value; - value = (I32)apply(PL_op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); + XPUSHi(value); RETURN; -#else - DIE(aTHX_ PL_no_func, "kill"); -#endif } PP(pp_getppid) { #ifdef HAS_GETPPID - dSP; dTARGET; + dVAR; dSP; dTARGET; +# ifdef THREADS_HAVE_PIDS + if (PL_ppid != 1 && getppid() == 1) + /* maybe the parent process has died. Refresh ppid cache */ + PL_ppid = 1; + XPUSHi( PL_ppid ); +# else XPUSHi( getppid() ); +# endif RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); @@ -4248,14 +4171,10 @@ PP(pp_getppid) PP(pp_getpgrp) { #ifdef HAS_GETPGRP - dSP; dTARGET; - Pid_t pid; + dVAR; dSP; dTARGET; Pid_t pgrp; + const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs); - if (MAXARG < 1) - pid = 0; - else - pid = SvIVx(POPs); #ifdef BSD_GETPGRP pgrp = (I32)BSD_GETPGRP(pid); #else @@ -4273,7 +4192,7 @@ PP(pp_getpgrp) PP(pp_setpgrp) { #ifdef HAS_SETPGRP - dSP; dTARGET; + dVAR; dSP; dTARGET; Pid_t pgrp; Pid_t pid; if (MAXARG < 2) { @@ -4305,9 +4224,9 @@ PP(pp_setpgrp) PP(pp_getpriority) { #ifdef HAS_GETPRIORITY - dSP; dTARGET; - int who = POPi; - int which = TOPi; + dVAR; dSP; dTARGET; + const int who = POPi; + const int which = TOPi; SETi( getpriority(which, who) ); RETURN; #else @@ -4318,10 +4237,10 @@ PP(pp_getpriority) PP(pp_setpriority) { #ifdef HAS_SETPRIORITY - dSP; dTARGET; - int niceval = POPi; - int who = POPi; - int which = TOPi; + dVAR; dSP; dTARGET; + const int niceval = POPi; + const int who = POPi; + const int which = TOPi; TAINT_PROPER("setpriority"); SETi( setpriority(which, who, niceval) >= 0 ); RETURN; @@ -4334,7 +4253,7 @@ PP(pp_setpriority) PP(pp_time) { - dSP; dTARGET; + dVAR; dSP; dTARGET; #ifdef BIG_TIME XPUSHn( time(Null(Time_t*)) ); #else @@ -4343,29 +4262,10 @@ PP(pp_time) RETURN; } -/* XXX The POSIX name is CLK_TCK; it is to be preferred - to HZ. Probably. For now, assume that if the system - defines HZ, it does so correctly. (Will this break - on VMS?) - Probably we ought to use _sysconf(_SC_CLK_TCK), if - it's supported. --AD 9/96. -*/ - -#ifdef __BEOS__ -# define HZ 1000000 -#endif - -#ifndef HZ -# ifdef CLK_TCK -# define HZ CLK_TCK -# else -# define HZ 60 -# endif -#endif - PP(pp_tms) { #ifdef HAS_TIMES + dVAR; dSP; EXTEND(SP, 4); #ifndef VMS @@ -4376,31 +4276,81 @@ PP(pp_tms) /* is returned. */ #endif - PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ))); + PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick))); if (GIMME == G_ARRAY) { - PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ))); - PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ))); - PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ))); + PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick))); + PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick))); + PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick))); } RETURN; #else +# ifdef PERL_MICRO + dSP; + PUSHs(sv_2mortal(newSVnv((NV)0.0))); + EXTEND(SP, 4); + if (GIMME == G_ARRAY) { + PUSHs(sv_2mortal(newSVnv((NV)0.0))); + PUSHs(sv_2mortal(newSVnv((NV)0.0))); + PUSHs(sv_2mortal(newSVnv((NV)0.0))); + } + RETURN; +# else DIE(aTHX_ "times not implemented"); +# endif #endif /* HAS_TIMES */ } -PP(pp_localtime) -{ - return pp_gmtime(); -} +#ifdef LOCALTIME_EDGECASE_BROKEN +static struct tm *S_my_localtime (pTHX_ Time_t *tp) +{ + auto time_t T; + auto struct tm *P; + + /* No workarounds in the valid range */ + if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000) + return (localtime (tp)); + + /* This edge case is to workaround the undefined behaviour, where the + * TIMEZONE makes the time go beyond the defined range. + * gmtime (0x7fffffff) => 2038-01-19 03:14:07 + * If there is a negative offset in TZ, like MET-1METDST, some broken + * implementations of localtime () (like AIX 5.2) barf with bogus + * return values: + * 0x7fffffff gmtime 2038-01-19 03:14:07 + * 0x7fffffff localtime 1901-12-13 21:45:51 + * 0x7fffffff mylocaltime 2038-01-19 04:14:07 + * 0x3c19137f gmtime 2001-12-13 20:45:51 + * 0x3c19137f localtime 2001-12-13 21:45:51 + * 0x3c19137f mylocaltime 2001-12-13 21:45:51 + * Given that legal timezones are typically between GMT-12 and GMT+12 + * we turn back the clock 23 hours before calling the localtime + * function, and add those to the return value. This will never cause + * day wrapping problems, since the edge case is Tue Jan *19* + */ + T = *tp - 82800; /* 23 hour. allows up to GMT-23 */ + P = localtime (&T); + P->tm_hour += 23; + if (P->tm_hour >= 24) { + P->tm_hour -= 24; + P->tm_mday++; /* 18 -> 19 */ + P->tm_wday++; /* Mon -> Tue */ + P->tm_yday++; /* 18 -> 19 */ + } + return (P); +} /* S_my_localtime */ +#endif PP(pp_gmtime) { + dVAR; dSP; Time_t when; - struct tm *tmbuf; - static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; - static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; + const struct tm *tmbuf; + static const char * const dayname[] = + {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; + static const char * const monname[] = + {"Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; if (MAXARG < 1) (void)time(&when); @@ -4412,7 +4362,11 @@ PP(pp_gmtime) #endif if (PL_op->op_type == OP_LOCALTIME) +#ifdef LOCALTIME_EDGECASE_BROKEN + tmbuf = S_my_localtime(aTHX_ &when); +#else tmbuf = localtime(&when); +#endif else tmbuf = gmtime(&when); @@ -4451,7 +4405,7 @@ PP(pp_gmtime) PP(pp_alarm) { #ifdef HAS_ALARM - dSP; dTARGET; + dVAR; dSP; dTARGET; int anum; anum = POPi; anum = alarm((unsigned int)anum); @@ -4467,7 +4421,7 @@ PP(pp_alarm) PP(pp_sleep) { - dSP; dTARGET; + dVAR; dSP; dTARGET; I32 duration; Time_t lasttime; Time_t when; @@ -4485,65 +4439,30 @@ PP(pp_sleep) } /* Shared memory. */ - -PP(pp_shmget) -{ - return pp_semget(); -} - -PP(pp_shmctl) -{ - return pp_semctl(); -} - -PP(pp_shmread) -{ - return pp_shmwrite(); -} +/* Merged with some message passing. */ PP(pp_shmwrite) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0); - SP = MARK; - PUSHi(value); - RETURN; -#else - return pp_semget(); -#endif -} - -/* Message passing. */ - -PP(pp_msgget) -{ - return pp_semget(); -} - -PP(pp_msgctl) -{ - return pp_semctl(); -} + dVAR; dSP; dMARK; dTARGET; + const int op_type = PL_op->op_type; + I32 value; -PP(pp_msgsnd) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - I32 value = (I32)(do_msgsnd(MARK, SP) >= 0); - SP = MARK; - PUSHi(value); - RETURN; -#else - return pp_semget(); -#endif -} + switch (op_type) { + case OP_MSGSND: + value = (I32)(do_msgsnd(MARK, SP) >= 0); + break; + case OP_MSGRCV: + value = (I32)(do_msgrcv(MARK, SP) >= 0); + break; + case OP_SEMOP: + value = (I32)(do_semop(MARK, SP) >= 0); + break; + default: + value = (I32)(do_shmio(op_type, MARK, SP) >= 0); + break; + } -PP(pp_msgrcv) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - I32 value = (I32)(do_msgrcv(MARK, SP) >= 0); SP = MARK; PUSHi(value); RETURN; @@ -4557,8 +4476,8 @@ PP(pp_msgrcv) PP(pp_semget) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - int anum = do_ipcget(PL_op->op_type, MARK, SP); + dVAR; dSP; dMARK; dTARGET; + const int anum = do_ipcget(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) RETPUSHUNDEF; @@ -4572,8 +4491,8 @@ PP(pp_semget) PP(pp_semctl) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - int anum = do_ipcctl(PL_op->op_type, MARK, SP); + dVAR; dSP; dMARK; dTARGET; + const int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) RETSETUNDEF; @@ -4589,43 +4508,12 @@ PP(pp_semctl) #endif } -PP(pp_semop) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - I32 value = (I32)(do_semop(MARK, SP) >= 0); - SP = MARK; - PUSHi(value); - RETURN; -#else - return pp_semget(); -#endif -} - /* Get system info. */ -PP(pp_ghbyname) -{ -#ifdef HAS_GETHOSTBYNAME - return pp_ghostent(); -#else - DIE(aTHX_ PL_no_sock_func, "gethostbyname"); -#endif -} - -PP(pp_ghbyaddr) -{ -#ifdef HAS_GETHOSTBYADDR - return pp_ghostent(); -#else - DIE(aTHX_ PL_no_sock_func, "gethostbyaddr"); -#endif -} - PP(pp_ghostent) { #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) - dSP; + dVAR; dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -4636,12 +4524,11 @@ PP(pp_ghostent) #endif struct hostent *hent; unsigned long len; - STRLEN n_a; EXTEND(SP, 10); if (which == OP_GHBYNAME) { #ifdef HAS_GETHOSTBYNAME - char* name = POPpbytex; + const char* const name = POPpbytex; hent = PerlSock_gethostbyname(name); #else DIE(aTHX_ PL_no_sock_func, "gethostbyname"); @@ -4649,8 +4536,8 @@ PP(pp_ghostent) } else if (which == OP_GHBYADDR) { #ifdef HAS_GETHOSTBYADDR - int addrtype = POPi; - SV *addrsv = POPs; + const int addrtype = POPi; + SV * const addrsv = POPs; STRLEN addrlen; Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen); @@ -4673,7 +4560,7 @@ PP(pp_ghostent) h_errno = PL_reentrant_buffer->_gethostent_errno; # endif #endif - STATUS_NATIVE_SET(h_errno); + STATUS_UNIX_SET(h_errno); } #endif @@ -4697,7 +4584,7 @@ PP(pp_ghostent) for (elem = hent->h_aliases; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) - sv_catpvn(sv, " ", 1); + sv_catpvs(sv, " "); } PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setiv(sv, (IV)hent->h_addrtype); @@ -4721,28 +4608,10 @@ PP(pp_ghostent) #endif } -PP(pp_gnbyname) -{ -#ifdef HAS_GETNETBYNAME - return pp_gnetent(); -#else - DIE(aTHX_ PL_no_sock_func, "getnetbyname"); -#endif -} - -PP(pp_gnbyaddr) -{ -#ifdef HAS_GETNETBYADDR - return pp_gnetent(); -#else - DIE(aTHX_ PL_no_sock_func, "getnetbyaddr"); -#endif -} - PP(pp_gnetent) { #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) - dSP; + dVAR; dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -4752,11 +4621,10 @@ PP(pp_gnetent) struct netent *getnetent(void); #endif struct netent *nent; - STRLEN n_a; if (which == OP_GNBYNAME){ #ifdef HAS_GETNETBYNAME - char *name = POPpbytex; + const char * const name = POPpbytex; nent = PerlSock_getnetbyname(name); #else DIE(aTHX_ PL_no_sock_func, "getnetbyname"); @@ -4764,8 +4632,8 @@ PP(pp_gnetent) } else if (which == OP_GNBYADDR) { #ifdef HAS_GETNETBYADDR - int addrtype = POPi; - Netdb_net_t addr = (Netdb_net_t) (U32)POPu; + const int addrtype = POPi; + const Netdb_net_t addr = (Netdb_net_t) (U32)POPu; nent = PerlSock_getnetbyaddr(addr, addrtype); #else DIE(aTHX_ PL_no_sock_func, "getnetbyaddr"); @@ -4785,7 +4653,7 @@ PP(pp_gnetent) h_errno = PL_reentrant_buffer->_getnetent_errno; # endif #endif - STATUS_NATIVE_SET(h_errno); + STATUS_UNIX_SET(h_errno); } #endif @@ -4808,7 +4676,7 @@ PP(pp_gnetent) for (elem = nent->n_aliases; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) - sv_catpvn(sv, " ", 1); + sv_catpvs(sv, " "); } PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setiv(sv, (IV)nent->n_addrtype); @@ -4822,28 +4690,10 @@ PP(pp_gnetent) #endif } -PP(pp_gpbyname) -{ -#ifdef HAS_GETPROTOBYNAME - return pp_gprotoent(); -#else - DIE(aTHX_ PL_no_sock_func, "getprotobyname"); -#endif -} - -PP(pp_gpbynumber) -{ -#ifdef HAS_GETPROTOBYNUMBER - return pp_gprotoent(); -#else - DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); -#endif -} - PP(pp_gprotoent) { #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) - dSP; + dVAR; dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -4853,11 +4703,10 @@ PP(pp_gprotoent) struct protoent *getprotoent(void); #endif struct protoent *pent; - STRLEN n_a; if (which == OP_GPBYNAME) { #ifdef HAS_GETPROTOBYNAME - char* name = POPpbytex; + const char* const name = POPpbytex; pent = PerlSock_getprotobyname(name); #else DIE(aTHX_ PL_no_sock_func, "getprotobyname"); @@ -4865,7 +4714,7 @@ PP(pp_gprotoent) } else if (which == OP_GPBYNUMBER) { #ifdef HAS_GETPROTOBYNUMBER - int number = POPi; + const int number = POPi; pent = PerlSock_getprotobynumber(number); #else DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); @@ -4897,7 +4746,7 @@ PP(pp_gprotoent) for (elem = pent->p_aliases; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) - sv_catpvn(sv, " ", 1); + sv_catpvs(sv, " "); } PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setiv(sv, (IV)pent->p_proto); @@ -4909,28 +4758,10 @@ PP(pp_gprotoent) #endif } -PP(pp_gsbyname) -{ -#ifdef HAS_GETSERVBYNAME - return pp_gservent(); -#else - DIE(aTHX_ PL_no_sock_func, "getservbyname"); -#endif -} - -PP(pp_gsbyport) -{ -#ifdef HAS_GETSERVBYPORT - return pp_gservent(); -#else - DIE(aTHX_ PL_no_sock_func, "getservbyport"); -#endif -} - PP(pp_gservent) { #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) - dSP; + dVAR; dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; @@ -4940,30 +4771,24 @@ PP(pp_gservent) struct servent *getservent(void); #endif struct servent *sent; - STRLEN n_a; if (which == OP_GSBYNAME) { #ifdef HAS_GETSERVBYNAME - char *proto = POPpbytex; - char *name = POPpbytex; - - if (proto && !*proto) - proto = Nullch; - - sent = PerlSock_getservbyname(name, proto); + const char * const proto = POPpbytex; + const char * const name = POPpbytex; + sent = PerlSock_getservbyname(name, (proto && !*proto) ? Nullch : proto); #else DIE(aTHX_ PL_no_sock_func, "getservbyname"); #endif } else if (which == OP_GSBYPORT) { #ifdef HAS_GETSERVBYPORT - char *proto = POPpbytex; + const char * const proto = POPpbytex; unsigned short port = (unsigned short)POPu; - #ifdef HAS_HTONS port = PerlSock_htons(port); #endif - sent = PerlSock_getservbyport(port, proto); + sent = PerlSock_getservbyport(port, (proto && !*proto) ? Nullch : proto); #else DIE(aTHX_ PL_no_sock_func, "getservbyport"); #endif @@ -4999,7 +4824,7 @@ PP(pp_gservent) for (elem = sent->s_aliases; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) - sv_catpvn(sv, " ", 1); + sv_catpvs(sv, " "); } PUSHs(sv = sv_mortalcopy(&PL_sv_no)); #ifdef HAS_NTOHS @@ -5020,7 +4845,7 @@ PP(pp_gservent) PP(pp_shostent) { #ifdef HAS_SETHOSTENT - dSP; + dVAR; dSP; PerlSock_sethostent(TOPi); RETSETYES; #else @@ -5031,7 +4856,7 @@ PP(pp_shostent) PP(pp_snetent) { #ifdef HAS_SETNETENT - dSP; + dVAR; dSP; PerlSock_setnetent(TOPi); RETSETYES; #else @@ -5042,7 +4867,7 @@ PP(pp_snetent) PP(pp_sprotoent) { #ifdef HAS_SETPROTOENT - dSP; + dVAR; dSP; PerlSock_setprotoent(TOPi); RETSETYES; #else @@ -5053,7 +4878,7 @@ PP(pp_sprotoent) PP(pp_sservent) { #ifdef HAS_SETSERVENT - dSP; + dVAR; dSP; PerlSock_setservent(TOPi); RETSETYES; #else @@ -5064,7 +4889,7 @@ PP(pp_sservent) PP(pp_ehostent) { #ifdef HAS_ENDHOSTENT - dSP; + dVAR; dSP; PerlSock_endhostent(); EXTEND(SP,1); RETPUSHYES; @@ -5076,7 +4901,7 @@ PP(pp_ehostent) PP(pp_enetent) { #ifdef HAS_ENDNETENT - dSP; + dVAR; dSP; PerlSock_endnetent(); EXTEND(SP,1); RETPUSHYES; @@ -5088,7 +4913,7 @@ PP(pp_enetent) PP(pp_eprotoent) { #ifdef HAS_ENDPROTOENT - dSP; + dVAR; dSP; PerlSock_endprotoent(); EXTEND(SP,1); RETPUSHYES; @@ -5100,7 +4925,7 @@ PP(pp_eprotoent) PP(pp_eservent) { #ifdef HAS_ENDSERVENT - dSP; + dVAR; dSP; PerlSock_endservent(); EXTEND(SP,1); RETPUSHYES; @@ -5109,31 +4934,12 @@ PP(pp_eservent) #endif } -PP(pp_gpwnam) -{ -#ifdef HAS_PASSWD - return pp_gpwent(); -#else - DIE(aTHX_ PL_no_func, "getpwnam"); -#endif -} - -PP(pp_gpwuid) -{ -#ifdef HAS_PASSWD - return pp_gpwent(); -#else - DIE(aTHX_ PL_no_func, "getpwuid"); -#endif -} - PP(pp_gpwent) { #ifdef HAS_PASSWD - dSP; + dVAR; dSP; I32 which = PL_op->op_type; register SV *sv; - STRLEN n_a; struct passwd *pwent = NULL; /* * We currently support only the SysV getsp* shadow password interface. @@ -5145,7 +4951,7 @@ PP(pp_gpwent) * AIX getpwnam() is clever enough to return the encrypted password * only if the caller (euid?) is root. * - * There are at least two other shadow password APIs. Many platforms + * There are at least three other shadow password APIs. Many platforms * seem to contain more than one interface for accessing the shadow * password databases, possibly for compatibility reasons. * The getsp*() is by far he simplest one, the other two interfaces @@ -5167,6 +4973,12 @@ PP(pp_gpwent) * char *(getespw*(...).ufld.fd_encrypt) * Mention HAS_GETESPWNAM here so that Configure probes for it. * + * (AIX) + * struct userpw *getuserpw(); + * The password is in + * char *(getuserpw(...)).spw_upw_passwd + * (but the de facto standard getpwnam() should work okay) + * * Mention I_PROT here so that Configure probes for it. * * In HP-UX for getprpw*() the manual page claims that one should include @@ -5189,10 +5001,16 @@ PP(pp_gpwent) * --jhi */ +# if defined(__CYGWIN__) && defined(USE_REENTRANT_API) + /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r(): + * the pw_comment is left uninitialized. */ + PL_reentrant_buffer->_pwent_struct.pw_comment = NULL; +# endif + switch (which) { case OP_GPWNAM: { - char* name = POPpbytex; + const char* const name = POPpbytex; pwent = getpwnam(name); } break; @@ -5205,6 +5023,9 @@ PP(pp_gpwent) case OP_GPWENT: # ifdef HAS_GETPWENT pwent = getpwent(); +#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */ + if (pwent) pwent = getpwnam(pwent->pw_name); +#endif # else DIE(aTHX_ PL_no_func, "getpwent"); # endif @@ -5249,16 +5070,16 @@ PP(pp_gpwent) * Divert the urge to writing an extension instead. * * --jhi */ -# ifdef HAS_GETSPNAM + /* Some AIX setups falsely(?) detect some getspnam(), which + * has a different API than the Solaris/IRIX one. */ +# if defined(HAS_GETSPNAM) && !defined(_AIX) { - struct spwd *spwent; - int saverrno; /* Save and restore errno so that + const int saverrno = errno; + const struct spwd * const spwent = getspnam(pwent->pw_name); + /* Save and restore errno so that * underprivileged attempts seem * to have never made the unsccessful * attempt to retrieve the shadow password. */ - - saverrno = errno; - spwent = getspnam(pwent->pw_name); errno = saverrno; if (spwent && spwent->sp_pwdp) sv_setpv(sv, spwent->sp_pwdp); @@ -5343,14 +5164,14 @@ PP(pp_gpwent) } RETURN; #else - DIE(aTHX_ PL_no_func, "getpwent"); + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); #endif } PP(pp_spwent) { #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) - dSP; + dVAR; dSP; setpwent(); RETPUSHYES; #else @@ -5361,7 +5182,7 @@ PP(pp_spwent) PP(pp_epwent) { #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) - dSP; + dVAR; dSP; endpwent(); RETPUSHYES; #else @@ -5369,40 +5190,21 @@ PP(pp_epwent) #endif } -PP(pp_ggrnam) -{ -#ifdef HAS_GROUP - return pp_ggrent(); -#else - DIE(aTHX_ PL_no_func, "getgrnam"); -#endif -} - -PP(pp_ggrgid) -{ -#ifdef HAS_GROUP - return pp_ggrent(); -#else - DIE(aTHX_ PL_no_func, "getgrgid"); -#endif -} - PP(pp_ggrent) { #ifdef HAS_GROUP - dSP; + dVAR; dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; struct group *grent; - STRLEN n_a; if (which == OP_GGRNAM) { - char* name = POPpbytex; + const char* const name = POPpbytex; grent = (struct group *)getgrnam(name); } else if (which == OP_GGRGID) { - Gid_t gid = POPi; + const Gid_t gid = POPi; grent = (struct group *)getgrgid(gid); } else @@ -5449,21 +5251,21 @@ PP(pp_ggrent) for (elem = grent->gr_mem; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) - sv_catpvn(sv, " ", 1); + sv_catpvs(sv, " "); } #endif } RETURN; #else - DIE(aTHX_ PL_no_func, "getgrent"); + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); #endif } PP(pp_sgrent) { #if defined(HAS_GROUP) && defined(HAS_SETGRENT) - dSP; + dVAR; dSP; setgrent(); RETPUSHYES; #else @@ -5474,7 +5276,7 @@ PP(pp_sgrent) PP(pp_egrent) { #if defined(HAS_GROUP) && defined(HAS_ENDGRENT) - dSP; + dVAR; dSP; endgrent(); RETPUSHYES; #else @@ -5485,7 +5287,7 @@ PP(pp_egrent) PP(pp_getlogin) { #ifdef HAS_GETLOGIN - dSP; dTARGET; + dVAR; dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) @@ -5502,12 +5304,11 @@ PP(pp_getlogin) PP(pp_syscall) { #ifdef HAS_SYSCALL - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; register I32 items = SP - MARK; unsigned long a[20]; register I32 i = 0; I32 retval = -1; - STRLEN n_a; if (PL_tainting) { while (++MARK <= SP) { @@ -5530,7 +5331,7 @@ PP(pp_syscall) else if (*MARK == &PL_sv_undef) a[i++] = 0; else - a[i++] = (unsigned long)SvPV_force(*MARK, n_a); + a[i++] = (unsigned long)SvPV_force_nolen(*MARK); if (i > 15) break; } @@ -5663,11 +5464,10 @@ static int lockf_emulate_flock(int fd, int operation) { int i; - int save_errno; + const int save_errno = errno; Off_t pos; /* flock locks entire file so for lockf we need to do the same */ - save_errno = errno; pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */ if (pos > 0) /* is seekable and needs to be repositioned */ if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0) @@ -5713,3 +5513,13 @@ lockf_emulate_flock(int fd, int operation) } #endif /* LOCKF_EMULATE_FLOCK */ + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */