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   {
  73     no strict 'refs';
  74     unshift(@{"${target}::ISA"}, 'DBIx::Class');
  75   }
  76   $target->load_components('DB');
  77   $target->connection(@info);
  78   my %reg = %{ $class->_class_registrations };
  79   while (my ($comp, $comp_class) = each %reg) {
  80     my $target_class = "${target}::${comp}";
  81     {
  82       no strict 'refs';
  83       unshift(@{"${target_class}::ISA"}, $comp_class, $target);
  84     }
  85   }
  86 }
  87
  88 1;
  89
  90 =back
  91
  92 =head1 AUTHORS
  93
  94 Matt S. Trout <perl-stuff@trout.me.uk>
  95
  96 =head1 LICENSE
  97
  98 You may distribute this code under the same terms as Perl itself.
  99
 100 =cut
 101