X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=8f8d846ef790b994d041f2e848695f17c2197332;hb=096f421241;hp=e0cb8cc4cfaa452d84a03d361a211418fe57ac3d;hpb=2053ab2a47d0cbf3db670003d01a9b4650bc46d6;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index e0cb8cc..8f8d846 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -4,6 +4,7 @@ use strict; use warnings; use Carp::Clan qw/^DBIx::Class/; +use Scalar::Util qw/weaken/; use base qw/DBIx::Class/; @@ -20,7 +21,7 @@ DBIx::Class::Schema - composable schemas package Library::Schema; use base qw/DBIx::Class::Schema/; - + # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD __PACKAGE__->load_classes(qw/CD Book DVD/); @@ -36,7 +37,7 @@ DBIx::Class::Schema - composable schemas $password, { AutoCommit => 0 }, ); - + my $schema2 = Library::Schema->connect($coderef_returning_dbh); # fetch objects using Library::Schema::DVD @@ -63,7 +64,7 @@ particular which module inherits off which. =back -Registers a class which isa L. Equivalent to +Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to calling: $schema->register_source($moniker, $component_class->result_source_instance); @@ -94,12 +95,13 @@ sub register_source { $reg{$moniker} = $source; $self->source_registrations(\%reg); $source->schema($self); + weaken($source->{schema}) if ref($self); if ($source->result_class) { my %map = %{$self->class_mappings}; $map{$source->result_class} = $moniker; $self->class_mappings(\%map); } -} +} =head2 class @@ -167,6 +169,12 @@ For example: sub sources { return keys %{shift->source_registrations}; } +=head2 storage + + my $storage = $schema->storage; + +Returns the L object for this Schema. + =head2 resultset =over 4 @@ -207,7 +215,7 @@ need to add C before your load_classes call. Example: My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist, - # etc. (anything under the My::Schema namespace) + # etc. (anything under the My::Schema namespace) # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but # not Other::Namespace::LinerNotes nor My::Schema::Track @@ -219,15 +227,15 @@ Example: sub load_classes { my ($class, @params) = @_; - + my %comps_for; - + if (@params) { foreach my $param (@params) { if (ref $param eq 'ARRAY') { # filter out commented entries my @modules = grep { $_ !~ /^#/ } @$param; - + push (@{$comps_for{$class}}, @modules); } elsif (ref $param eq 'HASH') { @@ -261,13 +269,17 @@ sub load_classes { foreach my $prefix (keys %comps_for) { foreach my $comp (@{$comps_for{$prefix}||[]}) { my $comp_class = "${prefix}::${comp}"; - eval "use $comp_class"; # If it fails, assume the user fixed it - if ($@) { - $comp_class =~ s/::/\//g; - die $@ unless $@ =~ /Can't locate.+$comp_class\.pm\sin\s\@INC/; - warn $@ if $@; + { # try to untaint module name. mods where this fails + # are left alone so we don't have to change the old behavior + no locale; # localized \w doesn't untaint expression + if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) { + $comp_class = $1; + } } - push(@to_register, [ $comp, $comp_class ]); + $class->ensure_class_loaded($comp_class); + $comp_class->source_name($comp) unless $comp_class->source_name; + + push(@to_register, [ $comp_class->source_name, $comp_class ]); } } } @@ -391,6 +403,8 @@ sub compose_namespace { $target_class => $source->result_class, ($base ? $base : ()) ); $source->result_class($target_class); + $target_class->result_source_instance($source) + if $target_class->can('result_source_instance'); } } Class::C3->reinitialize(); @@ -424,6 +438,26 @@ sub setup_connection_class { $target->connection(@info); } +=head2 storage_type + +=over 4 + +=item Arguments: $storage_type + +=item Return Value: $storage_type + +=back + +Set the storage class that will be instantiated when L is called. +If the classname starts with C<::>, the prefix C is +assumed by L. Defaults to C<::DBI>, +which is L. + +You want to use this to hardcoded subclasses of L +in cases where the appropriate subclass is not autodetected, such as when +dealing with MSSQL via L, in which case you'd set it to +C<::DBI::Sybase::MSSQL>. + =head2 connection =over 4 @@ -523,12 +557,11 @@ exception) an exception is thrown that includes a "Rollback failed" message. For example, my $author_rs = $schema->resultset('Author')->find(1); + my @titles = qw/Night Day It/; my $coderef = sub { - my ($author, @titles) = @_; - # If any one of these fails, the entire transaction fails - $author->create_related('books', { + $author_rs->create_related('books', { title => $_ }) foreach (@titles); @@ -537,16 +570,14 @@ For example, my $rs; eval { - $rs = $schema->txn_do($coderef, $author_rs, qw/Night Day It/); + $rs = $schema->txn_do($coderef); }; - if ($@) { - my $error = $@; - if ($error =~ /Rollback failed/) { - die "something terrible has happened!"; - } else { - deal_with_failed_transaction(); - } + if ($@) { # Transaction failed + die "something terrible has happened!" # + if ($@ =~ /Rollback failed/); # Rollback failed + + deal_with_failed_transaction(); } In a nested transaction (calling txn_do() from within a txn_do() coderef) only @@ -559,8 +590,8 @@ context and it will behave as expected. sub txn_do { my ($self, $coderef, @args) = @_; - ref $self or $self->throw_exception - ('Cannot execute txn_do as a class method'); + $self->storage or $self->throw_exception + ('txn_do called on $schema without storage'); ref $coderef eq 'CODE' or $self->throw_exception ('$coderef must be a CODE reference'); @@ -569,8 +600,8 @@ sub txn_do { $self->txn_begin; # If this throws an exception, no rollback is needed my $wantarray = wantarray; # Need to save this since the context - # inside the eval{} block is independent - # of the context that called txn_do() + # inside the eval{} block is independent + # of the context that called txn_do() eval { # Need to differentiate between scalar/list context to allow for @@ -599,7 +630,7 @@ sub txn_do { my $rollback_error = $@; my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION"; $self->throw_exception($error) # propagate nested rollback - if $rollback_error =~ /$exception_class/; + if $rollback_error =~ /$exception_class/; $self->throw_exception( "Transaction aborted: $error. Rollback failed: ${rollback_error}" @@ -627,7 +658,9 @@ copy. sub clone { my ($self) = @_; - my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self); + my $clone = { (ref $self ? %$self : ()) }; + bless $clone, (ref $self || $self); + foreach my $moniker ($self->sources) { my $source = $self->source($moniker); my $new = $source->new($source); @@ -640,13 +673,17 @@ sub clone { =over 4 -=item Arguments: $moniker, \@data; +=item Arguments: $source_name, \@data; =back -Populates the source registered with the given moniker with the supplied data. -@data should be a list of listrefs -- the first containing column names, the -second matching values. +Pass this method a resultsource name, and an arrayref of +arrayrefs. The arrayrefs should contain a list of column names, +followed by one or many sets of matching data for the given columns. + +Each set of data is inserted into the database using +L, and a arrayref of the resulting row +objects is returned. i.e., @@ -674,7 +711,7 @@ sub populate { =head2 throw_exception -=over 4 +=over 4 =item Arguments: $message @@ -694,7 +731,7 @@ sub throw_exception { =over 4 -=item Arguments: $sqlt_args +=item Arguments: $sqlt_args, $dir =back @@ -703,12 +740,58 @@ Attempts to deploy the schema to the current storage using L. Note that this feature is currently EXPERIMENTAL and may not work correctly across all databases, or fully handle complex relationships. +See L for a list of values for C<$sqlt_args>. The most +common value for this would be C<< { add_drop_table => 1, } >> to have the SQL +produced include a DROP TABLE statement for each table created. + =cut sub deploy { - my ($self, $sqltargs) = @_; + my ($self, $sqltargs, $dir) = @_; $self->throw_exception("Can't deploy without storage") unless $self->storage; - $self->storage->deploy($self, undef, $sqltargs); + $self->storage->deploy($self, undef, $sqltargs, $dir); +} + +=head2 create_ddl_dir (EXPERIMENTAL) + +=over 4 + +=item Arguments: \@databases, $version, $directory, $sqlt_args + +=back + +Creates an SQL file based on the Schema, for each of the specified +database types, in the given directory. + +Note that this feature is currently EXPERIMENTAL and may not work correctly +across all databases, or fully handle complex relationships. + +=cut + +sub create_ddl_dir { + my $self = shift; + + $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage; + $self->storage->create_ddl_dir($self, @_); +} + +=head2 ddl_filename (EXPERIMENTAL) + + my $filename = $table->ddl_filename($type, $dir, $version) + +Creates a filename for a SQL file based on the table class name. Not +intended for direct end user use. + +=cut + +sub ddl_filename { + my ($self, $type, $dir, $version) = @_; + + my $filename = ref($self); + $filename =~ s/::/-/; + $filename = "$dir$filename-$version-$type.sql"; + + return $filename; } 1; @@ -722,4 +805,3 @@ Matt S. Trout You may distribute this code under the same terms as Perl itself. =cut -