lib/DBIx/Class/Schema.pm

   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
  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
  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) = @_;
  72   $class->setup_connection_class($target, @info);
  73   my %reg = %{ $class->_class_registrations };
  74   while (my ($comp, $comp_class) = each %reg) {
  75     my $target_class = "${target}::${comp}";
  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);
  92   }
  93 }
  94
  95 1;
  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