From: Rafael Kitover <rkitover@cpan.org>
Date: Fri, 17 Jul 2009 21:30:13 +0000 (+0000)
Subject: some compatibility updated for older DBD::Sybase versions, some initial work on _sele... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5703eb149893635ad29b0a22c72700f61a2653dd;p=dbsrgits%2FDBIx-Class-Historic.git

some compatibility updated for older DBD::Sybase versions, some initial work on _select_args for blobs
---

diff --git a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm
index 16b4aa3..9424d45 100644
--- a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm
+++ b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm
@@ -57,7 +57,7 @@ sub _prep_for_execute {
     my $name_sep   = $self->_sql_maker_opts->{name_sep} || '.';
 
     $col =~ s/^([^\Q${name_sep}\E]*)\Q${name_sep}\E//;
-    my $alias = $1 || 'me';
+    my $alias = $1 || $rs_alias;
 
     my $rsrc = $alias2src->{$alias};
 
diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm
index cc8a0cc..2f27688 100644
--- a/lib/DBIx/Class/Storage/DBI/Sybase.pm
+++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm
@@ -31,6 +31,9 @@ without doing a C<select max(col)>.
 
 But your queries will be cached.
 
+You need at least version C<1.09> of L<DBD::Sybase> for placeholder support.
+Otherwise your storage will be automatically reblessed into C<::NoBindVars>.
+
 A recommended L<DBIx::Class::Storage::DBI/connect_info> settings:
 
   on_connect_call => [['datetime_setup'], [blob_setup => log_on_update => 0]]
@@ -58,11 +61,28 @@ sub _rebless {
     if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
       bless $self, $subclass;
       $self->_rebless;
-    } else {
-      # real Sybase
+    } else { # real Sybase
+      my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
+
       if (not $self->dbh->{syb_dynamic_supported}) {
-        $self->ensure_class_loaded('DBIx::Class::Storage::DBI::Sybase::NoBindVars');
-        bless $self, 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
+        $self->ensure_class_loaded($no_bind_vars);
+        bless $self, $no_bind_vars;
+        $self->_rebless;
+      }
+      
+      if ($DBD::Sybase::VERSION < 1.09) {
+        carp <<'EOF';
+
+Your version of Sybase potentially supports placeholders and query caching,
+however your version of DBD::Sybase is too old to do this properly. Please
+upgrade to at least version 1.09 if you want this feature.
+
+TEXT/IMAGE column support will also not work in older versions of DBD::Sybase.
+
+See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
+EOF
+        $self->ensure_class_loaded($no_bind_vars);
+        bless $self, $no_bind_vars;
         $self->_rebless;
       }
       $self->_set_maxConnect;
@@ -116,9 +136,56 @@ sub connect_call_blob_setup {
 
 sub _is_lob_type {
   my $self = shift;
-  shift =~ /(?:text|image|lob|bytea|binary)/i;
+  my $type = shift;
+  $type && $type =~ /(?:text|image|lob|bytea|binary)/i;
 }
 
+# Move TEXT/IMAGE column to the end of select list, and make sure there is only
+# one.
+#
+# work in progress
+#
+# * column indexes need to be fixed if @$select is reordered, not sure if that's
+# possible
+# * needs to handle hashrefs
+# * for some reason tests pass without this, even though documentation says
+# blobs should be at the end of the select list
+# * needs to at least croak for multiple blobs
+#
+#sub _select_args {
+#  my ($self, $ident, $select) = splice @_, 0, 3;
+#
+#  my ($alias2src, $rs_alias) = $self->_resolve_ident_sources($ident);
+#  my $name_sep = $self->_sql_maker_opts->{name_sep} || '.';
+#
+#  my (@non_blobs, @blobs);
+#
+#  for my $col (@$select) {
+#    if (ref $col) {
+## XXX should handle hashrefs too
+#      push @non_blobs, $col;
+#      next;
+#    }
+#
+#    $col =~ s/^([^\Q${name_sep}\E]*)\Q${name_sep}\E//;
+#    my $alias    = $1 || $rs_alias;
+#    my $rsrc     = $alias2src->{$alias};
+#    my $datatype = $rsrc && $rsrc->column_info($col)->{data_type};
+# 
+#    if ($self->_is_lob_type($datatype)) {
+#      push @blobs, $col;
+#    } else {
+#      push @non_blobs, $col;
+#    }
+#  }
+#
+#  croak "cannot select more than a one TEXT/IMAGE column"
+#    if @blobs > 1;
+#
+#  $self->next::method($ident, [@non_blobs, @blobs], @_);
+#}
+
+# override to handle TEXT/IMAGE
 sub insert {
   my ($self, $source, $to_insert) = splice @_, 0, 3;
 
@@ -305,11 +372,17 @@ for L<DBIx::Class::InflateColumn::DateTime>.
 
 =head1 IMAGE AND TEXT COLUMNS
 
+You need at least version C<1.09> of L<DBD::Sybase> for C<TEXT/IMAGE> column
+support.
+
 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 setting you need to work with C<IMAGE> columns.
 
 Due to limitations in L<DBD::Sybase> and this driver, it is only possible to
-select one C<TEXT> or C<IMAGE> column at a time.
+select one C<TEXT> or C<IMAGE> column at a time. This is handled automatically
+for tables with only one such column, if you have more than one, supply a
+C<< select => [qw/col list .../] >> key to your C<< ->search >> calls, with the
+single desired C<TEXT/IMAGE> column at the end of the list.
 
 =head1 AUTHORS
 
diff --git a/t/746sybase.t b/t/746sybase.t
index f82e3e6..2d0132a 100644
--- a/t/746sybase.t
+++ b/t/746sybase.t
@@ -9,13 +9,15 @@ use DBICTest;
 
 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/};
 
+my $TESTS = 31 + 2;
+
 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 => (29 + 2)*2;
+  plan tests => $TESTS*2;
 }
 
 my @storage_types = (
@@ -23,8 +25,10 @@ my @storage_types = (
   'DBI::Sybase::NoBindVars',
 );
 my $schema;
+my $storage_idx = -1;
 
 for my $storage_type (@storage_types) {
+  $storage_idx++;
   $schema = DBICTest::Schema->clone;
 
   unless ($storage_type eq 'DBI::Sybase') { # autodetect
@@ -40,6 +44,14 @@ for my $storage_type (@storage_types) {
   $schema->storage->ensure_connected;
   $schema->storage->_dbh->disconnect;
 
+  if ($storage_idx == 0 &&
+      $schema->storage->isa('DBIx::Class::Storage::DBI::Sybase::NoBindVars')) {
+# no placeholders in this version of Sybase or DBD::Sybase
+      my $tb = Test::More->builder;
+      $tb->skip('no placeholders') for 1..$TESTS;
+      next;
+  }
+
   isa_ok( $schema->storage, "DBIx::Class::Storage::$storage_type" );
 
   lives_ok (sub { $schema->storage->dbh }, 'reconnect works');
@@ -116,95 +128,127 @@ SQL
 
   is( $it->count, 7, 'COUNT of GROUP_BY ok' );
 
-# mostly stole the blob stuff Nniuq wrote for t/73oracle.t
-  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 });
-  }
+# mostly stolen from the blob stuff Nniuq wrote for t/73oracle.t
+  SKIP: {
+    skip 'Need at least version 1.09 of DBD::Sybase to test TEXT/IMAGE', 14
+        unless $DBD::Sybase::VERSION >= 1.09;
+
+    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 %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+    $binstr{'large'} = $binstr{'small'} x 1024;
 
-  my $maxloblen = length $binstr{'large'};
-  note "Localizing LongReadLen to $maxloblen to avoid truncation of test data";
-  local $dbh->{'LongReadLen'} = $maxloblen;
+    my $maxloblen = length $binstr{'large'};
+    note
+      "Localizing LongReadLen to $maxloblen to avoid truncation of test data";
+    local $dbh->{'LongReadLen'} = $maxloblen;
 
-  my $rs = $schema->resultset('BindType');
-  my $last_id;
+    my $rs = $schema->resultset('BindType');
+    my $last_id;
 
-  foreach my $type (qw(blob clob)) {
-    foreach my $size (qw(small large)) {
-      no warnings 'uninitialized';
+    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 $@;
+        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->search({ id => $last_id }, { select => [$type] })->single->$type
+        };
+        diag $@ if $@;
+        ok($got eq $binstr{$size}, "verified inserted $size $type");
+      }
+    }
 
-      $last_id = $created->id if $created;
+    # try a blob update
+    TODO: {
+      local $TODO = 'updating TEXT/IMAGE does not work yet';
 
-      my $got = eval {
-        $rs->search({ id => $last_id }, { select => [$type] })->single->$type
-      };
+      my $new_str = $binstr{large} . 'foo';
+      eval { $rs->search({ id => $last_id })->update({ blob => $new_str }) };
+      ok !$@, 'updated blob successfully';
+      diag $@ if $@;
+      ok(eval {
+        $rs->search({ id => $last_id }, { select => ['blob'] })->single->blob
+      } eq $new_str, "verified updated blob" );
       diag $@ if $@;
-      ok($got eq $binstr{$size}, "verified inserted $size $type");
     }
-  }
 
-  # try a blob update
-  TODO: {
-    local $TODO = 'updating TEXT/IMAGE does not work yet';
+    # blob insert with explicit PK
+    {
+      local $SIG{__WARN__} = sub {};
+      eval { $dbh->do('DROP TABLE bindtype_test') };
+
+      $dbh->do(qq[
+        CREATE TABLE bindtype_test 
+        (
+          id    INT   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");
+    diag $@ if $@;
 
-    my $new_str = $binstr{large} . 'foo';
-    eval { $rs->search({ id => $last_id })->update({ blob => $new_str }) };
-    ok !$@, 'updated blob successfully';
+    my $got = eval {
+      $rs->search({ id => 1 }, { select => ['blob'] })->single->blob
+    };
     diag $@ if $@;
-    ok(eval {
-      $rs->search({ id => $last_id }, { select => ['blob'] })->single->blob
-    } eq $new_str, "verified updated blob" );
+    ok($got eq $binstr{large}, "verified inserted large blob");
+
+    # Test select args ordering on a ->find for a table with one blob
+    {
+      local $SIG{__WARN__} = sub {};
+      eval { $dbh->do('DROP TABLE single_blob_test') };
+
+      $dbh->do(qq[
+        CREATE TABLE single_blob_test 
+        (
+          id    INT   IDENTITY PRIMARY KEY,
+          blob  IMAGE NULL,
+          foo VARCHAR(256) NULL
+        )
+      ],{ RaiseError => 1, PrintError => 0 });
+    }
+    $rs = $schema->resultset('SingleBlob');
+    $created = eval { $rs->create({
+      blob => $binstr{large}, foo => 'dummy'
+    }) };
+    ok(!$@, "inserted single large blob without dying");
     diag $@ if $@;
-  }
 
-  # blob insert with explicit PK
-  {
-    local $SIG{__WARN__} = sub {};
-    eval { $dbh->do('DROP TABLE bindtype_test') };
-
-    $dbh->do(qq[
-      CREATE TABLE bindtype_test 
-      (
-        id    INT   PRIMARY KEY,
-        bytea INT   NULL,
-        blob  IMAGE NULL,
-        clob  TEXT  NULL
-      )
-    ],{ RaiseError => 1, PrintError => 0 });
+    $got = eval { $rs->find($created->id)->blob };
+    diag $@ if $@;
+    ok($got eq $binstr{large}, "verified inserted large blob through ->find");
   }
-  my $created = eval { $rs->create( { id => 1, blob => $binstr{large} } ) };
-  ok(!$@, "inserted large blob without dying");
-  diag $@ if $@;
-
-  my $got = eval {
-    $rs->search({ id => 1 }, { select => ['blob'] })->single->blob
-  };
-  diag $@ if $@;
-  ok($got eq $binstr{large}, "verified inserted large blob");
 }
 
 # clean up our mess
 END {
   if (my $dbh = eval { $schema->storage->_dbh }) {
     $dbh->do('DROP TABLE artist');
-    $dbh->do('DROP TABLE bindtype_test');
+    eval { $dbh->do('DROP TABLE bindtype_test')    };
+    eval { $dbh->do('DROP TABLE single_blob_test') };
   }
 }
diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm
index b03d090..8072617 100644
--- a/t/lib/DBICTest/Schema.pm
+++ b/t/lib/DBICTest/Schema.pm
@@ -9,6 +9,7 @@ __PACKAGE__->load_classes(qw/
   Artist
   SequenceTest
   BindType
+  SingleBlob
   Employee
   CD
   FileColumn
diff --git a/t/lib/DBICTest/Schema/SingleBlob.pm b/t/lib/DBICTest/Schema/SingleBlob.pm
new file mode 100644
index 0000000..2818d33
--- /dev/null
+++ b/t/lib/DBICTest/Schema/SingleBlob.pm
@@ -0,0 +1,25 @@
+package # hide from PAUSE 
+    DBICTest::Schema::SingleBlob;
+
+use base qw/DBICTest::BaseResult/;
+
+__PACKAGE__->table('single_blob_test');
+
+__PACKAGE__->add_columns(
+  'id' => {
+    data_type => 'integer',
+    is_auto_increment => 1,
+  },
+  'blob' => {
+    data_type => 'blob',
+    is_nullable => 1,
+  },
+  'foo' => {
+    data_type => 'varchar',
+    is_nullable => 1,
+  }
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;