From: Peter Rabbitson Date: Mon, 7 Sep 2009 10:38:31 +0000 (+0000) Subject: Merge 'trunk' into 'sybase' X-Git-Tag: v0.08112~14^2~28 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d778a814639367cf6c2f8b45ec625c293ba02529;hp=59f27fc338728ada2cc29e392412720ccea4fb3a;p=dbsrgits%2FDBIx-Class.git Merge 'trunk' into 'sybase' r7511@Thesaurus (orig r7508): matthewt | 2009-09-03 20:12:53 +0200 get the COPYRIGHT in the right pless to not confuse META.yml generation r7513@Thesaurus (orig r7510): ribasushi | 2009-09-03 20:41:22 +0200 r7514@Thesaurus (orig r7511): ribasushi | 2009-09-03 20:41:34 +0200 r7472@Thesaurus (orig r7469): norbi | 2009-09-01 21:43:08 +0200 r7635@vger: mendel | 2009-09-01 21:02:23 +0200 Added pointer to 'SQL functions on the lhs' to the 'using stored procs' section. r7515@Thesaurus (orig r7512): ribasushi | 2009-09-03 20:41:44 +0200 r7473@Thesaurus (orig r7470): norbi | 2009-09-01 21:43:19 +0200 r7636@vger: mendel | 2009-09-01 21:09:43 +0200 Mentions the possibiliby of creating indexes on SQL function return values. r7516@Thesaurus (orig r7513): ribasushi | 2009-09-03 20:41:52 +0200 r7474@Thesaurus (orig r7471): norbi | 2009-09-01 21:43:31 +0200 r7637@vger: mendel | 2009-09-01 21:19:14 +0200 Rewrote 'SQL functions on the lhs' to use the new SQLA literal SQL + bind feature. r7517@Thesaurus (orig r7514): ribasushi | 2009-09-03 20:41:59 +0200 r7475@Thesaurus (orig r7472): norbi | 2009-09-01 21:43:42 +0200 r7638@vger: mendel | 2009-09-01 21:20:17 +0200 Added a comment to the example code to stress that it does not work. r7518@Thesaurus (orig r7515): ribasushi | 2009-09-03 20:42:10 +0200 r7476@Thesaurus (orig r7473): norbi | 2009-09-01 21:43:54 +0200 r7639@vger: mendel | 2009-09-01 21:28:18 +0200 Added pointer to DBIx::Class::DynamicSubclass. r7519@Thesaurus (orig r7516): ribasushi | 2009-09-03 20:42:15 +0200 r7477@Thesaurus (orig r7474): norbi | 2009-09-01 21:44:03 +0200 r7640@vger: mendel | 2009-09-01 21:30:13 +0200 Replaced deprecated \'colname DESC' order_by syntax with { -desc => 'colname' } syntax. r7520@Thesaurus (orig r7517): ribasushi | 2009-09-03 20:42:22 +0200 r7478@Thesaurus (orig r7475): norbi | 2009-09-01 21:44:17 +0200 r7641@vger: mendel | 2009-09-01 21:32:48 +0200 Rewrote 'SQL functions on the lhs' to use the new SQLA literal SQL + bind feature. r7521@Thesaurus (orig r7518): ribasushi | 2009-09-03 20:42:26 +0200 r7479@Thesaurus (orig r7476): norbi | 2009-09-01 21:44:28 +0200 r7642@vger: mendel | 2009-09-01 21:42:25 +0200 Added many-to-many add_to_*() example to stress that it returns the related row and not the linking table row. r7522@Thesaurus (orig r7519): ribasushi | 2009-09-03 20:42:32 +0200 r7480@Thesaurus (orig r7477): norbi | 2009-09-01 22:14:25 +0200 r7653@vger: mendel | 2009-09-01 22:14:11 +0200 Fixed wrong literal SQL + bind examples (missing operator and placeholders). r7523@Thesaurus (orig r7520): ribasushi | 2009-09-03 20:42:37 +0200 r7481@Thesaurus (orig r7478): norbi | 2009-09-01 22:30:48 +0200 r7655@vger: mendel | 2009-09-01 22:30:35 +0200 Fixed the bind value column names in the SQL literal + bind examples. r7524@Thesaurus (orig r7521): ribasushi | 2009-09-03 20:42:45 +0200 r7482@Thesaurus (orig r7479): norbi | 2009-09-01 22:52:21 +0200 r7657@vger: mendel | 2009-09-01 22:52:09 +0200 Further improvement in the bind value column names in the SQL literal + bind examples. r7549@Thesaurus (orig r7546): ribasushi | 2009-09-04 08:47:19 +0200 Stop connecting to determine dt-parser (test is in pg branch) r7553@Thesaurus (orig r7550): ribasushi | 2009-09-04 11:20:48 +0200 Require sqla with bool support r7560@Thesaurus (orig r7557): ribasushi | 2009-09-04 19:17:32 +0200 Dumper follies r7561@Thesaurus (orig r7558): ribasushi | 2009-09-04 19:27:50 +0200 Even better sqla r7570@Thesaurus (orig r7567): ribasushi | 2009-09-04 20:49:53 +0200 r7459@Thesaurus (orig r7456): rbuels | 2009-09-01 12:46:46 +0200 making another pg_unqualified_schema branch, for real this time r7460@Thesaurus (orig r7457): rbuels | 2009-09-01 12:51:31 +0200 reworked tests for pg last_insert_id in presence of un-schema-qualified things. adds some todo tests, including a case for which is does not seem to be possible to correctly guess the sequence to use for the liid r7461@Thesaurus (orig r7458): rbuels | 2009-09-01 12:54:34 +0200 in Pg storage, added a warning for case when the nextval sequence is not schema qualified r7462@Thesaurus (orig r7459): rbuels | 2009-09-01 13:01:31 +0200 tweak to Pg test, warnings_like -> warnings_exist r7463@Thesaurus (orig r7460): ribasushi | 2009-09-01 13:34:59 +0200 Rewrap todo properly r7490@Thesaurus (orig r7487): ribasushi | 2009-09-02 14:16:01 +0200 Make pg sequence autodetect deterministic (or throw exceptions). Test needs adjusting r7491@Thesaurus (orig r7488): rbuels | 2009-09-02 19:15:01 +0200 some reorganization and cleanup of pg-specific tests r7492@Thesaurus (orig r7489): rbuels | 2009-09-02 20:08:31 +0200 more cleanup of 72pg.t r7495@Thesaurus (orig r7492): rbuels | 2009-09-02 20:48:12 +0200 more cleanup of pg tests, added cascade to drop function, cleaned up create and drop of schemas to use dbh_do r7496@Thesaurus (orig r7493): rbuels | 2009-09-02 20:50:42 +0200 oops, missed something screwed up by the pull r7525@Thesaurus (orig r7522): rbuels | 2009-09-03 20:45:53 +0200 added __END__ before pod in Pg storage r7526@Thesaurus (orig r7523): rbuels | 2009-09-03 20:46:00 +0200 renamed pg test schemas to be more organized r7531@Thesaurus (orig r7528): rbuels | 2009-09-04 00:28:11 +0200 more pg test cleanup r7532@Thesaurus (orig r7529): rbuels | 2009-09-04 00:28:17 +0200 more pg test cleanup r7533@Thesaurus (orig r7530): rbuels | 2009-09-04 00:28:25 +0200 starting work on extended set of Pg auto-pk tests r7534@Thesaurus (orig r7531): rbuels | 2009-09-04 00:28:31 +0200 more work on extended set of Pg auto-pk tests r7535@Thesaurus (orig r7532): rbuels | 2009-09-04 00:28:39 +0200 more work on pg tests r7536@Thesaurus (orig r7533): rbuels | 2009-09-04 00:28:45 +0200 more work on extended set of Pg auto-pk tests r7537@Thesaurus (orig r7534): rbuels | 2009-09-04 00:28:50 +0200 added .gitignore for users of git-svn r7538@Thesaurus (orig r7535): rbuels | 2009-09-04 00:28:58 +0200 more work on extended set of Pg auto-pk tests r7539@Thesaurus (orig r7536): rbuels | 2009-09-04 00:29:04 +0200 added darcs and git to MANIFEST.SKIP version control skipping section r7540@Thesaurus (orig r7537): rbuels | 2009-09-04 00:41:26 +0200 more work on extended set of Pg auto-pk tests r7541@Thesaurus (orig r7538): rbuels | 2009-09-04 00:41:32 +0200 more work on extended set of Pg auto-pk tests r7542@Thesaurus (orig r7539): rbuels | 2009-09-04 00:41:38 +0200 more work on extended set of Pg auto-pk tests r7543@Thesaurus (orig r7540): rbuels | 2009-09-04 02:20:23 +0200 more work on extended set of Pg auto-pk tests r7544@Thesaurus (orig r7541): rbuels | 2009-09-04 02:20:32 +0200 rewrote autoinc fetcher as a query into the pg_catalog. all the old tests pass now, but not my new tests. the new tests might be buggy r7545@Thesaurus (orig r7542): rbuels | 2009-09-04 02:20:39 +0200 oops, forgot to put the drop for the extended tests back in the pg tests r7546@Thesaurus (orig r7543): rbuels | 2009-09-04 02:41:56 +0200 couple of comment/documentation tweaks to pg storage driver r7547@Thesaurus (orig r7544): rbuels | 2009-09-04 02:42:02 +0200 fixed my tests r7548@Thesaurus (orig r7545): rbuels | 2009-09-04 02:42:09 +0200 clarified the POD in Pg storage driver regarding multi-schema support r7551@Thesaurus (orig r7548): ribasushi | 2009-09-04 08:51:30 +0200 Proper unconnected test r7554@Thesaurus (orig r7551): ribasushi | 2009-09-04 11:26:12 +0200 Fixes to pg test after review: - Move the store_column test to 60core.t - Streamline the select ... for update test - Disable all exception warnings for normal test runs r7555@Thesaurus (orig r7552): ribasushi | 2009-09-04 11:56:00 +0200 Rewrite selector using sqla r7562@Thesaurus (orig r7559): rbuels | 2009-09-04 19:42:52 +0200 moved search_path querying function from Pg storage driver into tests r7563@Thesaurus (orig r7560): rbuels | 2009-09-04 19:43:00 +0200 refactored how Pg storage driver calls sequence search, made erorror message more informative when query into pg_catalog fails r7564@Thesaurus (orig r7561): rbuels | 2009-09-04 19:43:08 +0200 tweaked pg sequence discovery error message a bit more r7565@Thesaurus (orig r7562): rbuels | 2009-09-04 19:43:17 +0200 added big block comment explaining Pg sequence discovery strategy r7566@Thesaurus (orig r7563): rbuels | 2009-09-04 20:35:10 +0200 added code to use DBD::Pg column_info to fetch column default if recent enough r7567@Thesaurus (orig r7564): rbuels | 2009-09-04 20:35:18 +0200 tweaked comment r7568@Thesaurus (orig r7565): rbuels | 2009-09-04 20:35:30 +0200 oops, DBD::Pg 2.15.1 should be included in working versions r7572@Thesaurus (orig r7569): ribasushi | 2009-09-04 21:32:01 +0200 Stop double-caching datetime_parser - keep it in the storage only r7573@Thesaurus (orig r7570): ribasushi | 2009-09-04 21:36:39 +0200 No Serialize::Storable in core r7574@Thesaurus (orig r7571): ribasushi | 2009-09-04 21:49:54 +0200 Changes r7580@Thesaurus (orig r7577): ribasushi | 2009-09-06 12:28:44 +0200 Add mysterious exception test r7582@Thesaurus (orig r7579): ribasushi | 2009-09-06 15:43:10 +0200 No connection - no cleanup r7583@Thesaurus (orig r7580): ribasushi | 2009-09-06 15:45:51 +0200 Streamline test r7584@Thesaurus (orig r7581): ribasushi | 2009-09-06 17:39:03 +0200 Test cleanup: Benchmark and Data::Dumper have been in core forever Make POD testing conditional as shown in http://use.perl.org/~Alias/journal/38822 Remove some dead cdbi test files Stop openly giving contributors an option to override the authorcheck r7585@Thesaurus (orig r7582): ribasushi | 2009-09-06 17:48:32 +0200 Done long time ago r7586@Thesaurus (orig r7583): ribasushi | 2009-09-06 17:56:27 +0200 Release 0.08110 r7588@Thesaurus (orig r7585): ribasushi | 2009-09-06 18:33:46 +0200 Stop eating exceptions in ::Storage::DBI::DESTROY r7589@Thesaurus (orig r7586): ribasushi | 2009-09-06 20:35:30 +0200 Centralize identity insert control for mssql (it seems that issuing an OFF is not necessary) r7590@Thesaurus (orig r7587): ribasushi | 2009-09-06 20:45:41 +0200 Clearer MSSQL error message r7591@Thesaurus (orig r7588): ribasushi | 2009-09-06 23:58:22 +0200 Fix mssql pod r7592@Thesaurus (orig r7589): ribasushi | 2009-09-07 09:06:05 +0200 Release 0.08111 --- diff --git a/Changes b/Changes index a5d4473..2365696 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,17 @@ Revision history for DBIx::Class + - Complete Sybase RDBMS support including: + - Support for TEXT/IMAGE columns + - Support for the 'money' datatype + - Transaction savepoints support + - DateTime inflation support + - Support for bind variables when connecting to a newer Sybase with + OpenClient libraries + - Support for connections via FreeTDS with CASTs for bind variables + when needed + - Support for interpolated variables with proper quoting when + connecting to an older Sybase and/or via FreeTDS + 0.08111 2009-09-06 21:58:00 (UTC) - The hashref to connection_info now accepts a 'dbh_maker' coderef, allowing better intergration with Catalyst @@ -41,7 +53,7 @@ Revision history for DBIx::Class - 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) diff --git a/Makefile.PL b/Makefile.PL index adbd004..a4b6764 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -110,6 +110,12 @@ my %force_requires_if_author = ( 'DateTime::Format::Oracle' => '0', ) : () , + + $ENV{DBICTEST_SYBASE_DSN} + ? ( + 'DateTime::Format::Sybase' => 0, + ) : () + , ); @@ -126,7 +132,7 @@ resources 'license' => 'http://dev.perl.org/licenses/'; resources 'repository' => 'http://dev.catalyst.perl.org/svnweb/bast/browse/DBIx-Class/'; resources 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class'; -no_index 'DBIx::Class::Storage::DBI::Sybase::Base'; +no_index 'DBIx::Class::Storage::DBI::Sybase::Common'; no_index 'DBIx::Class::SQLAHacks'; no_index 'DBIx::Class::SQLAHacks::MSSQL'; no_index 'DBIx::Class::Storage::DBI::AmbiguousGlob'; diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 9bbeb73..6421875 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -2778,24 +2778,38 @@ sub _resolved_attrs { # 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->storage->_order_select_columns( + $source, + [ $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 { diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 7ebea34..8829cb3 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -681,7 +681,8 @@ sub disconnect { $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}++; @@ -1106,27 +1107,36 @@ sub txn_begin { 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; } @@ -1137,6 +1147,11 @@ sub txn_commit { } } +sub _dbh_commit { + my $self = shift; + $self->_dbh->commit; +} + sub txn_rollback { my $self = shift; my $dbh = $self->_dbh; @@ -1146,7 +1161,7 @@ sub txn_rollback { if ($self->debug); $self->{transaction_depth} = 0 if $self->_dbh_autocommit; - $dbh->rollback; + $self->_dbh_rollback; } elsif($self->{transaction_depth} > 1) { $self->{transaction_depth}--; @@ -1169,6 +1184,11 @@ sub txn_rollback { } } +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. @@ -1375,12 +1395,17 @@ sub insert_bulk { } 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); } @@ -1957,6 +1982,18 @@ sub _subq_count_select { return @pcols ? \@pcols : [ 1 ]; } +# +# Returns an ordered list of column names before they are used +# in a SELECT statement. By default simply returns the list +# passed in. +# +# This may be overridden in a specific storage when there are +# requirements such as moving BLOB columns to the end of the +# SELECT list. +sub _order_select_columns { + #my ($self, $source, $columns) = @_; + return @{$_[2]}; +} sub source_bind_attributes { my ($self, $source) = @_; @@ -2154,6 +2191,36 @@ sub _native_data_type { 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. diff --git a/lib/DBIx/Class/Storage/DBI/AutoCast.pm b/lib/DBIx/Class/Storage/DBI/AutoCast.pm index 3391cfb..d854c16 100644 --- a/lib/DBIx/Class/Storage/DBI/AutoCast.pm +++ b/lib/DBIx/Class/Storage/DBI/AutoCast.pm @@ -29,6 +29,10 @@ converted to: CAST(? as $mapped_type) +This option can also be enabled in L as: + + on_connect_call => ['set_auto_cast'] + =cut sub _prep_for_execute { @@ -60,8 +64,28 @@ sub _prep_for_execute { return ($sql, $bind); } +=head2 connect_call_set_auto_cast + +Executes: + + $schema->storage->auto_cast(1); + +on connection. + +Used as: + + on_connect_call => ['set_auto_cast'] + +in L. + +=cut + +sub connect_call_set_auto_cast { + my $self = shift; + $self->auto_cast(1); +} -=head1 AUTHORS +=head1 AUTHOR See L diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index 3d59e84..c4c9806 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -3,7 +3,15 @@ package DBIx::Class::Storage::DBI::Cursor; use strict; use warnings; -use base qw/DBIx::Class::Cursor/; +use base qw/ + Class::Accessor::Grouped + DBIx::Class::Cursor +/; +use mro 'c3'; + +__PACKAGE__->mk_group_accessors('simple' => + qw/sth/ +); =head1 NAME @@ -73,24 +81,24 @@ sub _dbh_next { && $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; @@ -120,8 +128,8 @@ sub _dbh_all { 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}; } @@ -146,14 +154,14 @@ sub reset { 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; } sub _soft_reset { my ($self) = @_; - delete $self->{sth}; + $self->sth(undef); delete $self->{done}; $self->{pos} = 0; return $self; @@ -173,7 +181,7 @@ sub DESTROY { # 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; diff --git a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm index 95f1cac..9f84702 100644 --- a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm @@ -40,24 +40,32 @@ Manually subs in the values for the usual C placeholders. 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; @@ -65,11 +73,43 @@ sub _prep_for_execute { return ($new_sql, []); } -=head1 AUTHORS +=head2 interpolate_unquoted + +This method is called by L 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:: 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 +=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 +See L =head1 LICENSE diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index b97e34f..88cf72d 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -206,12 +206,6 @@ sub connect_call_datetime_setup { "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 @@ -256,6 +250,12 @@ sub source_bind_attributes 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 } diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index ee43384..551dae9 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -222,7 +222,7 @@ has 'pool' => ( isa=>'DBIx::Class::Storage::DBI::Replicated::Pool', lazy_build=>1, handles=>[qw/ - connect_replicants + connect_replicants replicants has_replicants /], @@ -277,7 +277,7 @@ has 'read_handler' => ( select select_single columns_info_for - /], + /], ); =head2 write_handler @@ -290,9 +290,9 @@ has '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 @@ -300,8 +300,8 @@ has 'write_handler' => ( 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 @@ -316,19 +316,20 @@ has 'write_handler' => ( 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 + _order_select_columns + svp_rollback + svp_begin + svp_release /], ); @@ -364,7 +365,7 @@ around connect_info => sub { ); $self->pool($self->_build_pool) - if $self->pool; + if $self->pool; } if (@opts{qw/balancer_type balancer_args/}) { @@ -376,7 +377,7 @@ around connect_info => sub { ); $self->balancer($self->_build_balancer) - if $self->balancer; + if $self->balancer; } $self->_master_connect_info_opts(\%opts); @@ -413,9 +414,9 @@ sub BUILDARGS { my ($class, $schema, $storage_type_args, @args) = @_; return { - schema=>$schema, - %$storage_type_args, - @args + schema=>$schema, + %$storage_type_args, + @args } } @@ -452,7 +453,7 @@ the balancer knows which pool it's balancing. sub _build_balancer { my $self = shift @_; $self->create_balancer( - pool=>$self->pool, + pool=>$self->pool, master=>$self->master, %{$self->balancer_args}, ); @@ -501,7 +502,7 @@ around connect_replicants => sub { 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 @@ -600,11 +601,11 @@ sub execute_reliably { ($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. @@ -738,7 +739,7 @@ sub debug { if(@_) { foreach my $source ($self->all_storages) { $source->debug(@_); - } + } } return $self->master->debug; } @@ -754,7 +755,7 @@ sub debugobj { if(@_) { foreach my $source ($self->all_storages) { $source->debugobj(@_); - } + } } return $self->master->debugobj; } @@ -770,7 +771,7 @@ sub debugfh { if(@_) { foreach my $source ($self->all_storages) { $source->debugfh(@_); - } + } } return $self->master->debugfh; } @@ -786,7 +787,7 @@ sub debugcb { if(@_) { foreach my $source ($self->all_storages) { $source->debugcb(@_); - } + } } return $self->master->debugcb; } diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index 41b0c81..6c07369 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -4,63 +4,694 @@ use strict; use warnings; use base qw/ - DBIx::Class::Storage::DBI::Sybase::Base - DBIx::Class::Storage::DBI::NoBindVars + DBIx::Class::Storage::DBI::Sybase::Common + DBIx::Class::Storage::DBI::AutoCast /; use mro 'c3'; +use Carp::Clan qw/^DBIx::Class/; +use List::Util (); + +__PACKAGE__->mk_group_accessors('simple' => + qw/_identity _blob_log_on_update unsafe_insert _insert_dbh/ +); + +=head1 NAME + +DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class + +=head1 SYNOPSIS + +This subclass supports L for real Sybase databases. If you are +using an MSSQL database via L, your storage will be reblessed to +L. + +=head1 DESCRIPTION + +If your version of Sybase does not support placeholders, then your storage +will be reblessed to L. You can +also enable that driver explicitly, see the documentation for more details. + +With this driver there is unfortunately no way to get the C +without doing a C when placeholders are enabled. + +When using C transactions are +disabled. + +To turn off transactions for inserts (for an application that doesn't need +concurrency, or a loader, for example) use this setting in +L, + + on_connect_call => ['unsafe_insert'] + +To manipulate this setting at runtime, use: + + $schema->storage->unsafe_insert(0|1); + +=cut + +sub connect_call_unsafe_insert { + my $self = shift; + $self->unsafe_insert(1); +} + +sub _is_lob_type { + my $self = shift; + my $type = shift; + $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i; +} + +sub _prep_for_execute { + my $self = shift; + my ($op, $extra_bind, $ident, $args) = @_; + + my ($sql, $bind) = $self->next::method (@_); + + if ($op eq 'insert') { + my $table = $ident->from; + + my $bind_info = $self->_resolve_column_info( + $ident, [map $_->[0], @{$bind}] + ); + my $identity_col = List::Util::first + { $bind_info->{$_}{is_auto_increment} } + (keys %$bind_info) + ; + + if ($identity_col) { + $sql = join ("\n", + "SET IDENTITY_INSERT $table ON", + $sql, + "SET IDENTITY_INSERT $table OFF", + ); + } + else { + $identity_col = List::Util::first + { $ident->column_info($_)->{is_auto_increment} } + $ident->columns + ; + } + + if ($identity_col) { + $sql = + "$sql\n" . + $self->_fetch_identity_sql($ident, $identity_col); + } + } + + return ($sql, $bind); +} + +# Stolen from SQLT, with some modifications. This is a makeshift +# solution before a sane type-mapping library is available, thus +# the 'our' for easy overrides. +our %TYPE_MAPPING = ( + number => 'numeric', + money => 'money', + varchar => 'varchar', + varchar2 => 'varchar', + timestamp => 'datetime', + text => 'varchar', + real => 'double precision', + comment => 'text', + bit => 'bit', + tinyint => 'smallint', + float => 'double precision', + serial => 'numeric', + bigserial => 'numeric', + boolean => 'varchar', + long => 'varchar', +); + +sub _native_data_type { + my ($self, $type) = @_; + + $type = lc $type; + $type =~ s/\s* identity//x; + + return uc($TYPE_MAPPING{$type} || $type); +} + +sub _fetch_identity_sql { + my ($self, $source, $col) = @_; + + return "SELECT MAX($col) FROM ".$source->from; +} + +sub _execute { + my $self = shift; + my ($op) = @_; + + my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_); + + if ($op eq 'insert') { + $self->_identity($sth->fetchrow_array); + $sth->finish; + } + + return wantarray ? ($rv, $sth, @bind) : $rv; +} + +sub last_insert_id { shift->_identity } + +# handles TEXT/IMAGE and transaction for last_insert_id +sub insert { + my $self = shift; + my ($source, $to_insert) = @_; + + my $blob_cols = $self->_remove_blob_cols($source, $to_insert); + +# insert+blob insert done atomically + my $guard = $self->txn_scope_guard if $blob_cols; + + my $need_last_insert_id = 0; + + my ($identity_col) = + map $_->[0], + grep $_->[1]{is_auto_increment}, + map [ $_, $source->column_info($_) ], + $source->columns; + + $need_last_insert_id = 1 + if $identity_col && (not exists $to_insert->{$identity_col}); + + # We have to do the insert in a transaction to avoid race conditions with the + # SELECT MAX(COL) identity method used when placeholders are enabled. + my $updated_cols = do { + if ( + $need_last_insert_id && !$self->unsafe_insert && !$self->{transaction_depth} + ) { + local $self->{_dbh} = $self->_insert_dbh; + my $guard = $self->txn_scope_guard; + my $upd_cols = $self->next::method (@_); + $guard->commit; + $upd_cols; + } + else { + $self->next::method(@_); + } + }; + + $self->_insert_blobs($source, $blob_cols, $to_insert) if $blob_cols; + + $guard->commit if $guard; + + return $updated_cols; +} + +sub update { + my $self = shift; + my ($source, $fields, $where) = @_; + + my $wantarray = wantarray; + + my $blob_cols = $self->_remove_blob_cols($source, $fields); + +# update+blob update(s) done atomically + my $guard = $self->txn_scope_guard if $blob_cols; + + my @res; + if ($wantarray) { + @res = $self->next::method(@_); + } + elsif (defined $wantarray) { + $res[0] = $self->next::method(@_); + } + else { + $self->next::method(@_); + } + + $self->_update_blobs($source, $blob_cols, $where) if $blob_cols; + + $guard->commit if $guard; + + return $wantarray ? @res : $res[0]; +} + +sub _remove_blob_cols { + my ($self, $source, $fields) = @_; + + my %blob_cols; + + for my $col (keys %$fields) { + if ($self->_is_lob_type($source->column_info($col)->{data_type})) { + $blob_cols{$col} = delete $fields->{$col}; + $fields->{$col} = \"''"; + } + } + + return keys %blob_cols ? \%blob_cols : undef; +} + +sub _update_blobs { + my ($self, $source, $blob_cols, $where) = @_; + + my (@primary_cols) = $source->primary_columns; + + croak "Cannot update TEXT/IMAGE column(s) without a primary key" + unless @primary_cols; + +# check if we're updating a single row by PK + my $pk_cols_in_where = 0; + for my $col (@primary_cols) { + $pk_cols_in_where++ if defined $where->{$col}; + } + my @rows; + + if ($pk_cols_in_where == @primary_cols) { + my %row_to_update; + @row_to_update{@primary_cols} = @{$where}{@primary_cols}; + @rows = \%row_to_update; + } else { + my $rs = $source->resultset->search( + $where, + { + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + select => \@primary_cols + } + ); + @rows = $rs->all; # statement must finish + } + + for my $row (@rows) { + $self->_insert_blobs($source, $blob_cols, $row); + } +} + +sub _insert_blobs { + my ($self, $source, $blob_cols, $row) = @_; + my $dbh = $self->_get_dbh; + + my $table = $source->from; + + my %row = %$row; + my (@primary_cols) = $source->primary_columns; + + croak "Cannot update TEXT/IMAGE column(s) without a primary key" + unless @primary_cols; + + if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) { + if (@primary_cols == 1) { + my $col = $primary_cols[0]; + $row{$col} = $self->last_insert_id($source, $col); + } else { + croak "Cannot update TEXT/IMAGE column(s) without primary key values"; + } + } + + for my $col (keys %$blob_cols) { + my $blob = $blob_cols->{$col}; + + my %where = map { ($_, $row{$_}) } @primary_cols; + my $cursor = $source->resultset->search(\%where, { + select => [$col] + })->cursor; + $cursor->next; + my $sth = $cursor->sth; + + eval { + do { + $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr; + } while $sth->fetch; + + $sth->func('ct_prepare_send') or die $sth->errstr; + + my $log_on_update = $self->_blob_log_on_update; + $log_on_update = 1 if not defined $log_on_update; + + $sth->func('CS_SET', 1, { + total_txtlen => length($blob), + log_on_update => $log_on_update + }, 'ct_data_info') or die $sth->errstr; + + $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr; + + $sth->func('ct_finish_send') or die $sth->errstr; + }; + my $exception = $@; + $sth->finish if $sth; + if ($exception) { + if ($self->using_freetds) { + croak ( + 'TEXT/IMAGE operation failed, probably because you are using FreeTDS: ' + . $exception + ); + } else { + croak $exception; + } + } + } +} + +=head2 connect_call_datetime_setup + +Used as: + + on_connect_call => 'datetime_setup' + +In L to set: + + $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z + $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080 + +On connection for use with L, using +L, which you will need to install. + +This works for both C and C columns, although +C columns only have minute precision. + +=cut + +{ + my $old_dbd_warned = 0; + + sub connect_call_datetime_setup { + my $self = shift; + my $dbh = $self->_dbh; + + if ($dbh->can('syb_date_fmt')) { + # amazingly, this works with FreeTDS + $dbh->syb_date_fmt('ISO_strict'); + } elsif (not $old_dbd_warned) { + carp "Your DBD::Sybase is too old to support ". + "DBIx::Class::InflateColumn::DateTime, please upgrade!"; + $old_dbd_warned = 1; } + + $dbh->do('SET DATEFORMAT mdy'); + + 1; + } +} + +sub datetime_parser_type { "DateTime::Format::Sybase" } + +# ->begin_work and such have no effect with FreeTDS but we run them anyway to +# let the DBD keep any state it needs to. +# +# If they ever do start working, the extra statements will do no harm (because +# Sybase supports nested transactions.) + +sub _dbh_begin_work { + my $self = shift; + $self->next::method(@_); + if ($self->using_freetds) { + $self->_get_dbh->do('BEGIN TRAN'); + } +} + +sub _dbh_commit { + my $self = shift; + if ($self->using_freetds) { + $self->_dbh->do('COMMIT'); + } + return $self->next::method(@_); +} + +sub _dbh_rollback { + my $self = shift; + if ($self->using_freetds) { + $self->_dbh->do('ROLLBACK'); + } + return $self->next::method(@_); +} + +# savepoint support using ASE syntax + +sub _svp_begin { + my ($self, $name) = @_; + + $self->_get_dbh->do("SAVE TRANSACTION $name"); } -sub _dbh_last_insert_id { - my ($self, $dbh, $source, $col) = @_; - return ($dbh->selectrow_array('select @@identity'))[0]; +# A new SAVE TRANSACTION with the same name releases the previous one. +sub _svp_release { 1 } + +sub _svp_rollback { + my ($self, $name) = @_; + + $self->_get_dbh->do("ROLLBACK TRANSACTION $name"); } 1; -=head1 NAME +=head1 Schema::Loader Support -DBIx::Class::Storage::DBI::Sybase - Storage::DBI subclass for Sybase +There is an experimental branch of L that will +allow you to dump a schema from most (if not all) versions of Sybase. -=head1 SYNOPSIS +It is available via subversion from: + + http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/current/ + +=head1 FreeTDS + +This driver supports L compiled against FreeTDS +(L) to the best of our ability, however it is +recommended that you recompile L against the Sybase Open Client +libraries. They are a part of the Sybase ASE distribution: + +The Open Client FAQ is here: +L. + +Sybase ASE for Linux (which comes with the Open Client libraries) may be +downloaded here: L. + +To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run: + + perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}' + +Some versions of the libraries involved will not support placeholders, in which +case the storage will be reblessed to +L. + +In some configurations, placeholders will work but will throw implicit type +conversion errors for anything that's not expecting a string. In such a case, +the C option from L is +automatically set, which you may enable on connection with +L. The type info +for the Cs is taken from the L +definitions in your Result classes, and are mapped to a Sybase type (if it isn't +already) using a mapping based on L. + +In other configurations, placeholers will work just as they do with the Sybase +Open Client libraries. + +Inserts or updates of TEXT/IMAGE columns will B work with FreeTDS. + +=head1 TRANSACTIONS + +Due to limitations of the TDS protocol, L, or both; you cannot +begin a transaction while there are active cursors. An active cursor is, for +example, a L that has been executed using +C or C but has not been exhausted or +L. + +Transactions done for inserts in C mode when placeholders are in use +are also affected, so this won't work: + + while (my $row = $rs1->next) { + $rs2->create({ foo => $row->foo }); + } + +Some workarounds: + +=over 4 + +=item * set C<< $schema->storage->unsafe_insert(1) >> temporarily (see +L) + +=item * use L + +=item * L another L + +=item * load the data from your cursor with L + +=item * enlarge the scope of the transaction + +=back + +=head1 MAXIMUM CONNECTIONS + +The TDS protocol makes separate connections to the server for active statements +in the background. By default the number of such connections is limited to 25, +on both the client side and the server side. + +This is a bit too low for a complex L application, so on connection +the client side setting is set to C<256> (see L.) You +can override it to whatever setting you like in the DSN. + +See +L +for information on changing the setting on the server side. + +=head1 DATES + +See L to setup date formats +for L. + +=head1 TEXT/IMAGE COLUMNS + +L compiled with FreeTDS will B allow you to insert or update +C columns. + +Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either: + + $schema->storage->dbh->do("SET TEXTSIZE $bytes"); -This subclass supports L for real Sybase databases. If -you are using an MSSQL database via L, see -L. +or -=head1 CAVEATS + $schema->storage->set_textsize($bytes); -This storage driver uses L as a base. -This means that bind variables will be interpolated (properly quoted of course) -into the SQL query itself, without using bind placeholders. +instead. -More importantly this means that caching of prepared statements is explicitly -disabled, as the interpolation renders it useless. +However, the C you pass in +L is used to execute the equivalent +C command on connection. -=head1 AUTHORS +See L for a L +setting you need to work with C columns. -Brandon L Black +=head1 AUTHOR -Justin Hunter +See L. =head1 LICENSE You may distribute this code under the same terms as Perl itself. =cut +# vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/Base.pm b/lib/DBIx/Class/Storage/DBI/Sybase/Base.pm deleted file mode 100644 index 757d4d9..0000000 --- a/lib/DBIx/Class/Storage/DBI/Sybase/Base.pm +++ /dev/null @@ -1,54 +0,0 @@ -package # hide from PAUSE - DBIx::Class::Storage::DBI::Sybase::Base; - -use strict; -use warnings; - -use base qw/DBIx::Class::Storage::DBI/; -use mro 'c3'; - -=head1 NAME - -DBIx::Class::Storage::DBI::Sybase::Base - Common functionality for drivers using -DBD::Sybase - -=cut - -sub _ping { - my $self = shift; - - my $dbh = $self->_dbh or return 0; - - local $dbh->{RaiseError} = 1; - eval { - $dbh->do('select 1'); - }; - - return $@ ? 0 : 1; -} - -sub _placeholders_supported { - my $self = shift; - my $dbh = $self->_get_dbh; - - return eval { -# There's also $dbh->{syb_dynamic_supported} but it can be inaccurate for this -# purpose. - local $dbh->{PrintError} = 0; - local $dbh->{RaiseError} = 1; -# this specifically tests a bind that is NOT a string - $dbh->selectrow_array('select 1 where 1 = ?', {}, 1); - }; -} - -1; - -=head1 AUTHORS - -See L. - -=head1 LICENSE - -You may distribute this code under the same terms as Perl itself. - -=cut diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/Common.pm b/lib/DBIx/Class/Storage/DBI/Sybase/Common.pm new file mode 100644 index 0000000..c183a9f --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/Sybase/Common.pm @@ -0,0 +1,99 @@ +package DBIx::Class::Storage::DBI::Sybase::Common; + +use strict; +use warnings; + +use base qw/DBIx::Class::Storage::DBI/; +use mro 'c3'; + +=head1 NAME + +DBIx::Class::Storage::DBI::Sybase::Common - Common functionality for drivers using +DBD::Sybase + +=head1 DESCRIPTION + +This is the base class for L and +L. It provides some +utility methods related to L and the supported functions of the +database you are connecting to. + +=head1 METHODS + +=cut + +sub _ping { + my $self = shift; + + my $dbh = $self->_dbh or return 0; + + local $dbh->{RaiseError} = 1; + eval { + $dbh->do('select 1'); + }; + + return $@ ? 0 : 1; +} + +sub _set_max_connect { + my $self = shift; + my $val = shift || 256; + + my $dsn = $self->_dbi_connect_info->[0]; + + return if ref($dsn) eq 'CODE'; + + if ($dsn !~ /maxConnect=/) { + $self->_dbi_connect_info->[0] = "$dsn;maxConnect=$val"; + my $connected = defined $self->_dbh; + $self->disconnect; + $self->ensure_connected if $connected; + } +} + +=head2 using_freetds + +Whether or not L was compiled against FreeTDS. If false, it means +the Sybase OpenClient libraries were used. + +=cut + +sub using_freetds { + my $self = shift; + + return $self->_dbh->{syb_oc_version} =~ /freetds/i; +} + +=head2 set_textsize + +When using FreeTDS and/or MSSQL, C<< $dbh->{LongReadLen} >> is not available, +use this function instead. It does: + + $dbh->do("SET TEXTSIZE $bytes"); + +Takes the number of bytes, or uses the C value from your +L if omitted. + +=cut + +sub set_textsize { + my $self = shift; + my $text_size = shift || + eval { $self->_dbi_connect_info->[-1]->{LongReadLen} }; + + return unless defined $text_size; + + $self->_dbh->do("SET TEXTSIZE $text_size"); +} + +1; + +=head1 AUTHORS + +See L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm index 6a20ba4..e7f0e51 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm @@ -4,7 +4,7 @@ use strict; use warnings; use base qw/ - DBIx::Class::Storage::DBI::Sybase::Base + DBIx::Class::Storage::DBI::Sybase::Common DBIx::Class::Storage::DBI::MSSQL /; use mro 'c3'; @@ -13,7 +13,7 @@ sub _rebless { 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; diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/Sybase/NoBindVars.pm new file mode 100644 index 0000000..d40d0a6 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/Sybase/NoBindVars.pm @@ -0,0 +1,104 @@ +package DBIx::Class::Storage::DBI::Sybase::NoBindVars; + +use Class::C3; +use base qw/ + DBIx::Class::Storage::DBI::NoBindVars + DBIx::Class::Storage::DBI::Sybase +/; +use List::Util (); +use Scalar::Util (); + +sub _rebless { + my $self = shift; + $self->disable_sth_caching(1); + $self->unsafe_insert(1); # there is nothing unsafe as the + # last_insert_id mechanism is different + # without bindvars +} + +# this works when NOT using placeholders +sub _fetch_identity_sql { 'SELECT @@IDENTITY' } + +my $number = sub { Scalar::Util::looks_like_number($_[0]) }; + +my $decimal = sub { $_[0] =~ /^ [-+]? \d+ (?:\.\d*)? \z/x }; + +my %noquote = ( + int => sub { $_[0] =~ /^ [-+]? \d+ \z/x }, + bit => => sub { $_[0] =~ /^[01]\z/ }, + money => sub { $_[0] =~ /^\$ \d+ (?:\.\d*)? \z/x }, + float => $number, + real => $number, + double => $number, + decimal => $decimal, + numeric => $decimal, +); + +sub interpolate_unquoted { + my $self = shift; + my ($type, $value) = @_; + + return $self->next::method(@_) if not defined $value or not defined $type; + + if (my $key = List::Util::first { $type =~ /$_/i } keys %noquote) { + return 1 if $noquote{$key}->($value); + } + elsif ($self->is_datatype_numeric($type) && $number->($value)) { + return 1; + } + + return $self->next::method(@_); +} + +sub _prep_interpolated_value { + my ($self, $type, $value) = @_; + + if ($type =~ /money/i && defined $value) { + # change a ^ not followed by \$ to a \$ + $value =~ s/^ (?! \$) /\$/x; + } + + return $value; +} + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::Sybase::NoBindVars - Storage::DBI subclass for Sybase +without placeholder support + +=head1 DESCRIPTION + +If you're using this driver than your version of Sybase, or the libraries you +use to connect to it, do not support placeholders. + +You can also enable this driver explicitly using: + + my $schema = SchemaClass->clone; + $schema->storage_type('::DBI::Sybase::NoBindVars'); + $schema->connect($dsn, $user, $pass, \%opts); + +See the discussion in L<< DBD::Sybase/Using ? Placeholders & bind parameters to +$sth->execute >> for details on the pros and cons of using placeholders. + +One advantage of not using placeholders is that C in a transaction as the base Sybase driver does. + +When using this driver, bind variables will be interpolated (properly quoted of +course) into the SQL query itself, without using placeholders. + +The caching of prepared statements is also explicitly disabled, as the +interpolation renders it useless. + +=head1 AUTHORS + +See L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut +# vim:sts=2 sw=2: diff --git a/t/746mssql.t b/t/746mssql.t index a75001e..f120c12 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -143,14 +143,11 @@ $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE money_test") }; $dbh->do(<<'SQL'); - CREATE TABLE money_test ( id INT IDENTITY PRIMARY KEY, amount MONEY NULL ) - SQL - }); my $rs = $schema->resultset('Money'); diff --git a/t/746sybase.t b/t/746sybase.t index 9fc87f0..7e5696a 100644 --- a/t/746sybase.t +++ b/t/746sybase.t @@ -1,91 +1,365 @@ use strict; use warnings; +no warnings 'uninitialized'; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; +use DBIx::Class::Storage::DBI::Sybase; +use DBIx::Class::Storage::DBI::Sybase::NoBindVars; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/}; -plan skip_all => 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test' - unless ($dsn && $user); +my $TESTS = 39 + 2; -plan tests => 13; +if (not ($dsn && $user)) { + plan skip_all => + 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test' . + "\nWarning: This test drops and creates the tables " . + "'artist' and 'bindtype_test'"; +} else { + plan tests => $TESTS*2 + 1; +} + +my @storage_types = ( + 'DBI::Sybase', + 'DBI::Sybase::NoBindVars', +); +my $schema; +my $storage_idx = -1; + +sub get_schema { + DBICTest::Schema->connect($dsn, $user, $pass, { + on_connect_call => [ + [ blob_setup => log_on_update => 1 ], # this is a safer option + ], + }); +} + +my $ping_count = 0; +{ + my $ping = DBIx::Class::Storage::DBI::Sybase->can('_ping'); + *DBIx::Class::Storage::DBI::Sybase::_ping = sub { + $ping_count++; + goto $ping; + }; +} + +for my $storage_type (@storage_types) { + $storage_idx++; + + unless ($storage_type eq 'DBI::Sybase') { # autodetect + DBICTest::Schema->storage_type("::$storage_type"); + } -my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1}); + $schema = get_schema(); -# start disconnected to test reconnection -$schema->storage->ensure_connected; -$schema->storage->_dbh->disconnect; + $schema->storage->ensure_connected; -isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::Sybase' ); + if ($storage_idx == 0 && + $schema->storage->isa('DBIx::Class::Storage::DBI::Sybase::NoBindVars')) { +# no placeholders in this version of Sybase or DBD::Sybase (or using FreeTDS) + my $tb = Test::More->builder; + $tb->skip('no placeholders') for 1..$TESTS; + next; + } -my $dbh; -lives_ok (sub { - $dbh = $schema->storage->dbh; -}, 'reconnect works'); + isa_ok( $schema->storage, "DBIx::Class::Storage::$storage_type" ); -$schema->storage->dbh_do (sub { - my ($storage, $dbh) = @_; - eval { $dbh->do("DROP TABLE artist") }; - $dbh->do(<<'SQL'); + $schema->storage->_dbh->disconnect; + lives_ok (sub { $schema->storage->dbh }, 'reconnect works'); + $schema->storage->dbh_do (sub { + my ($storage, $dbh) = @_; + eval { $dbh->do("DROP TABLE artist") }; + $dbh->do(<<'SQL'); CREATE TABLE artist ( - artistid INT IDENTITY NOT NULL, + artistid INT IDENTITY PRIMARY KEY, name VARCHAR(100), rank INT DEFAULT 13 NOT NULL, - charfield CHAR(10) NULL, - primary key(artistid) + charfield CHAR(10) NULL ) - SQL + }); -}); - -my %seen_id; + my %seen_id; -# fresh $schema so we start unconnected -$schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1}); +# so we start unconnected + $schema->storage->disconnect; # test primary key handling -my $new = $schema->resultset('Artist')->create({ name => 'foo' }); -ok($new->artistid > 0, "Auto-PK worked"); + my $new = $schema->resultset('Artist')->create({ name => 'foo' }); + ok($new->artistid > 0, "Auto-PK worked"); -$seen_id{$new->artistid}++; + $seen_id{$new->artistid}++; -# test LIMIT support -for (1..6) { +# check redispatch to storage-specific insert when auto-detected storage + if ($storage_type eq 'DBI::Sybase') { + DBICTest::Schema->storage_type('::DBI'); + $schema = get_schema(); + } + + $new = $schema->resultset('Artist')->create({ name => 'Artist 1' }); + is ( $seen_id{$new->artistid}, undef, 'id for Artist 1 is unique' ); + $seen_id{$new->artistid}++; + +# inserts happen in a txn, so we make sure it still works inside a txn too + $schema->txn_begin; + + for (2..6) { $new = $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); is ( $seen_id{$new->artistid}, undef, "id for Artist $_ is unique" ); $seen_id{$new->artistid}++; -} + } + + $schema->txn_commit; -my $it; +# test simple count + is ($schema->resultset('Artist')->count, 7, 'count(*) of whole table ok'); -$it = $schema->resultset('Artist')->search( {}, { +# test LIMIT support + my $it = $schema->resultset('Artist')->search({ + artistid => { '>' => 0 } + }, { rows => 3, order_by => 'artistid', -}); + }); -TODO: { - local $TODO = 'Sybase is very very fucked in the limit department'; + is( $it->count, 3, "LIMIT count ok" ); - is( $it->count, 3, "LIMIT count ok" ); -} + is( $it->next->name, "foo", "iterator->next ok" ); + $it->next; + is( $it->next->name, "Artist 2", "iterator->next ok" ); + is( $it->next, undef, "next past end of resultset ok" ); + +# now try with offset + $it = $schema->resultset('Artist')->search({}, { + rows => 3, + offset => 3, + order_by => 'artistid', + }); + + is( $it->count, 3, "LIMIT with offset count ok" ); + + is( $it->next->name, "Artist 3", "iterator->next ok" ); + $it->next; + is( $it->next->name, "Artist 5", "iterator->next ok" ); + is( $it->next, undef, "next past end of resultset ok" ); + +# now try a grouped count + $schema->resultset('Artist')->create({ name => 'Artist 6' }) + for (1..6); + + $it = $schema->resultset('Artist')->search({}, { + group_by => 'name' + }); + + is( $it->count, 7, 'COUNT of GROUP_BY ok' ); + +# do an identity insert (which should happen with no txn when using +# placeholders.) + { + no warnings 'redefine'; + + my @debug_out; + local $schema->storage->{debug} = 1; + local $schema->storage->debugobj->{callback} = sub { + push @debug_out, $_[1]; + }; + + my $txn_used = 0; + my $txn_commit = \&DBIx::Class::Storage::DBI::txn_commit; + local *DBIx::Class::Storage::DBI::txn_commit = sub { + $txn_used = 1; + goto &$txn_commit; + }; + + $schema->resultset('Artist') + ->create({ artistid => 999, name => 'mtfnpy' }); + + ok((grep /IDENTITY_INSERT/i, @debug_out), 'IDENTITY_INSERT'); + + SKIP: { + skip 'not testing lack of txn on IDENTITY_INSERT with NoBindVars', 1 + if $storage_type =~ /NoBindVars/i; -# The iterator still works correctly with rows => 3, even though the sql is -# fucked, very interesting. + is $txn_used, 0, 'no txn on insert with IDENTITY_INSERT'; + } + } -is( $it->next->name, "foo", "iterator->next ok" ); -$it->next; -is( $it->next->name, "Artist 2", "iterator->next ok" ); -is( $it->next, undef, "next past end of resultset ok" ); +# test correlated subquery + my $subq = $schema->resultset('Artist')->search({ artistid => { '>' => 3 } }) + ->get_column('artistid') + ->as_query; + my $subq_rs = $schema->resultset('Artist')->search({ + artistid => { -in => $subq } + }); + is $subq_rs->count, 11, 'correlated subquery'; +# mostly stolen from the blob stuff Nniuq wrote for t/73oracle.t + SKIP: { + skip 'TEXT/IMAGE support does not work with FreeTDS', 12 + if $schema->storage->using_freetds; + + my $dbh = $schema->storage->_dbh; + { + local $SIG{__WARN__} = sub {}; + eval { $dbh->do('DROP TABLE bindtype_test') }; + + $dbh->do(qq[ + CREATE TABLE bindtype_test + ( + id INT IDENTITY PRIMARY KEY, + bytea INT NULL, + blob IMAGE NULL, + clob TEXT NULL + ) + ],{ RaiseError => 1, PrintError => 0 }); + } + + my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); + $binstr{'large'} = $binstr{'small'} x 1024; + + my $maxloblen = length $binstr{'large'}; + + if (not $schema->storage->using_freetds) { + $dbh->{'LongReadLen'} = $maxloblen * 2; + } else { + $dbh->do("set textsize ".($maxloblen * 2)); + } + + my $rs = $schema->resultset('BindType'); + my $last_id; + + foreach my $type (qw(blob clob)) { + foreach my $size (qw(small large)) { + no warnings 'uninitialized'; + + my $created = eval { $rs->create( { $type => $binstr{$size} } ) }; + ok(!$@, "inserted $size $type without dying"); + diag $@ if $@; + + $last_id = $created->id if $created; + + my $got = eval { + $rs->find($last_id)->$type + }; + diag $@ if $@; + ok($got eq $binstr{$size}, "verified inserted $size $type"); + } + } + + # blob insert with explicit PK + # also a good opportunity to test IDENTITY_INSERT + { + local $SIG{__WARN__} = sub {}; + eval { $dbh->do('DROP TABLE bindtype_test') }; + + $dbh->do(qq[ + CREATE TABLE bindtype_test + ( + id INT IDENTITY PRIMARY KEY, + bytea INT NULL, + blob IMAGE NULL, + clob TEXT NULL + ) + ],{ RaiseError => 1, PrintError => 0 }); + } + my $created = eval { $rs->create( { id => 1, blob => $binstr{large} } ) }; + ok(!$@, "inserted large blob without dying with manual PK"); + diag $@ if $@; + + my $got = eval { + $rs->find(1)->blob + }; + diag $@ if $@; + ok($got eq $binstr{large}, "verified inserted large blob with manual PK"); + + # try a blob update + my $new_str = $binstr{large} . 'mtfnpy'; + + # check redispatch to storage-specific update when auto-detected storage + if ($storage_type eq 'DBI::Sybase') { + DBICTest::Schema->storage_type('::DBI'); + $schema = get_schema(); + } + + eval { $rs->search({ id => 1 })->update({ blob => $new_str }) }; + ok !$@, 'updated blob successfully'; + diag $@ if $@; + $got = eval { + $rs->find(1)->blob + }; + diag $@ if $@; + ok($got eq $new_str, "verified updated blob"); + } + +# test MONEY column support + $schema->storage->dbh_do (sub { + my ($storage, $dbh) = @_; + eval { $dbh->do("DROP TABLE money_test") }; + $dbh->do(<<'SQL'); +CREATE TABLE money_test ( + id INT IDENTITY PRIMARY KEY, + amount MONEY NULL +) +SQL + }); + +# test insert transaction when there's an active cursor + TODO: { +# local $TODO = 'not supported yet or possibly ever'; + + SKIP: { + skip 'not testing insert with active cursor if using unsafe_insert', 1 + if $schema->storage->unsafe_insert; + + my $artist_rs = $schema->resultset('Artist'); + $artist_rs->first; + lives_ok { + my $row = $schema->resultset('Money')->create({ amount => 100 }); + $row->delete; + } 'inserted a row with an active cursor'; + $ping_count-- if $@; # dbh_do calls ->connected + } + } + +# Now test money values. + my $rs = $schema->resultset('Money'); + + my $row; + lives_ok { + $row = $rs->create({ amount => 100 }); + } 'inserted a money value'; + + is eval { $rs->find($row->id)->amount }, 100, 'money value round-trip'; + + lives_ok { + $row->update({ amount => 200 }); + } 'updated a money value'; + + is eval { $rs->find($row->id)->amount }, + 200, 'updated money value round-trip'; + + lives_ok { + $row->update({ amount => undef }); + } 'updated a money value to NULL'; + + my $null_amount = eval { $rs->find($row->id)->amount }; + ok( + (($null_amount == undef) && (not $@)), + 'updated money value to NULL round-trip' + ); + diag $@ if $@; +} + +is $ping_count, 0, 'no pings'; # clean up our mess END { - my $dbh = eval { $schema->storage->_dbh }; - $dbh->do('DROP TABLE artist') if $dbh; + if (my $dbh = eval { $schema->storage->_dbh }) { + eval { $dbh->do("DROP TABLE $_") } + for qw/artist bindtype_test money_test/; + } } - diff --git a/t/inflate/datetime_sybase.t b/t/inflate/datetime_sybase.t new file mode 100644 index 0000000..24d0f07 --- /dev/null +++ b/t/inflate/datetime_sybase.t @@ -0,0 +1,85 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; +use lib qw(t/lib); +use DBICTest; + +my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/}; + +if (not ($dsn && $user)) { + plan skip_all => + 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test' . + "\nWarning: This test drops and creates a table called 'track'"; +} else { + eval "use DateTime; use DateTime::Format::Sybase;"; + if ($@) { + plan skip_all => 'needs DateTime and DateTime::Format::Sybase for testing'; + } + else { + plan tests => (4 * 2 * 2) + 2; # (tests * dt_types * storage_types) + storage_tests + } +} + +my @storage_types = ( + 'DBI::Sybase', + 'DBI::Sybase::NoBindVars', +); +my $schema; + +for my $storage_type (@storage_types) { + $schema = DBICTest::Schema->clone; + + unless ($storage_type eq 'DBI::Sybase') { # autodetect + $schema->storage_type("::$storage_type"); + } + $schema->connection($dsn, $user, $pass, { + AutoCommit => 1, + on_connect_call => [ 'datetime_setup' ], + }); + + $schema->storage->ensure_connected; + + isa_ok( $schema->storage, "DBIx::Class::Storage::$storage_type" ); + +# coltype, col, date + my @dt_types = ( + ['DATETIME', 'last_updated_at', '2004-08-21T14:36:48.080Z'], +# minute precision + ['SMALLDATETIME', 'small_dt', '2004-08-21T14:36:00.000Z'], + ); + + for my $dt_type (@dt_types) { + my ($type, $col, $sample_dt) = @$dt_type; + + eval { $schema->storage->dbh->do("DROP TABLE track") }; + $schema->storage->dbh->do(<<"SQL"); +CREATE TABLE track ( + trackid INT IDENTITY PRIMARY KEY, + cd INT, + position INT, + $col $type, +) +SQL + ok(my $dt = DateTime::Format::Sybase->parse_datetime($sample_dt)); + + my $row; + ok( $row = $schema->resultset('Track')->create({ + $col => $dt, + cd => 1, + })); + ok( $row = $schema->resultset('Track') + ->search({ trackid => $row->trackid }, { select => [$col] }) + ->first + ); + is( $row->$col, $dt, 'DateTime roundtrip' ); + } +} + +# clean up our mess +END { + if (my $dbh = eval { $schema->storage->_dbh }) { + $dbh->do('DROP TABLE track'); + } +} diff --git a/t/lib/sqlite.sql b/t/lib/sqlite.sql index a160193..888ccd0 100644 --- a/t/lib/sqlite.sql +++ b/t/lib/sqlite.sql @@ -1,5 +1,3 @@ --- --- Created by SQL::Translator::Producer::SQLite -- Created on Tue Aug 25 12:34:34 2009 --