Test cloning a clone, and make sure original_* accessors follow a
[gitmo/Class-MOP.git] / MOP.xs
1
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 #define NEED_sv_2pv_flags
7 #define NEED_sv_2pv_nolen
8 #include "ppport.h"
9
10 SV *key_name;
11 U32 hash_name;
12
13 SV *key_package;
14 U32 hash_package;
15
16 SV *key_package_name;
17 U32 hash_package_name;
18
19 SV *key_body;
20 U32 hash_body;
21
22 /*
23 get_code_info:
24   Pass in a coderef, returns:
25   [ $pkg_name, $coderef_name ] ie:
26   [ 'Foo::Bar', 'new' ]
27 */
28
29 MODULE = Class::MOP   PACKAGE = Class::MOP
30
31 BOOT:
32     key_name = newSVpvs("name");
33     key_body = newSVpvs("body");
34     key_package = newSVpvs("package");
35     key_package_name = newSVpvs("package_name");
36
37     PERL_HASH(hash_name, "name", 4);
38     PERL_HASH(hash_body, "body", 4);
39     PERL_HASH(hash_package, "package", 7);
40     PERL_HASH(hash_package_name, "package_name", 12);
41
42
43 PROTOTYPES: ENABLE
44
45
46 void
47 get_code_info(coderef)
48   SV* coderef
49   PREINIT:
50     char* name;
51     char* pkg;
52   PPCODE:
53     if( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV){
54       coderef = SvRV(coderef);
55       /* I think this only gets triggered with a mangled coderef, but if
56          we hit it without the guard, we segfault. The slightly odd return
57          value strikes me as an improvement (mst)
58       */
59 #ifdef isGV_with_GP
60       if ( isGV_with_GP(CvGV(coderef))) {
61 #endif
62         pkg     = HvNAME( GvSTASH(CvGV(coderef)) );
63         name    = GvNAME( CvGV(coderef) );
64 #ifdef isGV_with_GP
65       } else {
66         pkg     = "__UNKNOWN__";
67         name    = "__ANON__";
68       }
69 #endif
70
71       EXTEND(SP, 2);
72       PUSHs(newSVpvn(pkg, strlen(pkg)));
73       PUSHs(newSVpvn(name, strlen(name)));
74     }
75
76
77 MODULE = Class::MOP   PACKAGE = Class::MOP::Package
78
79 void
80 get_all_package_symbols(self, ...)
81     SV *self
82     PROTOTYPE: $;$
83     PREINIT:
84         HV *stash = NULL;
85         SV *type_filter = NULL;
86         register HE *he;
87     PPCODE:
88         if (! SvROK(self)) {
89             die("Cannot call get_all_package_symbols as a class method");
90         }
91
92         switch ( GIMME_V ) {
93             case G_VOID: return; break;
94             case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
95         }
96
97         if ( items > 1 ) type_filter = ST(1);
98
99         PUTBACK;
100
101         if (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package))
102             stash = gv_stashsv(HeVAL(he),0);
103
104         if ( stash ) {
105
106             (void)hv_iterinit(stash);
107
108             if ( type_filter && SvPOK(type_filter) ) {
109                 const char *const type = SvPV_nolen(type_filter);
110
111                 while ((he = hv_iternext(stash))) {
112                     SV *const gv = HeVAL(he);
113                     SV *sv;
114                     char *key;
115                     STRLEN keylen;
116                     char *package;
117                     SV *fq;
118
119                     switch( SvTYPE(gv) ) {
120                         case SVt_PVGV:
121                             switch (*type) {
122                                 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
123                                 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
124                                 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
125                                 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
126                                 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
127                                 default:
128                                           croak("Unknown type %s\n", type);
129                             }
130                             break;
131                         case SVt_RV:
132                             /* BAH! constants are horrible */
133
134                             /* we don't really care about the length,
135                                but that's the API */
136                             key = HePV(he, keylen);
137                             package = HvNAME(stash);
138                             fq = newSVpvf("%s::%s", package, key);
139                             sv = sv_2mortal((SV*)get_cv(SvPV_nolen(fq), 0));
140                             break;
141                         default:
142                             continue;
143                     }
144
145                     if ( sv ) {
146                         SV *key = hv_iterkeysv(he);
147                         SPAGAIN;
148                         EXTEND(SP, 2);
149                         PUSHs(key);
150                         PUSHs(sv_2mortal(newRV_inc(sv)));
151                         PUTBACK;
152                     }
153                 }
154             } else {
155                 EXTEND(SP, HvKEYS(stash) * 2);
156
157                 while ((he = hv_iternext(stash))) {
158                     SV *key = hv_iterkeysv(he);
159                     SV *sv = HeVAL(he);
160                     SPAGAIN;
161                     PUSHs(key);
162                     PUSHs(sv);
163                     PUTBACK;
164                 }
165             }
166
167         }
168
169 SV *
170 name(self)
171     SV *self
172     PREINIT:
173         register HE *he;
174     PPCODE:
175         if (! SvROK(self)) {
176             die("Cannot call name as a class method");
177         }
178
179         if (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package))
180             XPUSHs(HeVAL(he));
181         else
182             ST(0) = &PL_sv_undef;
183
184 MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute
185
186 SV *
187 name(self)
188     SV *self
189     PREINIT:
190         register HE *he;
191     PPCODE:
192         if (! SvROK(self)) {
193             die("Cannot call name as a class method");
194         }
195
196         if (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name))
197             XPUSHs(HeVAL(he));
198         else
199             ST(0) = &PL_sv_undef;
200
201 MODULE = Class::MOP   PACKAGE = Class::MOP::Method
202
203 SV *
204 name(self)
205     SV *self
206     PREINIT:
207         register HE *he;
208     PPCODE:
209         if (! SvROK(self)) {
210             die("Cannot call name as a class method");
211         }
212
213         if (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name))
214             XPUSHs(HeVAL(he));
215         else
216             ST(0) = &PL_sv_undef;
217
218 SV *
219 package_name(self)
220     SV *self
221     PREINIT:
222         register HE *he;
223     PPCODE:
224         if (! SvROK(self)) {
225             die("Cannot call package_name as a class method");
226         }
227
228         if (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name))
229             XPUSHs(HeVAL(he));
230         else
231             ST(0) = &PL_sv_undef;
232
233 SV *
234 body(self)
235     SV *self
236     PREINIT:
237         register HE *he;
238     PPCODE:
239         if (! SvROK(self)) {
240             die("Cannot call body as a class method");
241         }
242
243         if (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body))
244             XPUSHs(HeVAL(he));
245         else
246             ST(0) = &PL_sv_undef;