5 mop_deconstruct_variable_name(pTHX_ SV* const variable,
6 const char** const var_name, STRLEN* const var_name_len,
8 const char** const type_name) {
11 if(SvROK(variable) && SvTYPE(SvRV(variable)) == SVt_PVHV){
12 /* e.g. variable = { type => "SCALAR", name => "foo" } */
13 HV* const hv = (HV*)SvRV(variable);
18 svp = hv_fetchs(hv, "name", FALSE);
19 if(!(svp && SvOK(*svp))){
20 croak("You must pass a variable name");
22 *var_name = SvPV_const(*svp, len);
25 croak("You must pass a variable name");
28 svp = hv_fetchs(hv, "type", FALSE);
29 if(!(svp && SvOK(*svp))) {
30 croak("You must pass a variable type");
32 pv = SvPV_nolen_const(*svp);
33 if(strEQ(pv, "SCALAR")){
34 *type = SVt_PV; /* for all the type of scalars */
36 else if(strEQ(pv, "ARRAY")){
39 else if(strEQ(pv, "HASH")){
42 else if(strEQ(pv, "CODE")){
45 else if(strEQ(pv, "GLOB")){
48 else if(strEQ(pv, "IO")){
52 croak("I do not recognize that type '%s'", pv);
59 /* e.g. variable = '$foo' */
61 croak("You must pass a variable name");
63 pv = SvPV_const(variable, len);
65 croak("You must pass a variable name including a sigil");
69 *var_name_len = len - 1;
73 *type = SVt_PV; /* for all the types of scalars */
74 *type_name = "SCALAR";
93 croak("I do not recognize that sigil '%c'", pv[0]);
99 mop_get_gv(pTHX_ SV* const self, svtype const type, const char* const var_name, I32 const var_name_len, I32 const flags){
104 if(!(flags & ~GV_NOADD_MASK)){ /* for shortcut fetching */
105 SV* const ns = mop_call0(aTHX_ self, mop_namespace);
107 if(!(SvROK(ns) && SvTYPE(SvRV(ns)) == SVt_PVHV)){
108 croak("namespace() did not return a hash reference");
110 gvp = (GV**)hv_fetch((HV*)SvRV(ns), var_name, var_name_len, FALSE);
111 if(gvp && isGV_with_GP(*gvp)){
116 package_name = mop_call0(aTHX_ self, KEY_FOR(name));
118 if(!SvOK(package_name)){
119 croak("name() did not return a defined value");
122 pv = SvPV_const(package_name, len);
124 return gv_fetchpvn_flags(Perl_form(aTHX_ "%s::%s", pv, var_name), (len + var_name_len + 2), flags, type);
128 mop_gv_elem(pTHX_ GV* const gv, svtype const type, I32 const add){
135 assert(isGV_with_GP(gv));
139 sv = (SV*)(add ? GvAVn(gv) : GvAV(gv));
142 sv = (SV*)(add ? GvHVn(gv) : GvHV(gv));
148 sv = (SV*)(add ? GvIOn(gv) : GvIO(gv));
153 default: /* SCALAR */
154 sv = add ? GvSVn(gv) : GvSV(gv);
163 mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
165 const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
166 SV *method_metaclass_name;
173 symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
174 sv_2mortal((SV*)symbols);
175 (void)hv_iterinit(symbols);
176 while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
177 CV *cv = (CV *)SvRV(coderef);
183 if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) {
187 /* this checks to see that the subroutine is actually from our package */
188 if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
189 if ( strNE(cvpkg_name, class_name_pv) ) {
194 method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
195 if ( SvOK(method_slot) ) {
196 SV *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
197 if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
202 method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */
205 $method_object = $method_metaclass->wrap(
207 associated_metaclass => $self,
208 package_name => $class_name,
217 PUSHs(method_metaclass_name); /* invocant */
218 mPUSHs(newRV_inc((SV *)cv));
219 PUSHs(mop_associated_metaclass);
221 PUSHs(KEY_FOR(package_name));
223 PUSHs(KEY_FOR(name));
224 mPUSHs(newSVpv(method_name, method_name_len));
227 call_sv(mop_wrap, G_SCALAR | G_METHOD);
229 method_object = POPs;
231 /* $map->{$method_name} = $method_object */
232 sv_setsv(method_slot, method_object);
239 MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package
244 get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
252 if ( ! SvROK(self) ) {
253 die("Cannot call get_all_package_symbols as a class method");
256 if (GIMME_V == G_VOID) {
262 if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) {
263 stash = gv_stashsv(HeVAL(he), 0);
271 symbols = mop_get_all_package_symbols(stash, filter);
272 PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));
278 HV *const obj = (HV *)SvRV(self);
279 SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) );
280 HV *const stash = gv_stashsv(class_name, 0);
286 mXPUSHs(newRV_noinc((SV *)newHV()));
290 current = mop_check_package_cache_flag(aTHX_ stash);
291 cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag)));
292 map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods)));
294 /* $self->{methods} does not yet exist (or got deleted) */
295 if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
296 SV *new_map_ref = newRV_noinc((SV *)newHV());
297 sv_2mortal(new_map_ref);
298 sv_setsv(map_ref, new_map_ref);
301 if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
302 mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
303 sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */
309 INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
313 add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
316 const char* type_name;
317 const char* var_name;
321 mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
322 gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, GV_ADDMULTI);
324 if(SvOK(ref)){ /* add_package_symbol with a value */
327 ref = newRV_noinc(newSVsv(ref));
331 else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
332 croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
335 if(type == SVt_PVCV && GvCV(gv)){
336 /* XXX: clear it before redefinition */
337 SvREFCNT_dec(GvCV(gv));
340 sv_setsv_mg((SV*)gv, ref); /* magical assignment into type glob (*glob = $ref) */
342 if(type == SVt_PVCV){ /* name a subroutine */
343 CV* const subr = (CV*)SvRV(ref);
347 && strEQ(GvNAME(CvGV(subr)), "__ANON__")){
350 A gv "has-a" cv, but a cv refers to a gv as a (pseudo) weak ref.
351 so we can replace CvGV with no SvREFCNT_inc/dec.
358 SvREFCNT_inc_simple_void_NN(ref);
361 SV* const sv = mop_gv_elem(aTHX_ gv, type, GV_ADDMULTI);
362 RETVAL = (sv && GIMME_V != G_VOID) ? newRV_inc(sv) : &PL_sv_undef;
368 has_package_symbol(SV* self, SV* variable)
371 const char* type_name;
372 const char* var_name;
376 mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
377 gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, 0);
378 RETVAL = mop_gv_elem(aTHX_ gv, type, FALSE) ? TRUE : FALSE;
383 get_package_symbol(SV* self, SV* variable, ...)
386 const char* type_name;
387 const char* var_name;
393 if(items > 2){ /* parse options */
395 if((items % 2) != 0){
396 croak("Odd number of arguments for get_package_symbol()");
398 for(i = 2; i < items; i += 2){
399 SV* const opt = ST(i);
400 SV* const val = ST(i+1);
401 if(strEQ(SvPV_nolen_const(opt), "create")){
403 flags |= GV_ADDMULTI;
406 flags &= ~GV_ADDMULTI;
410 warn("Unknown option \"%"SVf"\" for get_package_symbol()", opt);
414 mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
415 gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, flags);
416 sv = mop_gv_elem(aTHX_ gv, type, FALSE);
418 RETVAL = sv ? newRV_inc(sv) : &PL_sv_undef;