X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=3e9d93e7b683a1a961e0fba934f73efbb2999ef4;hb=5b0b4df82267d761f34c606a1f97b6950a2eed4a;hp=58a59dbeadb2d2ce321d54d5f26a215db1b744a4;hpb=90545b68b06c2d2d288d593462539fe45fff48a6;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 58a59db..3e9d93e 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -3,9 +3,11 @@ 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; +use Sub::Name (); require Module::Find; use base qw/DBIx::Class/; @@ -15,6 +17,8 @@ __PACKAGE__->mk_classdata('source_registrations' => {}); __PACKAGE__->mk_classdata('storage_type' => '::DBI'); __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,7 +97,32 @@ moniker. =cut sub register_source { - my ($self, $moniker, $source) = @_; + my $self = shift; + + $self->_register_source(@_); +} + +=head2 register_extra_source + +=over 4 + +=item Arguments: $moniker, $result_source + +=back + +As L but should be used if the result class already +has a source and you want to register an extra one. + +=cut + +sub register_extra_source { + my $self = shift; + + $self->_register_source(@_, { extra => 1 }); +} + +sub _register_source { + my ($self, $moniker, $source, $params) = @_; %$source = %{ $source->new( { %$source, source_name => $moniker }) }; @@ -102,10 +131,14 @@ sub register_source { $self->source_registrations(\%reg); $source->schema($self); - weaken($source->{schema}) if ref($self); + return if ($params->{extra}); + if ($source->result_class) { my %map = %{$self->class_mappings}; + if (exists $map{$source->result_class}) { + warn $source->result_class . ' already has a source, use register_extra_source for additional sources'; + } $map{$source->result_class} = $moniker; $self->class_mappings(\%map); } @@ -481,7 +514,9 @@ DEPRECATED. You probably wanted compose_namespace. Actually, you probably just wanted to call connect. -=for hidden due to deprecation +=begin hidden + +(hidden due to deprecation) Calls L to the target namespace, calls L with @db_info on the new schema, @@ -495,6 +530,8 @@ L and use the resulting schema object to operate on L objects with L for more information. +=end hidden + =cut { @@ -503,7 +540,8 @@ more information. sub compose_connection { my ($self, $target, @info) = @_; - warn "compose_connection deprecated as of 0.08000" unless $warn++; + warn "compose_connection deprecated as of 0.08000" + unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++); my $base = 'DBIx::Class::ResultSetProxy'; eval "require ${base};"; @@ -527,7 +565,8 @@ more information. my $schema = $self->compose_namespace($target, $base); { no strict 'refs'; - *{"${target}::schema"} = sub { $schema }; + my $name = join '::', $target, 'schema'; + *$name = Sub::Name::subname $name, sub { $schema }; } $schema->connection(@info); @@ -576,15 +615,31 @@ will produce the output =cut +# this might be oversimplified +# sub compose_namespace { +# my ($self, $target, $base) = @_; + +# my $schema = $self->clone; +# foreach my $moniker ($schema->sources) { +# my $source = $schema->source($moniker); +# my $target_class = "${target}::${moniker}"; +# $self->inject_base( +# $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'); +# $schema->register_source($moniker, $source); +# } +# return $schema; +# } + sub compose_namespace { my ($self, $target, $base) = @_; - my %reg = %{ $self->source_registrations }; - my %target; - my %map; my $schema = $self->clone; { no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { }; +# local *Class::C3::reinitialize = sub { }; foreach my $moniker ($schema->sources) { my $source = $schema->source($moniker); my $target_class = "${target}::${moniker}"; @@ -594,11 +649,13 @@ sub compose_namespace { $source->result_class($target_class); $target_class->result_source_instance($source) if $target_class->can('result_source_instance'); + $schema->register_source($moniker, $source); } } - Class::C3->reinitialize(); +# Class::C3->reinitialize(); { no strict 'refs'; + no warnings 'redefine'; foreach my $meth (qw/class source resultset/) { *{"${target}::${meth}"} = sub { shift->schema->$meth(@_) }; @@ -607,19 +664,6 @@ sub compose_namespace { return $schema; } -=head2 setup_connection_class - -=over 4 - -=item Arguments: $target, @info - -=back - -Sets up a database connection class to inject between the schema and the -subclasses that the schema creates. - -=cut - sub setup_connection_class { my ($class, $target, @info) = @_; $class->inject_base($target => 'DBIx::Class::DB'); @@ -631,9 +675,9 @@ sub setup_connection_class { =over 4 -=item Arguments: $storage_type +=item Arguments: $storage_type|{$storage_type, \%args} -=item Return Value: $storage_type +=item Return Value: $storage_type|{$storage_type, \%args} =back @@ -647,6 +691,13 @@ 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>. +If your storage type requires instantiation arguments, those are defined as a +second argument in the form of a hashref and the entire value needs to be +wrapped into an arrayref or a hashref. We support both types of refs here in +order to play nice with your Config::[class] or your choice. + +See L for an example of this. + =head2 connection =over 4 @@ -669,20 +720,33 @@ or L in general. sub connection { my ($self, @info) = @_; return $self if !@info && $self->storage; - my $storage_class = $self->storage_type; + + my ($storage_class, $args) = ref $self->storage_type ? + ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {}); + $storage_class = 'DBIx::Class::Storage'.$storage_class if $storage_class =~ m/^::/; eval "require ${storage_class};"; $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=>$args); $storage->connect_info(\@info); $self->storage($storage); - $self->on_connect() if($self->can('on_connect')); return $self; } +sub _normalize_storage_type { + my ($self, $storage_type) = @_; + if(ref $storage_type eq 'ARRAY') { + return @$storage_type; + } elsif(ref $storage_type eq 'HASH') { + return %$storage_type; + } else { + $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type); + } +} + =head2 connect =over 4 @@ -729,6 +793,22 @@ sub txn_do { $self->storage->txn_do(@_); } +=head2 txn_scope_guard (EXPERIMENTAL) + +Runs C on the schema's storage. See +L. + +=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 @@ -780,6 +860,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 @@ -798,10 +929,14 @@ sub clone { my $clone = { (ref $self ? %$self : ()) }; bless $clone, (ref $self || $self); + $clone->class_mappings({ %{$clone->class_mappings} }); + $clone->source_registrations({ %{$clone->source_registrations} }); foreach my $moniker ($self->sources) { my $source = $self->source($moniker); my $new = $source->new($source); - $clone->register_source($moniker => $new); + # we use extra here as we want to leave the class_mappings as they are + # but overwrite the source_registrations entry with the new source + $clone->register_extra_source($moniker => $new); } $clone->storage->set_schema($clone) if $clone->storage; return $clone; @@ -836,6 +971,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 @@ -852,7 +999,15 @@ sub populate { } return @created; } - $self->storage->insert_bulk($self->source($name), \@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 @@ -865,7 +1020,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, @@ -887,6 +1042,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 @@ -897,16 +1064,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 @@ -916,17 +1086,15 @@ 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. Saying that, it -has been used successfully by many people, including the core dev team. - 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. +only the sources listed will get deployed. Furthermore, you can use the +C parser parameter to prevent the parser from creating an index for each +FK. =cut @@ -936,6 +1104,30 @@ 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 @@ -956,6 +1148,8 @@ 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". +See L for details of $sqlt_args. + If no arguments are passed, then the following default values are used: =over 4 @@ -984,15 +1178,15 @@ sub create_ddl_dir { $self->storage->create_ddl_dir($self, @_); } -=head2 ddl_filename (EXPERIMENTAL) +=head2 ddl_filename =over 4 -=item Arguments: $directory, $database-type, $version, $preversion +=item Arguments: $database-type, $version, $directory, $preversion =back - my $filename = $table->ddl_filename($type, $dir, $version, $preversion) + my $filename = $table->ddl_filename($type, $version, $dir, $preversion) This method is called by C to compose a file name out of the supplied directory, database type and version number. The default file @@ -1004,14 +1198,84 @@ format. =cut sub ddl_filename { - my ($self, $type, $dir, $version, $pversion) = @_; + my ($self, $type, $version, $dir, $preversion) = @_; + + my $filename = ref($self); + $filename =~ s/::/-/g; + $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql"); + $filename =~ s/$version/$preversion-$version/ if($preversion); + + 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 - my $filename = ref($self); - $filename =~ s/::/-/g; - $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql"); - $filename =~ s/$version/$pversion-$version/ if($pversion); +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); +} + +=head2 schema_version + +Returns the current schema class' $VERSION - return $filename; +=cut + +sub schema_version { + my ($self) = @_; + my $class = ref($self)||$self; + + # does -not- use $schema->VERSION + # since that varies in results depending on if version.pm is installed, and if + # so the perl or XS versions. If you want this to change, bug the version.pm + # author to make vpp and vxs behave the same. + + my $version; + { + no strict 'refs'; + $version = ${"${class}::VERSION"}; + } + return $version; } 1;