... | ... |
@@ -1,4 +1,5 @@ |
1 | 1 |
0.1748 |
2 |
+ - added EXPERIMETNAL use_next_version method |
|
2 | 3 |
- DBIx::Custom::Query is DEPRECATED! |
3 | 4 |
0.1747 |
4 | 5 |
- fixed bug DBIx::Custom::Result fetch_hash_multi throw warnings |
... | ... |
@@ -18,6 +18,8 @@ use DBIx::Custom::Mapper; |
18 | 18 |
use DBIx::Custom::NotExists; |
19 | 19 |
use Encode qw/encode encode_utf8 decode_utf8/; |
20 | 20 |
use Scalar::Util qw/weaken/; |
21 |
+use DBIx::Custom::Class::Inspector; |
|
22 |
+ |
|
21 | 23 |
|
22 | 24 |
has [qw/connector dsn password quote user exclude_table user_table_info |
23 | 25 |
user_column_info/], |
... | ... |
@@ -1181,6 +1183,49 @@ sub update_timestamp { |
1181 | 1183 |
return $self->{update_timestamp}; |
1182 | 1184 |
} |
1183 | 1185 |
|
1186 |
+sub use_next_version { |
|
1187 |
+ my $self = shift; |
|
1188 |
+ |
|
1189 |
+ my @modules = ('', qw/::Where ::Util ::Result ::Order ::NotExists ::Model ::Mapper/); |
|
1190 |
+ |
|
1191 |
+ # Replace |
|
1192 |
+ for my $module (@modules) { |
|
1193 |
+ my $old = 'DBIx::Custom' . $module; |
|
1194 |
+ my $new = 'DBIx::Custom::Next' . $module; |
|
1195 |
+ |
|
1196 |
+ no strict 'refs'; |
|
1197 |
+ no warnings 'redefine'; |
|
1198 |
+ eval "require $old"; |
|
1199 |
+ die $@ if $@; |
|
1200 |
+ eval "require $new"; |
|
1201 |
+ die $@ if $@; |
|
1202 |
+ for my $method (@{DBIx::Custom::Class::Inspector->methods( $old, 'full', 'public' )}) { |
|
1203 |
+ next unless $method =~ /^DBIx::Custom/; |
|
1204 |
+ undef &{"$method"}; |
|
1205 |
+ *{"$method"} = sub { die "$method method is removed" }; |
|
1206 |
+ } |
|
1207 |
+ |
|
1208 |
+ for my $new_method (@{DBIx::Custom::Class::Inspector->methods( $new, 'full', 'public' )}) { |
|
1209 |
+ next unless $new_method =~ /^DBIx::Custom/; |
|
1210 |
+ my $old_method = $new_method; |
|
1211 |
+ $old_method =~ s/::Next//; |
|
1212 |
+ *{"$old_method"} = \&{"$new_method"}; |
|
1213 |
+ } |
|
1214 |
+ } |
|
1215 |
+ |
|
1216 |
+ # Remove |
|
1217 |
+ for my $module (qw/DBIx::Custom::Tag DBIx::Custom::QueryBuilder/) { |
|
1218 |
+ no strict 'refs'; |
|
1219 |
+ eval "require $module"; |
|
1220 |
+ die $@ if $@; |
|
1221 |
+ for my $method (@{DBIx::Custom::Class::Inspector->methods( $module, 'full', 'public' )}) { |
|
1222 |
+ next unless $method =~ /^DBIx::Custom/; |
|
1223 |
+ undef &{"$method"}; |
|
1224 |
+ *{"$method"} = sub { die "$method method is removed" }; |
|
1225 |
+ } |
|
1226 |
+ } |
|
1227 |
+} |
|
1228 |
+ |
|
1184 | 1229 |
sub values_clause { |
1185 | 1230 |
my ($self, $param, $opts) = @_; |
1186 | 1231 |
|
... | ... |
@@ -3368,6 +3413,13 @@ Show type name of the columns of specified table. |
3368 | 3413 |
|
3369 | 3414 |
This type name is used in C<type_rule>'s C<into1> and C<into2>. |
3370 | 3415 |
|
3416 |
+=head2 C<use_next_version EXPERIMENTAL> |
|
3417 |
+ |
|
3418 |
+ DBIx::Custom->use_next_version; |
|
3419 |
+ |
|
3420 |
+Upgrade next major version L<DBIx::Custom>. |
|
3421 |
+You can't use DEPRECATED method no more and method performance is improved. |
|
3422 |
+ |
|
3371 | 3423 |
=head2 C<values_clause> |
3372 | 3424 |
|
3373 | 3425 |
my $values_clause = $dbi->values_clause({title => 'a', age => 2}); |
... | ... |
@@ -0,0 +1,638 @@ |
1 |
+package DBIx::Custom::Class::Inspector; |
|
2 |
+ |
|
3 |
+=pod |
|
4 |
+ |
|
5 |
+=head1 NAME |
|
6 |
+ |
|
7 |
+DBIx::Custom::Class::Inspector - Internal use (Same as Class::Inspector) |
|
8 |
+ |
|
9 |
+=head1 SYNOPSIS |
|
10 |
+ |
|
11 |
+ use Class::Inspector; |
|
12 |
+ |
|
13 |
+ # Is a class installed and/or loaded |
|
14 |
+ Class::Inspector->installed( 'Foo::Class' ); |
|
15 |
+ Class::Inspector->loaded( 'Foo::Class' ); |
|
16 |
+ |
|
17 |
+ # Filename related information |
|
18 |
+ Class::Inspector->filename( 'Foo::Class' ); |
|
19 |
+ Class::Inspector->resolved_filename( 'Foo::Class' ); |
|
20 |
+ |
|
21 |
+ # Get subroutine related information |
|
22 |
+ Class::Inspector->functions( 'Foo::Class' ); |
|
23 |
+ Class::Inspector->function_refs( 'Foo::Class' ); |
|
24 |
+ Class::Inspector->function_exists( 'Foo::Class', 'bar' ); |
|
25 |
+ Class::Inspector->methods( 'Foo::Class', 'full', 'public' ); |
|
26 |
+ |
|
27 |
+ # Find all loaded subclasses or something |
|
28 |
+ Class::Inspector->subclasses( 'Foo::Class' ); |
|
29 |
+ |
|
30 |
+=head1 DESCRIPTION |
|
31 |
+ |
|
32 |
+Class::Inspector allows you to get information about a loaded class. Most or |
|
33 |
+all of this information can be found in other ways, but they aren't always |
|
34 |
+very friendly, and usually involve a relatively high level of Perl wizardry, |
|
35 |
+or strange and unusual looking code. Class::Inspector attempts to provide |
|
36 |
+an easier, more friendly interface to this information. |
|
37 |
+ |
|
38 |
+=head1 METHODS |
|
39 |
+ |
|
40 |
+=cut |
|
41 |
+ |
|
42 |
+use 5.006; |
|
43 |
+# We don't want to use strict refs anywhere in this module, since we do a |
|
44 |
+# lot of things in here that aren't strict refs friendly. |
|
45 |
+use strict qw{vars subs}; |
|
46 |
+use warnings; |
|
47 |
+use File::Spec (); |
|
48 |
+ |
|
49 |
+# Globals |
|
50 |
+use vars qw{$VERSION $RE_IDENTIFIER $RE_CLASS $UNIX}; |
|
51 |
+BEGIN { |
|
52 |
+ $VERSION = '1.25'; |
|
53 |
+ |
|
54 |
+ # If Unicode is available, enable it so that the |
|
55 |
+ # pattern matches below match unicode method names. |
|
56 |
+ # We can safely ignore any failure here. |
|
57 |
+ SCOPE: { |
|
58 |
+ local $@; |
|
59 |
+ eval "require utf8; utf8->import"; |
|
60 |
+ } |
|
61 |
+ |
|
62 |
+ # Predefine some regexs |
|
63 |
+ $RE_IDENTIFIER = qr/\A[^\W\d]\w*\z/s; |
|
64 |
+ $RE_CLASS = qr/\A[^\W\d]\w*(?:(?:\'|::)\w+)*\z/s; |
|
65 |
+ |
|
66 |
+ # Are we on something Unix-like? |
|
67 |
+ $UNIX = !! ( $File::Spec::ISA[0] eq 'File::Spec::Unix' ); |
|
68 |
+} |
|
69 |
+ |
|
70 |
+ |
|
71 |
+ |
|
72 |
+ |
|
73 |
+ |
|
74 |
+##################################################################### |
|
75 |
+# Basic Methods |
|
76 |
+ |
|
77 |
+=pod |
|
78 |
+ |
|
79 |
+=head2 installed $class |
|
80 |
+ |
|
81 |
+The C<installed> static method tries to determine if a class is installed |
|
82 |
+on the machine, or at least available to Perl. It does this by wrapping |
|
83 |
+around C<resolved_filename>. |
|
84 |
+ |
|
85 |
+Returns true if installed/available, false if the class is not installed, |
|
86 |
+or C<undef> if the class name is invalid. |
|
87 |
+ |
|
88 |
+=cut |
|
89 |
+ |
|
90 |
+sub installed { |
|
91 |
+ my $class = shift; |
|
92 |
+ !! ($class->loaded_filename($_[0]) or $class->resolved_filename($_[0])); |
|
93 |
+} |
|
94 |
+ |
|
95 |
+=pod |
|
96 |
+ |
|
97 |
+=head2 loaded $class |
|
98 |
+ |
|
99 |
+The C<loaded> static method tries to determine if a class is loaded by |
|
100 |
+looking for symbol table entries. |
|
101 |
+ |
|
102 |
+This method it uses to determine this will work even if the class does not |
|
103 |
+have its own file, but is contained inside a single file with multiple |
|
104 |
+classes in it. Even in the case of some sort of run-time loading class |
|
105 |
+being used, these typically leave some trace in the symbol table, so an |
|
106 |
+L<Autoload> or L<Class::Autouse>-based class should correctly appear |
|
107 |
+loaded. |
|
108 |
+ |
|
109 |
+Returns true if the class is loaded, false if not, or C<undef> if the |
|
110 |
+class name is invalid. |
|
111 |
+ |
|
112 |
+=cut |
|
113 |
+ |
|
114 |
+sub loaded { |
|
115 |
+ my $class = shift; |
|
116 |
+ my $name = $class->_class(shift) or return undef; |
|
117 |
+ $class->_loaded($name); |
|
118 |
+} |
|
119 |
+ |
|
120 |
+sub _loaded { |
|
121 |
+ my $class = shift; |
|
122 |
+ my $name = shift; |
|
123 |
+ |
|
124 |
+ # Handle by far the two most common cases |
|
125 |
+ # This is very fast and handles 99% of cases. |
|
126 |
+ return 1 if defined ${"${name}::VERSION"}; |
|
127 |
+ return 1 if defined @{"${name}::ISA"}; |
|
128 |
+ |
|
129 |
+ # Are there any symbol table entries other than other namespaces |
|
130 |
+ foreach ( keys %{"${name}::"} ) { |
|
131 |
+ next if substr($_, -2, 2) eq '::'; |
|
132 |
+ return 1 if defined &{"${name}::$_"}; |
|
133 |
+ } |
|
134 |
+ |
|
135 |
+ # No functions, and it doesn't have a version, and isn't anything. |
|
136 |
+ # As an absolute last resort, check for an entry in %INC |
|
137 |
+ my $filename = $class->_inc_filename($name); |
|
138 |
+ return 1 if defined $INC{$filename}; |
|
139 |
+ |
|
140 |
+ ''; |
|
141 |
+} |
|
142 |
+ |
|
143 |
+=pod |
|
144 |
+ |
|
145 |
+=head2 filename $class |
|
146 |
+ |
|
147 |
+For a given class, returns the base filename for the class. This will NOT |
|
148 |
+be a fully resolved filename, just the part of the filename BELOW the |
|
149 |
+C<@INC> entry. |
|
150 |
+ |
|
151 |
+ print Class->filename( 'Foo::Bar' ); |
|
152 |
+ > Foo/Bar.pm |
|
153 |
+ |
|
154 |
+This filename will be returned with the right seperator for the local |
|
155 |
+platform, and should work on all platforms. |
|
156 |
+ |
|
157 |
+Returns the filename on success or C<undef> if the class name is invalid. |
|
158 |
+ |
|
159 |
+=cut |
|
160 |
+ |
|
161 |
+sub filename { |
|
162 |
+ my $class = shift; |
|
163 |
+ my $name = $class->_class(shift) or return undef; |
|
164 |
+ File::Spec->catfile( split /(?:\'|::)/, $name ) . '.pm'; |
|
165 |
+} |
|
166 |
+ |
|
167 |
+=pod |
|
168 |
+ |
|
169 |
+=head2 resolved_filename $class, @try_first |
|
170 |
+ |
|
171 |
+For a given class, the C<resolved_filename> static method returns the fully |
|
172 |
+resolved filename for a class. That is, the file that the class would be |
|
173 |
+loaded from. |
|
174 |
+ |
|
175 |
+This is not nescesarily the file that the class WAS loaded from, as the |
|
176 |
+value returned is determined each time it runs, and the C<@INC> include |
|
177 |
+path may change. |
|
178 |
+ |
|
179 |
+To get the actual file for a loaded class, see the C<loaded_filename> |
|
180 |
+method. |
|
181 |
+ |
|
182 |
+Returns the filename for the class, or C<undef> if the class name is |
|
183 |
+invalid. |
|
184 |
+ |
|
185 |
+=cut |
|
186 |
+ |
|
187 |
+sub resolved_filename { |
|
188 |
+ my $class = shift; |
|
189 |
+ my $filename = $class->_inc_filename(shift) or return undef; |
|
190 |
+ my @try_first = @_; |
|
191 |
+ |
|
192 |
+ # Look through the @INC path to find the file |
|
193 |
+ foreach ( @try_first, @INC ) { |
|
194 |
+ my $full = "$_/$filename"; |
|
195 |
+ next unless -e $full; |
|
196 |
+ return $UNIX ? $full : $class->_inc_to_local($full); |
|
197 |
+ } |
|
198 |
+ |
|
199 |
+ # File not found |
|
200 |
+ ''; |
|
201 |
+} |
|
202 |
+ |
|
203 |
+=pod |
|
204 |
+ |
|
205 |
+=head2 loaded_filename $class |
|
206 |
+ |
|
207 |
+For a given loaded class, the C<loaded_filename> static method determines |
|
208 |
+(via the C<%INC> hash) the name of the file that it was originally loaded |
|
209 |
+from. |
|
210 |
+ |
|
211 |
+Returns a resolved file path, or false if the class did not have it's own |
|
212 |
+file. |
|
213 |
+ |
|
214 |
+=cut |
|
215 |
+ |
|
216 |
+sub loaded_filename { |
|
217 |
+ my $class = shift; |
|
218 |
+ my $filename = $class->_inc_filename(shift); |
|
219 |
+ $UNIX ? $INC{$filename} : $class->_inc_to_local($INC{$filename}); |
|
220 |
+} |
|
221 |
+ |
|
222 |
+ |
|
223 |
+ |
|
224 |
+ |
|
225 |
+ |
|
226 |
+##################################################################### |
|
227 |
+# Sub Related Methods |
|
228 |
+ |
|
229 |
+=pod |
|
230 |
+ |
|
231 |
+=head2 functions $class |
|
232 |
+ |
|
233 |
+For a loaded class, the C<functions> static method returns a list of the |
|
234 |
+names of all the functions in the classes immediate namespace. |
|
235 |
+ |
|
236 |
+Note that this is not the METHODS of the class, just the functions. |
|
237 |
+ |
|
238 |
+Returns a reference to an array of the function names on success, or C<undef> |
|
239 |
+if the class name is invalid or the class is not loaded. |
|
240 |
+ |
|
241 |
+=cut |
|
242 |
+ |
|
243 |
+sub functions { |
|
244 |
+ my $class = shift; |
|
245 |
+ my $name = $class->_class(shift) or return undef; |
|
246 |
+ return undef unless $class->loaded( $name ); |
|
247 |
+ |
|
248 |
+ # Get all the CODE symbol table entries |
|
249 |
+ my @functions = sort grep { /$RE_IDENTIFIER/o } |
|
250 |
+ grep { defined &{"${name}::$_"} } |
|
251 |
+ keys %{"${name}::"}; |
|
252 |
+ \@functions; |
|
253 |
+} |
|
254 |
+ |
|
255 |
+=pod |
|
256 |
+ |
|
257 |
+=head2 function_refs $class |
|
258 |
+ |
|
259 |
+For a loaded class, the C<function_refs> static method returns references to |
|
260 |
+all the functions in the classes immediate namespace. |
|
261 |
+ |
|
262 |
+Note that this is not the METHODS of the class, just the functions. |
|
263 |
+ |
|
264 |
+Returns a reference to an array of C<CODE> refs of the functions on |
|
265 |
+success, or C<undef> if the class is not loaded. |
|
266 |
+ |
|
267 |
+=cut |
|
268 |
+ |
|
269 |
+sub function_refs { |
|
270 |
+ my $class = shift; |
|
271 |
+ my $name = $class->_class(shift) or return undef; |
|
272 |
+ return undef unless $class->loaded( $name ); |
|
273 |
+ |
|
274 |
+ # Get all the CODE symbol table entries, but return |
|
275 |
+ # the actual CODE refs this time. |
|
276 |
+ my @functions = map { \&{"${name}::$_"} } |
|
277 |
+ sort grep { /$RE_IDENTIFIER/o } |
|
278 |
+ grep { defined &{"${name}::$_"} } |
|
279 |
+ keys %{"${name}::"}; |
|
280 |
+ \@functions; |
|
281 |
+} |
|
282 |
+ |
|
283 |
+=pod |
|
284 |
+ |
|
285 |
+=head2 function_exists $class, $function |
|
286 |
+ |
|
287 |
+Given a class and function name the C<function_exists> static method will |
|
288 |
+check to see if the function exists in the class. |
|
289 |
+ |
|
290 |
+Note that this is as a function, not as a method. To see if a method |
|
291 |
+exists for a class, use the C<can> method for any class or object. |
|
292 |
+ |
|
293 |
+Returns true if the function exists, false if not, or C<undef> if the |
|
294 |
+class or function name are invalid, or the class is not loaded. |
|
295 |
+ |
|
296 |
+=cut |
|
297 |
+ |
|
298 |
+sub function_exists { |
|
299 |
+ my $class = shift; |
|
300 |
+ my $name = $class->_class( shift ) or return undef; |
|
301 |
+ my $function = shift or return undef; |
|
302 |
+ |
|
303 |
+ # Only works if the class is loaded |
|
304 |
+ return undef unless $class->loaded( $name ); |
|
305 |
+ |
|
306 |
+ # Does the GLOB exist and its CODE part exist |
|
307 |
+ defined &{"${name}::$function"}; |
|
308 |
+} |
|
309 |
+ |
|
310 |
+=pod |
|
311 |
+ |
|
312 |
+=head2 methods $class, @options |
|
313 |
+ |
|
314 |
+For a given class name, the C<methods> static method will returns ALL |
|
315 |
+the methods available to that class. This includes all methods available |
|
316 |
+from every class up the class' C<@ISA> tree. |
|
317 |
+ |
|
318 |
+Returns a reference to an array of the names of all the available methods |
|
319 |
+on success, or C<undef> if the class name is invalid or the class is not |
|
320 |
+loaded. |
|
321 |
+ |
|
322 |
+A number of options are available to the C<methods> method that will alter |
|
323 |
+the results returned. These should be listed after the class name, in any |
|
324 |
+order. |
|
325 |
+ |
|
326 |
+ # Only get public methods |
|
327 |
+ my $method = Class::Inspector->methods( 'My::Class', 'public' ); |
|
328 |
+ |
|
329 |
+=over 4 |
|
330 |
+ |
|
331 |
+=item public |
|
332 |
+ |
|
333 |
+The C<public> option will return only 'public' methods, as defined by the Perl |
|
334 |
+convention of prepending an underscore to any 'private' methods. The C<public> |
|
335 |
+option will effectively remove any methods that start with an underscore. |
|
336 |
+ |
|
337 |
+=item private |
|
338 |
+ |
|
339 |
+The C<private> options will return only 'private' methods, as defined by the |
|
340 |
+Perl convention of prepending an underscore to an private methods. The |
|
341 |
+C<private> option will effectively remove an method that do not start with an |
|
342 |
+underscore. |
|
343 |
+ |
|
344 |
+B<Note: The C<public> and C<private> options are mutually exclusive> |
|
345 |
+ |
|
346 |
+=item full |
|
347 |
+ |
|
348 |
+C<methods> normally returns just the method name. Supplying the C<full> option |
|
349 |
+will cause the methods to be returned as the full names. That is, instead of |
|
350 |
+returning C<[ 'method1', 'method2', 'method3' ]>, you would instead get |
|
351 |
+C<[ 'Class::method1', 'AnotherClass::method2', 'Class::method3' ]>. |
|
352 |
+ |
|
353 |
+=item expanded |
|
354 |
+ |
|
355 |
+The C<expanded> option will cause a lot more information about method to be |
|
356 |
+returned. Instead of just the method name, you will instead get an array |
|
357 |
+reference containing the method name as a single combined name, ala C<full>, |
|
358 |
+the seperate class and method, and a CODE ref to the actual function ( if |
|
359 |
+available ). Please note that the function reference is not guarenteed to |
|
360 |
+be available. C<Class::Inspector> is intended at some later time, work |
|
361 |
+with modules that have some some of common run-time loader in place ( e.g |
|
362 |
+C<Autoloader> or C<Class::Autouse> for example. |
|
363 |
+ |
|
364 |
+The response from C<methods( 'Class', 'expanded' )> would look something like |
|
365 |
+the following. |
|
366 |
+ |
|
367 |
+ [ |
|
368 |
+ [ 'Class::method1', 'Class', 'method1', \&Class::method1 ], |
|
369 |
+ [ 'Another::method2', 'Another', 'method2', \&Another::method2 ], |
|
370 |
+ [ 'Foo::bar', 'Foo', 'bar', \&Foo::bar ], |
|
371 |
+ ] |
|
372 |
+ |
|
373 |
+=back |
|
374 |
+ |
|
375 |
+=cut |
|
376 |
+ |
|
377 |
+sub methods { |
|
378 |
+ my $class = shift; |
|
379 |
+ my $name = $class->_class( shift ) or return undef; |
|
380 |
+ my @arguments = map { lc $_ } @_; |
|
381 |
+ |
|
382 |
+ # Process the arguments to determine the options |
|
383 |
+ my %options = (); |
|
384 |
+ foreach ( @arguments ) { |
|
385 |
+ if ( $_ eq 'public' ) { |
|
386 |
+ # Only get public methods |
|
387 |
+ return undef if $options{private}; |
|
388 |
+ $options{public} = 1; |
|
389 |
+ |
|
390 |
+ } elsif ( $_ eq 'private' ) { |
|
391 |
+ # Only get private methods |
|
392 |
+ return undef if $options{public}; |
|
393 |
+ $options{private} = 1; |
|
394 |
+ |
|
395 |
+ } elsif ( $_ eq 'full' ) { |
|
396 |
+ # Return the full method name |
|
397 |
+ return undef if $options{expanded}; |
|
398 |
+ $options{full} = 1; |
|
399 |
+ |
|
400 |
+ } elsif ( $_ eq 'expanded' ) { |
|
401 |
+ # Returns class, method and function ref |
|
402 |
+ return undef if $options{full}; |
|
403 |
+ $options{expanded} = 1; |
|
404 |
+ |
|
405 |
+ } else { |
|
406 |
+ # Unknown or unsupported options |
|
407 |
+ return undef; |
|
408 |
+ } |
|
409 |
+ } |
|
410 |
+ |
|
411 |
+ # Only works if the class is loaded |
|
412 |
+ return undef unless $class->loaded( $name ); |
|
413 |
+ |
|
414 |
+ # Get the super path ( not including UNIVERSAL ) |
|
415 |
+ # Rather than using Class::ISA, we'll use an inlined version |
|
416 |
+ # that implements the same basic algorithm. |
|
417 |
+ my @path = (); |
|
418 |
+ my @queue = ( $name ); |
|
419 |
+ my %seen = ( $name => 1 ); |
|
420 |
+ while ( my $cl = shift @queue ) { |
|
421 |
+ push @path, $cl; |
|
422 |
+ unshift @queue, grep { ! $seen{$_}++ } |
|
423 |
+ map { s/^::/main::/; s/\'/::/g; $_ } |
|
424 |
+ ( @{"${cl}::ISA"} ); |
|
425 |
+ } |
|
426 |
+ |
|
427 |
+ # Find and merge the function names across the entire super path. |
|
428 |
+ # Sort alphabetically and return. |
|
429 |
+ my %methods = (); |
|
430 |
+ foreach my $namespace ( @path ) { |
|
431 |
+ my @functions = grep { ! $methods{$_} } |
|
432 |
+ grep { /$RE_IDENTIFIER/o } |
|
433 |
+ grep { defined &{"${namespace}::$_"} } |
|
434 |
+ keys %{"${namespace}::"}; |
|
435 |
+ foreach ( @functions ) { |
|
436 |
+ $methods{$_} = $namespace; |
|
437 |
+ } |
|
438 |
+ } |
|
439 |
+ |
|
440 |
+ # Filter to public or private methods if needed |
|
441 |
+ my @methodlist = sort keys %methods; |
|
442 |
+ @methodlist = grep { ! /^\_/ } @methodlist if $options{public}; |
|
443 |
+ @methodlist = grep { /^\_/ } @methodlist if $options{private}; |
|
444 |
+ |
|
445 |
+ # Return in the correct format |
|
446 |
+ @methodlist = map { "$methods{$_}::$_" } @methodlist if $options{full}; |
|
447 |
+ @methodlist = map { |
|
448 |
+ [ "$methods{$_}::$_", $methods{$_}, $_, \&{"$methods{$_}::$_"} ] |
|
449 |
+ } @methodlist if $options{expanded}; |
|
450 |
+ |
|
451 |
+ \@methodlist; |
|
452 |
+} |
|
453 |
+ |
|
454 |
+ |
|
455 |
+ |
|
456 |
+ |
|
457 |
+ |
|
458 |
+##################################################################### |
|
459 |
+# Search Methods |
|
460 |
+ |
|
461 |
+=pod |
|
462 |
+ |
|
463 |
+=head2 subclasses $class |
|
464 |
+ |
|
465 |
+The C<subclasses> static method will search then entire namespace (and thus |
|
466 |
+B<all> currently loaded classes) to find all classes that are subclasses |
|
467 |
+of the class provided as a the parameter. |
|
468 |
+ |
|
469 |
+The actual test will be done by calling C<isa> on the class as a static |
|
470 |
+method. (i.e. C<My::Class-E<gt>isa($class)>. |
|
471 |
+ |
|
472 |
+Returns a reference to a list of the loaded classes that match the class |
|
473 |
+provided, or false is none match, or C<undef> if the class name provided |
|
474 |
+is invalid. |
|
475 |
+ |
|
476 |
+=cut |
|
477 |
+ |
|
478 |
+sub subclasses { |
|
479 |
+ my $class = shift; |
|
480 |
+ my $name = $class->_class( shift ) or return undef; |
|
481 |
+ |
|
482 |
+ # Prepare the search queue |
|
483 |
+ my @found = (); |
|
484 |
+ my @queue = grep { $_ ne 'main' } $class->_subnames(''); |
|
485 |
+ while ( @queue ) { |
|
486 |
+ my $c = shift(@queue); # c for class |
|
487 |
+ if ( $class->_loaded($c) ) { |
|
488 |
+ # At least one person has managed to misengineer |
|
489 |
+ # a situation in which ->isa could die, even if the |
|
490 |
+ # class is real. Trap these cases and just skip |
|
491 |
+ # over that (bizarre) class. That would at limit |
|
492 |
+ # problems with finding subclasses to only the |
|
493 |
+ # modules that have broken ->isa implementation. |
|
494 |
+ local $@; |
|
495 |
+ eval { |
|
496 |
+ if ( $c->isa($name) ) { |
|
497 |
+ # Add to the found list, but don't add the class itself |
|
498 |
+ push @found, $c unless $c eq $name; |
|
499 |
+ } |
|
500 |
+ }; |
|
501 |
+ } |
|
502 |
+ |
|
503 |
+ # Add any child namespaces to the head of the queue. |
|
504 |
+ # This keeps the queue length shorted, and allows us |
|
505 |
+ # not to have to do another sort at the end. |
|
506 |
+ unshift @queue, map { "${c}::$_" } $class->_subnames($c); |
|
507 |
+ } |
|
508 |
+ |
|
509 |
+ @found ? \@found : ''; |
|
510 |
+} |
|
511 |
+ |
|
512 |
+sub _subnames { |
|
513 |
+ my ($class, $name) = @_; |
|
514 |
+ return sort |
|
515 |
+ grep { |
|
516 |
+ substr($_, -2, 2, '') eq '::' |
|
517 |
+ and |
|
518 |
+ /$RE_IDENTIFIER/o |
|
519 |
+ } |
|
520 |
+ keys %{"${name}::"}; |
|
521 |
+} |
|
522 |
+ |
|
523 |
+ |
|
524 |
+ |
|
525 |
+ |
|
526 |
+ |
|
527 |
+##################################################################### |
|
528 |
+# Children Related Methods |
|
529 |
+ |
|
530 |
+# These can go undocumented for now, until I decide if its best to |
|
531 |
+# just search the children in namespace only, or if I should do it via |
|
532 |
+# the file system. |
|
533 |
+ |
|
534 |
+# Find all the loaded classes below us |
|
535 |
+sub children { |
|
536 |
+ my $class = shift; |
|
537 |
+ my $name = $class->_class(shift) or return (); |
|
538 |
+ |
|
539 |
+ # Find all the Foo:: elements in our symbol table |
|
540 |
+ no strict 'refs'; |
|
541 |
+ map { "${name}::$_" } sort grep { s/::$// } keys %{"${name}::"}; |
|
542 |
+} |
|
543 |
+ |
|
544 |
+# As above, but recursively |
|
545 |
+sub recursive_children { |
|
546 |
+ my $class = shift; |
|
547 |
+ my $name = $class->_class(shift) or return (); |
|
548 |
+ my @children = ( $name ); |
|
549 |
+ |
|
550 |
+ # Do the search using a nicer, more memory efficient |
|
551 |
+ # variant of actual recursion. |
|
552 |
+ my $i = 0; |
|
553 |
+ no strict 'refs'; |
|
554 |
+ while ( my $namespace = $children[$i++] ) { |
|
555 |
+ push @children, map { "${namespace}::$_" } |
|
556 |
+ grep { ! /^::/ } # Ignore things like ::ISA::CACHE:: |
|
557 |
+ grep { s/::$// } |
|
558 |
+ keys %{"${namespace}::"}; |
|
559 |
+ } |
|
560 |
+ |
|
561 |
+ sort @children; |
|
562 |
+} |
|
563 |
+ |
|
564 |
+ |
|
565 |
+ |
|
566 |
+ |
|
567 |
+ |
|
568 |
+##################################################################### |
|
569 |
+# Private Methods |
|
570 |
+ |
|
571 |
+# Checks and expands ( if needed ) a class name |
|
572 |
+sub _class { |
|
573 |
+ my $class = shift; |
|
574 |
+ my $name = shift or return ''; |
|
575 |
+ |
|
576 |
+ # Handle main shorthand |
|
577 |
+ return 'main' if $name eq '::'; |
|
578 |
+ $name =~ s/\A::/main::/; |
|
579 |
+ |
|
580 |
+ # Check the class name is valid |
|
581 |
+ $name =~ /$RE_CLASS/o ? $name : ''; |
|
582 |
+} |
|
583 |
+ |
|
584 |
+# Create a INC-specific filename, which always uses '/' |
|
585 |
+# regardless of platform. |
|
586 |
+sub _inc_filename { |
|
587 |
+ my $class = shift; |
|
588 |
+ my $name = $class->_class(shift) or return undef; |
|
589 |
+ join( '/', split /(?:\'|::)/, $name ) . '.pm'; |
|
590 |
+} |
|
591 |
+ |
|
592 |
+# Convert INC-specific file name to local file name |
|
593 |
+sub _inc_to_local { |
|
594 |
+ # Shortcut in the Unix case |
|
595 |
+ return $_[1] if $UNIX; |
|
596 |
+ |
|
597 |
+ # On other places, we have to deal with an unusual path that might look |
|
598 |
+ # like C:/foo/bar.pm which doesn't fit ANY normal pattern. |
|
599 |
+ # Putting it through splitpath/dir and back again seems to normalise |
|
600 |
+ # it to a reasonable amount. |
|
601 |
+ my $class = shift; |
|
602 |
+ my $inc_name = shift or return undef; |
|
603 |
+ my ($vol, $dir, $file) = File::Spec->splitpath( $inc_name ); |
|
604 |
+ $dir = File::Spec->catdir( File::Spec->splitdir( $dir || "" ) ); |
|
605 |
+ File::Spec->catpath( $vol, $dir, $file || "" ); |
|
606 |
+} |
|
607 |
+ |
|
608 |
+1; |
|
609 |
+ |
|
610 |
+=pod |
|
611 |
+ |
|
612 |
+=head1 SUPPORT |
|
613 |
+ |
|
614 |
+Bugs should be reported via the CPAN bug tracker |
|
615 |
+ |
|
616 |
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Class-Inspector> |
|
617 |
+ |
|
618 |
+For other issues, or commercial enhancement or support, contact the author. |
|
619 |
+ |
|
620 |
+=head1 AUTHOR |
|
621 |
+ |
|
622 |
+Adam Kennedy E<lt>adamk@cpan.orgE<gt> |
|
623 |
+ |
|
624 |
+=head1 SEE ALSO |
|
625 |
+ |
|
626 |
+L<http://ali.as/>, L<Class::Handle> |
|
627 |
+ |
|
628 |
+=head1 COPYRIGHT |
|
629 |
+ |
|
630 |
+Copyright 2002 - 2011 Adam Kennedy. |
|
631 |
+ |
|
632 |
+This program is free software; you can redistribute |
|
633 |
+it and/or modify it under the same terms as Perl itself. |
|
634 |
+ |
|
635 |
+The full text of the license can be found in the |
|
636 |
+LICENSE file included with this module. |
|
637 |
+ |
|
638 |
+=cut |