Showing 2 changed files with 0 additions and 639 deletions
-1
lib/DBIx/Custom.pm
... ...
@@ -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
-638
lib/DBIx/Custom/Class/Inspector.pm
... ...
@@ -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