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=3d7e681ee31ff1c4b8f24daa0ed7f678338025cd;hpb=27f01d1f4fc106e0d27a13c6f6c9d5fa131e9447;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 3d7e681..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 @@ -50,7 +51,7 @@ use L and allows you to use more than one concurrent connection with your classes. NB: If you're used to L it's worth reading the L -carefully as DBIx::Class does things a little differently. Note in +carefully, as DBIx::Class does things a little differently. Note in particular which module inherits off which. =head1 METHODS @@ -59,12 +60,12 @@ particular which module inherits off which. =over 4 -=item Arguments: ($moniker, $component_class) +=item Arguments: $moniker, $component_class =back -Registers a class which isa L. Equivalent to -calling +Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to +calling: $schema->register_source($moniker, $component_class->result_source_instance); @@ -79,7 +80,7 @@ sub register_class { =over 4 -=item Arguments: ($moniker, $result_source) +=item Arguments: $moniker, $result_source =back @@ -94,26 +95,25 @@ 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 =over 4 -=item Arguments: ($moniker) +=item Arguments: $moniker -=item Returns: $classname +=item Return Value: $classname =back -Retrieves the result class name for the given moniker. - -e.g., +Retrieves the result class name for the given moniker. For example: my $class = $schema->class('CD'); @@ -128,9 +128,9 @@ sub class { =over 4 -=item Arguments: ($moniker) +=item Arguments: $moniker -=item Returns: $result_source +=item Return Value: $result_source =back @@ -156,13 +156,12 @@ sub source { =over 4 -=item Returns: @source_monikers +=item Return Value: @source_monikers =back Returns the source monikers of all source registrations on this schema. - -e.g., +For example: my @source_monikers = $schema->sources; @@ -170,13 +169,19 @@ e.g., sub sources { return keys %{shift->source_registrations}; } +=head2 storage + + my $storage = $schema->storage; + +Returns the L object for this Schema. + =head2 resultset =over 4 -=item Arguments: ($moniker) +=item Arguments: $moniker -=item Returns: $result_set +=item Return Value: $result_set =back @@ -203,14 +208,14 @@ With no arguments, this method uses L to find all classes under the schema's namespace. Otherwise, this method loads the classes you specify (using L), and registers them (using L). -It is possible to comment out classes with a leading '#', but note that perl -will think it's a mistake (trying to use a comment in a qw list) so you'll -need to add "no warnings 'qw';" before your load_classes call. +It is possible to comment out classes with a leading C<#>, but note that perl +will think it's a mistake (trying to use a comment in a qw list), so you'll +need to add C before your load_classes call. -e.g., +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 @@ -222,15 +227,15 @@ e.g., 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') { @@ -264,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 ]); } } } @@ -286,16 +295,16 @@ sub load_classes { =over 4 -=item Arguments: ($target_namespace, @db_info) +=item Arguments: $target_namespace, @db_info -=item Returns: $new_schema +=item Return Value: $new_schema =back -Calls L to the target namespace, -calls L(@db_info) on the new schema, then -injects the L component and a resultset_instance -classdata entry on all the new classes in order to support +Calls L to the target namespace, +calls L with @db_info on the new schema, +then injects the L component and a +resultset_instance classdata entry on all the new classes, in order to support $target_namespaces::$class->search(...) method calls. This is primarily useful when you have a specific need for class method access @@ -351,7 +360,7 @@ sub compose_connection { =item Arguments: $target_namespace, $additional_base_class? -=item Returns: $new_schema +=item Return Value: $new_schema =back @@ -365,13 +374,13 @@ new $schema object. If C<$additional_base_class> is given, the new composed classes will inherit from first the corresponding classe from the current schema then the base class. -e.g. (for a schema with My::Schema::CD and My::Schema::Artist classes), +For example, for a schema with My::Schema::CD and My::Schema::Artist classes, $schema->compose_namespace('My::DB', 'Base::Class'); print join (', ', @My::DB::CD::ISA) . "\n"; print join (', ', @My::DB::Artist::ISA) ."\n"; -Will produce the output +will produce the output My::Schema::CD, Base::Class My::Schema::Artist, Base::Class @@ -394,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(); @@ -411,7 +422,7 @@ sub compose_namespace { =over 4 -=item Arguments: ($target, @info) +=item Arguments: $target, @info =back @@ -427,13 +438,33 @@ 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 -=item Arguments: (@args) +=item Arguments: @args -=item Returns: $new_schema +=item Return Value: $new_schema =back @@ -464,9 +495,9 @@ sub connection { =over 4 -=item Arguments: (@info) +=item Arguments: @info -=item Returns: $new_schema +=item Return Value: $new_schema =back @@ -512,9 +543,9 @@ sub txn_rollback { shift->storage->txn_rollback } =over 4 -=item Arguments: (C<$coderef>, @coderef_args?) +=item Arguments: C<$coderef>, @coderef_args? -=item Returns: The return value of $coderef +=item Return Value: The return value of $coderef =back @@ -526,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); @@ -540,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 @@ -562,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'); @@ -572,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 @@ -602,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}" @@ -619,7 +647,7 @@ sub txn_do { =over 4 -=item Returns: $new_schema +=item Return Value: $new_schema =back @@ -630,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); @@ -643,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., @@ -677,9 +711,9 @@ sub populate { =head2 throw_exception -=over 4 +=over 4 -=item Arguments: ($message) +=item Arguments: $message =back @@ -697,7 +731,7 @@ sub throw_exception { =over 4 -=item Arguments: ($sqlt_args) +=item Arguments: $sqlt_args, $dir =back @@ -706,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; @@ -725,4 +805,3 @@ Matt S. Trout You may distribute this code under the same terms as Perl itself. =cut -