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 # this might be oversimplified
 619 sub compose_namespace {
 620   my ($self, $target, $base) = @_;
 621
 622   my $schema = $self->clone;
 623   foreach my $moniker ($schema->sources) {
 624     my $source = $schema->source($moniker);
 625     my $target_class = "${target}::${moniker}";
 626     $self->inject_base(
 627       $target_class => $source->result_class, ($base ? $base : ())
 628     );
 629     $source->result_class($target_class);
 630     $target_class->result_source_instance($source)
 631       if $target_class->can('result_source_instance');
 632     $schema->register_source($moniker, $source);
 633   }
 634   return $schema;
 635 }
 636
 637 sub setup_connection_class {
 638   my ($class, $target, @info) = @_;
 639   $class->inject_base($target => 'DBIx::Class::DB');
 640   #$target->load_components('DB');
 641   $target->connection(@info);
 642 }
 643
 644 =head2 storage_type
 645
 646 =over 4
 647
 648 =item Arguments: $storage_type|{$storage_type, \%args}
 649
 650 =item Return Value: $storage_type|{$storage_type, \%args}
 651
 652 =back
 653
 654 Set the storage class that will be instantiated when L</connect> is called.
 655 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
 656 assumed by L</connect>.  Defaults to C<::DBI>,
 657 which is L<DBIx::Class::Storage::DBI>.
 658
 659 You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
 660 in cases where the appropriate subclass is not autodetected, such as when
 661 dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
 662 C<::DBI::Sybase::MSSQL>.
 663
 664 If your storage type requires instantiation arguments, those are defined as a
 665 second argument in the form of a hashref and the entire value needs to be
 666 wrapped into an arrayref or a hashref.  We support both types of refs here in
 667 order to play nice with your Config::[class] or your choice.
 668
 669 See L<DBIx::Class::Storage::DBI::Replicated> for an example of this.
 670
 671 =head2 connection
 672
 673 =over 4
 674
 675 =item Arguments: @args
 676
 677 =item Return Value: $new_schema
 678
 679 =back
 680
 681 Instantiates a new Storage object of type
 682 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 683 $storage->connect_info. Sets the connection in-place on the schema.
 684
 685 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
 686 or L<DBIx::Class::Storage> in general.
 687
 688 =cut
 689
 690 sub connection {
 691   my ($self, @info) = @_;
 692   return $self if !@info && $self->storage;
 693
 694   my ($storage_class, $args) = ref $self->storage_type ?
 695     ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
 696
 697   $storage_class = 'DBIx::Class::Storage'.$storage_class
 698     if $storage_class =~ m/^::/;
 699   eval "require ${storage_class};";
 700   $self->throw_exception(
 701     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 702   ) if $@;
 703   my $storage = $storage_class->new($self=>$args);
 704   $storage->connect_info(\@info);
 705   $self->storage($storage);
 706   return $self;
 707 }
 708
 709 sub _normalize_storage_type {
 710   my ($self, $storage_type) = @_;
 711   if(ref $storage_type eq 'ARRAY') {
 712     return @$storage_type;
 713   } elsif(ref $storage_type eq 'HASH') {
 714     return %$storage_type;
 715   } else {
 716     $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
 717   }
 718 }
 719
 720 =head2 connect
 721
 722 =over 4
 723
 724 =item Arguments: @info
 725
 726 =item Return Value: $new_schema
 727
 728 =back
 729
 730 This is a convenience method. It is equivalent to calling
 731 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 732 information.
 733
 734 =cut
 735
 736 sub connect { shift->clone->connection(@_) }
 737
 738 =head2 txn_do
 739
 740 =over 4
 741
 742 =item Arguments: C<$coderef>, @coderef_args?
 743
 744 =item Return Value: The return value of $coderef
 745
 746 =back
 747
 748 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 749 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
 750 See L<DBIx::Class::Storage/"txn_do"> for more information.
 751
 752 This interface is preferred over using the individual methods L</txn_begin>,
 753 L</txn_commit>, and L</txn_rollback> below.
 754
 755 =cut
 756
 757 sub txn_do {
 758   my $self = shift;
 759
 760   $self->storage or $self->throw_exception
 761     ('txn_do called on $schema without storage');
 762
 763   $self->storage->txn_do(@_);
 764 }
 765
 766 =head2 txn_scope_guard (EXPERIMENTAL)
 767
 768 Runs C<txn_scope_guard> on the schema's storage. See
 769 L<DBIx::Class::Storage/txn_scope_guard>.
 770
 771 =cut
 772
 773 sub txn_scope_guard {
 774   my $self = shift;
 775
 776   $self->storage or $self->throw_exception
 777     ('txn_scope_guard called on $schema without storage');
 778
 779   $self->storage->txn_scope_guard(@_);
 780 }
 781
 782 =head2 txn_begin
 783
 784 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 785 calling $schema->storage->txn_begin. See
 786 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 787
 788 =cut
 789
 790 sub txn_begin {
 791   my $self = shift;
 792
 793   $self->storage or $self->throw_exception
 794     ('txn_begin called on $schema without storage');
 795
 796   $self->storage->txn_begin;
 797 }
 798
 799 =head2 txn_commit
 800
 801 Commits the current transaction. Equivalent to calling
 802 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 803 for more information.
 804
 805 =cut
 806
 807 sub txn_commit {
 808   my $self = shift;
 809
 810   $self->storage or $self->throw_exception
 811     ('txn_commit called on $schema without storage');
 812
 813   $self->storage->txn_commit;
 814 }
 815
 816 =head2 txn_rollback
 817
 818 Rolls back the current transaction. Equivalent to calling
 819 $schema->storage->txn_rollback. See
 820 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 821
 822 =cut
 823
 824 sub txn_rollback {
 825   my $self = shift;
 826
 827   $self->storage or $self->throw_exception
 828     ('txn_rollback called on $schema without storage');
 829
 830   $self->storage->txn_rollback;
 831 }
 832
 833 =head2 svp_begin
 834
 835 Creates a new savepoint (does nothing outside a transaction).
 836 Equivalent to calling $schema->storage->svp_begin.  See
 837 L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
 838
 839 =cut
 840
 841 sub svp_begin {
 842   my ($self, $name) = @_;
 843
 844   $self->storage or $self->throw_exception
 845     ('svp_begin called on $schema without storage');
 846
 847   $self->storage->svp_begin($name);
 848 }
 849
 850 =head2 svp_release
 851
 852 Releases a savepoint (does nothing outside a transaction).
 853 Equivalent to calling $schema->storage->svp_release.  See
 854 L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
 855
 856 =cut
 857
 858 sub svp_release {
 859   my ($self, $name) = @_;
 860
 861   $self->storage or $self->throw_exception
 862     ('svp_release called on $schema without storage');
 863
 864   $self->storage->svp_release($name);
 865 }
 866
 867 =head2 svp_rollback
 868
 869 Rollback to a savepoint (does nothing outside a transaction).
 870 Equivalent to calling $schema->storage->svp_rollback.  See
 871 L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
 872
 873 =cut
 874
 875 sub svp_rollback {
 876   my ($self, $name) = @_;
 877
 878   $self->storage or $self->throw_exception
 879     ('svp_rollback called on $schema without storage');
 880
 881   $self->storage->svp_rollback($name);
 882 }
 883
 884 =head2 clone
 885
 886 =over 4
 887
 888 =item Return Value: $new_schema
 889
 890 =back
 891
 892 Clones the schema and its associated result_source objects and returns the
 893 copy.
 894
 895 =cut
 896
 897 sub clone {
 898   my ($self) = @_;
 899   my $clone = { (ref $self ? %$self : ()) };
 900   bless $clone, (ref $self || $self);
 901
 902   $clone->class_mappings({ %{$clone->class_mappings} });
 903   $clone->source_registrations({ %{$clone->source_registrations} });
 904   foreach my $moniker ($self->sources) {
 905     my $source = $self->source($moniker);
 906     my $new = $source->new($source);
 907     # we use extra here as we want to leave the class_mappings as they are
 908     # but overwrite the source_registrations entry with the new source
 909     $clone->register_extra_source($moniker => $new);
 910   }
 911   $clone->storage->set_schema($clone) if $clone->storage;
 912   return $clone;
 913 }
 914
 915 =head2 populate
 916
 917 =over 4
 918
 919 =item Arguments: $source_name, \@data;
 920
 921 =back
 922
 923 Pass this method a resultsource name, and an arrayref of
 924 arrayrefs. The arrayrefs should contain a list of column names,
 925 followed by one or many sets of matching data for the given columns.
 926
 927 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
 928 to insert the data, as this is a fast method. However, insert_bulk currently
 929 assumes that your datasets all contain the same type of values, using scalar
 930 references in a column in one row, and not in another will probably not work.
 931
 932 Otherwise, each set of data is inserted into the database using
 933 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 934 objects is returned.
 935
 936 i.e.,
 937
 938   $schema->populate('Artist', [
 939     [ qw/artistid name/ ],
 940     [ 1, 'Popular Band' ],
 941     [ 2, 'Indie Band' ],
 942     ...
 943   ]);
 944
 945 Since wantarray context is basically the same as looping over $rs->create(...)
 946 you won't see any performance benefits and in this case the method is more for
 947 convenience. Void context sends the column information directly to storage
 948 using <DBI>s bulk insert method. So the performance will be much better for
 949 storages that support this method.
 950
 951 Because of this difference in the way void context inserts rows into your
 952 database you need to note how this will effect any loaded components that
 953 override or augment insert.  For example if you are using a component such
 954 as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
 955 wantarray context if you want the PKs automatically created.
 956
 957 =cut
 958
 959 sub populate {
 960   my ($self, $name, $data) = @_;
 961   my $rs = $self->resultset($name);
 962   my @names = @{shift(@$data)};
 963   if(defined wantarray) {
 964     my @created;
 965     foreach my $item (@$data) {
 966       my %create;
 967       @create{@names} = @$item;
 968       push(@created, $rs->create(\%create));
 969     }
 970     return @created;
 971   }
 972   my @results_to_create;
 973   foreach my $datum (@$data) {
 974     my %result_to_create;
 975     foreach my $index (0..$#names) {
 976       $result_to_create{$names[$index]} = $$datum[$index];
 977     }
 978     push @results_to_create, \%result_to_create;
 979   }
 980   $rs->populate(\@results_to_create);
 981 }
 982
 983 =head2 exception_action
 984
 985 =over 4
 986
 987 =item Arguments: $code_reference
 988
 989 =back
 990
 991 If C<exception_action> is set for this class/object, L</throw_exception>
 992 will prefer to call this code reference with the exception as an argument,
 993 rather than its normal C<croak> or C<confess> action.
 994
 995 Your subroutine should probably just wrap the error in the exception
 996 object/class of your choosing and rethrow.  If, against all sage advice,
 997 you'd like your C<exception_action> to suppress a particular exception
 998 completely, simply have it return true.
 999
