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 | |
74b92d9a |
9 | __PACKAGE__->mk_classdata('class_registrations' => {}); |
a02675cd |
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 | |
656796f2 |
42 | my @obj = My::DB::Foo->search({}); # My::DB::Foo isa My::Schema::Foo My::DB |
c2da098a |
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) = @_; |
74b92d9a |
54 | my %reg = %{$class->class_registrations}; |
a02675cd |
55 | $reg{$name} = $to_register; |
74b92d9a |
56 | $class->class_registrations(\%reg); |
57 | } |
58 | |
59 | sub registered_classes { |
60 | return values %{shift->class_registrations}; |
a02675cd |
61 | } |
62 | |
63 | sub load_classes { |
64 | my $class = shift; |
65 | my @comp = grep { $_ !~ /^#/ } @_; |
66 | foreach my $comp (@comp) { |
67 | my $comp_class = "${class}::${comp}"; |
68 | eval "use $comp_class"; |
69 | die $@ if $@; |
70 | $class->register_class($comp => $comp_class); |
71 | } |
72 | } |
73 | |
74 | sub compose_connection { |
75 | my ($class, $target, @info) = @_; |
b7951443 |
76 | $class->setup_connection_class($target, @info); |
74b92d9a |
77 | my %reg = %{ $class->class_registrations }; |
a02675cd |
78 | while (my ($comp, $comp_class) = each %reg) { |
79 | my $target_class = "${target}::${comp}"; |
b7951443 |
80 | $class->inject_base($target_class, $comp_class, $target); |
81 | } |
82 | } |
83 | |
84 | sub setup_connection_class { |
85 | my ($class, $target, @info) = @_; |
86 | $class->inject_base($target => 'DBIx::Class'); |
87 | $target->load_components('DB'); |
88 | $target->connection(@info); |
89 | } |
90 | |
91 | sub inject_base { |
92 | my ($class, $target, @to_inject) = @_; |
93 | { |
94 | no strict 'refs'; |
95 | unshift(@{"${target}::ISA"}, @to_inject); |
a02675cd |
96 | } |
97 | } |
98 | |
99 | 1; |
c2da098a |
100 | |
101 | =back |
102 | |
103 | =head1 AUTHORS |
104 | |
105 | Matt S. Trout <perl-stuff@trout.me.uk> |
106 | |
107 | =head1 LICENSE |
108 | |
109 | You may distribute this code under the same terms as Perl itself. |
110 | |
111 | =cut |
112 | |