- Make sure to turn off IDENTITY_INSERT after insert() on MSSQL
tables that needed it
- More informative exception on failing _resolve_relationship
+ - Allow undef/NULL as the sole grouping value in Ordered
- Fix unreported rollback exceptions in TxnScopeGuard
- Fix overly-eager left-join chain enforcing code
+ - Warn about using distinct with an existing group_by
+ - Warn about attempting to $rs->get_column a non-unique column
+ when has_many joins are added to resultset
0.08111 2009-09-06 21:58:00 (UTC)
- The hashref to connection_info now accepts a 'dbh_maker'
- Support for MSSQL 'money' type
- Support for 'smalldatetime' type used in MSSQL and Sybase for
InflateColumn::DateTime
- - support for Postgres 'timestamp without timezone' type in
+ - Support for Postgres 'timestamp without timezone' type in
InflateColumn::DateTime (RT#48389)
- Added new MySQL specific on_connect_call macro 'set_strict_mode'
(also known as make_mysql_not_suck_as_much)
'Hash::Merge', => '0.11',
);
-# when changing also adjust $DBIx::Class::minimum_sqlt_version
-my $sqlt_recommends = '0.11002';
-
+#************************************************************************#
+# Make *ABSOLUTELY SURE* that nothing on this list is a real require, #
+# since every module listed in %force_requires_if_author is deleted #
+# from the final META.yml (thus will never make it as a CPAN dependency) #
+#************************************************************************#
my %force_requires_if_author = (
%replication_requires,
+ # when changing also adjust $DBIx::Class::Storage::DBI::minimum_sqlt_version
+ 'SQL::Translator' => '0.11002',
+
# 'Module::Install::Pod::Inherit' => '0.01',
- 'SQL::Translator' => $sqlt_recommends,
# when changing also adjust version in t/02pod.t
'Test::Pod' => '1.26',
) : ()
,
);
+#************************************************************************#
+# Make *ABSOLUTELY SURE* that nothing on the list aboveis a real require,#
+# since every module listed in %force_requires_if_author is deleted #
+# from the final META.yml (thus will never make it as a CPAN dependency) #
+#************************************************************************#
install_script (qw|
use MRO::Compat;
use vars qw($VERSION);
-use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
+use base qw/Class::C3::Componentised Class::Accessor::Grouped/;
use DBIx::Class::StartupCheck;
sub mk_classdata {
# Always remember to do all digits for the version even if they're 0
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-
$VERSION = '0.08111';
$VERSION = eval $VERSION; # numify for warning-free dev releases
-# what version of sqlt do we require if deploy() without a ddl_dir is invoked
-# when changing also adjust $sqlt_recommends in Makefile.PL
-my $minimum_sqlt_version = '0.11002';
-
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code,@attrs) = @_;
$class->mk_classdata('__attr_cache' => {})
return $@ ? $cache : { %$cache, %$rest };
}
-# SQLT version handling
-{
- my $_sqlt_version_ok; # private
- my $_sqlt_version_error; # private
-
- sub _sqlt_version_ok {
- if (!defined $_sqlt_version_ok) {
- eval "use SQL::Translator $minimum_sqlt_version";
- if ($@) {
- $_sqlt_version_ok = 0;
- $_sqlt_version_error = $@;
- }
- else {
- $_sqlt_version_ok = 1;
- }
- }
- return $_sqlt_version_ok;
- }
-
- sub _sqlt_version_error {
- shift->_sqlt_version_ok unless defined $_sqlt_version_ok;
- return $_sqlt_version_error;
- }
-
- sub _sqlt_minimum_version { $minimum_sqlt_version };
-}
-
-
1;
=head1 NAME
use strict;
use warnings;
-use base 'Class::C3::Componentised';
-use Carp::Clan qw/^DBIx::Class/;
-
-sub inject_base {
- my ($class, $target, @to_inject) = @_;
- {
- no strict 'refs';
- foreach my $to (reverse @to_inject) {
- my @comps = qw(DigestColumns ResultSetManager Ordered UTF8Columns);
- # Add components here that need to be loaded before Core
- foreach my $first_comp (@comps) {
- if ($to eq 'DBIx::Class::Core' &&
- $target->isa("DBIx::Class::${first_comp}")) {
- carp "Possible incorrect order of components in ".
- "${target}::load_components($first_comp) call: Core loaded ".
- "before $first_comp. See the documentation for ".
- "DBIx::Class::$first_comp for more information";
- }
- }
- unshift( @{"${target}::ISA"}, $to )
- unless ($target eq $to || $target->isa($to));
- }
- }
+###
+# Keep this class for backwards compatibility
+###
- $class->next::method($target, @to_inject);
-}
+use base 'Class::C3::Componentised';
1;
use strict;
use warnings;
+use base qw/DBIx::Class/;
+
=head1 NAME
DBIx::Class::Cursor - Abstract object representing a query cursor on a
sub move_to_group {
my( $self, $to_group, $to_position ) = @_;
- $self->throw_exception ('move_to_group() expects a group specification')
- unless defined $to_group;
-
- # if we're given a string, turn it into a hashref
+ # if we're given a single value, turn it into a hashref
unless (ref $to_group eq 'HASH') {
my @gcols = $self->_grouping_columns;
'bool' => "_bool",
fallback => 1;
use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Exception;
use Data::Page;
use Storable;
use DBIx::Class::ResultSetColumn;
# build columns (as long as select isn't set) into a set of as/select hashes
unless ( $attrs->{select} ) {
- @colbits = map {
- ( ref($_) eq 'HASH' )
- ? $_
- : {
- (
- /^\Q${alias}.\E(.+)$/
- ? "$1"
- : "$_"
- )
- =>
- (
- /\./
- ? "$_"
- : "${alias}.$_"
- )
- }
- } ( ref($attrs->{columns}) eq 'ARRAY' ) ? @{ delete $attrs->{columns}} : (delete $attrs->{columns} || $source->columns );
+
+ my @cols = ( ref($attrs->{columns}) eq 'ARRAY' )
+ ? @{ delete $attrs->{columns}}
+ : (
+ ( delete $attrs->{columns} )
+ ||
+ $source->columns
+ )
+ ;
+
+ @colbits = map {
+ ( ref($_) eq 'HASH' )
+ ? $_
+ : {
+ (
+ /^\Q${alias}.\E(.+)$/
+ ? "$1"
+ : "$_"
+ )
+ =>
+ (
+ /\./
+ ? "$_"
+ : "${alias}.$_"
+ )
+ }
+ } @cols;
}
+
# add the additional columns on
foreach ( 'include_columns', '+columns' ) {
push @colbits, map {
sub throw_exception {
my $self=shift;
+
if (ref $self && $self->_source_handle->schema) {
$self->_source_handle->schema->throw_exception(@_)
- } else {
- croak(@_);
}
-
+ else {
+ DBIx::Class::Exception->throw(@_);
+ }
}
# XXX: FIXME: Attributes docs need clearing up
package DBIx::Class::ResultSetColumn;
+
use strict;
use warnings;
+
use base 'DBIx::Class';
+
+use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Exception;
use List::Util;
=head1 NAME
my $select = defined $as_index ? $select_list->[$as_index] : $column;
# {collapse} would mean a has_many join was injected, which in turn means
- # we need to group IF WE CAN (only if the column in question is unique)
+ # we need to group *IF WE CAN* (only if the column in question is unique)
if (!$new_attrs->{group_by} && keys %{$orig_attrs->{collapse}}) {
# scan for a constraint that would contain our column only - that'd be proof
if ($col eq $select or $fqcol eq $select) {
$new_attrs->{group_by} = [ $select ];
+ delete $new_attrs->{distinct}; # it is ignored when group_by is present
last;
}
}
+
+ if (!$new_attrs->{group_by}) {
+ carp (
+ "Attempting to retrieve non-unique column '$column' on a resultset containing "
+ . 'one-to-many joins will return duplicate results.'
+ );
+ }
}
my $new = bless { _select => $select, _as => $column, _parent_resultset => $new_parent_rs }, $class;
sub throw_exception {
my $self=shift;
+
if (ref $self && $self->{_parent_resultset}) {
- $self->{_parent_resultset}->throw_exception(@_)
- } else {
- croak(@_);
+ $self->{_parent_resultset}->throw_exception(@_);
+ }
+ else {
+ DBIx::Class::Exception->throw(@_);
}
}
use DBIx::Class::ResultSet;
use DBIx::Class::ResultSourceHandle;
+
+use DBIx::Class::Exception;
use Carp::Clan qw/^DBIx::Class/;
use base qw/DBIx::Class/;
sub throw_exception {
my $self = shift;
+
if (defined $self->schema) {
$self->schema->throw_exception(@_);
- } else {
- croak(@_);
+ }
+ else {
+ DBIx::Class::Exception->throw(@_);
}
}
use warnings;
use base qw/DBIx::Class/;
-use Carp::Clan qw/^DBIx::Class/;
+
+use DBIx::Class::Exception;
use Scalar::Util ();
-use Scope::Guard;
###
### Internal method
foreach my $key (keys %$attrs) {
if (ref $attrs->{$key}) {
## Can we extract this lot to use with update(_or .. ) ?
- confess "Can't do multi-create without result source" unless $source;
+ $new->throw_exception("Can't do multi-create without result source")
+ unless $source;
my $info = $source->relationship_info($key);
if ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'single')
sub throw_exception {
my $self=shift;
+
if (ref $self && ref $self->result_source && $self->result_source->schema) {
- $self->result_source->schema->throw_exception(@_);
- } else {
- croak(@_);
+ $self->result_source->schema->throw_exception(@_)
+ }
+ else {
+ DBIx::Class::Exception->throw(@_);
}
}
return;
}
- $self->throw_exception($self->_sqlt_version_error)
- if (not $self->_sqlt_version_ok);
+ $self->throw_exception($self->storage->_sqlt_version_error)
+ if (not $self->storage->_sqlt_version_ok);
- my $db_tr = SQL::Translator->new({
- add_drop_table => 1,
+ my $db_tr = SQL::Translator->new({
+ add_drop_table => 1,
parser => 'DBI',
parser_args => { dbh => $self->storage->dbh }
});
use base qw/DBIx::Class/;
use mro 'c3';
-use Scalar::Util qw/weaken/;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Exception;
+use Scalar::Util();
use IO::File;
use DBIx::Class::Storage::TxnScopeGuard;
sub set_schema {
my ($self, $schema) = @_;
$self->schema($schema);
- weaken($self->{schema}) if ref $self->{schema};
+ Scalar::Util::weaken($self->{schema}) if ref $self->{schema};
}
=head2 connected
sub throw_exception {
my $self = shift;
- $self->schema->throw_exception(@_) if $self->schema;
- croak @_;
+ if ($self->schema) {
+ $self->schema->throw_exception(@_);
+ }
+ else {
+ DBIx::Class::Exception->throw(@_);
+ }
}
=head2 txn_do
use Scalar::Util();
use List::Util();
+# what version of sqlt do we require if deploy() without a ddl_dir is invoked
+# when changing also adjust the corresponding author_require in Makefile.PL
+my $minimum_sqlt_version = '0.11002';
+
+
__PACKAGE__->mk_group_accessors('simple' =>
qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
_conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints/
$self->_do_connection_actions(disconnect_call_ => $_) for @actions;
- $self->_dbh->rollback unless $self->_dbh_autocommit;
+ $self->_dbh_rollback unless $self->_dbh_autocommit;
+
$self->_dbh->disconnect;
$self->_dbh(undef);
$self->{_dbh_gen}++;
return $self->_sql_maker;
}
+# nothing to do by default
sub _rebless {}
+sub _init {}
sub _populate_dbh {
my ($self) = @_;
$self->_driver_determined(1);
+ $self->_init; # run driver-specific initializations
+
$self->_run_connection_actions
if $started_unconnected && defined $self->_dbh;
}
$weak_self->throw_exception("DBI Exception: $_[0]");
}
else {
+ # the handler may be invoked by something totally out of
+ # the scope of DBIC
croak ("DBI Exception: $_[0]");
}
};
if($self->{transaction_depth} == 0) {
$self->debugobj->txn_begin()
if $self->debug;
-
- # being here implies we have AutoCommit => 1
- # if the user is utilizing txn_do - good for
- # him, otherwise we need to ensure that the
- # $dbh is healthy on BEGIN
- my $dbh_method = $self->{_in_dbh_do} ? '_dbh' : 'dbh';
- $self->$dbh_method->begin_work;
-
- } elsif ($self->auto_savepoint) {
+ $self->_dbh_begin_work;
+ }
+ elsif ($self->auto_savepoint) {
$self->svp_begin;
}
$self->{transaction_depth}++;
}
+sub _dbh_begin_work {
+ my $self = shift;
+
+ # if the user is utilizing txn_do - good for him, otherwise we need to
+ # ensure that the $dbh is healthy on BEGIN.
+ # We do this via ->dbh_do instead of ->dbh, so that the ->dbh "ping"
+ # will be replaced by a failure of begin_work itself (which will be
+ # then retried on reconnect)
+ if ($self->{_in_dbh_do}) {
+ $self->_dbh->begin_work;
+ } else {
+ $self->dbh_do(sub { $_[1]->begin_work });
+ }
+}
+
sub txn_commit {
my $self = shift;
if ($self->{transaction_depth} == 1) {
my $dbh = $self->_dbh;
$self->debugobj->txn_commit()
if ($self->debug);
- $dbh->commit;
+ $self->_dbh_commit;
$self->{transaction_depth} = 0
if $self->_dbh_autocommit;
}
}
}
+sub _dbh_commit {
+ my $self = shift;
+ $self->_dbh->commit;
+}
+
sub txn_rollback {
my $self = shift;
my $dbh = $self->_dbh;
if ($self->debug);
$self->{transaction_depth} = 0
if $self->_dbh_autocommit;
- $dbh->rollback;
+ $self->_dbh_rollback;
}
elsif($self->{transaction_depth} > 1) {
$self->{transaction_depth}--;
}
}
+sub _dbh_rollback {
+ my $self = shift;
+ $self->_dbh->rollback;
+}
+
# This used to be the top-half of _execute. It was split out to make it
# easier to override in NoBindVars without duping the rest. It takes up
# all of _execute's args, and emits $sql, @bind.
}
sub update {
- my $self = shift @_;
- my $source = shift @_;
- $self->_determine_driver;
+ my ($self, $source, @args) = @_;
+
+# redispatch to update method of storage we reblessed into, if necessary
+ if (not $self->_driver_determined) {
+ $self->_determine_driver;
+ goto $self->can('update');
+ }
+
my $bind_attributes = $self->source_bind_attributes($source);
- return $self->_execute('update' => [], $source, $bind_attributes, @_);
+ return $self->_execute('update' => [], $source, $bind_attributes, @args);
}
return undef
}
+# Check if placeholders are supported at all
+sub _placeholders_supported {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
+
+ # some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported})
+ # but it is inaccurate more often than not
+ eval {
+ local $dbh->{PrintError} = 0;
+ local $dbh->{RaiseError} = 1;
+ $dbh->do('select ?', {}, 1);
+ };
+ return $@ ? 0 : 1;
+}
+
+# Check if placeholders bound to non-string types throw exceptions
+#
+sub _typeless_placeholders_supported {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
+
+ eval {
+ local $dbh->{PrintError} = 0;
+ local $dbh->{RaiseError} = 1;
+ # this specifically tests a bind that is NOT a string
+ $dbh->do('select 1 where 1 = ?', {}, 1);
+ };
+ return $@ ? 0 : 1;
+}
+
=head2 sqlt_type
Returns the database driver name.
return;
}
+# SQLT version handling
+{
+ my $_sqlt_version_ok; # private
+ my $_sqlt_version_error; # private
+
+ sub _sqlt_version_ok {
+ if (!defined $_sqlt_version_ok) {
+ eval "use SQL::Translator $minimum_sqlt_version";
+ if ($@) {
+ $_sqlt_version_ok = 0;
+ $_sqlt_version_error = $@;
+ }
+ else {
+ $_sqlt_version_ok = 1;
+ }
+ }
+ return $_sqlt_version_ok;
+ }
+
+ sub _sqlt_version_error {
+ shift->_sqlt_version_ok unless defined $_sqlt_version_ok;
+ return $_sqlt_version_error;
+ }
+
+ sub _sqlt_minimum_version { $minimum_sqlt_version };
+}
+
sub DESTROY {
my $self = shift;
}
-=head1 AUTHORS
+=head1 AUTHOR
See L<DBIx::Class/CONTRIBUTORS>
use base qw/DBIx::Class::Cursor/;
+__PACKAGE__->mk_group_accessors('simple' =>
+ qw/sth/
+);
+
=head1 NAME
DBIx::Class::Storage::DBI::Cursor - Object representing a query cursor on a
&& $self->{attrs}{rows}
&& $self->{pos} >= $self->{attrs}{rows}
) {
- $self->{sth}->finish if $self->{sth}->{Active};
- delete $self->{sth};
+ $self->sth->finish if $self->sth->{Active};
+ $self->sth(undef);
$self->{done} = 1;
}
return if $self->{done};
- unless ($self->{sth}) {
- $self->{sth} = ($storage->_select(@{$self->{args}}))[1];
+ unless ($self->sth) {
+ $self->sth(($storage->_select(@{$self->{args}}))[1]);
if ($self->{attrs}{software_limit}) {
if (my $offset = $self->{attrs}{offset}) {
- $self->{sth}->fetch for 1 .. $offset;
+ $self->sth->fetch for 1 .. $offset;
}
}
}
- my @row = $self->{sth}->fetchrow_array;
+ my @row = $self->sth->fetchrow_array;
if (@row) {
$self->{pos}++;
} else {
- delete $self->{sth};
+ $self->sth(undef);
$self->{done} = 1;
}
return @row;
my ($storage, $dbh, $self) = @_;
$self->_check_dbh_gen;
- $self->{sth}->finish if $self->{sth}->{Active};
- delete $self->{sth};
+ $self->sth->finish if $self->sth && $self->sth->{Active};
+ $self->sth(undef);
my ($rv, $sth) = $storage->_select(@{$self->{args}});
return @{$sth->fetchall_arrayref};
}
my ($self) = @_;
# No need to care about failures here
- eval { $self->{sth}->finish if $self->{sth} && $self->{sth}->{Active} };
+ eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
$self->_soft_reset;
return undef;
}
sub _soft_reset {
my ($self) = @_;
- delete $self->{sth};
+ $self->sth(undef);
delete $self->{done};
$self->{pos} = 0;
}
# None of the reasons this would die matter if we're in DESTROY anyways
local $@;
- eval { $self->{sth}->finish if $self->{sth} && $self->{sth}->{Active} };
+ eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
}
1;
sub _prep_for_execute {
my $self = shift;
- my ($op, $extra_bind, $ident) = @_;
-
my ($sql, $bind) = $self->next::method(@_);
- # stringify args, quote via $dbh, and manually insert
+ # stringify bind args, quote via $dbh, and manually insert
+ #my ($op, $extra_bind, $ident, $args) = @_;
+ my $ident = $_[2];
my @sql_part = split /\?/, $sql;
my $new_sql;
+ my $col_info = $self->_resolve_column_info($ident, [ map $_->[0], @$bind ]);
+
foreach my $bound (@$bind) {
my $col = shift @$bound;
- my $datatype = 'FIXME!!!';
+
+ my $datatype = $col_info->{$col}{data_type};
+
foreach my $data (@$bound) {
- if(ref $data) {
- $data = ''.$data;
- }
- $data = $self->_dbh->quote($data);
- $new_sql .= shift(@sql_part) . $data;
+ $data = ''.$data if ref $data;
+
+ $data = $self->_prep_interpolated_value($datatype, $data)
+ if $datatype;
+
+ $data = $self->_dbh->quote($data)
+ unless $self->interpolate_unquoted($datatype, $data);
+
+ $new_sql .= shift(@sql_part) . $data;
}
}
$new_sql .= join '', @sql_part;
return ($new_sql, []);
}
-=head1 AUTHORS
+=head2 interpolate_unquoted
+
+This method is called by L</_prep_for_execute> for every column in
+order to determine if its value should be quoted or not. The arguments
+are the current column data type and the actual bind value. The return
+value is interpreted as: true - do not quote, false - do quote. You should
+override this in you Storage::DBI::<database> subclass, if your RDBMS
+does not like quotes around certain datatypes (e.g. Sybase and integer
+columns). The default method always returns false (do quote).
+
+ WARNING!!!
+
+ Always validate that the bind-value is valid for the current datatype.
+ Otherwise you may very well open the door to SQL injection attacks.
-Brandon Black <blblack@gmail.com>
+=cut
+
+sub interpolate_unquoted {
+ #my ($self, $datatype, $value) = @_;
+ return 0;
+}
+
+=head2 _prep_interpolated_value
+
+Given a datatype and the value to be inserted directly into a SQL query, returns
+the necessary string to represent that value (by e.g. adding a '$' sign)
+
+=cut
+
+sub _prep_interpolated_value {
+ #my ($self, $datatype, $value) = @_;
+ return $_[2];
+}
+
+=head1 AUTHORS
-Trym Skaar <trym@tryms.no>
+See L<DBIx::Class/CONTRIBUTORS>
=head1 LICENSE
use base qw/DBIx::Class::Storage::DBI::MSSQL/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
use List::Util();
use Scalar::Util ();
my $self = shift;
if (ref($self->_dbi_connect_info->[0]) eq 'CODE') {
- croak 'cannot set DBI attributes on a CODE ref connect_info';
+ $self->throw_exception ('cannot set DBI attributes on a CODE ref connect_info');
}
my $dbi_attrs = $self->_dbi_connect_info->[-1];
$dbh->do('SELECT @@IDENTITY');
};
if ($@) {
- croak <<'EOF';
+ $self->throw_exception (<<'EOF');
Your drivers do not seem to support dynamic cursors (odbc_cursortype => 2),
if you're using FreeTDS, make sure to set tds_version to 8.0 or greater.
$self->_identity_method('@@identity');
}
-sub _rebless {
- no warnings 'uninitialized';
+sub _init {
my $self = shift;
- if (ref($self->_dbi_connect_info->[0]) ne 'CODE' &&
- eval { $self->_dbi_connect_info->[-1]{odbc_cursortype} } == 2) {
+ no warnings qw/uninitialized/;
+
+ if (
+ ref($self->_dbi_connect_info->[0]) ne 'CODE'
+ &&
+ ref ($self->_dbi_connect_info->[-1]) eq 'HASH'
+ &&
+ $self->_dbi_connect_info->[-1]{odbc_cursortype} == 2
+ ) {
$self->_set_dynamic_cursors;
return;
}
my $dsn = $self->_dbi_connect_info->[0];
if (ref($dsn) eq 'CODE') {
- croak 'cannot change the DBI DSN on a CODE ref connect_info';
+ $self->throw_exception('cannot change the DBI DSN on a CODE ref connect_info');
}
if ($dsn !~ /MARS_Connection=/) {
? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
: 'DBIx::Class::Storage::DBI::Oracle::Generic';
- # Load and rebless
- eval "require $class";
-
- bless $self, $class unless $@;
+ $self->ensure_class_loaded ($class);
+ bless $self, $class;
}
}
"alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
}
-sub _svp_begin {
- my ($self, $name) = @_;
-
- $self->_get_dbh->do("SAVEPOINT $name");
-}
-
=head2 source_bind_attributes
Handle LOB types in Oracle. Under a certain size (4k?), you can get away
return \%bind_attributes;
}
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->_get_dbh->do("SAVEPOINT $name");
+}
+
# Oracle automatically releases a savepoint when you start another one with the
# same name.
sub _svp_release { 1 }
my @didnt_load;
for my $module (keys %replication_required) {
- eval "use $module $replication_required{$module}";
- push @didnt_load, "$module $replication_required{$module}"
- if $@;
+ eval "use $module $replication_required{$module}";
+ push @didnt_load, "$module $replication_required{$module}"
+ if $@;
}
croak("@{[ join ', ', @didnt_load ]} are missing and are required for Replication")
use DBIx::Class::Storage::DBI::Replicated::Types qw/BalancerClassNamePart DBICSchema DBICStorageDBI/;
use MooseX::Types::Moose qw/ClassName HashRef Object/;
use Scalar::Util 'reftype';
-use Carp::Clan qw/^DBIx::Class/;
use Hash::Merge 'merge';
use namespace::clean -except => 'meta';
isa=>'DBIx::Class::Storage::DBI::Replicated::Pool',
lazy_build=>1,
handles=>[qw/
- connect_replicants
+ connect_replicants
replicants
has_replicants
/],
select
select_single
columns_info_for
- /],
+ /],
);
=head2 write_handler
is=>'ro',
isa=>Object,
lazy_build=>1,
- handles=>[qw/
+ handles=>[qw/
on_connect_do
- on_disconnect_do
+ on_disconnect_do
connect_info
throw_exception
sql_maker
create_ddl_dir
deployment_statements
datetime_parser
- datetime_parser_type
- build_datetime_parser
+ datetime_parser_type
+ build_datetime_parser
last_insert_id
insert
insert_bulk
sth
deploy
with_deferred_fk_checks
- dbh_do
+ dbh_do
reload_row
- with_deferred_fk_checks
+ with_deferred_fk_checks
_prep_for_execute
- backup
- is_datatype_numeric
- _count_select
- _subq_count_select
- _subq_update_delete
- svp_rollback
- svp_begin
- svp_release
+ backup
+ is_datatype_numeric
+ _count_select
+ _subq_count_select
+ _subq_update_delete
+ svp_rollback
+ svp_begin
+ svp_release
/],
);
);
$self->pool($self->_build_pool)
- if $self->pool;
+ if $self->pool;
}
if (@opts{qw/balancer_type balancer_args/}) {
);
$self->balancer($self->_build_balancer)
- if $self->balancer;
+ if $self->balancer;
}
$self->_master_connect_info_opts(\%opts);
my ($class, $schema, $storage_type_args, @args) = @_;
return {
- schema=>$schema,
- %$storage_type_args,
- @args
+ schema=>$schema,
+ %$storage_type_args,
+ @args
}
}
sub _build_balancer {
my $self = shift @_;
$self->create_balancer(
- pool=>$self->pool,
+ pool=>$self->pool,
master=>$self->master,
%{$self->balancer_args},
);
for my $r (@args) {
$r = [ $r ] unless reftype $r eq 'ARRAY';
- croak "coderef replicant connect_info not supported"
+ $self->throw_exception('coderef replicant connect_info not supported')
if ref $r->[0] && reftype $r->[0] eq 'CODE';
# any connect_info options?
my $i = 0;
$i++ while $i < @$r && (reftype($r->[$i])||'') ne 'HASH';
-# make one if none
+# make one if none
$r->[$i] = {} unless $r->[$i];
# merge if two hashes
my @hashes = @$r[$i .. $#{$r}];
- croak "invalid connect_info options"
+ $self->throw_exception('invalid connect_info options')
if (grep { reftype($_) eq 'HASH' } @hashes) != @hashes;
- croak "too many hashrefs in connect_info"
+ $self->throw_exception('too many hashrefs in connect_info')
if @hashes > 2;
my %opts = %{ merge(reverse @hashes) };
($result[0]) = ($coderef->(@args));
} else {
$coderef->(@args);
- }
+ }
};
##Reset to the original state
- $self->read_handler($current);
+ $self->read_handler($current);
##Exception testing has to come last, otherwise you might leave the
##read_handler set to master.
if(@_) {
foreach my $source ($self->all_storages) {
$source->debug(@_);
- }
+ }
}
return $self->master->debug;
}
if(@_) {
foreach my $source ($self->all_storages) {
$source->debugobj(@_);
- }
+ }
}
return $self->master->debugobj;
}
if(@_) {
foreach my $source ($self->all_storages) {
$source->debugfh(@_);
- }
+ }
}
return $self->master->debugfh;
}
if(@_) {
foreach my $source ($self->all_storages) {
$source->debugcb(@_);
- }
+ }
}
return $self->master->debugcb;
}
my $self = shift;
my $dbh = $self->_get_dbh;
- if (not $self->_placeholders_supported) {
+ if (not $self->_typeless_placeholders_supported) {
bless $self,
'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars';
$self->_rebless;
$dbh->do("set textsize $text_size");
}
+
1;
=head1 NAME
/;
use mro 'c3';
-sub _rebless {
+sub _init {
my $self = shift;
-
$self->disable_sth_caching(1);
}
use strict;
use warnings;
-use base qw/Class::Accessor::Grouped/;
+use base qw/DBIx::Class/;
use IO::File;
__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh silence/);
use lib qw(t/lib);
use DBICTest::ForeignComponent;
-plan tests => 6;
-
# Tests if foreign component was loaded by calling foreign's method
ok( DBICTest::ForeignComponent->foreign_test_method, 'foreign component' );
'inject_base filters duplicates'
);
-# Test for a warning with incorrect order in load_components
-my @warnings = ();
-{
- package A::Test;
- our @ISA = 'DBIx::Class';
- {
- local $SIG{__WARN__} = sub { push @warnings, shift};
- __PACKAGE__->load_components(qw(Core UTF8Columns));
- }
-}
-like( $warnings[0], qr/Core loaded before UTF8Columns/,
- 'warning issued for incorrect order in load_components()' );
-is( scalar @warnings, 1,
- 'only one warning issued for incorrect load_components call' );
-
-# Test that no warning is issued for the correct order in load_components
-{
- @warnings = ();
- package B::Test;
- our @ISA = 'DBIx::Class';
- {
- local $SIG{__WARN__} = sub { push @warnings, shift };
- __PACKAGE__->load_components(qw(UTF8Columns Core));
- }
-}
-is( scalar @warnings, 0,
- 'warning not issued for correct order in load_components()' );
-
use_ok('DBIx::Class::AccessorGroup');
+use_ok('DBIx::Class::Componentised');
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
use DBICTest;
BEGIN {
- require DBIx::Class;
+ require DBIx::Class::Storage::DBI;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class->_sqlt_minimum_version
- if not DBIx::Class->_sqlt_version_ok;
+ 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
+ if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
}
my $schema = DBICTest->init_schema (no_deploy => 1);
plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
unless ($dsn);
- require DBIx::Class;
+ require DBIx::Class::Storage::DBI;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class->_sqlt_minimum_version
- if not DBIx::Class->_sqlt_version_ok;
+ 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
+ if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
}
my $version_table_name = 'dbix_class_schema_versions';
use DBICTest;
BEGIN {
- require DBIx::Class;
+ require DBIx::Class::Storage::DBI;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class->_sqlt_minimum_version
- if not DBIx::Class->_sqlt_version_ok;
+ 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
+ if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
}
my $schema = DBICTest->init_schema();
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Tue Aug 25 12:34:34 2009
+-- Created on Mon Sep 21 00:11:34 2009
--
projects / dbsrgits/DBIx-Class.git / commitdiff