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