lib/DBIx/Class/Schema.pm

   1 package DBIx::Class::Schema;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp::Clan qw/^DBIx::Class/;
   7
   8 use base qw/DBIx::Class/;
   9
  10 __PACKAGE__->mk_classdata('class_mappings' => {});
  11 __PACKAGE__->mk_classdata('source_registrations' => {});
  12 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
  13 __PACKAGE__->mk_classdata('storage');
  14
  15 =head1 NAME
  16
  17 DBIx::Class::Schema - composable schemas
  18
  19 =head1 SYNOPSIS
  20
  21   package My::Schema;
  22   use base qw/DBIx::Class::Schema/;
  23
  24   # load My::Schema::Foo, My::Schema::Bar, My::Schema::Baz
  25   __PACKAGE__->load_classes(qw/Foo Bar Baz/);
  26
  27   package My::Schema::Foo;
  28   use base qw/DBIx::Class/;
  29   __PACKAGE__->load_components(qw/PK::Auto::Pg Core/); # for example
  30   __PACKAGE__->table('foo');
  31
  32   my $schema1 = My::Schema->connect(
  33     $dsn,
  34     $user,
  35     $password,
  36     $attrs
  37   );
  38
  39   my $schema2 = My::Schema->connect( ... );
  40
  41   # fetch objects using My::Schema::Foo
  42   my $resultset = $schema1->resultset('Foo')->search( ... );
  43   my @objects = $schema2->resultset('Foo')->search( ... );
  44
  45 =head1 DESCRIPTION
  46
  47 Creates database classes based on a schema. This is the recommended way to
  48 use L<DBIx::Class> and allows you to use more than one concurrent connection
  49 with your classes.
  50
  51 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
  52 carefully as DBIx::Class does things a little differently. Note in
  53 particular which module inherits off which.
  54
  55 =head1 METHODS
  56
  57 =head2 register_class <moniker> <component_class>
  58
  59 Registers a class which isa ResultSourceProxy; equivalent to calling
  60
  61   $schema->register_source($moniker, $class->result_source_instance);
  62
  63 =cut
  64
  65 sub register_class {
  66   my ($self, $moniker, $to_register) = @_;
  67   $self->register_source($moniker => $to_register->result_source_instance);
  68 }
  69
  70 =head2 register_source <moniker> <result source>
  71
  72 Registers the result source in the schema with the given moniker
  73
  74 =cut
  75
  76 sub register_source {
  77   my ($self, $moniker, $source) = @_;
  78   my %reg = %{$self->source_registrations};
  79   $reg{$moniker} = $source;
  80   $self->source_registrations(\%reg);
  81   $source->schema($self);
  82   if ($source->result_class) {
  83     my %map = %{$self->class_mappings};
  84     $map{$source->result_class} = $moniker;
  85     $self->class_mappings(\%map);
  86   }
  87 }
  88
  89 =head2 class
  90
  91   my $class = $schema->class('Foo');
  92
  93 Retrieves the result class name for a given result source
  94
  95 =cut
  96
  97 sub class {
  98   my ($self, $moniker) = @_;
  99   return $self->source($moniker)->result_class;
 100 }
 101
 102 =head2 source
 103
 104   my $source = $schema->source('Foo');
 105
 106 Returns the result source object for the registered name
 107
 108 =cut
 109
 110 sub source {
 111   my ($self, $moniker) = @_;
 112   my $sreg = $self->source_registrations;
 113   return $sreg->{$moniker} if exists $sreg->{$moniker};
 114
 115   # if we got here, they probably passed a full class name
 116   my $mapped = $self->class_mappings->{$moniker};
 117   $self->throw_exception("Can't find source for ${moniker}")
 118     unless $mapped && exists $sreg->{$mapped};
 119   return $sreg->{$mapped};
 120 }
 121
 122 =head2 sources
 123
 124   my @source_monikers = $schema->sources;
 125
 126 Returns the source monikers of all source registrations on this schema
 127
 128 =cut
 129
 130 sub sources { return keys %{shift->source_registrations}; }
 131
 132 =head2 resultset
 133
 134   my $rs = $schema->resultset('Foo');
 135
 136 Returns the resultset for the registered moniker
 137
 138 =cut
 139
 140 sub resultset {
 141   my ($self, $moniker) = @_;
 142   return $self->source($moniker)->resultset;
 143 }
 144
 145 =head2  load_classes [<classes>, (<class>, <class>), {<namespace> => [<classes>]}]
 146
 147 Uses L<Module::Find> to find all classes under the database class' namespace,
 148 or uses the classes you select.  Then it loads the component (using L<use>),
 149 and registers them (using B<register_class>);
 150
 151 It is possible to comment out classes with a leading '#', but note that perl
 152 will think it's a mistake (trying to use a comment in a qw list) so you'll
 153 need to add "no warnings 'qw';" before your load_classes call.
 154
 155 =cut
 156
 157 sub load_classes {
 158   my ($class, @params) = @_;
 159
 160   my %comps_for;
 161
 162   if (@params) {
 163     foreach my $param (@params) {
 164       if (ref $param eq 'ARRAY') {
 165         # filter out commented entries
 166         my @modules = grep { $_ !~ /^#/ } @$param;
 167
 168         push (@{$comps_for{$class}}, @modules);
 169       }
 170       elsif (ref $param eq 'HASH') {
 171         # more than one namespace possible
 172         for my $comp ( keys %$param ) {
 173           # filter out commented entries
 174           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
 175
 176           push (@{$comps_for{$comp}}, @modules);
 177         }
 178       }
 179       else {
 180         # filter out commented entries
 181         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
 182       }
 183     }
 184   } else {
 185     eval "require Module::Find;";
 186     $class->throw_exception("No arguments to load_classes and couldn't load".
 187       " Module::Find ($@)") if $@;
 188     my @comp = map { substr $_, length "${class}::"  } Module::Find::findallmod($class);
 189     $comps_for{$class} = \@comp;
 190   }
 191
 192   foreach my $prefix (keys %comps_for) {
 193     foreach my $comp (@{$comps_for{$prefix}||[]}) {
 194       my $comp_class = "${prefix}::${comp}";
 195       eval "use $comp_class"; # If it fails, assume the user fixed it
 196       if ($@) {
 197         die $@ unless $@ =~ /Can't locate/;
 198       }
 199       $class->register_class($comp => $comp_class);
 200       #  if $class->can('result_source_instance');
 201     }
 202   }
 203 }
 204
 205 =head2 compose_connection <target> <@db_info>
 206
 207 This is the most important method in this class. it takes a target namespace,
 208 as well as dbh connection info, and creates a L<DBIx::Class::DB> class as
 209 well as subclasses for each of your database classes in this namespace, using
 210 this connection.
 211
 212 It will also setup a ->class method on the target class, which lets you
 213 resolve database classes based on the schema component name, for example
 214
 215   MyApp::DB->class('Foo') # returns MyApp::DB::Foo,
 216                           # which ISA MyApp::Schema::Foo
 217
 218 This is the recommended API for accessing Schema generated classes, and
 219 using it might give you instant advantages with future versions of DBIC.
 220
 221 WARNING: Loading components into Schema classes after compose_connection
 222 may not cause them to be seen by the classes in your target namespace due
 223 to the dispatch table approach used by Class::C3. If you do this you may find
 224 you need to call Class::C3->reinitialize() afterwards to get the behaviour
 225 you expect.
 226
 227 =cut
 228
 229 sub compose_connection {
 230   my ($self, $target, @info) = @_;
 231   my $base = 'DBIx::Class::ResultSetProxy';
 232   eval "require ${base};";
 233   $self->throw_exception("No arguments to load_classes and couldn't load".
 234       " ${base} ($@)") if $@;
 235
 236   if ($self eq $target) {
 237     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 238     foreach my $moniker ($self->sources) {
 239       my $source = $self->source($moniker);
 240       my $class = $source->result_class;
 241       $self->inject_base($class, $base);
 242       $class->mk_classdata(resultset_instance => $source->resultset);
 243       $class->mk_classdata(class_resolver => $self);
 244     }
 245     $self->connection(@info);
 246     return $self;
 247   }
 248
 249   my $schema = $self->compose_namespace($target, $base);
 250   {
 251     no strict 'refs';
 252     *{"${target}::schema"} = sub { $schema };
 253   }
 254
 255   $schema->connection(@info);
 256   foreach my $moniker ($schema->sources) {
 257     my $source = $schema->source($moniker);
 258     my $class = $source->result_class;
 259     #warn "$moniker $class $source ".$source->storage;
 260     $class->mk_classdata(result_source_instance => $source);
 261     $class->mk_classdata(resultset_instance => $source->resultset);
 262     $class->mk_classdata(class_resolver => $schema);
 263   }
 264   return $schema;
 265 }
 266
 267 sub compose_namespace {
 268   my ($self, $target, $base) = @_;
 269   my %reg = %{ $self->source_registrations };
 270   my %target;
 271   my %map;
 272   my $schema = $self->clone;
 273   foreach my $moniker ($schema->sources) {
 274     my $source = $schema->source($moniker);
 275     my $target_class = "${target}::${moniker}";
 276     $self->inject_base(
 277       $target_class => $source->result_class, ($base ? $base : ())
 278     );
 279     $source->result_class($target_class);
 280   }
 281   {
 282     no strict 'refs';
 283     foreach my $meth (qw/class source resultset/) {
 284       *{"${target}::${meth}"} =
 285         sub { shift->schema->$meth(@_) };
 286     }
 287   }
 288   return $schema;
 289 }
 290
 291 =head2 setup_connection_class <$target> <@info>
 292
 293 Sets up a database connection class to inject between the schema
 294 and the subclasses the schema creates.
 295
 296 =cut
 297
 298 sub setup_connection_class {
 299   my ($class, $target, @info) = @_;
 300   $class->inject_base($target => 'DBIx::Class::DB');
 301   #$target->load_components('DB');
 302   $target->connection(@info);
 303 }
 304
 305 =head2 connection(@args)
 306
 307 Instantiates a new Storage object of type storage_type and passes the
 308 arguments to $storage->connect_info. Sets the connection in-place on
 309 the schema.
 310
 311 =cut
 312
 313 sub connection {
 314   my ($self, @info) = @_;
 315   my $storage_class = $self->storage_type;
 316   $storage_class = 'DBIx::Class::Storage'.$storage_class
 317     if $storage_class =~ m/^::/;
 318   eval "require ${storage_class};";
 319   $self->throw_exception("No arguments to load_classes and couldn't load".
 320       " ${storage_class} ($@)") if $@;
 321   my $storage = $storage_class->new;
 322   $storage->connect_info(\@info);
 323   $self->storage($storage);
 324   return $self;
 325 }
 326
 327 =head2 connect(@info)
 328
 329 Conveneience method, equivalent to $schema->clone->connection(@info)
 330
 331 =cut
 332
 333 sub connect { shift->clone->connection(@_) }
 334
 335 =head2 txn_begin
 336
 337 Begins a transaction (does nothing if AutoCommit is off).
 338
 339 =cut
 340
 341 sub txn_begin { shift->storage->txn_begin }
 342
 343 =head2 txn_commit
 344
 345 Commits the current transaction.
 346
 347 =cut
 348
 349 sub txn_commit { shift->storage->txn_commit }
 350
 351 =head2 txn_rollback
 352
 353 Rolls back the current transaction.
 354
 355 =cut
 356
 357 sub txn_rollback { shift->storage->txn_rollback }
 358
 359 =head2 clone
 360
 361 Clones the schema and its associated result_source objects and returns the
 362 copy.
 363
 364 =cut
 365
 366 sub clone {
 367   my ($self) = @_;
 368   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
 369   foreach my $moniker ($self->sources) {
 370     my $source = $self->source($moniker);
 371     my $new = $source->new($source);
 372     $clone->register_source($moniker => $new);
 373   }
 374   return $clone;
 375 }
 376
 377 =head2 populate($moniker, \@data);
 378
 379 Populates the source registered with the given moniker with the supplied data.
 380 @data should be a list of listrefs, the first containing column names, the
 381 second matching values - i.e.
 382
 383 $schema->populate('Foo', [
 384   [ qw/foo_id foo_string/ ],
 385   [ 1, 'One' ],
 386   [ 2, 'Two' ],
 387   ...
 388 ]);
 389
 390 =cut
 391
 392 sub populate {
 393   my ($self, $name, $data) = @_;
 394   my $rs = $self->resultset($name);
 395   my @names = @{shift(@$data)};
 396   foreach my $item (@$data) {
 397     my %create;
 398     @create{@names} = @$item;
 399     $rs->create(\%create);
 400   }
 401 }
 402
 403 =head2 throw_exception
 404
 405 Defaults to using Carp::Clan to report errors from user perspective.
 406
 407 =cut
 408
 409 sub throw_exception {
 410   my ($self) = shift;
 411   croak @_;
 412 }
 413
 414 1;
 415
 416 =head1 AUTHORS
 417
 418 Matt S. Trout <mst@shadowcatsystems.co.uk>
 419
 420 =head1 LICENSE
 421
 422 You may distribute this code under the same terms as Perl itself.
 423
 424 =cut
 425