X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=3ce1c1cd1c0f15c0a38d64aaed059e6ea9040c22;hb=cb6ec758e3c4607ec8e30dd943a500a1d70d8940;hp=c9ba994251ca312b1cccf60a4699ca6ef662413b;hpb=54e0bd0660145a1a86bf7cc460336e0ee9c6cbfa;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index c9ba994..3ce1c1c 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -3,8 +3,10 @@ package DBIx::Class::Schema; use strict; use warnings; +use DBIx::Class::Exception; use Carp::Clan qw/^DBIx::Class/; use Scalar::Util qw/weaken/; +use File::Spec; require Module::Find; use base qw/DBIx::Class/; @@ -12,8 +14,11 @@ use base qw/DBIx::Class/; __PACKAGE__->mk_classdata('class_mappings' => {}); __PACKAGE__->mk_classdata('source_registrations' => {}); __PACKAGE__->mk_classdata('storage_type' => '::DBI'); +__PACKAGE__->mk_classdata('storage_type_args' => {}); __PACKAGE__->mk_classdata('storage'); __PACKAGE__->mk_classdata('exception_action'); +__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0); +__PACKAGE__->mk_classdata('default_resultset_attributes' => {}); =head1 NAME @@ -93,10 +98,15 @@ moniker. sub register_source { my ($self, $moniker, $source) = @_; + + %$source = %{ $source->new( { %$source, source_name => $moniker }) }; + my %reg = %{$self->source_registrations}; $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}; @@ -105,6 +115,19 @@ sub register_source { } } +sub _unregister_source { + my ($self, $moniker) = @_; + my %reg = %{$self->source_registrations}; + + my $source = delete $reg{$moniker}; + $self->source_registrations(\%reg); + if ($source->result_class) { + my %map = %{$self->class_mappings}; + delete $map{$source->result_class}; + $self->class_mappings(\%map); + } +} + =head2 class =over 4 @@ -267,10 +290,18 @@ sub load_classes { foreach my $prefix (keys %comps_for) { foreach my $comp (@{$comps_for{$prefix}||[]}) { my $comp_class = "${prefix}::${comp}"; + { # 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; + } + } $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 ]); + $comp = $comp_class->source_name || $comp; +# $DB::single = 1; + push(@to_register, [ $comp, $comp_class ]); } } } @@ -440,7 +471,7 @@ sub load_namespaces { return; } -=head2 compose_connection +=head2 compose_connection (DEPRECATED) =over 4 @@ -450,6 +481,14 @@ sub load_namespaces { =back +DEPRECATED. You probably wanted compose_namespace. + +Actually, you probably just wanted to call connect. + +=begin hidden + +(hidden due to deprecation) + Calls L to the target namespace, calls L with @db_info on the new schema, then injects the L component and a @@ -462,45 +501,55 @@ L and use the resulting schema object to operate on L objects with L for more information. -=cut +=end hidden -sub compose_connection { - my ($self, $target, @info) = @_; - my $base = 'DBIx::Class::ResultSetProxy'; - eval "require ${base};"; - $self->throw_exception - ("No arguments to load_classes and couldn't load ${base} ($@)") - if $@; +=cut - if ($self eq $target) { - # Pathological case, largely caused by the docs on early C::M::DBIC::Plain - foreach my $moniker ($self->sources) { - my $source = $self->source($moniker); +{ + my $warn; + + sub compose_connection { + my ($self, $target, @info) = @_; + + warn "compose_connection deprecated as of 0.08000" + unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++); + + my $base = 'DBIx::Class::ResultSetProxy'; + eval "require ${base};"; + $self->throw_exception + ("No arguments to load_classes and couldn't load ${base} ($@)") + if $@; + + if ($self eq $target) { + # Pathological case, largely caused by the docs on early C::M::DBIC::Plain + foreach my $moniker ($self->sources) { + my $source = $self->source($moniker); + my $class = $source->result_class; + $self->inject_base($class, $base); + $class->mk_classdata(resultset_instance => $source->resultset); + $class->mk_classdata(class_resolver => $self); + } + $self->connection(@info); + return $self; + } + + my $schema = $self->compose_namespace($target, $base); + { + no strict 'refs'; + *{"${target}::schema"} = sub { $schema }; + } + + $schema->connection(@info); + foreach my $moniker ($schema->sources) { + my $source = $schema->source($moniker); my $class = $source->result_class; - $self->inject_base($class, $base); + #warn "$moniker $class $source ".$source->storage; + $class->mk_classdata(result_source_instance => $source); $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $self); + $class->mk_classdata(class_resolver => $schema); } - $self->connection(@info); - return $self; - } - - my $schema = $self->compose_namespace($target, $base); - { - no strict 'refs'; - *{"${target}::schema"} = sub { $schema }; - } - - $schema->connection(@info); - foreach my $moniker ($schema->sources) { - my $source = $schema->source($moniker); - my $class = $source->result_class; - #warn "$moniker $class $source ".$source->storage; - $class->mk_classdata(result_source_instance => $source); - $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $schema); + return $schema; } - return $schema; } =head2 compose_namespace @@ -538,9 +587,6 @@ will produce the output sub compose_namespace { my ($self, $target, $base) = @_; - my %reg = %{ $self->source_registrations }; - my %target; - my %map; my $schema = $self->clone; { no warnings qw/redefine/; @@ -559,6 +605,7 @@ sub compose_namespace { Class::C3->reinitialize(); { no strict 'refs'; + no warnings 'redefine'; foreach my $meth (qw/class source resultset/) { *{"${target}::${meth}"} = sub { shift->schema->$meth(@_) }; @@ -636,7 +683,7 @@ sub connection { $self->throw_exception( "No arguments to load_classes and couldn't load ${storage_class} ($@)" ) if $@; - my $storage = $storage_class->new($self); + my $storage = $storage_class->new($self, $self->storage_type_args); $storage->connect_info(\@info); $self->storage($storage); return $self; @@ -688,6 +735,21 @@ sub txn_do { $self->storage->txn_do(@_); } +=head2 txn_scope_guard + +Runs C on the schema's storage. + +=cut + +sub txn_scope_guard { + my $self = shift; + + $self->storage or $self->throw_exception + ('txn_scope_guard called on $schema without storage'); + + $self->storage->txn_scope_guard(@_); +} + =head2 txn_begin Begins a transaction (does nothing if AutoCommit is off). Equivalent to @@ -739,6 +801,57 @@ sub txn_rollback { $self->storage->txn_rollback; } +=head2 svp_begin + +Creates a new savepoint (does nothing outside a transaction). +Equivalent to calling $schema->storage->svp_begin. See +L for more information. + +=cut + +sub svp_begin { + my ($self, $name) = @_; + + $self->storage or $self->throw_exception + ('svp_begin called on $schema without storage'); + + $self->storage->svp_begin($name); +} + +=head2 svp_release + +Releases a savepoint (does nothing outside a transaction). +Equivalent to calling $schema->storage->svp_release. See +L for more information. + +=cut + +sub svp_release { + my ($self, $name) = @_; + + $self->storage or $self->throw_exception + ('svp_release called on $schema without storage'); + + $self->storage->svp_release($name); +} + +=head2 svp_rollback + +Rollback to a savepoint (does nothing outside a transaction). +Equivalent to calling $schema->storage->svp_rollback. See +L for more information. + +=cut + +sub svp_rollback { + my ($self, $name) = @_; + + $self->storage or $self->throw_exception + ('svp_rollback called on $schema without storage'); + + $self->storage->svp_rollback($name); +} + =head2 clone =over 4 @@ -778,7 +891,12 @@ 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 +In void context, C in L is used +to insert the data, as this is a fast method. However, insert_bulk currently +assumes that your datasets all contain the same type of values, using scalar +references in a column in one row, and not in another will probably not work. + +Otherwise, each set of data is inserted into the database using L, and a arrayref of the resulting row objects is returned. @@ -790,6 +908,18 @@ i.e., [ 2, 'Indie Band' ], ... ]); + +Since wantarray context is basically the same as looping over $rs->create(...) +you won't see any performance benefits and in this case the method is more for +convenience. Void context sends the column information directly to storage +using s bulk insert method. So the performance will be much better for +storages that support this method. + +Because of this difference in the way void context inserts rows into your +database you need to note how this will effect any loaded components that +override or augment insert. For example if you are using a component such +as L to populate your primary keys you MUST use +wantarray context if you want the PKs automatically created. =cut @@ -806,7 +936,15 @@ sub populate { } return @created; } - $self->storage->insert_bulk($self->source($name)->from, \@names, $data); + my @results_to_create; + foreach my $datum (@$data) { + my %result_to_create; + foreach my $index (0..$#names) { + $result_to_create{$names[$index]} = $$datum[$index]; + } + push @results_to_create, \%result_to_create; + } + $rs->populate(\@results_to_create); } =head2 exception_action @@ -819,7 +957,7 @@ sub populate { If C is set for this class/object, L will prefer to call this code reference with the exception as an argument, -rather than its normal action. +rather than its normal C or C action. Your subroutine should probably just wrap the error in the exception object/class of your choosing and rethrow. If, against all sage advice, @@ -841,6 +979,18 @@ Example: # suppress all exceptions, like a moron: $schema_obj->exception_action(sub { 1 }); +=head2 stacktrace + +=over 4 + +=item Arguments: boolean + +=back + +Whether L should include stack trace information. +Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}> +is true. + =head2 throw_exception =over 4 @@ -851,16 +1001,19 @@ Example: Throws an exception. Defaults to using L to report errors from user's perspective. See L for details on overriding -this method's behavior. +this method's behavior. If L is turned on, C's +default behavior will provide a detailed stack trace. =cut sub throw_exception { my $self = shift; - croak @_ if !$self->exception_action || !$self->exception_action->(@_); + + DBIx::Class::Exception->throw($_[0], $self->stacktrace) + if !$self->exception_action || !$self->exception_action->(@_); } -=head2 deploy (EXPERIMENTAL) +=head2 deploy =over 4 @@ -870,13 +1023,14 @@ sub throw_exception { 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. +Additionally, the DBIx::Class parser accepts a C parameter as a hash +ref or an array ref, containing a list of source to deploy. If present, then +only the sources listed will get deployed. + =cut sub deploy { @@ -885,20 +1039,69 @@ sub deploy { $self->storage->deploy($self, undef, $sqltargs, $dir); } +=head2 deployment_statements + +=over 4 + +=item Arguments: $rdbms_type + +=back + +Returns the SQL statements used by L and L. +C<$rdbms_type> provides the DBI database driver name for which the SQL +statements are produced. If not supplied, the type of the current schema storage +will be used. + +=cut + +sub deployment_statements { + my ($self, $rdbms_type) = @_; + + $self->throw_exception("Can't generate deployment statements without a storage") + if not $self->storage; + + $self->storage->deployment_statements($self, $rdbms_type); +} + =head2 create_ddl_dir (EXPERIMENTAL) =over 4 -=item Arguments: \@databases, $version, $directory, $sqlt_args +=item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args =back Creates an SQL file based on the Schema, for each of the specified -database types, in the given directory. +database types, in the given directory. Given a previous version number, +this will also create a file containing the ALTER TABLE statements to +transform the previous schema into the current one. Note that these +statements may contain DROP TABLE or DROP COLUMN statements that can +potentially destroy data. + +The file names are created using the C method below, please +override this method in your schema if you would like a different file +name format. For the ALTER file, the same format is used, replacing +$version in the name with "$preversion-$version". + +If no arguments are passed, then the following default values are used: + +=over 4 + +=item databases - ['MySQL', 'SQLite', 'PostgreSQL'] + +=item version - $schema->VERSION + +=item directory - './' + +=item preversion - + +=back Note that this feature is currently EXPERIMENTAL and may not work correctly across all databases, or fully handle complex relationships. +WARNING: Please check all SQL files created, before applying them. + =cut sub create_ddl_dir { @@ -910,23 +1113,81 @@ sub create_ddl_dir { =head2 ddl_filename (EXPERIMENTAL) - my $filename = $table->ddl_filename($type, $dir, $version) +=over 4 + +=item Arguments: $directory, $database-type, $version, $preversion + +=back + + my $filename = $table->ddl_filename($type, $dir, $version, $preversion) -Creates a filename for a SQL file based on the table class name. Not -intended for direct end user use. +This method is called by C to compose a file name out of +the supplied directory, database type and version number. The default file +name format is: C<$dir$schema-$version-$type.sql>. + +You may override this method in your schema if you wish to use a different +format. =cut sub ddl_filename { - my ($self, $type, $dir, $version) = @_; + my ($self, $type, $dir, $version, $pversion) = @_; my $filename = ref($self); - $filename =~ s/::/-/; - $filename = "$dir$filename-$version-$type.sql"; + $filename =~ s/::/-/g; + $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql"); + $filename =~ s/$version/$pversion-$version/ if($pversion); return $filename; } +=head2 sqlt_deploy_hook($sqlt_schema) + +An optional sub which you can declare in your own Schema class that will get +passed the L object when you deploy the schema via +L or L. + +For an example of what you can do with this, see +L. + +=head2 thaw + +Provided as the recommened way of thawing schema objects. You can call +C directly if you wish, but the thawed objects will not have a +reference to any schema, so are rather useless + +=cut + +sub thaw { + my ($self, $obj) = @_; + local $DBIx::Class::ResultSourceHandle::thaw_schema = $self; + return Storable::thaw($obj); +} + +=head2 freeze + +This doesn't actualy do anything more than call L, it is just +provided here for symetry. + +=cut + +sub freeze { + return Storable::freeze($_[1]); +} + +=head2 dclone + +Recommeneded way of dcloning objects. This is needed to properly maintain +references to the schema object (which itself is B cloned.) + +=cut + +sub dclone { + my ($self, $obj) = @_; + local $DBIx::Class::ResultSourceHandle::thaw_schema = $self; + return Storable::dclone($obj); +} + 1; =head1 AUTHORS