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)) {
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);
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)
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;
}
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)
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)) {
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
#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
#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)
#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
#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)
#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
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;
}
int
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR; dSP;
+ dVAR;
MAGIC *tmg;
SV *val;
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;
}
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;
}
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));
}
/* 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;
}
#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)
#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);
projects / p5sagit/p5-mst-13.2.git / commitdiff