ColumnCase is loaded
- reorganized and simplified tests
- added Ordered
+ - added the ability to set on_connect_do and the various sql_maker
+ options as part of Storage::DBI's connect_info.
0.06003 2006-05-19 15:37:30
- make find_or_create_related check defined() instead of truth
use strict;
use warnings;
+use Scalar::Util ();
use base qw/DBIx::Class/;
=head1 NAME
my $new_obj = $obj->new_related('relname', \%col_data);
Create a new item of the related foreign class. If called on a
-L<DBIx::Class::Manual::Glossary/"Row"> object, it will magically set any
-primary key values into foreign key columns for you. The newly created item
-will not be saved into your storage until you call L<DBIx::Class::Row/insert>
+L<DBIx::Class::Manual::Glossary/"Row"> object, it will magically
+set any foreign key columns of the new object to the related primary
+key columns of the source object for you. The newly created item will
+not be saved into your storage until you call L<DBIx::Class::Row/insert>
on it.
=cut
if (defined $f_obj) {
my $f_class = $self->result_source->schema->class($rel_obj->{class});
$self->throw_exception( "Object $f_obj isn't a ".$f_class )
- unless $f_obj->isa($f_class);
+ unless Scalar::Util::blessed($f_obj) and $f_obj->isa($f_class);
}
$self->set_columns(
$self->result_source->resolve_condition(
sub search_rs {
my $self = shift;
- my $our_attrs = { %{$self->{attrs}} };
- my $having = delete $our_attrs->{having};
my $attrs = {};
$attrs = pop(@_) if @_ > 1 and ref $_[$#_] eq 'HASH';
-
+ my $our_attrs = ($attrs->{_parent_attrs}) ? { %{$attrs->{_parent_attrs}} } : { %{$self->{attrs}} };
+ my $having = delete $our_attrs->{having};
+
# merge new attrs into old
foreach my $key (qw/join prefetch/) {
next unless (exists $attrs->{$key});
+ if ($attrs->{_live_join} || $our_attrs->{_live_join}) {
+ $attrs->{$key} = { ($attrs->{_live_join}) ? $attrs->{_live_join} : $our_attrs->{_live_join} => $attrs->{$key} };
+ }
if (exists $our_attrs->{$key}) {
$our_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key});
} else {
delete $attrs->{$key};
}
+ $our_attrs->{join} = $self->_merge_attr($our_attrs->{join}, $attrs->{_live_join}, 1) if ($attrs->{_live_join});
if (exists $our_attrs->{prefetch}) {
$our_attrs->{join} = $self->_merge_attr($our_attrs->{join}, $our_attrs->{prefetch}, 1);
}
my $new_attrs = { %{$our_attrs}, %{$attrs} };
-
- # merge new where and having into old
my $where = (@_
? ((@_ == 1 || ref $_[0] eq "HASH")
? shift
return if(exists $self->{_attrs}); #return if _resolve has already been called
- my $attrs = $self->{attrs};
+ my $attrs = $self->{attrs};
my $source = ($self->{_parent_rs}) ? $self->{_parent_rs} : $self->{result_source};
# XXX - lose storable dclone
my $rs = $self->result_source->schema->resultset($rel_obj->{class}
)->search( undef,
- { %{$self->{attrs}},
- select => undef,
+ { select => undef,
as => undef,
- join => $rel,
- _live_join => $rel }
+ #join => $rel,
+ _live_join => $rel,
+ _parent_attrs => $self->{attrs}}
);
# keep reference of the original resultset
- $rs->{_parent_rs} = $self->result_source;
+ $rs->{_parent_rs} = ($self->{_parent_rs}) ? $self->{_parent_rs} : $self->result_source;
return $rs;
};
}
$self->SUPER::_RowNum(@_);
}
-# Accessor for setting limit dialect. This is useful
-# for JDBC-bridge among others where the remote SQL-dialect cannot
-# be determined by the name of the driver alone.
-#
sub limit_dialect {
my $self = shift;
$self->{limit_dialect} = shift if @_;
=head2 connect_info
-Connection information arrayref. Can either be the same arguments
-one would pass to DBI->connect, or a code-reference which returns
-a connected database handle. In either case, there is an optional
-final element in the arrayref, which can hold a hashref of
-connection-specific Storage::DBI options. These include
-C<on_connect_do>, and the sql_maker options C<limit_dialect>,
-C<quote_char>, and C<name_sep>. Examples:
+The arguments of C<connect_info> are always a single array reference.
- ->connect_info([ 'dbi:SQLite:./foo.db' ]);
- ->connect_info(sub { DBI->connect(...) });
- ->connect_info([ 'dbi:Pg:dbname=foo',
- 'postgres',
- '',
- { AutoCommit => 0 },
- { quote_char => q{`}, name_sep => q{@} },
- ]);
+This is normally accessed via L<DBIx::Class::Schema/connection>, which
+encapsulates its argument list in an arrayref before calling
+C<connect_info> here.
-=head2 on_connect_do
+The arrayref can either contain the same set of arguments one would
+normally pass to L<DBI/connect>, or a lone code reference which returns
+a connected database handle.
-Executes the sql statements given as a listref on every db connect.
+In either case, there is an optional final element within the arrayref
+which can hold a hashref of connection-specific Storage::DBI options.
+These include C<on_connect_do>, and the sql_maker options
+C<limit_dialect>, C<quote_char>, and C<name_sep>. Examples:
-=head2 quote_char
+ ->connect_info([ 'dbi:SQLite:./foo.db' ]);
-Specifies what characters to use to quote table and column names. If
-you use this you will want to specify L<name_sep> as well.
+ ->connect_info([ sub { DBI->connect(...) } ]);
-quote_char expectes either a single character, in which case is it is placed
-on either side of the table/column, or an array of length 2 in which case the
-table/column name is placed between the elements.
+ ->connect_info(
+ [
+ 'dbi:Pg:dbname=foo',
+ 'postgres',
+ 'my_pg_password',
+ { AutoCommit => 0 },
+ { quote_char => q{`}, name_sep => q{@} },
+ ]
+ );
-For example under MySQL you'd use C<quote_char('`')>, and user SQL Server you'd
-use C<quote_char(qw/[ ]/)>.
+ ->connect_info(
+ [
+ sub { DBI->connect(...) },
+ { quote_char => q{`}, name_sep => q{@} },
+ ]
+ );
-=head2 name_sep
+=head2 on_connect_do
-This only needs to be used in conjunction with L<quote_char>, and is used to
-specify the charecter that seperates elements (schemas, tables, columns) from
-each other. In most cases this is simply a C<.>.
+Executes the sql statements given as a listref on every db connect.
+
+This option can also be set via L</connect_info>.
=head2 debug
}
sub connect_info {
- my ($self, $info_arg) = @_;
-
- if($info_arg) {
- my $info = [ @$info_arg ]; # copy because we can alter it
- my $last_info = $info->[-1];
- if(ref $last_info eq 'HASH') {
- my $used;
- if(my $on_connect_do = $last_info->{on_connect_do}) {
- $used = 1;
- $self->on_connect_do($on_connect_do);
- }
- for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
- if(my $opt_val = $last_info->{$sql_maker_opt}) {
- $used = 1;
- $self->sql_maker->$sql_maker_opt($opt_val);
- }
- }
-
- # remove our options hashref if it was there, to avoid confusing
- # DBI in the case the user didn't use all 4 DBI options, as in:
- # [ 'dbi:SQLite:foo.db', { quote_char => q{`} } ]
- pop(@$info) if $used;
+ my ($self, $info_arg) = @_;
+
+ if($info_arg) {
+ my $info = [ @$info_arg ]; # copy because we can alter it
+ my $last_info = $info->[-1];
+ if(ref $last_info eq 'HASH') {
+ my $used;
+ if(my $on_connect_do = $last_info->{on_connect_do}) {
+ $used = 1;
+ $self->on_connect_do($on_connect_do);
+ }
+ for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
+ if(my $opt_val = $last_info->{$sql_maker_opt}) {
+ $used = 1;
+ $self->sql_maker->$sql_maker_opt($opt_val);
}
+ }
- $self->_connect_info($info);
+ # remove our options hashref if it was there, to avoid confusing
+ # DBI in the case the user didn't use all 4 DBI options, as in:
+ # [ 'dbi:SQLite:foo.db', { quote_char => q{`} } ]
+ pop(@$info) if $used;
}
- $self->_connect_info;
+ $self->_connect_info($info);
+ }
+
+ $self->_connect_info;
}
sub _populate_dbh {
}
eval {
- if(ref $info[0] eq 'CODE') {
- $dbh = &{$info[0]};
- }
- else {
- $dbh = DBI->connect(@info);
- }
+ $dbh = ref $info[0] eq 'CODE'
+ ? &{$info[0]}
+ : DBI->connect(@info);
};
$DBI::connect_via = $old_connect_via if $old_connect_via;
=item limit_dialect
+Accessor for setting limit dialect. This is useful
+for JDBC-bridge among others where the remote SQL-dialect cannot
+be determined by the name of the driver alone.
+
+This option can also be set via L</connect_info>.
+
=item quote_char
+Specifies what characters to use to quote table and column names. If
+you use this you will want to specify L<name_sep> as well.
+
+quote_char expectes either a single character, in which case is it is placed
+on either side of the table/column, or an arrayref of length 2 in which case the
+table/column name is placed between the elements.
+
+For example under MySQL you'd use C<quote_char('`')>, and user SQL Server you'd
+use C<quote_char(qw/[ ]/)>.
+
+This option can also be set via L</connect_info>.
+
=item name_sep
+This only needs to be used in conjunction with L<quote_char>, and is used to
+specify the charecter that seperates elements (schemas, tables, columns) from
+each other. In most cases this is simply a C<.>.
+
+This option can also be set via L</connect_info>.
+
=back
=head1 ENVIRONMENT VARIABLES
+++ /dev/null
-package DBIx::Class::Validation;
-
-use strict;
-use warnings;
-
-use base qw( DBIx::Class );
-use English qw( -no_match_vars );
-
-#local $^W = 0; # Silence C:D:I redefined sub errors.
-# Switched to C::D::Accessor which doesn't do this. Hate hate hate hate.
-
-our $VERSION = '0.01';
-
-__PACKAGE__->mk_classdata( 'validation_module' => 'FormValidator::Simple' );
-__PACKAGE__->mk_classdata( 'validation_profile' );
-__PACKAGE__->mk_classdata( 'validation_auto' => 1 );
-
-sub validation_module {
- my $class = shift;
- my $module = shift;
-
- eval("use $module");
- $class->throw_exception("Unable to load the validation module '$module' because $EVAL_ERROR") if ($EVAL_ERROR);
- $class->throw_exception("The '$module' module does not support the check method") if (!$module->can('check'));
-
- $class->_validation_module_accessor( $module );
-}
-
-sub validation {
- my $class = shift;
- my %args = @_;
-
- $class->validation_module( $args{module} ) if (exists $args{module});
- $class->validation_profile( $args{profile} ) if (exists $args{profile});
- $class->validation_auto( $args{auto} ) if (exists $args{auto});
-}
-
-sub validate {
- my $self = shift;
- my %data = $self->get_columns();
- my $module = $self->validation_module();
- my $profile = $self->validation_profile();
- my $result = $module->check( \%data => $profile );
- return $result if ($result->success());
- $self->throw_exception( $result );
-}
-
-sub insert {
- my $self = shift;
- $self->validate if ($self->validation_auto());
- $self->next::method(@_);
-}
-
-sub update {
- my $self = shift;
- $self->validate if ($self->validation_auto());
- $self->next::method(@_);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-DBIx::Class::Validation - Validate all data before submitting to your database.
-
-=head1 SYNOPSIS
-
-In your base DBIC package:
-
- __PACKAGE__->load_components(qw/... Validation/);
-
-And in your subclasses:
-
- __PACKAGE__->validation(
- module => 'FormValidator::Simple',
- profile => { ... },
- auto => 1,
- );
-
-And then somewhere else:
-
- eval{ $obj->validate() };
- if( my $results = $EVAL_ERROR ){
- ...
- }
-
-=head1 METHODS
-
-=head2 validation
-
- __PACKAGE__->validation(
- module => 'FormValidator::Simple',
- profile => { ... },
- auto => 1,
- );
-
-Calls validation_module(), validation_profile(), and validation_auto() if the corresponding
-argument is defined.
-
-=head2 validation_module
-
- __PACKAGE__->validation_module('Data::FormValidator');
-
-Sets the validation module to use. Any module that supports a check() method just like
-Data::FormValidator's can be used here, such as FormValidator::Simple.
-
-Defaults to FormValidator::Simple.
-
-=head2 validation_profile
-
- __PACKAGE__->validation_profile(
- { ... }
- );
-
-Sets the profile that will be passed to the validation module.
-
-=head2 validation_auto
-
- __PACKAGE__->validation_auto( 1 );
-
-This flag, when enabled, causes any updates or inserts of the class
-to call validate() before actually executing.
-
-=head2 validate
-
- $obj->validate();
-
-Validates all the data in the object against the pre-defined validation
-module and profile. If there is a problem then a hard error will be
-thrown. If you put the validation in an eval you can capture whatever
-the module's check() method returned.
-
-=head2 auto_validate
-
- __PACKAGE__->auto_validate( 0 );
-
-Turns on and off auto-validation. This feature makes all UPDATEs and
-INSERTs call the validate() method before doing anything. The default
-is for auto-validation to be on.
-
-Defaults to on.
-
-=head1 EXTENDED METHODS
-
-The following methods are extended by this module:-
-
-=over 4
-
-=item insert
-
-=item update
-
-=back
-
-=head1 AUTHOR
-
-Aran C. Deltac <bluefeet@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+plan tests => 1;
+
+# Set up the "usual" sqlite for DBICTest
+my $normal_schema = DBICTest->init_schema;
+
+# Steal the dsn, which should be like 'dbi:SQLite:t/var/DBIxClass.db'
+my $normal_dsn = $normal_schema->storage->connect_info->[0];
+
+# Make sure we have no active connection
+$normal_schema->storage->disconnect;
+
+# Make a new clone with a new connection, using a code reference
+my $code_ref_schema = $normal_schema->connect(sub { DBI->connect($normal_dsn); });
+
+# Stolen from 60core.t - this just verifies things seem to work at all
+my @art = $code_ref_schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
+cmp_ok(@art, '==', 3, "Three artists returned");
my $schema = DBICTest->init_schema();
-plan tests => 60;
+plan tests => 61;
# figure out if we've got a version of sqlite that is older than 3.2.6, in
# which case COUNT(DISTINCT()) doesn't work
# Test backwards compatibility
{
+ my $warnings = '';
+ local $SIG{__WARN__} = sub { $warnings .= $_[0] };
+
my $artist_by_hash = $schema->resultset('Artist')->find(artistid => 4);
is($artist_by_hash->name, 'Man With A Spoon', 'Retrieved correctly');
is($artist_by_hash->ID, 'DBICTest::Artist|artist|artistid=4', 'unique object id generated correctly');
+ like($warnings, qr/deprecated/, 'warned about deprecated find usage');
}
is($schema->resultset("Artist")->count, 4, 'count ok');
my $schema = DBICTest->init_schema();
-plan tests => 8;
+plan tests => 9;
my @rs1a_results = $schema->resultset("Artist")->search_related('cds', {title => 'Forkful of bees'}, {order_by => 'title'});
is($rs1a_results[0]->title, 'Forkful of bees', "bare field conditions okay after search related");
cmp_ok(scalar @cds, '==', 1, "condition based on inherited join okay");
# this is wrong, should accept me.title really
-my $rs3 = $rs2->search_related('cds')->search({'cds.title' => 'Forkful of bees'});
-
-cmp_ok($rs3->count, '==', 1, "Three artists returned");
+my $rs3 = $rs2->search_related('cds');
+cmp_ok($rs3->count, '==', 9, "Nine artists returned");
my $rs4 = $schema->resultset("CD")->search({ 'artist.artistid' => '1' }, { join => ['tracks', 'artist'], prefetch => 'artist' });
my @rs4_results = $rs4->all;
-
is($rs4_results[0]->cdid, 1, "correct artist returned");
my $rs5 = $rs4->search({'tracks.title' => 'Sticky Honey'});
my $producers = $cd->producers;
is($producers->find(2)->name, 'Bob The Builder', "find on many to many okay");
+my @prods = $producers->search({name => 'Bob The Builder'}, { prefetch => 'producer_to_cd' })->all;
+is($prods[0]->name, 'Bob The Builder', 'prefetch after has_many rel okay');
+
1;
__PACKAGE__->set_primary_key('producerid');
__PACKAGE__->add_unique_constraint(prod_name => [ qw/name/ ]);
+__PACKAGE__->has_many(
+ producer_to_cd => 'DBICTest::Schema::CD_to_Producer' => 'producer'
+);
+
1;
projects / dbsrgits/DBIx-Class.git / commitdiff