lib/DBIx/Class/Schema.pm

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