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