1000 Example:
1001
1002    package My::Schema;
1003    use base qw/DBIx::Class::Schema/;
1004    use My::ExceptionClass;
1005    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
1006    __PACKAGE__->load_classes;
1007
1008    # or:
1009    my $schema_obj = My::Schema->connect( .... );
1010    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
1011
1012    # suppress all exceptions, like a moron:
1013    $schema_obj->exception_action(sub { 1 });
1014
1015 =head2 stacktrace
1016
1017 =over 4
1018
1019 =item Arguments: boolean
1020
1021 =back
1022
1023 Whether L</throw_exception> should include stack trace information.
1024 Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
1025 is true.
1026
1027 =head2 throw_exception
1028
1029 =over 4
1030
1031 =item Arguments: $message
1032
1033 =back
1034
1035 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
1036 user's perspective.  See L</exception_action> for details on overriding
1037 this method's behavior.  If L</stacktrace> is turned on, C<throw_exception>'s
1038 default behavior will provide a detailed stack trace.
1039
1040 =cut
1041
1042 sub throw_exception {
1043   my $self = shift;
1044
1045   DBIx::Class::Exception->throw($_[0], $self->stacktrace)
1046     if !$self->exception_action || !$self->exception_action->(@_);
1047 }
1048
1049 =head2 deploy
1050
1051 =over 4
1052
1053 =item Arguments: $sqlt_args, $dir
1054
1055 =back
1056
1057 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
1058
1059 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
1060 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
1061 produced include a DROP TABLE statement for each table created.
1062
1063 Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
1064 ref or an array ref, containing a list of source to deploy. If present, then
1065 only the sources listed will get deployed. Furthermore, you can use the
1066 C<add_fk_index> parser parameter to prevent the parser from creating an index for each
1067 FK.
1068
1069 =cut
1070
1071 sub deploy {
1072   my ($self, $sqltargs, $dir) = @_;
1073   $self->throw_exception("Can't deploy without storage") unless $self->storage;
1074   $self->storage->deploy($self, undef, $sqltargs, $dir);
1075 }
1076
1077 =head2 deployment_statements
1078
1079 =over 4
1080
1081 =item Arguments: $rdbms_type
1082
1083 =back
1084
1085 Returns the SQL statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1086 C<$rdbms_type> provides the DBI database driver name for which the SQL
1087 statements are produced. If not supplied, the type of the current schema storage
1088 will be used.
1089
1090 =cut
1091
1092 sub deployment_statements {
1093   my ($self, $rdbms_type) = @_;
1094
1095   $self->throw_exception("Can't generate deployment statements without a storage")
1096     if not $self->storage;
1097
1098   $self->storage->deployment_statements($self, $rdbms_type);
1099 }
1100
1101 =head2 create_ddl_dir (EXPERIMENTAL)
1102
1103 =over 4
1104
1105 =item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args
1106
1107 =back
1108
1109 Creates an SQL file based on the Schema, for each of the specified
1110 database types, in the given directory. Given a previous version number,
1111 this will also create a file containing the ALTER TABLE statements to
1112 transform the previous schema into the current one. Note that these
1113 statements may contain DROP TABLE or DROP COLUMN statements that can
1114 potentially destroy data.
1115
1116 The file names are created using the C<ddl_filename> method below, please
1117 override this method in your schema if you would like a different file
1118 name format. For the ALTER file, the same format is used, replacing
1119 $version in the name with "$preversion-$version".
1120
1121 See L<DBIx::Class::Schema/deploy> for details of $sqlt_args.
1122
1123 If no arguments are passed, then the following default values are used:
1124
1125 =over 4
1126
1127 =item databases  - ['MySQL', 'SQLite', 'PostgreSQL']
1128
1129 =item version    - $schema->VERSION
1130
1131 =item directory  - './'
1132
1133 =item preversion - <none>
1134
1135 =back
1136
1137 Note that this feature is currently EXPERIMENTAL and may not work correctly
1138 across all databases, or fully handle complex relationships.
1139
1140 WARNING: Please check all SQL files created, before applying them.
1141
1142 =cut
1143
1144 sub create_ddl_dir {
1145   my $self = shift;
1146
1147   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
1148   $self->storage->create_ddl_dir($self, @_);
1149 }
1150
1151 =head2 ddl_filename
1152
1153 =over 4
1154
1155 =item Arguments: $database-type, $version, $directory, $preversion
1156
1157 =back
1158
1159   my $filename = $table->ddl_filename($type, $version, $dir, $preversion)
1160
1161 This method is called by C<create_ddl_dir> to compose a file name out of
1162 the supplied directory, database type and version number. The default file
1163 name format is: C<$dir$schema-$version-$type.sql>.
1164
1165 You may override this method in your schema if you wish to use a different
1166 format.
1167
1168 =cut
1169
1170 sub ddl_filename {
1171   my ($self, $type, $version, $dir, $preversion) = @_;
1172
1173   my $filename = ref($self);
1174   $filename =~ s/::/-/g;
1175   $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
1176   $filename =~ s/$version/$preversion-$version/ if($preversion);
1177
1178   return $filename;
1179 }
1180
1181 =head2 sqlt_deploy_hook($sqlt_schema)
1182
1183 An optional sub which you can declare in your own Schema class that will get
1184 passed the L<SQL::Translator::Schema> object when you deploy the schema via
1185 L</create_ddl_dir> or L</deploy>.
1186
1187 For an example of what you can do with this, see
1188 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1189
1190 =head2 thaw
1191
1192 Provided as the recommened way of thawing schema objects. You can call
1193 C<Storable::thaw> directly if you wish, but the thawed objects will not have a
1194 reference to any schema, so are rather useless
1195
1196 =cut
1197
1198 sub thaw {
1199   my ($self, $obj) = @_;
1200   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1201   return Storable::thaw($obj);
1202 }
1203
1204 =head2 freeze
1205
1206 This doesn't actualy do anything more than call L<Storable/freeze>, it is just
1207 provided here for symetry.
1208
1209 =cut
1210
1211 sub freeze {
1212   return Storable::freeze($_[1]);
1213 }
1214
1215 =head2 dclone
1216
1217 Recommeneded way of dcloning objects. This is needed to properly maintain
1218 references to the schema object (which itself is B<not> cloned.)
1219
1220 =cut
1221
1222 sub dclone {
1223   my ($self, $obj) = @_;
1224   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1225   return Storable::dclone($obj);
1226 }
1227
1228 =head2 schema_version
1229
1230 Returns the current schema class' $VERSION
1231
1232 =cut
1233
1234 sub schema_version {
1235   my ($self) = @_;
1236   my $class = ref($self)||$self;
1237
1238   # does -not- use $schema->VERSION
1239   # since that varies in results depending on if version.pm is installed, and if
1240   # so the perl or XS versions. If you want this to change, bug the version.pm
1241   # author to make vpp and vxs behave the same.
1242
1243   my $version;
1244   {
1245     no strict 'refs';
1246     $version = ${"${class}::VERSION"};
1247   }
1248   return $version;
1249 }
1250
1251 1;
1252
1253 =head1 AUTHORS
1254
1255 Matt S. Trout <mst@shadowcatsystems.co.uk>
1256
1257 =head1 LICENSE
1258
1259 You may distribute this code under the same terms as Perl itself.
1260
1261 =cut