diff options
| -rw-r--r-- | av.c | 92 | ||||
| -rw-r--r-- | embed.fnc | 8 | ||||
| -rw-r--r-- | embed.h | 6 | ||||
| -rw-r--r-- | mg.c | 191 | ||||
| -rw-r--r-- | proto.h | 11 |
5 files changed, 140 insertions, 168 deletions
@@ -74,19 +74,9 @@ Perl_av_extend(pTHX_ AV *av, I32 key) mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (mg) { - dSP; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,2); - PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - mPUSHi(key + 1); - PUTBACK; - call_method("EXTEND", G_SCALAR|G_DISCARD); - POPSTACK; - FREETMPS; - LEAVE; + SV *arg1 = sv_newmortal(); + sv_setiv(arg1, (IV)(key + 1)); + magic_methcall(MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1, arg1, NULL); return; } if (key > AvMAX(av)) { @@ -554,17 +544,7 @@ Perl_av_push(pTHX_ register AV *av, SV *val) Perl_croak(aTHX_ "%s", PL_no_modify); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,2); - PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - PUSHs(val); - PUTBACK; - ENTER; - call_method("PUSH", G_SCALAR|G_DISCARD); - LEAVE; - POPSTACK; + magic_methcall(MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1, val, NULL); return; } av_store(av,AvFILLp(av)+1,val); @@ -592,19 +572,9 @@ Perl_av_pop(pTHX_ register AV *av) if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - PUTBACK; - ENTER; - if (call_method("POP", G_SCALAR)) { - retval = newSVsv(*PL_stack_sp--); - } else { - retval = &PL_sv_undef; - } - LEAVE; - POPSTACK; + retval = magic_methcall(MUTABLE_SV(av), mg, "POP", 0, 0, NULL, NULL); + if (retval) + retval = newSVsv(retval); return retval; } if (AvFILL(av) < 0) @@ -662,19 +632,8 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) Perl_croak(aTHX_ "%s", PL_no_modify); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,1+num); - PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - while (num-- > 0) { - PUSHs(&PL_sv_undef); - } - PUTBACK; - ENTER; - call_method("UNSHIFT", G_SCALAR|G_DISCARD); - LEAVE; - POPSTACK; + magic_methcall(MUTABLE_SV(av), mg, "UNSHIFT", G_DISCARD, + -num, NULL, NULL); return; } @@ -734,19 +693,9 @@ Perl_av_shift(pTHX_ register AV *av) if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - PUTBACK; - ENTER; - if (call_method("SHIFT", G_SCALAR)) { - retval = newSVsv(*PL_stack_sp--); - } else { - retval = &PL_sv_undef; - } - LEAVE; - POPSTACK; + retval = magic_methcall(MUTABLE_SV(av), mg, "SHIFT", 0, 0, NULL, NULL); + if (retval) + retval = newSVsv(retval); return retval; } if (AvFILL(av) < 0) @@ -806,19 +755,10 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) if (fill < 0) fill = -1; if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,2); - PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - mPUSHi(fill + 1); - PUTBACK; - call_method("STORESIZE", G_SCALAR|G_DISCARD); - POPSTACK; - FREETMPS; - LEAVE; + SV *arg1 = sv_newmortal(); + sv_setiv(arg1, (IV)(fill + 1)); + magic_methcall(MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD, + 1, arg1, NULL); return; } if (fill <= AvMAX(av)) { @@ -681,6 +681,9 @@ p |int |magic_setutf8 |NN SV* sv|NN MAGIC* mg p |int |magic_set_all_env|NN SV* sv|NN MAGIC* mg p |U32 |magic_sizepack |NN SV* sv|NN MAGIC* mg p |int |magic_wipepack |NN SV* sv|NN MAGIC* mg +pd |SV* |magic_methcall |NN SV *sv|NN const MAGIC *mg \ + |NN const char *meth|I32 flags \ + |int n|NULLOK SV* arg1|NULLOK SV* arg2 Ap |void |markstack_grow #if defined(USE_LOCALE_COLLATE) p |int |magic_setcollxfrm|NN SV* sv|NN MAGIC* mg @@ -1489,8 +1492,9 @@ sM |SV * |refcounted_he_value |NN const struct refcounted_he *he #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) s |void |save_magic |I32 mgs_ix|NN SV *sv -s |int |magic_methpack |NN SV *sv|NN const MAGIC *mg|NN const char *meth -s |int |magic_methcall |NN SV *sv|NN const MAGIC *mg|NN const char *meth|I32 f \ +-s |int |magic_methpack |NN SV *sv|NN const MAGIC *mg|NN const char *meth +s |SV* |magic_methcall1|NN SV *sv|NN const MAGIC *mg \ + |NN const char *meth|I32 flags \ |int n|NULLOK SV *val s |void |restore_magic |NULLOK const void *p s |void |unwind_handler_stack|NN const void *p @@ -511,6 +511,7 @@ #define magic_set_all_env Perl_magic_set_all_env #define magic_sizepack Perl_magic_sizepack #define magic_wipepack Perl_magic_wipepack +#define magic_methcall Perl_magic_methcall #endif #define markstack_grow Perl_markstack_grow #if defined(USE_LOCALE_COLLATE) @@ -1242,7 +1243,7 @@ #ifdef PERL_CORE #define save_magic S_save_magic #define magic_methpack S_magic_methpack -#define magic_methcall S_magic_methcall +#define magic_methcall1 S_magic_methcall1 #define restore_magic S_restore_magic #define unwind_handler_stack S_unwind_handler_stack #endif @@ -2922,6 +2923,7 @@ #define magic_set_all_env(a,b) Perl_magic_set_all_env(aTHX_ a,b) #define magic_sizepack(a,b) Perl_magic_sizepack(aTHX_ a,b) #define magic_wipepack(a,b) Perl_magic_wipepack(aTHX_ a,b) +#define magic_methcall(a,b,c,d,e,f,g) Perl_magic_methcall(aTHX_ a,b,c,d,e,f,g) #endif #define markstack_grow() Perl_markstack_grow(aTHX) #if defined(USE_LOCALE_COLLATE) @@ -3647,7 +3649,7 @@ #ifdef PERL_CORE #define save_magic(a,b) S_save_magic(aTHX_ a,b) #define magic_methpack(a,b,c) S_magic_methpack(aTHX_ a,b,c) -#define magic_methcall(a,b,c,d,e,f) S_magic_methcall(aTHX_ a,b,c,d,e,f) +#define magic_methcall1(a,b,c,d,e,f) S_magic_methcall1(aTHX_ a,b,c,d,e,f) #define restore_magic(a) S_restore_magic(aTHX_ a) #define unwind_handler_stack(a) S_unwind_handler_stack(aTHX_ a) #endif @@ -1642,55 +1642,111 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) return 0; } -/* caller is responsible for stack switching/cleanup */ -STATIC int -S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val) +/* +=for apidoc magic_methcall + +Invoke a magic method (like FETCH). + +* sv and mg are the tied thinggy and the tie magic; +* meth is the name of the method to call; +* n, arg1, arg2 are the number of args (in addition to $self) to pass to + the method, and the args themselves (negative n is special-cased); +* flags: + G_DISCARD: invoke method with G_DISCARD flag and don't return a value + +Returns the SV (if any) returned by the method, or NULL on failure. + + +=cut +*/ + +SV* +Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, + int n, SV *arg1, SV *arg2) { dVAR; dSP; + SV* ret = NULL; PERL_ARGS_ASSERT_MAGIC_METHCALL; + ENTER; + PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP, n); - PUSHs(SvTIED_obj(sv, mg)); - if (n > 1) { - if (mg->mg_ptr) { - if (mg->mg_len >= 0) - mPUSHp(mg->mg_ptr, mg->mg_len); - else if (mg->mg_len == HEf_SVKEY) - PUSHs(MUTABLE_SV(mg->mg_ptr)); - } - else if (mg->mg_type == PERL_MAGIC_tiedelem) { - mPUSHi(mg->mg_len); + + if (n < 0) { + /* special case for UNSHIFT */ + EXTEND(SP,-n+1); + PUSHs(SvTIED_obj(sv, mg)); + while (n++ < 0) { + PUSHs(&PL_sv_undef); } } - if (n > 2) { - PUSHs(val); + else { + EXTEND(SP,n+1); + PUSHs(SvTIED_obj(sv, mg)); + if (n > 0) { + PUSHs(arg1); + if (n > 1) PUSHs(arg2); + assert(n <= 2); + } } PUTBACK; + if (flags & G_DISCARD) { + call_method(meth, G_SCALAR|G_DISCARD); + } + else { + if (call_method(meth, G_SCALAR)) + ret = *PL_stack_sp--; + } + POPSTACK; + LEAVE; + return ret; +} + + +/* wrapper for magic_methcall that creates the first arg */ - return call_method(meth, flags); +STATIC SV* +S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, + int n, SV *val) +{ + dVAR; + SV* arg1 = NULL; + + PERL_ARGS_ASSERT_MAGIC_METHCALL1; + + if (mg->mg_ptr) { + if (mg->mg_len >= 0) { + arg1 = newSVpvn(mg->mg_ptr, mg->mg_len); + sv_2mortal(arg1); + } + else if (mg->mg_len == HEf_SVKEY) + arg1 = MUTABLE_SV(mg->mg_ptr); + } + else if (mg->mg_type == PERL_MAGIC_tiedelem) { + arg1 = newSV_type(SVt_IV); + sv_setiv(arg1, (IV)(mg->mg_len)); + sv_2mortal(arg1); + } + if (!arg1) { + arg1 = val; + n--; + } + return magic_methcall(sv, mg, meth, flags, n, arg1, val); } STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) { - dVAR; dSP; + dVAR; + SV* ret; PERL_ARGS_ASSERT_MAGIC_METHPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - - if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { - sv_setsv(sv, *PL_stack_sp--); - } - - POPSTACK; - FREETMPS; - LEAVE; + ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); + if (ret) + sv_setsv(sv, ret); return 0; } @@ -1708,7 +1764,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; MAGIC *tmg; SV *val; @@ -1733,11 +1789,7 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) else val = sv; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, val); - POPSTACK; - LEAVE; + magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val); return 0; } @@ -1753,69 +1805,46 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; I32 retval = 0; + SV* retsv; PERL_ARGS_ASSERT_MAGIC_SIZEPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { - sv = *PL_stack_sp--; - retval = SvIV(sv)-1; + retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL); + if (retsv) { + retval = SvIV(retsv)-1; if (retval < -1) Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); } - POPSTACK; - FREETMPS; - LEAVE; return (U32) retval; } int Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; PERL_ARGS_ASSERT_MAGIC_WIPEPACK; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(sv, mg)); - PUTBACK; - call_method("CLEAR", G_SCALAR|G_DISCARD); - POPSTACK; - LEAVE; - + magic_methcall(sv, mg, "CLEAR", G_DISCARD, 0, NULL, NULL); return 0; } int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) { - dVAR; dSP; - const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; + dVAR; + SV* ret; PERL_ARGS_ASSERT_MAGIC_NEXTPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(SvTIED_obj(sv, mg)); - if (SvOK(key)) - PUSHs(key); - PUTBACK; - - if (call_method(meth, G_SCALAR)) - sv_setsv(key, *PL_stack_sp--); - - POPSTACK; - FREETMPS; - LEAVE; + ret = magic_methcall(sv, mg, + (SvOK(key) ? "NEXTKEY" : "FIRSTKEY"), + 0, + (SvOK(key) ? 1 : 0), key, NULL); + if (ret) + sv_setsv(key,ret); return 0; } @@ -1830,7 +1859,7 @@ Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) SV * Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) { - dVAR; dSP; + dVAR; SV *retval; SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); HV * const pkg = SvSTASH((const SV *)SvRV(tied)); @@ -1850,19 +1879,9 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) } /* there is a SCALAR method that we can call */ - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 1); - PUSHs(tied); - PUTBACK; - - if (call_method("SCALAR", G_SCALAR)) - retval = *PL_stack_sp--; - else + retval = magic_methcall(MUTABLE_SV(hv), mg, "SCALAR", 0, 0, NULL, NULL); + if (!retval) retval = &PL_sv_undef; - POPSTACK; - LEAVE; return retval; } @@ -1901,6 +1901,13 @@ PERL_CALLCONV int Perl_magic_wipepack(pTHX_ SV* sv, MAGIC* mg) #define PERL_ARGS_ASSERT_MAGIC_WIPEPACK \ assert(sv); assert(mg) +PERL_CALLCONV SV* Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV* arg1, SV* arg2) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_MAGIC_METHCALL \ + assert(sv); assert(mg); assert(meth) + PERL_CALLCONV void Perl_markstack_grow(pTHX); #if defined(USE_LOCALE_COLLATE) PERL_CALLCONV int Perl_magic_setcollxfrm(pTHX_ SV* sv, MAGIC* mg) @@ -4481,11 +4488,11 @@ STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) #define PERL_ARGS_ASSERT_MAGIC_METHPACK \ assert(sv); assert(mg); assert(meth) -STATIC int S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 f, int n, SV *val) +STATIC SV* S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); -#define PERL_ARGS_ASSERT_MAGIC_METHCALL \ +#define PERL_ARGS_ASSERT_MAGIC_METHCALL1 \ assert(sv); assert(mg); assert(meth) STATIC void S_restore_magic(pTHX_ const void *p); |