# Although this is needed only if the order_by is not defined, it is
# actually cheaper to just populate this rather than properly examining
# order_by (stuf like [ {} ] and the like)
- $attrs->{_virtual_order_by} = [ $self->result_source->primary_columns ];
-
+ my $prefix = $alias . ($source->schema->storage->_sql_maker_opts->{name_sep} || '.');
+ $attrs->{_virtual_order_by} = [
+ map { $prefix . $_ } ($source->primary_columns)
+ ];
$attrs->{collapse} ||= {};
if ( my $prefetch = delete $attrs->{prefetch} ) {
sub _Top {
my ( $self, $sql, $order, $rows, $offset ) = @_;
+ # mangle the input sql so it can be properly aliased in the outer queries
+ $sql =~ s/^ \s* SELECT \s+ (.+?) \s+ (?=FROM)//ix
+ or croak "Unrecognizable SELECT: $sql";
+ my $select = $1;
+
+ my (@outer_select, %col_index);
+ for my $selected_col (@{$self->{_dbic_rs_attrs}{select}}) {
+
+ my $new_colname;
+
+ if (ref $selected_col) {
+ $new_colname = $self->_quote ('column_' . (@outer_select + 1) );
+ }
+ else {
+ my $quoted_col = $self->_quote ($selected_col);
+
+ my $name_sep = $self->name_sep || '.';
+ $name_sep = "\Q$name_sep\E";
+
+ my ($table, $orig_colname) = ( $selected_col =~ / (?: (.+) $name_sep )? ([^$name_sep]+) $ /x );
+ $new_colname = $self->_quote ("${table}__${orig_colname}");
+
+ $select =~ s/(\Q$quoted_col\E|\Q$selected_col\E)/"$1 AS $new_colname"/e;
+
+ # record qualified name if available (should be)
+ $col_index{$selected_col} = $new_colname if $table;
+
+ # record unqialified name, undef if a duplicate is found
+ if (exists $col_index{$orig_colname}) {
+ $col_index{$orig_colname} = undef;
+ }
+ else {
+ $col_index{$orig_colname} = $new_colname;
+ }
+ }
+
+ push @outer_select, $new_colname;
+ }
+
+ my $outer_select = join (', ', @outer_select );
+
+
+ # deal with order
croak '$order supplied to SQLAHacks limit emulators must be a hash'
if (ref $order ne 'HASH');
$order = { %$order }; #copy
- my $last = $rows + $offset;
+ my $req_order = [ $self->_order_by_chunks ($order->{order_by}) ];
+ my $limit_order = [ @$req_order ? @$req_order : $self->_order_by_chunks ($order->{_virtual_order_by}) ];
- my $req_order = $self->_order_by ($order->{order_by});
- my $limit_order = $req_order ? $order->{order_by} : $order->{_virtual_order_by};
+ # normalize all column names in order by
+ # no copies, just aliasing ($_)
+ for ($req_order, $limit_order) {
+ for ( @{$_ || []} ) {
+ $_ = $col_index{$_} if $col_index{$_};
+ }
+ }
+
+ # generate the rest
delete $order->{$_} for qw/order_by _virtual_order_by/;
my $grpby_having = $self->_order_by ($order);
my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
- $sql =~ s/^\s*(SELECT|select)//;
+ my $last = $rows + $offset;
$sql = <<"SQL";
- SELECT * FROM
- (
- SELECT TOP $rows * FROM
+
+ SELECT TOP $rows $outer_select FROM
(
- SELECT TOP $last $sql $grpby_having $order_by_inner
- ) AS foo
+ SELECT TOP $last $select $sql $grpby_having $order_by_inner
+ ) AS inner_sel
$order_by_outer
- ) AS bar
- $req_order
+SQL
+
+ if (@$req_order) {
+ my $order_by_requested = $self->_order_by ($req_order);
+
+ $sql = <<"SQL";
+ SELECT $outer_select FROM
+ ( $sql ) AS outer_sel
+ $order_by_requested;
SQL
- return $sql;
+
+ }
+
+ return $sql;
}
return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
}
+my $for_syntax = {
+ update => 'FOR UPDATE',
+ shared => 'FOR SHARE',
+};
sub select {
my ($self, $table, $fields, $where, $order, @rest) = @_;
my ($sql, @where_bind) = $self->SUPER::select(
$table, $self->_recurse_fields($fields), $where, $order, @rest
);
- $sql .=
- $self->{for} ?
- (
- $self->{for} eq 'update' ? ' FOR UPDATE' :
- $self->{for} eq 'shared' ? ' FOR SHARE' :
- ''
- ) :
- ''
- ;
+ if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
+ $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
+ }
+
return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
}
use base 'DBIx::Class::Storage';
-use strict;
+use strict;
use warnings;
use Carp::Clan qw/^DBIx::Class/;
use DBI;
=item *
-A single code reference which returns a connected
-L<DBI database handle|DBI/connect> optionally followed by
+A single code reference which returns a connected
+L<DBI database handle|DBI/connect> optionally followed by
L<extra attributes|/DBIx::Class specific connection attributes> recognized
by DBIx::Class:
%extra_attributes,
}];
-This is particularly useful for L<Catalyst> based applications, allowing the
+This is particularly useful for L<Catalyst> based applications, allowing the
following config (L<Config::General> style):
<Model::DB>
set C<AutoCommit> to either I<0> or I<1>. L<DBIx::Class> further
recommends that it be set to I<1>, and that you perform transactions
via our L<DBIx::Class::Schema/txn_do> method. L<DBIx::Class> will set it
-to I<1> if you do not do explicitly set it to zero. This is the default
+to I<1> if you do not do explicitly set it to zero. This is the default
for most DBDs. See L</DBIx::Class and AutoCommit> for details.
=head3 DBIx::Class specific connection attributes
If set to a true value, this option will disable the caching of
statement handles via L<DBI/prepare_cached>.
-=item limit_dialect
+=item limit_dialect
Sets the limit dialect. This is useful for JDBC-bridge among others
where the remote SQL-dialect cannot be determined by the name of the
=item quote_char
-Specifies what characters to use to quote table and column names. If
+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.
C<quote_char> expects either a single character, in which case is it
=item name_sep
-This only needs to be used in conjunction with C<quote_char>, and is used to
-specify the charecter that seperates elements (schemas, tables, columns) from
+This only needs to be used in conjunction with C<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<.>.
The consequences of not supplying this value is that L<SQL::Abstract>
sub _sql_maker_args {
my ($self) = @_;
-
+
return ( bindtype=>'columns', array_datatypes => 1, limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
}
$self->throw_exception ("Your Storage implementation doesn't support savepoints")
unless $self->can('_svp_begin');
-
+
push @{ $self->{savepoints} }, $name;
$self->debugobj->svp_begin($name) if $self->debug;
-
+
return $self->_svp_begin($name);
}
}
$self->debugobj->svp_rollback($name) if $self->debug;
-
+
return $self->_svp_rollback($name);
}
my $sth = $self->sth($sql,$op);
- my $placeholder_index = 1;
+ my $placeholder_index = 1;
foreach my $bound (@$bind) {
my $attributes = {};
}
## Still not quite perfect, and EXPERIMENTAL
-## Currently it is assumed that all values passed will be "normal", i.e. not
+## Currently it is assumed that all values passed will be "normal", i.e. not
## scalar refs, or at least, all the same type as the first set, the statement is
## only prepped once.
sub insert_bulk {
my $table = $source->from;
@colvalues{@$cols} = (0..$#$cols);
my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
-
+
$self->_query_start( $sql, @bind );
my $sth = $self->sth($sql);
my $bind_attributes = $self->source_bind_attributes($source);
## Bind the values and execute
- my $placeholder_index = 1;
+ my $placeholder_index = 1;
foreach my $bound (@bind) {
my $self = shift @_;
my $source = shift @_;
my $bind_attributes = $self->source_bind_attributes($source);
-
+
return $self->_execute('update' => [], $source, $bind_attributes, @_);
}
sub delete {
my $self = shift @_;
my $source = shift @_;
-
+
my $bind_attrs = $self->source_bind_attributes($source);
-
+
return $self->_execute('delete' => [], $source, $bind_attrs, @_);
}
my $self = shift;
# localization is neccessary as
- # 1) there is no infrastructure to pass this around (easy to do, but will wait)
+ # 1) there is no infrastructure to pass this around before SQLA2
# 2) _select_args sets it and _prep_for_execute consumes it
my $sql_maker = $self->sql_maker;
- local $sql_maker->{for};
+ local $sql_maker->{_dbic_rs_attrs};
return $self->_execute($self->_select_args(@_));
}
my $self = shift;
# localization is neccessary as
- # 1) there is no infrastructure to pass this around (easy to do, but will wait)
+ # 1) there is no infrastructure to pass this around before SQLA2
# 2) _select_args sets it and _prep_for_execute consumes it
my $sql_maker = $self->sql_maker;
- local $sql_maker->{for};
+ local $sql_maker->{_dbic_rs_attrs};
# my ($op, $bind, $ident, $bind_attrs, $select, $cond, $order, $rows, $offset)
# = $self->_select_args($ident, $select, $cond, $attrs);
my ($self, $ident, $select, $where, $attrs) = @_;
my $sql_maker = $self->sql_maker;
+ $sql_maker->{_dbic_rs_attrs} = $attrs;
+
my $alias2source = $self->_resolve_ident_sources ($ident);
# calculate bind_attrs before possible $ident mangling
return $alias2source;
}
+# Takes $ident, \@column_names
+#
+# returns { $column_name => \%column_info, ... }
+# also note: this adds -result_source => $rsrc to the column info
+#
+# usage:
+# my $col_sources = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
+sub _resolve_column_info {
+ my ($self, $ident, $colnames) = @_;
+ my $alias2src = $self->_resolve_ident_sources($ident);
+
+ my $sep = $self->_sql_maker_opts->{name_sep} || '.';
+ $sep = "\Q$sep\E";
+
+ my %return;
+ foreach my $col (@{$colnames}) {
+ $col =~ m/^ (?: ([^$sep]+) $sep)? (.+) $/x;
+
+ my $alias = $1 || 'me';
+ my $colname = $2;
+
+ my $rsrc = $alias2src->{$alias};
+ $return{$col} = $rsrc && { %{$rsrc->column_info($colname)}, -result_source => $rsrc };
+ }
+ return \%return;
+}
+
sub count {
my ($self, $source, $attrs) = @_;
sub source_bind_attributes {
my ($self, $source) = @_;
-
+
my $bind_attributes;
foreach my $column ($source->columns) {
-
+
my $data_type = $source->column_info($column)->{data_type} || '';
$bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
if $data_type;
{ add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1 }
-merged with the hash passed in. To disable any of those features, pass in a
+merged with the hash passed in. To disable any of those features, pass in a
hashref like the following
{ ignore_constraint_names => 0, # ... other options }
-Note that this feature is currently EXPERIMENTAL and may not work correctly
+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.
$version ||= $schema_version;
$sqltargs = {
- add_drop_table => 1,
+ add_drop_table => 1,
ignore_constraint_names => 1,
ignore_index_names => 1,
%{$sqltargs || {}}
}
print $file $output;
close($file);
-
+
next unless ($preversion);
require SQL::Translator::Diff;
carp("Overwriting existing diff file - $difffile");
unlink($difffile);
}
-
+
my $source_schema;
{
my $t = SQL::Translator->new($sqltargs);
unless ( $source_schema->name );
}
- # The "new" style of producers have sane normalization and can support
+ # The "new" style of producers have sane normalization and can support
# diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
# And we have to diff parsed SQL against parsed SQL.
my $dest_schema = $sqlt_schema;
$dest_schema->name( $filename )
unless $dest_schema->name;
}
-
+
my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
$dest_schema, $db,
$sqltargs
);
- if(!open $file, ">$difffile") {
+ if(!open $file, ">$difffile") {
$self->throw_exception("Can't write to $difffile ($!)");
next;
}
if(-f $filename)
{
my $file;
- open($file, "<$filename")
+ open($file, "<$filename")
or $self->throw_exception("Can't open $filename ($!)");
my @rows = <$file>;
close($file);
eval qq{use SQL::Translator::Producer::${type}};
$self->throw_exception($@) if $@;
- # sources needs to be a parser arg, but for simplicty allow at top level
+ # sources needs to be a parser arg, but for simplicty allow at top level
# coming in
$sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
if exists $sqltargs->{sources};
sub is_replicating {
return;
-
+
}
=head2 lag_behind_master
--- /dev/null
+package DBIx::Class::Storage::DBI::AmbiguousGlob;\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use base 'DBIx::Class::Storage::DBI';\r
+\r
+=head1 NAME\r
+\r
+DBIx::Class::Storage::DBI::AmbiguousGlob - Storage component for RDBMS supporting multicolumn in clauses\r
+\r
+=head1 DESCRIPTION\r
+\r
+Some servers choke on things like:\r
+\r
+ COUNT(*) FROM (SELECT tab1.col, tab2.col FROM tab1 JOIN tab2 ... )\r
+\r
+claiming that col is a duplicate column (it loses the table specifiers by\r
+the time it gets to the *). Thus for any subquery count we select only the\r
+primary keys of the main table in the inner query. This hopefully still\r
+hits the indexes and keeps the server happy.\r
+\r
+At this point the only overriden method is C<_grouped_count_select()>\r
+\r
+=cut\r
+\r
+sub _grouped_count_select {\r
+ my ($self, $source, $rs_args) = @_;\r
+ my @pcols = map { join '.', $rs_args->{alias}, $_ } ($source->primary_columns);\r
+ return @pcols ? \@pcols : $rs_args->{group_by};\r
+}\r
+\r
+=head1 AUTHORS\r
+\r
+See L<DBIx::Class/CONTRIBUTORS>\r
+\r
+=head1 LICENSE\r
+\r
+You may distribute this code under the same terms as Perl itself.\r
+\r
+=cut\r
+\r
+1;\r
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI/;
+use base qw/DBIx::Class::Storage::DBI::AmbiguousGlob DBIx::Class::Storage::DBI/;
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
unless ( $@ ) {
# Translate the backend name into a perl identifier
$dbtype =~ s/\W/_/gi;
- my $class = "DBIx::Class::Storage::DBI::ODBC::${dbtype}";
- eval "require $class";
- bless $self, $class unless $@;
+ my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}";
+ if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
+ bless $self, $subclass;
+ $self->_rebless;
+ }
}
}
use base qw/DBIx::Class::Storage::DBI::MSSQL/;
+sub insert_bulk {
+ my ($self, $source, $cols, $data) = @_;
+
+ my $identity_insert = 0;
+
+ COLUMNS:
+ foreach my $col (@{$cols}) {
+ if ($source->column_info($col)->{is_auto_increment}) {
+ $identity_insert = 1;
+ last COLUMNS;
+ }
+ }
+
+ my $table = $source->from;
+ if ($identity_insert) {
+ $source->storage->dbh_do(sub {
+ my ($storage, $dbh, @cols) = @_;
+ $dbh->do("SET IDENTITY_INSERT $table ON;");
+ });
+ }
+
+ next::method(@_);
+
+ if ($identity_insert) {
+ $source->storage->dbh_do(sub {
+ my ($storage, $dbh, @cols) = @_;
+ $dbh->do("SET IDENTITY_INSERT $table OFF;");
+ });
+ }
+
+}
+
sub _prep_for_execute {
- my $self = shift;
- my ($op, $extra_bind, $ident, $args) = @_;
+ my $self = shift;
+ my ($op, $extra_bind, $ident, $args) = @_;
+
+ my ($sql, $bind) = $self->next::method (@_);
+ $sql .= ';SELECT SCOPE_IDENTITY()' if $op eq 'insert';
+
+ my %identity_insert_tables;
+ my $col_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
+
+ foreach my $bound (@{$bind}) {
+ my $col = $bound->[0];
+ if ($col_info->{$col}->{is_auto_increment}) {
+ my $table = $col_info->{$col}->{-result_source}->from;
+ $identity_insert_tables{$table} = 1;
+ }
+ }
- my ($sql, $bind) = $self->next::method (@_);
- $sql .= ';SELECT SCOPE_IDENTITY()' if $op eq 'insert';
+ my $identity_insert_on = join '', map { "SET IDENTITY_INSERT $_ ON; " } keys %identity_insert_tables;
+ my $identity_insert_off = join '', map { "SET IDENTITY_INSERT $_ OFF; " } keys %identity_insert_tables;
+ $sql = "$identity_insert_on $sql $identity_insert_off";
- return ($sql, $bind);
+ return ($sql, $bind);
}
sub _execute {
You may distribute this code under the same terms as Perl itself.
=cut
+# vim: sw=2 sts=2
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI::MultiColumnIn/;
+use base qw/DBIx::Class::Storage::DBI::MultiColumnIn DBIx::Class::Storage::DBI::AmbiguousGlob/;
__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MySQL');
$self->dbh->do("ROLLBACK TO SAVEPOINT $name")
}
-
+
sub is_replicating {
my $status = shift->dbh->selectrow_hashref('show slave status');
return ($status->{Slave_IO_Running} eq 'Yes') && ($status->{Slave_SQL_Running} eq 'Yes');
return shift->_per_row_update_delete (@_);
}
-# MySql chokes on things like:
-# COUNT(*) FROM (SELECT tab1.col, tab2.col FROM tab1 JOIN tab2 ... )
-# claiming that col is a duplicate column (it loses the table specifiers by
-# the time it gets to the *). Thus for any subquery count we select only the
-# primary keys of the main table in the inner query. This hopefully still
-# hits the indexes and keeps mysql happy.
-# (mysql does not care if the SELECT and the GROUP BY match)
-sub _grouped_count_select {
- my ($self, $source, $rs_args) = @_;
- my @pcols = map { join '.', $rs_args->{alias}, $_ } ($source->primary_columns);
- return @pcols ? \@pcols : $rs_args->{group_by};
-}
-
1;
=head1 NAME
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test'
unless ($dsn && $user);
-plan tests => 13;
+plan tests => 19;
my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1});
is( $it->next->name, "Artist 2", "iterator->next ok" );
is( $it->next, undef, "next past end of resultset ok" );
+$schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE Owners") };
+ eval { $dbh->do("DROP TABLE Books") };
+ $dbh->do(<<'SQL');
+
+
+CREATE TABLE Books (
+ id INT IDENTITY (1, 1) NOT NULL,
+ source VARCHAR(100),
+ owner INT,
+ title VARCHAR(10),
+ price INT NULL
+)
+
+CREATE TABLE Owners (
+ id INT IDENTITY (1, 1) NOT NULL,
+ [name] VARCHAR(100),
+)
+
+SQL
+
+});
+$schema->populate ('Owners', [
+ [qw/id name /],
+ [qw/1 wiggle/],
+ [qw/2 woggle/],
+ [qw/3 boggle/],
+ [qw/4 fREW/],
+ [qw/5 fRIOUX/],
+ [qw/6 fROOH/],
+ [qw/7 fRUE/],
+ [qw/8 fISMBoC/],
+ [qw/9 station/],
+ [qw/10 mirror/],
+ [qw/11 dimly/],
+ [qw/12 face_to_face/],
+ [qw/13 icarus/],
+ [qw/14 dream/],
+ [qw/15 dyrstyggyr/],
+]);
+
+$schema->populate ('BooksInLibrary', [
+ [qw/source owner title /],
+ [qw/Library 1 secrets1/],
+ [qw/Eatery 1 secrets2/],
+ [qw/Library 2 secrets3/],
+ [qw/Library 3 secrets4/],
+ [qw/Eatery 3 secrets5/],
+ [qw/Library 4 secrets6/],
+ [qw/Library 5 secrets7/],
+ [qw/Eatery 5 secrets8/],
+ [qw/Library 6 secrets9/],
+ [qw/Library 7 secrets10/],
+ [qw/Eatery 7 secrets11/],
+ [qw/Library 8 secrets12/],
+]);
+
+#
+# try a distinct + prefetch on tables with identically named columns
+#
+
+{
+ # try a ->has_many direction (due to a 'multi' accessor the select/group_by group is collapsed)
+ my $owners = $schema->resultset ('Owners')->search ({
+ 'books.id' => { '!=', undef }
+ }, {
+ prefetch => 'books',
+ distinct => 1,
+ order_by => 'name',
+ page => 2,
+ rows => 5,
+ });
+
+ is ($owners->all, 3, 'Prefetched grouped search returns correct number of rows');
+ is ($owners->count, 3, 'Prefetched grouped search returns correct count');
+
+ # try a ->belongs_to direction (no select collapse)
+ my $books = $schema->resultset ('BooksInLibrary')->search ({
+ 'owner.name' => 'wiggle'
+ }, {
+ prefetch => 'owner',
+ distinct => 1,
+ order_by => 'name',
+ rows => 5,
+ });
+
+
+ is ($books->page(1)->all, 1, 'Prefetched grouped search returns correct number of rows');
+ is ($books->page(1)->count, 1, 'Prefetched grouped search returns correct count');
+
+ is ($books->page(2)->all, 0, 'Prefetched grouped search returns correct number of rows');
+ is ($books->page(2)->count, 0, 'Prefetched grouped search returns correct count');
+
+}
# clean up our mess
END {
my $dbh = eval { $schema->storage->_dbh };
$dbh->do('DROP TABLE artist') if $dbh;
}
-
+# vim:sw=2 sts=2
projects / dbsrgits/DBIx-Class.git / commitdiff