X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=2b96829572d8dad3c36860131f51283f129a9fbf;hb=778ddebdd36200650e05e3789258e36307a5988b;hp=492e35191d1065f7bf7bd2d4af4025f83b38540a;hpb=13c6d55afa635942d3703ea1d73eb249186edfd4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 492e351..2b96829 100644 --- a/mg.c +++ b/mg.c @@ -30,6 +30,11 @@ * Use the "DESTRUCTOR" scope cleanup to reinstate magic. */ +#ifdef PERL_OBJECT + +#define VTBL this->*vtbl + +#else struct magic_state { SV* mgs_sv; U32 mgs_flags; @@ -37,8 +42,11 @@ struct magic_state { typedef struct magic_state MGS; static void restore_magic _((void *p)); +#define VTBL *vtbl + +#endif -static void +STATIC void save_magic(MGS *mgs, SV *sv) { assert(SvMAGICAL(sv)); @@ -52,7 +60,7 @@ save_magic(MGS *mgs, SV *sv) SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; } -static void +STATIC void restore_magic(void *p) { MGS* mgs = (MGS*)p; @@ -76,11 +84,11 @@ mg_magical(SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl) { - if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) + if ((vtbl->svt_get != NULL) && !(mg->mg_flags & MGf_GSKIP)) SvGMAGICAL_on(sv); if (vtbl->svt_set) SvSMAGICAL_on(sv); - if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear) + if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || (vtbl->svt_clear != NULL)) SvRMAGICAL_on(sv); } } @@ -100,8 +108,8 @@ mg_get(SV *sv) mgp = &SvMAGIC(sv); while ((mg = *mgp) != 0) { MGVTBL* vtbl = mg->mg_virtual; - if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { - (*vtbl->svt_get)(sv, mg); + if (!(mg->mg_flags & MGf_GSKIP) && vtbl && (vtbl->svt_get != NULL)) { + (VTBL->svt_get)(sv, mg); /* Ignore this magic if it's been deleted */ if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && (mg->mg_flags & MGf_GSKIP)) @@ -137,8 +145,8 @@ mg_set(SV *sv) mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ mgs.mgs_flags = 0; } - if (vtbl && vtbl->svt_set) - (*vtbl->svt_set)(sv, mg); + if (vtbl && (vtbl->svt_set != NULL)) + (VTBL->svt_set)(sv, mg); } LEAVE; @@ -146,7 +154,7 @@ mg_set(SV *sv) } U32 -mg_len(SV *sv) +mg_length(SV *sv) { MAGIC* mg; char *junk; @@ -154,13 +162,13 @@ mg_len(SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; - if (vtbl && vtbl->svt_len) { + if (vtbl && (vtbl->svt_len != NULL)) { MGS mgs; ENTER; save_magic(&mgs, sv); /* omit MGf_GSKIP -- not changed here */ - len = (*vtbl->svt_len)(sv, mg); + len = (VTBL->svt_len)(sv, mg); LEAVE; return len; } @@ -178,11 +186,11 @@ mg_size(SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; - if (vtbl && vtbl->svt_len) { + if (vtbl && (vtbl->svt_len != NULL)) { MGS mgs; ENTER; /* omit MGf_GSKIP -- not changed here */ - len = (*vtbl->svt_len)(sv, mg); + len = (VTBL->svt_len)(sv, mg); LEAVE; return len; } @@ -214,8 +222,8 @@ mg_clear(SV *sv) MGVTBL* vtbl = mg->mg_virtual; /* omit GSKIP -- never set here */ - if (vtbl && vtbl->svt_clear) - (*vtbl->svt_clear)(sv, mg); + if (vtbl && (vtbl->svt_clear != NULL)) + (VTBL->svt_clear)(sv, mg); } LEAVE; @@ -255,8 +263,8 @@ mg_free(SV *sv) for (mg = SvMAGIC(sv); mg; mg = moremagic) { MGVTBL* vtbl = mg->mg_virtual; moremagic = mg->mg_moremagic; - if (vtbl && vtbl->svt_free) - (*vtbl->svt_free)(sv, mg); + if (vtbl && (vtbl->svt_free != NULL)) + (VTBL->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -385,7 +393,17 @@ magic_get(SV *sv, MAGIC *mg) DWORD dwErr = GetLastError(); sv_setnv(sv, (double)dwErr); if (dwErr) + { +#ifdef PERL_OBJECT + char *sMsg; + DWORD dwLen; + PerlProc_GetSysMsg(sMsg, dwLen, dwErr); + sv_setpvn(sv, sMsg, dwLen); + PerlProc_FreeBuf(sMsg); +#else win32_str_os_error(sv, dwErr); +#endif + } else sv_setpv(sv, ""); SetLastError(dwErr); @@ -460,7 +478,7 @@ magic_get(SV *sv, MAGIC *mg) } sv_setpvn(sv,s,i); if (tainting) - tainted = was_tainted || RX_MATCH_TAINTED(rx); + tainted = (was_tainted || RX_MATCH_TAINTED(rx)); break; } } @@ -880,55 +898,7 @@ magic_setsig(SV *sv, MAGIC *mg) int magic_setisa(SV *sv, MAGIC *mg) { - HV *stash; - SV **svp; - I32 fill; - HV *basefields = Nullhv; - GV **gvp; - GV *gv; - HE *he; - static char *FIELDS = "FIELDS"; - sub_generation++; - - if (mg->mg_type == 'i') - return 0; /* Ignore lower-case version of the magic */ - - stash = GvSTASH(mg->mg_obj); - svp = AvARRAY((AV*)sv); - - /* NOTE: No support for tied ISA */ - for (fill = AvFILLp((AV*)sv); fill >= 0; fill--, svp++) { - HV *basestash = gv_stashsv(*svp, FALSE); - - if (!basestash) { - if (dowarn) - warn("No such package \"%_\" in @ISA assignment", *svp); - continue; - } - gvp = (GV**)hv_fetch(basestash, FIELDS, 6, FALSE); - if (gvp && *gvp && GvHV(*gvp)) { - if (basefields) - croak("Can't multiply inherit %%FIELDS"); - basefields = GvHV(*gvp); - } - } - - if (!basefields) - return 0; - - gv = (GV*)*hv_fetch(stash, FIELDS, 6, TRUE); - if (!isGV(gv)) - gv_init(gv, stash, FIELDS, 6, TRUE); - if (!GvHV(gv)) - GvHV(gv) = newHV(); - if (HvKEYS(GvHV(gv))) - croak("Inherited %%FIELDS can't override existing %%FIELDS"); - - hv_iterinit(GvHV(gv)); - while ((he = hv_iternext(basefields))) - hv_store(GvHV(gv), HeKEY(he), HeKLEN(he), HeVAL(he), HeHASH(he)); - return 0; } @@ -945,17 +915,39 @@ magic_setamagic(SV *sv, MAGIC *mg) #endif /* OVERLOAD */ int +magic_getnkeys(SV *sv, MAGIC *mg) +{ + HV *hv = (HV*)LvTARG(sv); + HE *entry; + I32 i = 0; + + if (hv) { + (void) hv_iterinit(hv); + if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P')) + i = HvKEYS(hv); + else { + /*SUPPRESS 560*/ + while (entry = hv_iternext(hv)) { + i++; + } + } + } + + sv_setiv(sv, (IV)i); + return 0; +} + +int magic_setnkeys(SV *sv, MAGIC *mg) { if (LvTARG(sv)) { hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); - LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */ } return 0; } /* caller is responsible for stack switching/cleanup */ -static int +STATIC int magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val) { dSP; @@ -982,20 +974,20 @@ magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val) return perl_call_method(meth, flags); } -static int +STATIC int magic_methpack(SV *sv, MAGIC *mg, char *meth) { dSP; ENTER; SAVETMPS; - PUSHSTACK(SI_MAGIC); + PUSHSTACKi(PERLSI_MAGIC); if (magic_methcall(mg, meth, G_SCALAR, 2, NULL)) { sv_setsv(sv, *stack_sp--); } - POPSTACK(); + POPSTACK; FREETMPS; LEAVE; return 0; @@ -1015,9 +1007,9 @@ magic_setpack(SV *sv, MAGIC *mg) { dSP; ENTER; - PUSHSTACK(SI_MAGIC); + PUSHSTACKi(PERLSI_MAGIC); magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); - POPSTACK(); + POPSTACK; LEAVE; return 0; } @@ -1037,12 +1029,12 @@ magic_sizepack(SV *sv, MAGIC *mg) ENTER; SAVETMPS; - PUSHSTACK(SI_MAGIC); + PUSHSTACKi(PERLSI_MAGIC); if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { sv = *stack_sp--; retval = (U32) SvIV(sv)-1; } - POPSTACK(); + POPSTACK; FREETMPS; LEAVE; return retval; @@ -1053,12 +1045,12 @@ int magic_wipepack(SV *sv, MAGIC *mg) dSP; ENTER; - PUSHSTACK(SI_MAGIC); + PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); XPUSHs(mg->mg_obj); PUTBACK; perl_call_method("CLEAR", G_SCALAR|G_DISCARD); - POPSTACK(); + POPSTACK; LEAVE; return 0; } @@ -1071,7 +1063,7 @@ magic_nextpack(SV *sv, MAGIC *mg, SV *key) ENTER; SAVETMPS; - PUSHSTACK(SI_MAGIC); + PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP, 2); PUSHs(mg->mg_obj); @@ -1082,7 +1074,7 @@ magic_nextpack(SV *sv, MAGIC *mg, SV *key) if (perl_call_method(meth, G_SCALAR)) sv_setsv(key, *stack_sp--); - POPSTACK(); + POPSTACK; FREETMPS; LEAVE; return 0; @@ -1218,6 +1210,23 @@ magic_setglob(SV *sv, MAGIC *mg) } int +magic_getsubstr(SV *sv, MAGIC *mg) +{ + STRLEN len; + SV *lsv = LvTARG(sv); + char *tmps = SvPV(lsv,len); + I32 offs = LvTARGOFF(sv); + I32 rem = LvTARGLEN(sv); + + if (offs > len) + offs = len; + if (rem + offs > len) + rem = len - offs; + sv_setpvn(sv, tmps + offs, (STRLEN)rem); + return 0; +} + +int magic_setsubstr(SV *sv, MAGIC *mg) { STRLEN len; @@ -1253,6 +1262,72 @@ magic_settaint(SV *sv, MAGIC *mg) } int +magic_getvec(SV *sv, MAGIC *mg) +{ + SV *lsv = LvTARG(sv); + unsigned char *s; + unsigned long retnum; + STRLEN lsvlen; + I32 len; + I32 offset; + I32 size; + + if (!lsv) { + SvOK_off(sv); + return 0; + } + s = (unsigned char *) SvPV(lsv, lsvlen); + offset = LvTARGOFF(sv); + size = LvTARGLEN(sv); + len = (offset + size + 7) / 8; + + /* Copied from pp_vec() */ + + if (len > lsvlen) { + if (size <= 8) + retnum = 0; + else { + offset >>= 3; + if (size == 16) { + if (offset >= lsvlen) + retnum = 0; + else + retnum = (unsigned long) s[offset] << 8; + } + else if (size == 32) { + if (offset >= lsvlen) + retnum = 0; + else if (offset + 1 >= lsvlen) + retnum = (unsigned long) s[offset] << 24; + else if (offset + 2 >= lsvlen) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16); + else + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8); + } + } + } + else if (size < 8) + retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); + else { + offset >>= 3; + if (size == 8) + retnum = s[offset]; + else if (size == 16) + retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; + else if (size == 32) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8) + s[offset+3]; + } + + sv_setuv(sv, (UV)retnum); + return 0; +} + +int magic_setvec(SV *sv, MAGIC *mg) { do_vecset(sv); /* XXX slurp this routine */ @@ -1271,7 +1346,7 @@ magic_getdefelem(SV *sv, MAGIC *mg) targ = HeVAL(he); } else { - AV* av = (AV*)LvTARG(sv); + AV* av = (AV*)LvTARG(sv); if ((I32)LvTARGOFF(sv) <= AvFILL(av)) targ = AvARRAY(av)[LvTARGOFF(sv)]; } @@ -1578,15 +1653,15 @@ magic_set(SV *sv, MAGIC *mg) (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1); #else if (uid == euid) /* special case $< = $> */ - (void)setuid(uid); + (void)PerlProc_setuid(uid); else { - uid = (I32)getuid(); + uid = (I32)PerlProc_getuid(); croak("setruid() not implemented"); } #endif #endif #endif - uid = (I32)getuid(); + uid = (I32)PerlProc_getuid(); tainting |= (uid && (euid != uid || egid != gid)); break; case '>': @@ -1605,15 +1680,15 @@ magic_set(SV *sv, MAGIC *mg) (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1); #else if (euid == uid) /* special case $> = $< */ - setuid(euid); + PerlProc_setuid(euid); else { - euid = (I32)geteuid(); + euid = (I32)PerlProc_geteuid(); croak("seteuid() not implemented"); } #endif #endif #endif - euid = (I32)geteuid(); + euid = (I32)PerlProc_geteuid(); tainting |= (uid && (euid != uid || egid != gid)); break; case '(': @@ -1632,15 +1707,15 @@ magic_set(SV *sv, MAGIC *mg) (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1); #else if (gid == egid) /* special case $( = $) */ - (void)setgid(gid); + (void)PerlProc_setgid(gid); else { - gid = (I32)getgid(); + gid = (I32)PerlProc_getgid(); croak("setrgid() not implemented"); } #endif #endif #endif - gid = (I32)getgid(); + gid = (I32)PerlProc_getgid(); tainting |= (uid && (euid != uid || egid != gid)); break; case ')': @@ -1682,15 +1757,15 @@ magic_set(SV *sv, MAGIC *mg) (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1); #else if (egid == gid) /* special case $) = $( */ - (void)setgid(egid); + (void)PerlProc_setgid(egid); else { - egid = (I32)getegid(); + egid = (I32)PerlProc_getegid(); croak("setegid() not implemented"); } #endif #endif #endif - egid = (I32)getegid(); + egid = (I32)PerlProc_getegid(); tainting |= (uid && (euid != uid || egid != gid)); break; case ':': @@ -1794,7 +1869,7 @@ whichsig(char *sig) static SV* sig_sv; -static void +STATIC void unwind_handler_stack(void *p) { dTHR; @@ -1872,14 +1947,14 @@ sighandler(int sig) sv_setpv(sv,sig_name[sig]); } - PUSHSTACK(SI_SIGNAL); + PUSHSTACKi(PERLSI_SIGNAL); PUSHMARK(SP); PUSHs(sv); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - POPSTACK(); + POPSTACK; cleanup: if (flags & 1) savestack_ix -= 8; /* Unprotect save in progress. */