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