Commit | Line | Data |
a02675cd |
1 | package DBIx::Class::Schema; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use base qw/Class::Data::Inheritable/; |
7 | use DBIx::Class; |
8 | |
9 | __PACKAGE__->mk_classdata('_class_registrations' => {}); |
10 | |
c2da098a |
11 | =head1 NAME |
12 | |
13 | DBIx::Class::Schema - composable schemas |
14 | |
15 | =head1 SYNOPSIS |
16 | |
17 | in My/Schema.pm |
18 | |
19 | package My::Schema; |
20 | |
21 | use base qw/DBIx::Class::Schema/; |
22 | |
23 | __PACKAGE__->load_classes(qw/Foo Bar Baz/); |
24 | |
25 | in My/Schema/Foo.pm |
26 | |
27 | package My::Schema::Foo; |
28 | |
29 | use base qw/DBIx::Class::Core/; |
30 | |
31 | __PACKAGE__->table('foo'); |
32 | ... |
33 | |
34 | in My/DB.pm |
35 | |
36 | use My::Schema; |
37 | |
38 | My::Schema->compose_connection('My::DB', $dsn, $user, $pass, $attrs); |
39 | |
40 | then in app code |
41 | |
42 | my @obj = My::DB::Foo->retrieve_all; # My::DB::Foo isa My::Schema::Foo My::DB |
43 | |
44 | =head1 DESCRIPTION |
45 | |
46 | =head1 METHODS |
47 | |
48 | =over 4 |
49 | |
50 | =cut |
51 | |
a02675cd |
52 | sub register_class { |
53 | my ($class, $name, $to_register) = @_; |
54 | my %reg = %{$class->_class_registrations}; |
55 | $reg{$name} = $to_register; |
56 | $class->_class_registrations(\%reg); |
57 | } |
58 | |
59 | sub load_classes { |
60 | my $class = shift; |
61 | my @comp = grep { $_ !~ /^#/ } @_; |
62 | foreach my $comp (@comp) { |
63 | my $comp_class = "${class}::${comp}"; |
64 | eval "use $comp_class"; |
65 | die $@ if $@; |
66 | $class->register_class($comp => $comp_class); |
67 | } |
68 | } |
69 | |
70 | sub compose_connection { |
71 | my ($class, $target, @info) = @_; |
b7951443 |
72 | $class->setup_connection_class($target, @info); |
a02675cd |
73 | my %reg = %{ $class->_class_registrations }; |
74 | while (my ($comp, $comp_class) = each %reg) { |
75 | my $target_class = "${target}::${comp}"; |
b7951443 |
76 | $class->inject_base($target_class, $comp_class, $target); |
77 | } |
78 | } |
79 | |
80 | sub setup_connection_class { |
81 | my ($class, $target, @info) = @_; |
82 | $class->inject_base($target => 'DBIx::Class'); |
83 | $target->load_components('DB'); |
84 | $target->connection(@info); |
85 | } |
86 | |
87 | sub inject_base { |
88 | my ($class, $target, @to_inject) = @_; |
89 | { |
90 | no strict 'refs'; |
91 | unshift(@{"${target}::ISA"}, @to_inject); |
a02675cd |
92 | } |
93 | } |
94 | |
95 | 1; |
c2da098a |
96 | |
97 | =back |
98 | |
99 | =head1 AUTHORS |
100 | |
101 | Matt S. Trout <perl-stuff@trout.me.uk> |
102 | |
103 | =head1 LICENSE |
104 | |
105 | You may distribute this code under the same terms as Perl itself. |
106 | |
107 | =cut |
108 | |