... | ... |
@@ -18,7 +18,6 @@ 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 | 23 |
has [qw/connector dsn password quote user exclude_table user_table_info |
... | ... |
@@ -1,638 +0,0 @@ |
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 |