Fixed DBICTest Schema class names, added class_resolver system to make them work
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Schema.pm
CommitLineData
a02675cd 1package DBIx::Class::Schema;
2
3use strict;
4use warnings;
5
6use base qw/Class::Data::Inheritable/;
41a6f8c0 7use base qw/DBIx::Class/;
a02675cd 8
41a6f8c0 9__PACKAGE__->load_components(qw/Exception/);
74b92d9a 10__PACKAGE__->mk_classdata('class_registrations' => {});
a02675cd 11
c2da098a 12=head1 NAME
13
14DBIx::Class::Schema - composable schemas
15
16=head1 SYNOPSIS
17
18 in My/Schema.pm
19
20 package My::Schema;
21
22 use base qw/DBIx::Class::Schema/;
23
24 __PACKAGE__->load_classes(qw/Foo Bar Baz/);
25
26 in My/Schema/Foo.pm
27
28 package My::Schema::Foo;
29
30 use base qw/DBIx::Class::Core/;
31
32 __PACKAGE__->table('foo');
33 ...
34
35 in My/DB.pm
36
37 use My::Schema;
38
39 My::Schema->compose_connection('My::DB', $dsn, $user, $pass, $attrs);
40
41 then in app code
42
656796f2 43 my @obj = My::DB::Foo->search({}); # My::DB::Foo isa My::Schema::Foo My::DB
c2da098a 44
45=head1 DESCRIPTION
46
47=head1 METHODS
48
49=over 4
50
51=cut
52
a02675cd 53sub register_class {
54 my ($class, $name, $to_register) = @_;
74b92d9a 55 my %reg = %{$class->class_registrations};
a02675cd 56 $reg{$name} = $to_register;
74b92d9a 57 $class->class_registrations(\%reg);
58}
59
60sub registered_classes {
61 return values %{shift->class_registrations};
a02675cd 62}
63
64sub load_classes {
65 my $class = shift;
66 my @comp = grep { $_ !~ /^#/ } @_;
41a6f8c0 67 unless (@comp) {
68 eval "require Module::Find;";
69 $class->throw("No arguments to load_classes and couldn't load".
70 " Module::Find ($@)") if $@;
71 @comp = map { substr $_, length "${class}::" }
72 Module::Find::findallmod($class);
73 }
a02675cd 74 foreach my $comp (@comp) {
75 my $comp_class = "${class}::${comp}";
76 eval "use $comp_class";
77 die $@ if $@;
78 $class->register_class($comp => $comp_class);
79 }
80}
81
82sub compose_connection {
83 my ($class, $target, @info) = @_;
11b78bd6 84 my $conn_class = "${target}::_db";
85 $class->setup_connection_class($conn_class, @info);
74b92d9a 86 my %reg = %{ $class->class_registrations };
11b78bd6 87 my %target;
88 my %map;
a02675cd 89 while (my ($comp, $comp_class) = each %reg) {
90 my $target_class = "${target}::${comp}";
11b78bd6 91 $class->inject_base($target_class, $comp_class, $conn_class);
92 @map{$comp, $comp_class} = ($target_class, $target_class);
b7951443 93 }
11b78bd6 94 {
95 no strict 'refs';
96 *{"${target}::class"} =
97 sub {
98 my ($class, $to_map) = @_;
99 return $map{$to_map};
100 };
101 }
102 $conn_class->class_resolver($target);
b7951443 103}
104
105sub setup_connection_class {
106 my ($class, $target, @info) = @_;
107 $class->inject_base($target => 'DBIx::Class');
108 $target->load_components('DB');
109 $target->connection(@info);
110}
111
112sub inject_base {
113 my ($class, $target, @to_inject) = @_;
114 {
115 no strict 'refs';
116 unshift(@{"${target}::ISA"}, @to_inject);
a02675cd 117 }
118}
119
1201;
c2da098a 121
122=back
123
124=head1 AUTHORS
125
126Matt S. Trout <perl-stuff@trout.me.uk>
127
128=head1 LICENSE
129
130You may distribute this code under the same terms as Perl itself.
131
132=cut
133