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