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