From: Brendan Byrd Date: Thu, 14 Mar 2013 23:20:13 +0000 (-0400) Subject: Add support for SQL::Statement-based DBDs X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ac50f57b1472b19cfcbd000c61e87d566c9f6f20;p=dbsrgits%2FDBIx-Class.git Add support for SQL::Statement-based DBDs --- diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 6af4221..ac26ed2 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -104,6 +104,33 @@ my $rdbms_firebird_interbase = { my $rdbms_firebird_odbc = { 'DBD::ODBC' => '0', }; +my $rdbms_ss_csv = { + 'DBD::CSV' => '0', + 'SQL::Statement' => '1.33', +}; +my $rdbms_ss_dbm = { + 'DBD::DBM' => '0', + 'MLDBM' => '0', + 'SQL::Statement' => '1.33', +}; +my $rdbms_ss_po = { + 'DBD::PO' => '0', + 'SQL::Statement' => '1.33', +}; +my $rdbms_ss_sys = { + 'DBD::Sys' => '0', + 'SQL::Statement' => '1.33', +}; +my $rdbms_ss_anydata = { + ### XXX: DBD::AnyData 0.110 and DBI 1.623 conflict! ### + 'DBD::AnyData' => '0', + 'SQL::Statement' => '1.33', +}; +my $rdbms_ss_treedata = { + ### XXX: DBD::AnyData 0.110 and DBI 1.623 conflict! ### + 'DBD::TreeData' => '0', + 'SQL::Statement' => '1.33', +}; my $reqs = { replicated => { @@ -436,6 +463,66 @@ my $reqs = { }, }, + rdbms_ss_csv => { + req => { + %$rdbms_ss_csv, + }, + pod => { + title => 'CSV support via DBD::CSV', + desc => 'Modules required to connect to CSV files via DBD::CSV', + }, + }, + + rdbms_ss_dbm => { + req => { + %$rdbms_ss_dbm, + }, + pod => { + title => 'ML/DBM support via DBD::DBM', + desc => 'Modules required to connect to DBM & MLDBM files via DBD::DBM', + }, + }, + + rdbms_ss_po => { + req => { + %$rdbms_ss_po, + }, + pod => { + title => 'PO support via DBD::PO', + desc => 'Modules required to connect to PO files via DBD::PO', + }, + }, + + rdbms_ss_sys => { + req => { + %$rdbms_ss_sys, + }, + pod => { + title => 'System tables interface support via DBD::Sys', + desc => 'Modules required to connect to system tables via DBD::Sys', + }, + }, + + rdbms_ss_anydata => { + req => { + %$rdbms_ss_anydata, + }, + pod => { + title => 'Abstract flat data support via DBD::AnyData', + desc => 'Modules required to connect to abstract flat data via DBD::AnyData', + }, + }, + + rdbms_ss_treedata => { + req => { + %$rdbms_ss_treedata, + }, + pod => { + title => 'Abstract tree data support via DBD::TreeData', + desc => 'Modules required to connect to abstract tree data via DBD::TreeData', + }, + }, + # the order does matter because the rdbms support group might require # a different version that the test group test_rdbms_pg => { @@ -600,6 +687,54 @@ my $reqs = { }, }, + test_rdbms_ss_csv => { + req => { + %$rdbms_ss_csv, + }, + }, + + test_rdbms_ss_dbm => { + req => { + %$rdbms_ss_dbm, + }, + }, + + test_rdbms_ss_po => { + req => { + $ENV{DBICTEST_DBD_PO} + ? ( + %$rdbms_ss_po, + ) : () + }, + }, + + test_rdbms_ss_sys => { + req => { + $ENV{DBICTEST_DBD_SYS} + ? ( + %$rdbms_ss_sys, + ) : () + }, + }, + + test_rdbms_ss_anydata => { + req => { + $ENV{DBICTEST_DBD_ANYDATA} + ? ( + %$rdbms_ss_anydata, + ) : () + }, + }, + + test_rdbms_ss_treedata => { + req => { + $ENV{DBICTEST_DBD_TREEDATA} + ? ( + %$rdbms_ss_treedata, + ) : () + }, + }, + test_memcached => { req => { $ENV{DBICTEST_MEMCACHED} diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index 7639988..ca968ee 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -63,7 +63,7 @@ sub _LimitOffset { SELECT ... LIMIT $offset $limit -Supported by B and any L based DBD +Supported by B =cut sub _LimitXY { @@ -79,6 +79,22 @@ sub _LimitXY { return $sql; } +=head2 LimitXY_NoBinds + + SELECT ... LIMIT $offset $limit + +Supported by any L based DBD. (Implemented without +bindvals, since L doesn't like them in C.) + +=cut +sub _LimitXY_NoBinds { + my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_; + $sql .= $self->_parse_rs_attrs( $rs_attrs ) . " LIMIT "; + $sql .= "$offset, " if +$offset; + $sql .= $rows; + return $sql; +} + =head2 RowNumberOver SELECT * FROM ( diff --git a/lib/DBIx/Class/SQLMaker/SQLStatement.pm b/lib/DBIx/Class/SQLMaker/SQLStatement.pm new file mode 100644 index 0000000..a3add76 --- /dev/null +++ b/lib/DBIx/Class/SQLMaker/SQLStatement.pm @@ -0,0 +1,123 @@ +package # Hide from PAUSE + DBIx::Class::SQLMaker::SQLStatement; + +use parent 'DBIx::Class::SQLMaker'; + +# SQL::Statement does not understand +# INSERT INTO $table DEFAULT VALUES +# Adjust SQL here instead +sub insert { # basically just a copy of the MySQL version... + my $self = shift; + + if (! $_[1] or (ref $_[1] eq 'HASH' and !keys %{$_[1]} ) ) { + my $table = $self->_quote($_[0]); + return "INSERT INTO ${table} (1) VALUES (1)" + } + + return $self->next::method (@_); +} + +# SQL::Statement does not understand +# SELECT ... FOR UPDATE +# Disable it here +sub _lock_select () { '' }; + +1; + +# SQL::Statement can't handle more than +# one ANSI join, so just convert them all +# to Oracle 8i-style WHERE-clause joins + +# (As such, we are stealing globs of code from OracleJoins.pm...) + +sub select { + my ($self, $table, $fields, $where, $rs_attrs, @rest) = @_; + + if (ref $table eq 'ARRAY') { + # count tables accurately + my ($cnt, @node) = (0, @$table); + while (my $tbl = shift @node) { + my $r = ref $tbl; + if ($r eq 'ARRAY') { push(@node, @$tbl); } + elsif ($r eq 'HASH') { $cnt++ if ($tbl->{'-rsrc'}); } + } + + # pull out all join conds as regular WHEREs from all extra tables + # (but only if we're joining more than 2 tables) + if ($cnt > 2) { + $where = $self->_where_joins($where, @{ $table }[ 1 .. $#$table ]); + } + } + + return $self->next::method($table, $fields, $where, $rs_attrs, @rest); +} + +sub _recurse_from { + my ($self, $from, @join) = @_; + + # check for a single JOIN + unless (@join > 1) { + my $sql = $self->next::method($from, @join); + + # S:S still doesn't like the JOIN X ON ( Y ) syntax with the parens + $sql =~ s/JOIN (.+) ON \( (.+) \)/JOIN $1 ON $2/; + return $sql; + } + + my @sqlf = $self->_from_chunk_to_sql($from); + + for (@join) { + my ($to, $on) = @$_; + + push (@sqlf, (ref $to eq 'ARRAY') ? + $self->_recurse_from(@$to) : + $self->_from_chunk_to_sql($to) + ); + } + + return join q{, }, @sqlf; +} + +sub _where_joins { + my ($self, $where, @join) = @_; + my $join_where = $self->_recurse_where_joins(@join); + + if (keys %$join_where) { + unless (defined $where) { $where = $join_where; } + else { + $where = { -or => $where } if (ref $where eq 'ARRAY'); + $where = { -and => [ $join_where, $where ] }; + } + } + return $where; +} + +sub _recurse_where_joins { + my $self = shift; + + my @where; + foreach my $j (@_) { + my ($to, $on) = @$j; + + push @where, $self->_recurse_where_joins(@$to) if (ref $to eq 'ARRAY'); + + my $join_opts = ref $to eq 'ARRAY' ? $to->[0] : $to; + if (ref $join_opts eq 'HASH' and my $jt = $join_opts->{-join_type}) { + # TODO: Figure out a weird way to support ANSI joins and WHERE joins at the same time. + # (Though, time would be better spent just fixing SQL::Parser to not require this stuff.) + + $self->throw_exception("Can't handle non-inner, non-ANSI joins in SQL::Statement SQL yet!\n") + if $jt =~ /NATURAL|LEFT|RIGHT|FULL|CROSS|UNION/i; + } + + # sadly SQLA treats where($scalar) as literal, so we need to jump some hoops + push @where, map { \sprintf ('%s = %s', + ref $_ ? $self->_recurse_where($_) : $self->_quote($_), + ref $on->{$_} ? $self->_recurse_where($on->{$_}) : $self->_quote($on->{$_}), + ) } keys %$on; + } + + return { -and => \@where }; +} + +1; diff --git a/lib/DBIx/Class/Storage/DBI/AnyData.pm b/lib/DBIx/Class/Storage/DBI/AnyData.pm new file mode 100644 index 0000000..d1993d2 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/AnyData.pm @@ -0,0 +1,31 @@ +package DBIx::Class::Storage::DBI::AnyData; + +use base 'DBIx::Class::Storage::DBI::SQL::Statement'; +use mro 'c3'; +use namespace::clean; + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::AnyData - Support for freeform data via DBD::AnyData + +=head1 SYNOPSIS + +This subclass supports freeform data tables via L. + +=head1 DESCRIPTION + +This subclass is essentially just a stub that uses the super class +L. Patches welcome if +anything specific to this driver is required. + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/DBIx/Class/Storage/DBI/CSV.pm b/lib/DBIx/Class/Storage/DBI/CSV.pm new file mode 100644 index 0000000..432b8b8 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/CSV.pm @@ -0,0 +1,31 @@ +package DBIx::Class::Storage::DBI::CSV; + +use base 'DBIx::Class::Storage::DBI::SQL::Statement'; +use mro 'c3'; +use namespace::clean; + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::SNMP - Support for CSV files via DBD::CSV + +=head1 SYNOPSIS + +This subclass supports CSV files via L. + +=head1 DESCRIPTION + +This subclass is essentially just a stub that uses the super class +L. Patches welcome if +anything specific to this driver is required. + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/DBIx/Class/Storage/DBI/DBM.pm b/lib/DBIx/Class/Storage/DBI/DBM.pm new file mode 100644 index 0000000..26eb290 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/DBM.pm @@ -0,0 +1,69 @@ +package DBIx::Class::Storage::DBI::DBM; + +use base 'DBIx::Class::Storage::DBI::SQL::Statement'; +use mro 'c3'; +use namespace::clean; + +sub insert { + my ($self, $source, $to_insert) = @_; + + my $col_infos = $source->columns_info; + + foreach my $col (keys %$col_infos) { + # this will naturally fall into undef/NULL if default_value doesn't exist + $to_insert->{$col} = $col_infos->{$col}{default_value} + unless (exists $to_insert->{$col}); + } + + $self->next::method($source, $to_insert); +} + +sub insert_bulk { + my ($self, $source, $cols, $data) = @_; + + my $col_infos = $source->columns_info; + + foreach my $col (keys %$col_infos) { + unless (grep { $_ eq $col } @$cols) { + push @$cols, $col; + for my $r (0 .. $#$data) { + # this will naturally fall into undef/NULL if default_value doesn't exist + $data->[$r][$#$cols] = $col_infos->{$col}{default_value}; + } + } + } + + $self->next::method($source, $cols, $data); +} + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::SNMP - Support for DBM & MLDBM files via DBD::DBM + +=head1 SYNOPSIS + +This subclass supports DBM & MLDBM files via L. + +=head1 DESCRIPTION + +This subclass is essentially just a stub that uses the super class +L. + +=head1 IMPLEMENTATION NOTES + +=head2 Missing fields on INSERTs + +L will balk at missing columns on INSERTs. This storage engine will +add them in with either the default_value attribute or NULL. + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/DBIx/Class/Storage/DBI/PO.pm b/lib/DBIx/Class/Storage/DBI/PO.pm new file mode 100644 index 0000000..f728117 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/PO.pm @@ -0,0 +1,31 @@ +package DBIx::Class::Storage::DBI::PO; + +use base 'DBIx::Class::Storage::DBI::SQL::Statement'; +use mro 'c3'; +use namespace::clean; + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::SNMP - Support for GNU gettext PO files via DBD::PO + +=head1 SYNOPSIS + +This subclass supports GNU gettext PO files via L. + +=head1 DESCRIPTION + +This subclass is essentially just a stub that uses the super class +L. Patches welcome if +anything specific to this driver is required. + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/DBIx/Class/Storage/DBI/SNMP.pm b/lib/DBIx/Class/Storage/DBI/SNMP.pm new file mode 100644 index 0000000..a6a3cc2 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/SNMP.pm @@ -0,0 +1,31 @@ +package DBIx::Class::Storage::DBI::SNMP; + +use base 'DBIx::Class::Storage::DBI::SQL::Statement'; +use mro 'c3'; +use namespace::clean; + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::SNMP - Support for SNMP data via DBD::SNMP + +=head1 SYNOPSIS + +This subclass supports SNMP data via L. + +=head1 DESCRIPTION + +This subclass is essentially just a stub that uses the super class +L. Patches welcome if +anything specific to this driver is required. + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/DBIx/Class/Storage/DBI/SQL/Statement.pm b/lib/DBIx/Class/Storage/DBI/SQL/Statement.pm new file mode 100644 index 0000000..972a23c --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/SQL/Statement.pm @@ -0,0 +1,92 @@ +package DBIx::Class::Storage::DBI::SQL::Statement; + +use strict; +use base 'DBIx::Class::Storage::DBI'; +use mro 'c3'; +use namespace::clean; + +__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::SQLStatement'); +__PACKAGE__->sql_quote_char('"'); +__PACKAGE__->sql_limit_dialect('LimitXY_NoBinds'); + +# Unsupported options +sub _determine_supports_insert_returning { 0 }; + +# Statement caching currently buggy with either S:S or DBD::AnyData (and/or possibly others) +# Disable it here and look into fixing it later on +sub _init { + my $self = shift; + $self->next::method(@_); + $self->disable_sth_caching(1); +} + +# No support for transactions; sorry... +sub txn_begin { + my $self = shift; + + # Only certain internal calls are allowed through, and even then, we are merely + # ignoring the txn part + my $callers = join "\n", map { (caller($_))[3] } (1 .. 4); + return $self->_get_dbh + if ($callers =~ / + DBIx::Class::Storage::DBI::insert_bulk| + DBIx::Class::Relationship::CascadeActions::update + /x); + + $self->throw_exception('SQL::Statement-based drivers do not support transactions!'); +} +sub svp_begin { shift->throw_exception('SQL::Statement-based drivers do not support savepoints!'); } + +# Nor is there any last_insert_id support (unless the driver supports it directly) +sub _dbh_last_insert_id { shift->throw_exception('SQL::Statement-based drivers do not support AUTOINCREMENT keys! You will need to specify the PKs directly.'); } + +# leftovers to support txn_begin exceptions +sub txn_commit { 1; } + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::SQL::Statement - Base Class for SQL::Statement- / DBI::DBD::SqlEngine-based +DBD support in DBIx::Class + +=head1 SYNOPSIS + +This is the base class for DBDs that use L and/or +L. This class is +used for: + +=over +=item L +=item L +=item L +=item L +=item L +=item L +=item L +=back + +=head1 IMPLEMENTATION NOTES + +=head2 Transactions + +These drivers do not support transactions (and in fact, even the SQL syntax for +them). Therefore, any attempts to use txn_* or svp_* methods will throw an +exception. + +In a future release, they may be replaced with emulated functionality. (Then +again, it would probably be added into L instead.) + +=head2 SELECT ... FOR UPDATE/SHARE + +This also is not supported, but it will silently ignore these. + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/DBIx/Class/Storage/DBI/Sys.pm b/lib/DBIx/Class/Storage/DBI/Sys.pm new file mode 100644 index 0000000..26690ef --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/Sys.pm @@ -0,0 +1,31 @@ +package DBIx::Class::Storage::DBI::Sys; + +use base 'DBIx::Class::Storage::DBI::SQL::Statement'; +use mro 'c3'; +use namespace::clean; + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::Sys - Support for system data via DBD::Sys + +=head1 SYNOPSIS + +This subclass supports system data information via L. + +=head1 DESCRIPTION + +This subclass is essentially just a stub that uses the super class +L. Patches welcome if +anything specific to this driver is required. + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/DBIx/Class/Storage/DBI/TreeData.pm b/lib/DBIx/Class/Storage/DBI/TreeData.pm new file mode 100644 index 0000000..639ca91 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/TreeData.pm @@ -0,0 +1,31 @@ +package DBIx::Class::Storage::DBI::TreeData; + +use base 'DBIx::Class::Storage::DBI::SQL::Statement'; +use mro 'c3'; +use namespace::clean; + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::TreeData - Support for JSON-like tree data via DBD::TreeData + +=head1 SYNOPSIS + +This subclass supports JSON-like tree tables via L. + +=head1 DESCRIPTION + +This subclass is essentially just a stub that uses the super class +L. Patches welcome if +anything specific to this driver is required. + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/t/86ss_csv.t b/t/86ss_csv.t new file mode 100644 index 0000000..99d2605 --- /dev/null +++ b/t/86ss_csv.t @@ -0,0 +1,250 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use lib qw(t/lib); +use DBICTest; +use DBIC::SqlMakerTest; +use DBIx::Class::Optional::Dependencies (); + +use Path::Class; + +plan skip_all => + 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_ss_csv') + unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_ss_csv'); + +my $db_dir = dir(qw/t var/, "ss_csv-$$"); +$db_dir->mkpath unless -d $db_dir; + +my ($dsn, $opts) = ('dbi:CSV:', { + f_schema => undef, + f_dir => "$db_dir", + f_ext => ".csv/r", + f_lock => 0, + f_encoding => "utf8", + + csv_null => 1, + csv_eol => "\n", +}); + +my $schema = DBICTest::Schema->connect($dsn, '', '', $opts); +is ($schema->storage->sqlt_type, 'CSV', 'sqlt_type correct pre-connection'); +isa_ok($schema->storage->sql_maker, 'DBIx::Class::SQLMaker::SQLStatement'); + +# Custom deployment +my $dbh = $schema->storage->dbh; +my @cmds = split /\s*\;\s*/, scalar file(qw/t lib test_deploy DBICTest-Schema-1.x-SQL-Statement.sql/)->slurp; +$dbh->do($_) for @cmds; + +### S:S doesn't have any sort of AUTOINCREMENT support, so IDs will have to be generated by hand ### + +# test primary key handling +my $new = $schema->resultset('Artist')->create({ + artistid => 1, + name => 'foo' +}); +ok($new->artistid, "Create worked"); + +# test LIMIT support +for (1..6) { + $schema->resultset('Artist')->create({ + artistid => $_+1, + name => 'Artist '.$_, + }); +} +my $it = $schema->resultset('Artist')->search( {}, { + rows => 3, + offset => 2, + order_by => 'artistid' +}); +is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists +is( $it->next->name, "Artist 2", "iterator->next ok" ); +$it->next; +$it->next; +is( $it->next, undef, "next past end of resultset ok" ); + +# Limit with select-lock (which is silently thrown away) +lives_ok { + isa_ok ( + $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}), + 'DBICTest::Schema::Artist', + ); +} 'Limited FOR UPDATE select works'; + +# shared-lock (which is silently thrown away) +lives_ok { + isa_ok ( + $schema->resultset('Artist')->find({artistid => 1}, {for => 'shared'}), + 'DBICTest::Schema::Artist', + ); +} 'LOCK IN SHARE MODE select works'; + +# (everything seems to be a VARCHAR with S:S) +my $test_type_info = { + 'artistid' => { + 'data_type' => 'VARCHAR', + 'is_nullable' => 0, + 'size' => 0, + }, + 'name' => { + 'data_type' => 'VARCHAR', + 'is_nullable' => 1, + 'size' => 100, + }, + 'rank' => { + 'data_type' => 'VARCHAR', + 'is_nullable' => 0, + 'size' => 0, + }, + 'charfield' => { + 'data_type' => 'VARCHAR', + 'is_nullable' => 1, + 'size' => 10, + }, +}; + +$schema->populate ('Owners', [ + [qw/id name /], + [qw/1 wiggle/], + [qw/2 woggle/], + [qw/3 boggle/], +]); + +$schema->populate ('BooksInLibrary', [ + [qw/id source owner title /], + [qw/1 Library 1 secrets1/], + [qw/2 Eatery 1 secrets2/], + [qw/3 Library 2 secrets3/], +]); + +{ + # 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', cache => 1 } + ); + is($owners->all, 2, 'Prefetched grouped search returns correct number of rows'); + + # only works here because of the full cache + # S:S would croak on a subselect otherwise + is($owners->count, 2, '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 } + ); + + { + local $TODO = 'populate does not subtract the non-Library INSERTs here...'; + is($owners->all, 1, 'Prefetched grouped search returns correct number of rows'); + is($owners->count, 1, 'Prefetched grouped search returns correct count'); + } +} + +my $type_info = $schema->storage->columns_info_for('artist'); +is_deeply($type_info, $test_type_info, 'columns_info_for - column data types'); + +my $cd = $schema->resultset('CD')->create({ cdid => 1 }); +my $producer = $schema->resultset('Producer')->create({ producerid => 1 }); +lives_ok { $cd->set_producers ([ $producer ]) } 'set_relationship doesnt die'; + +{ + my $artist = $schema->resultset('Artist')->next; + my $cd = $schema->resultset('CD')->next; + $cd->set_from_related('artist', $artist); + $cd->update; + + my $rs = $schema->resultset('CD')->search ({}, { prefetch => 'artist' }); + + lives_ok sub { + my $cd = $rs->next; + is ($cd->artist->name, $artist->name, 'Prefetched artist'); + }, 'join does not throw'; + + local $schema->storage->sql_maker->{_default_jointype} = 'inner'; + is_same_sql_bind ( + $rs->as_query, + '( + SELECT + me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, + artist.artistid, artist.name, artist.rank, artist.charfield + FROM cd me + INNER JOIN artist artist ON artist.artistid = me.artist + )', + [], + 'overriden default join type works', + ); +} + +{ + # Test support for straight joins + my $cdsrc = $schema->source('CD'); + my $artrel_info = $cdsrc->relationship_info ('artist'); + $cdsrc->add_relationship( + 'straight_artist', + $artrel_info->{class}, + $artrel_info->{cond}, + { %{$artrel_info->{attrs}}, join_type => 'straight' }, + ); + is_same_sql_bind ( + $cdsrc->resultset->search({}, { prefetch => 'straight_artist' })->as_query, + '( + SELECT + me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, + straight_artist.artistid, straight_artist.name, straight_artist.rank, straight_artist.charfield + FROM cd me + STRAIGHT JOIN artist straight_artist ON straight_artist.artistid = me.artist + )', + [], + 'straight joins correctly supported' + ); +} + +# Can we properly deal with the null search problem? +{ + $schema->resultset('Artist')->create({ artistid => 2222, name => 'last created artist' }); + + ok my $artist1_rs = $schema->resultset('Artist')->search({artistid=>6666}) + => 'Created an artist resultset of 6666'; + + is $artist1_rs->count, 0 + => 'Got no returned rows'; + + ok my $artist2_rs = $schema->resultset('Artist')->search({artistid=>undef}) + => 'Created an artist resultset of undef'; + + is $artist2_rs->count, 0 + => 'got no rows'; + + my $artist = $artist2_rs->single; + + is $artist => undef + => 'Nothing Found!'; +} + +{ + my $cds_per_year = { + 2001 => 2, + 2002 => 1, + 2005 => 3, + }; + + # kill the scalar ref here + $schema->source('CD')->name('cd'); + + my $rs = $schema->resultset('CD'); + $rs->delete; + my $cdid = 1; + foreach my $y (keys %$cds_per_year) { + foreach my $c (1 .. $cds_per_year->{$y} ) { + $rs->create({ cdid => $cdid++, title => "CD $y-$c", artist => 1, year => "$y-01-01" }); + } + } + + is ($rs->count, 6, 'CDs created successfully'); +} + +done_testing; diff --git a/t/86ss_dbm.t b/t/86ss_dbm.t new file mode 100644 index 0000000..1b22033 --- /dev/null +++ b/t/86ss_dbm.t @@ -0,0 +1,248 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use lib qw(t/lib); +use DBICTest; +use DBIC::SqlMakerTest; +use DBIx::Class::Optional::Dependencies (); + +use Path::Class; + +plan skip_all => + 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_ss_dbm') + unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_ss_dbm'); + +my $db_dir = dir(qw/t var/, "ss_dbm-$$"); +$db_dir->mkpath unless -d $db_dir; + +my ($dsn, $opts) = ('dbi:DBM:', { + f_dir => "$db_dir", + f_lockfile => '.lock', + + dbm_type => 'BerkeleyDB', + dbm_mldbm => 'Storable', + dbm_store_metadata => 1, +}); + +my $schema = DBICTest::Schema->connect($dsn, '', '', $opts); +is ($schema->storage->sqlt_type, 'DBM', 'sqlt_type correct pre-connection'); +isa_ok($schema->storage->sql_maker, 'DBIx::Class::SQLMaker::SQLStatement'); + +# Custom deployment +my $dbh = $schema->storage->dbh; +my @cmds = split /\s*\;\s*/, scalar file(qw/t lib test_deploy DBICTest-Schema-1.x-SQL-Statement.sql/)->slurp; +$dbh->do($_) for @cmds; + +### S:S doesn't have any sort of AUTOINCREMENT support, so IDs will have to be generated by hand ### + +# test primary key handling +my $new = $schema->resultset('Artist')->create({ + artistid => 1, + name => 'foo' +}); +ok($new->artistid, "Create worked"); + +# test LIMIT support +for (1..6) { + $schema->resultset('Artist')->create({ + artistid => $_+1, + name => 'Artist '.$_, + }); +} +my $it = $schema->resultset('Artist')->search( {}, { + rows => 3, + offset => 2, + order_by => 'artistid' +}); +is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists +is( $it->next->name, "Artist 2", "iterator->next ok" ); +$it->next; +$it->next; +is( $it->next, undef, "next past end of resultset ok" ); + +# Limit with select-lock (which is silently thrown away) +lives_ok { + isa_ok ( + $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}), + 'DBICTest::Schema::Artist', + ); +} 'Limited FOR UPDATE select works'; + +# shared-lock (which is silently thrown away) +lives_ok { + isa_ok ( + $schema->resultset('Artist')->find({artistid => 1}, {for => 'shared'}), + 'DBICTest::Schema::Artist', + ); +} 'LOCK IN SHARE MODE select works'; + +# (No nullables with DBD::DBM) +my $test_type_info = { + 'artistid' => { + 'data_type' => 'VARCHAR', + 'is_nullable' => 0, + 'size' => 0, + }, + 'name' => { + 'data_type' => 'VARCHAR', + 'is_nullable' => 0, + 'size' => 100, + }, + 'rank' => { + 'data_type' => 'VARCHAR', + 'is_nullable' => 0, + 'size' => 0, + }, + 'charfield' => { + 'data_type' => 'VARCHAR', + 'is_nullable' => 0, + 'size' => 10, + }, +}; + +$schema->populate ('Owners', [ + [qw/id name /], + [qw/1 wiggle/], + [qw/2 woggle/], + [qw/3 boggle/], +]); + +$schema->populate ('BooksInLibrary', [ + [qw/id source owner title /], + [qw/1 Library 1 secrets1/], + [qw/2 Eatery 1 secrets2/], + [qw/3 Library 2 secrets3/], +]); + +{ + # 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', cache => 1 } + ); + is($owners->all, 2, 'Prefetched grouped search returns correct number of rows'); + + # only works here because of the full cache + # S:S would croak on a subselect otherwise + is($owners->count, 2, '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 } + ); + + { + local $TODO = 'populate does not subtract the non-Library INSERTs here...'; + is($owners->all, 1, 'Prefetched grouped search returns correct number of rows'); + is($owners->count, 1, 'Prefetched grouped search returns correct count'); + } +} + +my $type_info = $schema->storage->columns_info_for('artist'); +is_deeply($type_info, $test_type_info, 'columns_info_for - column data types'); + +my $cd = $schema->resultset('CD')->create({ cdid => 1 }); +my $producer = $schema->resultset('Producer')->create({ producerid => 1 }); +lives_ok { $cd->set_producers ([ $producer ]) } 'set_relationship doesnt die'; + +{ + my $artist = $schema->resultset('Artist')->next; + my $cd = $schema->resultset('CD')->next; + $cd->set_from_related('artist', $artist); + $cd->update; + + my $rs = $schema->resultset('CD')->search ({}, { prefetch => 'artist' }); + + lives_ok sub { + my $cd = $rs->next; + is ($cd->artist->name, $artist->name, 'Prefetched artist'); + }, 'join does not throw'; + + local $schema->storage->sql_maker->{_default_jointype} = 'inner'; + is_same_sql_bind ( + $rs->as_query, + '( + SELECT + me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, + artist.artistid, artist.name, artist.rank, artist.charfield + FROM cd me + INNER JOIN artist artist ON artist.artistid = me.artist + )', + [], + 'overriden default join type works', + ); +} + +{ + # Test support for straight joins + my $cdsrc = $schema->source('CD'); + my $artrel_info = $cdsrc->relationship_info ('artist'); + $cdsrc->add_relationship( + 'straight_artist', + $artrel_info->{class}, + $artrel_info->{cond}, + { %{$artrel_info->{attrs}}, join_type => 'straight' }, + ); + is_same_sql_bind ( + $cdsrc->resultset->search({}, { prefetch => 'straight_artist' })->as_query, + '( + SELECT + me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, + straight_artist.artistid, straight_artist.name, straight_artist.rank, straight_artist.charfield + FROM cd me + STRAIGHT JOIN artist straight_artist ON straight_artist.artistid = me.artist + )', + [], + 'straight joins correctly supported' + ); +} + +# Can we properly deal with the null search problem? +{ + $schema->resultset('Artist')->create({ artistid => 2222, name => 'last created artist' }); + + ok my $artist1_rs = $schema->resultset('Artist')->search({artistid=>6666}) + => 'Created an artist resultset of 6666'; + + is $artist1_rs->count, 0 + => 'Got no returned rows'; + + ok my $artist2_rs = $schema->resultset('Artist')->search({artistid=>undef}) + => 'Created an artist resultset of undef'; + + is $artist2_rs->count, 0 + => 'got no rows'; + + my $artist = $artist2_rs->single; + + is $artist => undef + => 'Nothing Found!'; +} + +{ + my $cds_per_year = { + 2001 => 2, + 2002 => 1, + 2005 => 3, + }; + + # kill the scalar ref here + $schema->source('CD')->name('cd'); + + my $rs = $schema->resultset('CD'); + $rs->delete; + my $cdid = 1; + foreach my $y (keys %$cds_per_year) { + foreach my $c (1 .. $cds_per_year->{$y} ) { + $rs->create({ cdid => $cdid++, title => "CD $y-$c", artist => 1, year => "$y-01-01" }); + } + } + + is ($rs->count, 6, 'CDs created successfully'); +} + +done_testing; diff --git a/t/lib/test_deploy/DBICTest-Schema-1.x-SQL-Statement.sql b/t/lib/test_deploy/DBICTest-Schema-1.x-SQL-Statement.sql new file mode 100644 index 0000000..ef1c017 --- /dev/null +++ b/t/lib/test_deploy/DBICTest-Schema-1.x-SQL-Statement.sql @@ -0,0 +1,232 @@ +CREATE TABLE artist ( + artistid INTEGER PRIMARY KEY NOT NULL, + name varchar(100), + rank integer NOT NULL, + charfield char(10) +); + +CREATE TABLE collection ( + collectionid INTEGER PRIMARY KEY NOT NULL, + name varchar(100) NOT NULL +); + +CREATE TABLE encoded ( + id INTEGER PRIMARY KEY NOT NULL, + encoded varchar(100) +); + +CREATE TABLE event ( + id INTEGER PRIMARY KEY NOT NULL, + starts_at varchar(20) NOT NULL, + created_on varchar(20) NOT NULL, + varchar_date varchar(20), + varchar_datetime varchar(20), + skip_inflation varchar(20), + ts_without_tz varchar(20) +); + +CREATE TABLE fourkeys ( + foo integer NOT NULL, + bar integer NOT NULL, + hello integer NOT NULL, + goodbye integer NOT NULL, + sensors char(10) NOT NULL, + read_count integer, + PRIMARY KEY (foo, bar, hello, goodbye) +); + +CREATE TABLE genre ( + genreid INTEGER PRIMARY KEY NOT NULL, + name varchar(100) NOT NULL +); + +CREATE TABLE link ( + id INTEGER PRIMARY KEY NOT NULL, + url varchar(100), + title varchar(100) +); + +CREATE TABLE noprimarykey ( + foo integer NOT NULL, + bar integer NOT NULL, + baz integer NOT NULL +); + +CREATE TABLE onekey ( + id INTEGER PRIMARY KEY NOT NULL, + artist integer NOT NULL, + cd integer NOT NULL +); + +CREATE TABLE owners ( + id INTEGER PRIMARY KEY NOT NULL, + name varchar(100) NOT NULL +); + +CREATE TABLE producer ( + producerid INTEGER PRIMARY KEY NOT NULL, + name varchar(100) NOT NULL +); + +CREATE TABLE self_ref ( + id INTEGER PRIMARY KEY NOT NULL, + name varchar(100) NOT NULL +); + +CREATE TABLE sequence_test ( + pkid1 integer NOT NULL, + pkid2 integer NOT NULL, + nonpkid integer NOT NULL, + name varchar(100), + PRIMARY KEY (pkid1, pkid2) +); + +CREATE TABLE serialized ( + id INTEGER PRIMARY KEY NOT NULL, + serialized text NOT NULL +); + +CREATE TABLE treelike ( + id INTEGER PRIMARY KEY NOT NULL, + parent integer, + name varchar(100) NOT NULL +); + +CREATE TABLE twokeytreelike ( + id1 integer NOT NULL, + id2 integer NOT NULL, + parent1 integer NOT NULL, + parent2 integer NOT NULL, + name varchar(100) NOT NULL, + PRIMARY KEY (id1, id2) +); + +CREATE TABLE typed_object ( + objectid INTEGER PRIMARY KEY NOT NULL, + type varchar(100) NOT NULL, + value varchar(100) NOT NULL +); + +CREATE TABLE artist_undirected_map ( + id1 integer NOT NULL, + id2 integer NOT NULL, + PRIMARY KEY (id1, id2) +); + +CREATE TABLE bookmark ( + id INTEGER PRIMARY KEY NOT NULL, + link integer +); + +CREATE TABLE books ( + id INTEGER PRIMARY KEY NOT NULL, + source varchar(100) NOT NULL, + owner integer NOT NULL, + title varchar(100) NOT NULL, + price integer +); + +CREATE TABLE employee ( + employee_id INTEGER PRIMARY KEY NOT NULL, + position integer NOT NULL, + group_id integer, + group_id_2 integer, + group_id_3 integer, + name varchar(100), + encoded integer +); + +CREATE TABLE forceforeign ( + artist INTEGER PRIMARY KEY NOT NULL, + cd integer NOT NULL +); + +CREATE TABLE self_ref_alias ( + self_ref integer NOT NULL, + alias integer NOT NULL, + PRIMARY KEY (self_ref, alias) +); + +CREATE TABLE track ( + trackid INTEGER PRIMARY KEY NOT NULL, + cd integer NOT NULL, + position int NOT NULL, + title varchar(100) NOT NULL, + last_updated_on varchar(20), + last_updated_at varchar(20) +); + +CREATE TABLE cd ( + cdid INTEGER PRIMARY KEY NOT NULL, + artist integer NOT NULL, + title varchar(100) NOT NULL, + year varchar(100) NOT NULL, + genreid integer, + single_track integer +); + +CREATE TABLE collection_object ( + collection integer NOT NULL, + object integer NOT NULL, + PRIMARY KEY (collection, object) +); + +CREATE TABLE lyrics ( + lyric_id INTEGER PRIMARY KEY NOT NULL, + track_id integer NOT NULL +); + +CREATE TABLE liner_notes ( + liner_id INTEGER PRIMARY KEY NOT NULL, + notes varchar(100) NOT NULL +); + +CREATE TABLE lyric_versions ( + id INTEGER PRIMARY KEY NOT NULL, + lyric_id integer NOT NULL, + ltext varchar(100) NOT NULL +); + +CREATE TABLE tags ( + tagid INTEGER PRIMARY KEY NOT NULL, + cd integer NOT NULL, + tag varchar(100) NOT NULL +); + +CREATE TABLE cd_to_producer ( + cd integer NOT NULL, + producer integer NOT NULL, + attribute integer, + PRIMARY KEY (cd, producer) +); + +CREATE TABLE images ( + id INTEGER PRIMARY KEY NOT NULL, + artwork_id integer NOT NULL, + name varchar(100) NOT NULL, + data blob +); + +CREATE TABLE twokeys ( + artist integer NOT NULL, + cd integer NOT NULL, + PRIMARY KEY (artist, cd) +); + +CREATE TABLE artwork_to_artist ( + artwork_cd_id integer NOT NULL, + artist_id integer NOT NULL, + PRIMARY KEY (artwork_cd_id, artist_id) +); + +CREATE TABLE fourkeys_to_twokeys ( + f_foo integer NOT NULL, + f_bar integer NOT NULL, + f_hello integer NOT NULL, + f_goodbye integer NOT NULL, + t_artist integer NOT NULL, + t_cd integer NOT NULL, + autopilot char NOT NULL, + pilot_sequence integer, + PRIMARY KEY (f_foo, f_bar, f_hello, f_goodbye, t_artist, t_cd) +);