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