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