Commit | Line | Data |
e0e4674a |
1 | |
2 | #include "EXTERN.h" |
3 | #include "perl.h" |
4 | #include "XSUB.h" |
15273f3c |
5 | |
6 | #define NEED_sv_2pv_nolen |
b0e94057 |
7 | #include "ppport.h" |
e0e4674a |
8 | |
9 | /* |
e0e4674a |
10 | get_code_info: |
11 | Pass in a coderef, returns: |
12 | [ $pkg_name, $coderef_name ] ie: |
13 | [ 'Foo::Bar', 'new' ] |
14 | */ |
15 | |
16 | MODULE = Class::MOP PACKAGE = Class::MOP |
17 | |
d7bf3478 |
18 | PROTOTYPES: ENABLE |
19 | |
e0e4674a |
20 | void |
21 | get_code_info(coderef) |
22 | SV* coderef |
23 | PREINIT: |
24 | char* name; |
25 | char* pkg; |
26 | PPCODE: |
e0e4674a |
27 | if( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV){ |
28 | coderef = SvRV(coderef); |
7b62d87f |
29 | /* I think this only gets triggered with a mangled coderef, but if |
30 | we hit it without the guard, we segfault. The slightly odd return |
31 | value strikes me as an improvement (mst) |
32 | */ |
a4f4221a |
33 | #ifdef isGV_with_GP |
34 | if ( isGV_with_GP(CvGV(coderef))) { |
35 | #endif |
7b62d87f |
36 | pkg = HvNAME( GvSTASH(CvGV(coderef)) ); |
37 | name = GvNAME( CvGV(coderef) ); |
a4f4221a |
38 | #ifdef isGV_with_GP |
39 | } else { |
40 | pkg = "__UNKNOWN__"; |
41 | name = "__ANON__"; |
42 | } |
43 | #endif |
e0e4674a |
44 | |
45 | EXTEND(SP, 2); |
46 | PUSHs(newSVpvn(pkg, strlen(pkg))); |
47 | PUSHs(newSVpvn(name, strlen(name))); |
48 | } |
49 | |
15273f3c |
50 | |
51 | MODULE = Class::MOP PACKAGE = Class::MOP::Package |
52 | |
53 | void |
54 | get_all_package_symbols(package, ...) |
55 | SV *package |
56 | PROTOTYPE: $;$ |
57 | PREINIT: |
58 | HV *stash; |
59 | SV *type_filter = NULL; |
60 | PPCODE: |
61 | |
62 | switch ( GIMME_V ) { |
63 | case G_VOID: return; break; |
64 | case G_SCALAR: ST(0) = &PL_sv_undef; return; break; |
65 | } |
66 | |
67 | if ( items > 1 ) type_filter = ST(1); |
68 | |
69 | PUTBACK; |
70 | |
71 | ENTER; |
72 | SAVETMPS; |
73 | PUSHMARK(SP); |
74 | XPUSHs(package); |
75 | PUTBACK; |
76 | call_method("name", 0); |
77 | SPAGAIN; |
78 | stash = gv_stashsv(POPs, 0); |
79 | FREETMPS; |
80 | LEAVE; |
81 | |
82 | PUTBACK; |
83 | |
84 | if ( stash ) { |
85 | register HE *entry; |
86 | |
87 | (void)hv_iterinit(stash); |
88 | |
89 | if ( type_filter && SvPOK(type_filter) ) { |
90 | const char *const type = SvPV_nolen(type_filter); |
91 | |
92 | |
93 | while ((entry = hv_iternext(stash))) { |
94 | SV *const gv = hv_iterval(stash, entry); |
95 | SV *const key = hv_iterkeysv(entry); |
96 | SV *sv; |
97 | char *package = HvNAME(stash); |
98 | STRLEN pkglen = strlen(package); |
99 | char *fq; |
100 | STRLEN fqlen; |
101 | |
102 | SPAGAIN; |
103 | |
104 | switch( SvTYPE(gv) ) { |
105 | case SVt_PVGV: |
106 | switch (*type) { |
107 | case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */ |
108 | case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */ |
109 | case 'I': sv = (SV *)GvIO(gv); break; /* IO */ |
110 | case 'H': sv = (SV *)GvHV(gv); break; /* HASH */ |
111 | case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */ |
112 | default: |
113 | croak("Unknown type %s\n", type); |
114 | } |
115 | break; |
116 | case SVt_RV: |
117 | /* BAH! constants are horrible */ |
118 | fqlen = pkglen + SvCUR(key) + 3; |
119 | fq = (char *)alloca(fqlen); |
120 | snprintf(fq, fqlen, "%s::%s", package, SvPV_nolen(key)); |
121 | sv = get_cv(fq, 0); |
122 | break; |
123 | default: |
124 | continue; |
125 | } |
126 | |
127 | if ( sv ) { |
128 | SPAGAIN; |
129 | EXTEND(SP, 2); |
130 | PUSHs(key); |
131 | PUSHs(newRV_noinc(sv)); |
132 | PUTBACK; |
133 | } |
134 | } |
135 | } else { |
136 | EXTEND(SP, HvKEYS(stash) * 2); |
137 | |
138 | while ((entry = hv_iternext(stash))) { |
139 | SV *sv; |
140 | SPAGAIN; |
141 | sv = hv_iterkeysv(entry); |
142 | SPAGAIN; |
143 | PUSHs(sv); |
144 | PUTBACK; |
145 | sv = hv_iterval(stash, entry); |
146 | SPAGAIN; |
147 | PUSHs(sv); |
148 | PUTBACK; |
149 | } |
150 | } |
151 | |
152 | } |
153 | |