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 use Scalar::Util qw/weaken/;
   8 use File::Spec;
   9 require Module::Find;
  10
  11 use base qw/DBIx::Class/;
  12
  13 __PACKAGE__->mk_classdata('class_mappings' => {});
  14 __PACKAGE__->mk_classdata('source_registrations' => {});
  15 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
  16 __PACKAGE__->mk_classdata('storage');
  17 __PACKAGE__->mk_classdata('exception_action');
  18
  19 =head1 NAME
  20
  21 DBIx::Class::Schema - composable schemas
  22
  23 =head1 SYNOPSIS
  24
  25   package Library::Schema;
  26   use base qw/DBIx::Class::Schema/;
  27
  28   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
  29   __PACKAGE__->load_classes(qw/CD Book DVD/);
  30
  31   package Library::Schema::CD;
  32   use base qw/DBIx::Class/;
  33   __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
  34   __PACKAGE__->table('cd');
  35
  36   # Elsewhere in your code:
  37   my $schema1 = Library::Schema->connect(
  38     $dsn,
  39     $user,
  40     $password,
  41     { AutoCommit => 0 },
  42   );
  43
  44   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
  45
  46   # fetch objects using Library::Schema::DVD
  47   my $resultset = $schema1->resultset('DVD')->search( ... );
  48   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
  49
  50 =head1 DESCRIPTION
  51
  52 Creates database classes based on a schema. This is the recommended way to
  53 use L<DBIx::Class> and allows you to use more than one concurrent connection
  54 with your classes.
  55
  56 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
  57 carefully, as DBIx::Class does things a little differently. Note in
  58 particular which module inherits off which.
  59
  60 =head1 METHODS
  61
  62 =head2 register_class
  63
  64 =over 4
  65
  66 =item Arguments: $moniker, $component_class
  67
  68 =back
  69
  70 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
  71 calling:
  72
  73   $schema->register_source($moniker, $component_class->result_source_instance);
  74
  75 =cut
  76
  77 sub register_class {
  78   my ($self, $moniker, $to_register) = @_;
  79   $self->register_source($moniker => $to_register->result_source_instance);
  80 }
  81
  82 =head2 register_source
  83
  84 =over 4
  85
  86 =item Arguments: $moniker, $result_source
  87
  88 =back
  89
  90 Registers the L<DBIx::Class::ResultSource> in the schema with the given
  91 moniker.
  92
  93 =cut
  94
  95 sub register_source {
  96   my ($self, $moniker, $source) = @_;
  97   my %reg = %{$self->source_registrations};
  98   $reg{$moniker} = $source;
  99   $self->source_registrations(\%reg);
 100   $source->schema($self);
 101   weaken($source->{schema}) if ref($self);
 102   if ($source->result_class) {
 103     my %map = %{$self->class_mappings};
 104     $map{$source->result_class} = $moniker;
 105     $self->class_mappings(\%map);
 106   }
 107 }
 108
 109 =head2 class
 110
 111 =over 4
 112
 113 =item Arguments: $moniker
 114
 115 =item Return Value: $classname
 116
 117 =back
 118
 119 Retrieves the result class name for the given moniker. For example:
 120
 121   my $class = $schema->class('CD');
 122
 123 =cut
 124
 125 sub class {
 126   my ($self, $moniker) = @_;
 127   return $self->source($moniker)->result_class;
 128 }
 129
 130 =head2 source
 131
 132 =over 4
 133
 134 =item Arguments: $moniker
 135
 136 =item Return Value: $result_source
 137
 138 =back
 139
 140   my $source = $schema->source('Book');
 141
 142 Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
 143
 144 =cut
 145
 146 sub source {
 147   my ($self, $moniker) = @_;
 148   my $sreg = $self->source_registrations;
 149   return $sreg->{$moniker} if exists $sreg->{$moniker};
 150
 151   # if we got here, they probably passed a full class name
 152   my $mapped = $self->class_mappings->{$moniker};
 153   $self->throw_exception("Can't find source for ${moniker}")
 154     unless $mapped && exists $sreg->{$mapped};
 155   return $sreg->{$mapped};
 156 }
 157
 158 =head2 sources
 159
 160 =over 4
 161
 162 =item Return Value: @source_monikers
 163
 164 =back
 165
 166 Returns the source monikers of all source registrations on this schema.
 167 For example:
 168
 169   my @source_monikers = $schema->sources;
 170
 171 =cut
 172
 173 sub sources { return keys %{shift->source_registrations}; }
 174
 175 =head2 storage
 176
 177   my $storage = $schema->storage;
 178
 179 Returns the L<DBIx::Class::Storage> object for this Schema.
 180
 181 =head2 resultset
 182
 183 =over 4
 184
 185 =item Arguments: $moniker
 186
 187 =item Return Value: $result_set
 188
 189 =back
 190
 191   my $rs = $schema->resultset('DVD');
 192
 193 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
 194
 195 =cut
 196
 197 sub resultset {
 198   my ($self, $moniker) = @_;
 199   return $self->source($moniker)->resultset;
 200 }
 201
 202 =head2 load_classes
 203
 204 =over 4
 205
 206 =item Arguments: @classes?, { $namespace => [ @classes ] }+
 207
 208 =back
 209
 210 With no arguments, this method uses L<Module::Find> to find all classes under
 211 the schema's namespace. Otherwise, this method loads the classes you specify
 212 (using L<use>), and registers them (using L</"register_class">).
 213
 214 It is possible to comment out classes with a leading C<#>, but note that perl
 215 will think it's a mistake (trying to use a comment in a qw list), so you'll
 216 need to add C<no warnings 'qw';> before your load_classes call.
 217
 218 Example:
 219
 220   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
 221                               # etc. (anything under the My::Schema namespace)
 222
 223   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
 224   # not Other::Namespace::LinerNotes nor My::Schema::Track
 225   My::Schema->load_classes(qw/ CD Artist #Track /, {
 226     Other::Namespace => [qw/ Producer #LinerNotes /],
 227   });
 228
 229 =cut
 230
 231 sub load_classes {
 232   my ($class, @params) = @_;
 233
 234   my %comps_for;
 235
 236   if (@params) {
 237     foreach my $param (@params) {
 238       if (ref $param eq 'ARRAY') {
 239         # filter out commented entries
 240         my @modules = grep { $_ !~ /^#/ } @$param;
 241
 242         push (@{$comps_for{$class}}, @modules);
 243       }
 244       elsif (ref $param eq 'HASH') {
 245         # more than one namespace possible
 246         for my $comp ( keys %$param ) {
 247           # filter out commented entries
 248           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
 249
 250           push (@{$comps_for{$comp}}, @modules);
 251         }
 252       }
 253       else {
 254         # filter out commented entries
 255         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
 256       }
 257     }
 258   } else {
 259     my @comp = map { substr $_, length "${class}::"  }
 260                  Module::Find::findallmod($class);
 261     $comps_for{$class} = \@comp;
 262   }
 263
 264   my @to_register;
 265   {
 266     no warnings qw/redefine/;
 267     local *Class::C3::reinitialize = sub { };
 268     foreach my $prefix (keys %comps_for) {
 269       foreach my $comp (@{$comps_for{$prefix}||[]}) {
 270         my $comp_class = "${prefix}::${comp}";
 271         { # try to untaint module name. mods where this fails
 272           # are left alone so we don't have to change the old behavior
 273           no locale; # localized \w doesn't untaint expression
 274           if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) {
 275             $comp_class = $1;
 276           }
 277         }
 278         $class->ensure_class_loaded($comp_class);
 279         $comp_class->source_name($comp) unless $comp_class->source_name;
 280
 281         push(@to_register, [ $comp_class->source_name, $comp_class ]);
 282       }
 283     }
 284   }
 285   Class::C3->reinitialize;
 286
 287   foreach my $to (@to_register) {
 288     $class->register_class(@$to);
 289     #  if $class->can('result_source_instance');
 290   }
 291 }
 292
 293 =head2 load_namespaces
 294
 295 =over 4
 296
 297 =item Arguments: %options?
 298
 299 =back
 300
 301 This is an alternative to L</load_classes> above which assumes an alternative
 302 layout for automatic class loading.  It assumes that all result
 303 classes are underneath a sub-namespace of the schema called C<Result>, any
 304 corresponding ResultSet classes are underneath a sub-namespace of the schema
 305 called C<ResultSet>.
 306
 307 Both of the sub-namespaces are configurable if you don't like the defaults,
 308 via the options C<result_namespace> and C<resultset_namespace>.
 309
 310 If (and only if) you specify the option C<default_resultset_class>, any found
 311 Result classes for which we do not find a corresponding
 312 ResultSet class will have their C<resultset_class> set to
 313 C<default_resultset_class>.
 314
 315 C<load_namespaces> takes care of calling C<resultset_class> for you where
 316 neccessary if you didn't do it for yourself.
 317
 318 All of the namespace and classname options to this method are relative to
 319 the schema classname by default.  To specify a fully-qualified name, prefix
 320 it with a literal C<+>.
 321
 322 Examples:
 323
 324   # load My::Schema::Result::CD, My::Schema::Result::Artist,
 325   #    My::Schema::ResultSet::CD, etc...
 326   My::Schema->load_namespaces;
 327
 328   # Override everything to use ugly names.
 329   # In this example, if there is a My::Schema::Res::Foo, but no matching
 330   #   My::Schema::RSets::Foo, then Foo will have its
 331   #   resultset_class set to My::Schema::RSetBase
 332   My::Schema->load_namespaces(
 333     result_namespace => 'Res',
 334     resultset_namespace => 'RSets',
 335     default_resultset_class => 'RSetBase',
 336   );
 337
 338   # Put things in other namespaces
 339   My::Schema->load_namespaces(
 340     result_namespace => '+Some::Place::Results',
 341     resultset_namespace => '+Another::Place::RSets',
 342   );
 343
 344 If you'd like to use multiple namespaces of each type, simply use an arrayref
 345 of namespaces for that option.  In the case that the same result
 346 (or resultset) class exists in multiple namespaces, the latter entries in
 347 your list of namespaces will override earlier ones.
 348
 349   My::Schema->load_namespaces(
 350     # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
 351     result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
 352     resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
 353   );
 354
 355 =cut
 356
 357 # Pre-pends our classname to the given relative classname or
 358 #   class namespace, unless there is a '+' prefix, which will
 359 #   be stripped.
 360 sub _expand_relative_name {
 361   my ($class, $name) = @_;
 362   return if !$name;
 363   $name = $class . '::' . $name if ! ($name =~ s/^\+//);
 364   return $name;
 365 }
 366
 367 # returns a hash of $shortname => $fullname for every package
 368 #  found in the given namespaces ($shortname is with the $fullname's
 369 #  namespace stripped off)
 370 sub _map_namespaces {
 371   my ($class, @namespaces) = @_;
 372
 373   my @results_hash;
 374   foreach my $namespace (@namespaces) {
 375     push(
 376       @results_hash,
 377       map { (substr($_, length "${namespace}::"), $_) }
 378       Module::Find::findallmod($namespace)
 379     );
 380   }
 381
 382   @results_hash;
 383 }
 384
 385 sub load_namespaces {
 386   my ($class, %args) = @_;
 387
 388   my $result_namespace = delete $args{result_namespace} || 'Result';
 389   my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
 390   my $default_resultset_class = delete $args{default_resultset_class};
 391
 392   $class->throw_exception('load_namespaces: unknown option(s): '
 393     . join(q{,}, map { qq{'$_'} } keys %args))
 394       if scalar keys %args;
 395
 396   $default_resultset_class
 397     = $class->_expand_relative_name($default_resultset_class);
 398
 399   for my $arg ($result_namespace, $resultset_namespace) {
 400     $arg = [ $arg ] if !ref($arg) && $arg;
 401
 402     $class->throw_exception('load_namespaces: namespace arguments must be '
 403       . 'a simple string or an arrayref')
 404         if ref($arg) ne 'ARRAY';
 405
 406     $_ = $class->_expand_relative_name($_) for (@$arg);
 407   }
 408
 409   my %results = $class->_map_namespaces(@$result_namespace);
 410   my %resultsets = $class->_map_namespaces(@$resultset_namespace);
 411
 412   my @to_register;
 413   {
 414     no warnings 'redefine';
 415     local *Class::C3::reinitialize = sub { };
 416     use warnings 'redefine';
 417
 418     foreach my $result (keys %results) {
 419       my $result_class = $results{$result};
 420       $class->ensure_class_loaded($result_class);
 421       $result_class->source_name($result) unless $result_class->source_name;
 422
 423       my $rs_class = delete $resultsets{$result};
 424       my $rs_set = $result_class->resultset_class;
 425       if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
 426         if($rs_class && $rs_class ne $rs_set) {
 427           warn "We found ResultSet class '$rs_class' for '$result', but it seems "
 428              . "that you had already set '$result' to use '$rs_set' instead";
 429         }
 430       }
 431       elsif($rs_class ||= $default_resultset_class) {
 432         $class->ensure_class_loaded($rs_class);
 433         $result_class->resultset_class($rs_class);
 434       }
 435
 436       push(@to_register, [ $result_class->source_name, $result_class ]);
 437     }
 438   }
 439
 440   foreach (sort keys %resultsets) {
 441     warn "load_namespaces found ResultSet class $_ with no "
 442       . 'corresponding Result class';
 443   }
 444
 445   Class::C3->reinitialize;
 446   $class->register_class(@$_) for (@to_register);
 447
 448   return;
 449 }
 450
 451 =head2 compose_connection (DEPRECATED)
 452
 453 =over 4
 454
 455 =item Arguments: $target_namespace, @db_info
 456
 457 =item Return Value: $new_schema
 458
 459 =back
 460
 461 DEPRECATED. You probably wanted compose_namespace.
 462
 463 Actually, you probably just wanted to call connect.
 464
 465 =for hidden due to deprecation
 466
 467 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 468 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 469 then injects the L<DBix::Class::ResultSetProxy> component and a
 470 resultset_instance classdata entry on all the new classes, in order to support
 471 $target_namespaces::$class->search(...) method calls.
 472
 473 This is primarily useful when you have a specific need for class method access
 474 to a connection. In normal usage it is preferred to call
 475 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 476 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 477 more information.
 478
 479 =cut
 480
 481 {
 482   my $warn;
 483
 484   sub compose_connection {
 485     my ($self, $target, @info) = @_;
 486
 487     warn "compose_connection deprecated as of 0.08000" unless $warn++;
 488
 489     my $base = 'DBIx::Class::ResultSetProxy';
 490     eval "require ${base};";
 491     $self->throw_exception
 492       ("No arguments to load_classes and couldn't load ${base} ($@)")
 493         if $@;
 494
 495     if ($self eq $target) {
 496       # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 497       foreach my $moniker ($self->sources) {
 498         my $source = $self->source($moniker);
 499         my $class = $source->result_class;
 500         $self->inject_base($class, $base);
 501         $class->mk_classdata(resultset_instance => $source->resultset);
 502         $class->mk_classdata(class_resolver => $self);
 503       }
 504       $self->connection(@info);
 505       return $self;
 506     }
 507
 508     my $schema = $self->compose_namespace($target, $base);
 509     {
 510       no strict 'refs';
 511       *{"${target}::schema"} = sub { $schema };
 512     }
 513
 514     $schema->connection(@info);
 515     foreach my $moniker ($schema->sources) {
 516       my $source = $schema->source($moniker);
 517       my $class = $source->result_class;
 518       #warn "$moniker $class $source ".$source->storage;
 519       $class->mk_classdata(result_source_instance => $source);
 520       $class->mk_classdata(resultset_instance => $source->resultset);
 521       $class->mk_classdata(class_resolver => $schema);
 522     }
 523     return $schema;
 524   }
 525 }
 526
 527 =head2 compose_namespace
 528
 529 =over 4
 530
 531 =item Arguments: $target_namespace, $additional_base_class?
 532
 533 =item Return Value: $new_schema
 534
 535 =back
 536
 537 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 538 class in the target namespace (e.g. $target_namespace::CD,
 539 $target_namespace::Artist) that inherits from the corresponding classes
 540 attached to the current schema.
 541
 542 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 543 new $schema object. If C<$additional_base_class> is given, the new composed
 544 classes will inherit from first the corresponding classe from the current
 545 schema then the base class.
 546
 547 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 548
 549   $schema->compose_namespace('My::DB', 'Base::Class');
 550   print join (', ', @My::DB::CD::ISA) . "\n";
 551   print join (', ', @My::DB::Artist::ISA) ."\n";
 552
 553 will produce the output
 554
 555   My::Schema::CD, Base::Class
 556   My::Schema::Artist, Base::Class
 557
 558 =cut
 559
 560 sub compose_namespace {
 561   my ($self, $target, $base) = @_;
 562   my %reg = %{ $self->source_registrations };
 563   my %target;
 564   my %map;
 565   my $schema = $self->clone;
 566   {
 567     no warnings qw/redefine/;
 568     local *Class::C3::reinitialize = sub { };
 569     foreach my $moniker ($schema->sources) {
 570       my $source = $schema->source($moniker);
 571       my $target_class = "${target}::${moniker}";
 572       $self->inject_base(
 573         $target_class => $source->result_class, ($base ? $base : ())
 574       );
 575       $source->result_class($target_class);
 576       $target_class->result_source_instance($source)
 577         if $target_class->can('result_source_instance');
 578     }
 579   }
 580   Class::C3->reinitialize();
 581   {
 582     no strict 'refs';
 583     foreach my $meth (qw/class source resultset/) {
 584       *{"${target}::${meth}"} =
 585         sub { shift->schema->$meth(@_) };
 586     }
 587   }
 588   return $schema;
 589 }
 590
 591 =head2 setup_connection_class
 592
 593 =over 4
 594
 595 =item Arguments: $target, @info
 596
 597 =back
 598
 599 Sets up a database connection class to inject between the schema and the
 600 subclasses that the schema creates.
 601
 602 =cut
 603
 604 sub setup_connection_class {
 605   my ($class, $target, @info) = @_;
 606   $class->inject_base($target => 'DBIx::Class::DB');
 607   #$target->load_components('DB');
 608   $target->connection(@info);
 609 }
 610
 611 =head2 storage_type
 612
 613 =over 4
 614
 615 =item Arguments: $storage_type
 616
 617 =item Return Value: $storage_type
 618
 619 =back
 620
 621 Set the storage class that will be instantiated when L</connect> is called.
 622 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
 623 assumed by L</connect>.  Defaults to C<::DBI>,
 624 which is L<DBIx::Class::Storage::DBI>.
 625
 626 You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
 627 in cases where the appropriate subclass is not autodetected, such as when
 628 dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
 629 C<::DBI::Sybase::MSSQL>.
 630
 631 =head2 connection
 632
 633 =over 4
 634
 635 =item Arguments: @args
 636
 637 =item Return Value: $new_schema
 638
 639 =back
 640
 641 Instantiates a new Storage object of type
 642 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 643 $storage->connect_info. Sets the connection in-place on the schema.
 644
 645 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
 646 or L<DBIx::Class::Storage> in general.
 647
 648 =cut
 649
 650 sub connection {
 651   my ($self, @info) = @_;
 652   return $self if !@info && $self->storage;
 653   my $storage_class = $self->storage_type;
 654   $storage_class = 'DBIx::Class::Storage'.$storage_class
 655     if $storage_class =~ m/^::/;
 656   eval "require ${storage_class};";
 657   $self->throw_exception(
 658     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 659   ) if $@;
 660   my $storage = $storage_class->new($self);
 661   $storage->connect_info(\@info);
 662   $self->storage($storage);
 663   $self->on_connect() if($self->can('on_connect'));
 664   return $self;
 665 }
 666
 667 =head2 connect
 668
 669 =over 4
 670
 671 =item Arguments: @info
 672
 673 =item Return Value: $new_schema
 674
 675 =back
 676
 677 This is a convenience method. It is equivalent to calling
 678 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 679 information.
 680
 681 =cut
 682
 683 sub connect { shift->clone->connection(@_) }
 684
 685 =head2 txn_do
 686
 687 =over 4
 688
 689 =item Arguments: C<$coderef>, @coderef_args?
 690
 691 =item Return Value: The return value of $coderef
 692
 693 =back
 694
 695 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 696 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
 697 See L<DBIx::Class::Storage/"txn_do"> for more information.
 698
 699 This interface is preferred over using the individual methods L</txn_begin>,
 700 L</txn_commit>, and L</txn_rollback> below.
 701
 702 =cut
 703
 704 sub txn_do {
 705   my $self = shift;
 706
 707   $self->storage or $self->throw_exception
 708     ('txn_do called on $schema without storage');
 709
 710   $self->storage->txn_do(@_);
 711 }
 712
 713 =head2 txn_begin
 714
 715 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 716 calling $schema->storage->txn_begin. See
 717 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 718
 719 =cut
 720
 721 sub txn_begin {
 722   my $self = shift;
 723
 724   $self->storage or $self->throw_exception
 725     ('txn_begin called on $schema without storage');
 726
 727   $self->storage->txn_begin;
 728 }
 729
 730 =head2 txn_commit
 731
 732 Commits the current transaction. Equivalent to calling
 733 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 734 for more information.
 735
 736 =cut
 737
 738 sub txn_commit {
 739   my $self = shift;
 740
 741   $self->storage or $self->throw_exception
 742     ('txn_commit called on $schema without storage');
 743
 744   $self->storage->txn_commit;
 745 }
 746
 747 =head2 txn_rollback
 748
 749 Rolls back the current transaction. Equivalent to calling
 750 $schema->storage->txn_rollback. See
 751 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 752
 753 =cut
 754
 755 sub txn_rollback {
 756   my $self = shift;
 757
 758   $self->storage or $self->throw_exception
 759     ('txn_rollback called on $schema without storage');
 760
 761   $self->storage->txn_rollback;
 762 }
 763
 764 =head2 clone
 765
 766 =over 4
 767
 768 =item Return Value: $new_schema
 769
 770 =back
 771
 772 Clones the schema and its associated result_source objects and returns the
 773 copy.
 774
 775 =cut
 776
 777 sub clone {
 778   my ($self) = @_;
 779   my $clone = { (ref $self ? %$self : ()) };
 780   bless $clone, (ref $self || $self);
 781
 782   foreach my $moniker ($self->sources) {
 783     my $source = $self->source($moniker);
 784     my $new = $source->new($source);
 785     $clone->register_source($moniker => $new);
 786   }
 787   $clone->storage->set_schema($clone) if $clone->storage;
 788   return $clone;
 789 }
 790
 791 =head2 populate
 792
 793 =over 4
 794
 795 =item Arguments: $source_name, \@data;
 796
 797 =back
 798
 799 Pass this method a resultsource name, and an arrayref of
 800 arrayrefs. The arrayrefs should contain a list of column names,
 801 followed by one or many sets of matching data for the given columns.
 802
 803 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
 804 to insert the data, as this is a fast method. However, insert_bulk currently
 805 assumes that your datasets all contain the same type of values, using scalar
 806 references in a column in one row, and not in another will probably not work.
 807
 808 Otherwise, each set of data is inserted into the database using
 809 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 810 objects is returned.
 811
 812 i.e.,
 813
 814   $schema->populate('Artist', [
 815     [ qw/artistid name/ ],
 816     [ 1, 'Popular Band' ],
 817     [ 2, 'Indie Band' ],
 818     ...
 819   ]);
 820
 821 =cut
 822
 823 sub populate {
 824   my ($self, $name, $data) = @_;
 825   my $rs = $self->resultset($name);
 826   my @names = @{shift(@$data)};
 827   if(defined wantarray) {
 828     my @created;
 829     foreach my $item (@$data) {
 830       my %create;
 831       @create{@names} = @$item;
 832       push(@created, $rs->create(\%create));
 833     }
 834     return @created;
 835   }
 836   $self->storage->insert_bulk($self->source($name)->from, \@names, $data);
 837 }
 838
 839 =head2 exception_action
 840
 841 =over 4
 842
 843 =item Arguments: $code_reference
 844
 845 =back
 846
 847 If C<exception_action> is set for this class/object, L</throw_exception>
 848 will prefer to call this code reference with the exception as an argument,
 849 rather than its normal <croak> action.
 850
 851 Your subroutine should probably just wrap the error in the exception
 852 object/class of your choosing and rethrow.  If, against all sage advice,
 853 you'd like your C<exception_action> to suppress a particular exception
 854 completely, simply have it return true.
 855
 856 Example:
 857
 858    package My::Schema;
 859    use base qw/DBIx::Class::Schema/;
 860    use My::ExceptionClass;
 861    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
 862    __PACKAGE__->load_classes;
 863
 864    # or:
 865    my $schema_obj = My::Schema->connect( .... );
 866    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
 867
 868    # suppress all exceptions, like a moron:
 869    $schema_obj->exception_action(sub { 1 });
 870
 871 =head2 throw_exception
 872
 873 =over 4
 874
 875 =item Arguments: $message
 876
 877 =back
 878
 879 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 880 user's perspective.  See L</exception_action> for details on overriding
 881 this method's behavior.
 882
 883 =cut
 884
 885 sub throw_exception {
 886   my $self = shift;
 887   croak @_ if !$self->exception_action || !$self->exception_action->(@_);
 888 }
 889
 890 =head2 deploy (EXPERIMENTAL)
 891
 892 =over 4
 893
 894 =item Arguments: $sqlt_args, $dir
 895
 896 =back
 897
 898 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 899
 900 Note that this feature is currently EXPERIMENTAL and may not work correctly
 901 across all databases, or fully handle complex relationships.
 902
 903 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 904 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 905 produced include a DROP TABLE statement for each table created.
 906
 907 =cut
 908
 909 sub deploy {
 910   my ($self, $sqltargs, $dir) = @_;
 911   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 912   $self->storage->deploy($self, undef, $sqltargs, $dir);
 913 }
 914
 915 =head2 create_ddl_dir (EXPERIMENTAL)
 916
 917 =over 4
 918
 919 =item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args
 920
 921 =back
 922
 923 Creates an SQL file based on the Schema, for each of the specified
 924 database types, in the given directory. Given a previous version number,
 925 this will also create a file containing the ALTER TABLE statements to
 926 transform the previous schema into the current one. Note that these
 927 statements may contain DROP TABLE or DROP COLUMN statements that can
 928 potentially destroy data.
 929
 930 The file names are created using the C<ddl_filename> method below, please
 931 override this method in your schema if you would like a different file
 932 name format. For the ALTER file, the same format is used, replacing
 933 $version in the name with "$preversion-$version".
 934
 935 If no arguments are passed, then the following default values are used:
 936
 937 =over 4
 938
 939 =item databases  - ['MySQL', 'SQLite', 'PostgreSQL']
 940
 941 =item version    - $schema->VERSION
 942
 943 =item directory  - './'
 944
 945 =item preversion - <none>
 946
 947 =back
 948
 949 Note that this feature is currently EXPERIMENTAL and may not work correctly
 950 across all databases, or fully handle complex relationships.
 951
 952 WARNING: Please check all SQL files created, before applying them.
 953
 954 =cut
 955
 956 sub create_ddl_dir {
 957   my $self = shift;
 958
 959   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 960   $self->storage->create_ddl_dir($self, @_);
 961 }
 962
 963 =head2 ddl_filename (EXPERIMENTAL)
 964
 965 =over 4
 966
 967 =item Arguments: $directory, $database-type, $version, $preversion
 968
 969 =back
 970
 971   my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
 972
 973 This method is called by C<create_ddl_dir> to compose a file name out of
 974 the supplied directory, database type and version number. The default file
 975 name format is: C<$dir$schema-$version-$type.sql>.
 976
 977 You may override this method in your schema if you wish to use a different
 978 format.
 979
 980 =cut
 981
 982 sub ddl_filename {
 983     my ($self, $type, $dir, $version, $pversion) = @_;
 984
 985     my $filename = ref($self);
 986     $filename =~ s/::/-/;
 987     $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
 988     $filename =~ s/$version/$pversion-$version/ if($pversion);
 989
 990     return $filename;
 991 }
 992
 993 1;
 994
 995 =head1 AUTHORS
 996
 997 Matt S. Trout <mst@shadowcatsystems.co.uk>
 998
 999 =head1 LICENSE
1000
1001 You may distribute this code under the same terms as Perl itself.
1002
1003 =cut