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->search({}); # 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 registered_classes {
  60   return values %{shift->class_registrations};
  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) = @_;
  76   $class->setup_connection_class($target, @info);
  77   my %reg = %{ $class->class_registrations };
  78   while (my ($comp, $comp_class) = each %reg) {
  79     my $target_class = "${target}::${comp}";
  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);
  96   }
  97 }
  98
  99 1;
 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