Merge 'trunk' into 'storage-interbase'
Rafael Kitover [Mon, 22 Feb 2010 11:15:16 +0000 (11:15 +0000)]
r23356@hlagh (orig r8756):  caelum | 2010-02-19 06:21:53 -0500
bump Test::Pod dep
r23357@hlagh (orig r8757):  caelum | 2010-02-19 06:23:07 -0500
bump Test::Pod dep in Optional::Dependencies too
r23380@hlagh (orig r8760):  ribasushi | 2010-02-19 10:40:18 -0500
Fix stupid sqlt parser regression
r23381@hlagh (orig r8761):  ribasushi | 2010-02-19 10:41:36 -0500
Port remaining tests to the Opt::Dep reposiory
r23382@hlagh (orig r8762):  ribasushi | 2010-02-19 10:42:32 -0500
Some test cleanups
r23387@hlagh (orig r8767):  ribasushi | 2010-02-20 14:57:59 -0500
Test::Deep actually isn't required
r23393@hlagh (orig r8773):  ribasushi | 2010-02-20 16:20:22 -0500
These are core for perl 5.8
r23394@hlagh (orig r8774):  ribasushi | 2010-02-21 04:51:13 -0500
Shuffle tests a bit
r23395@hlagh (orig r8775):  ribasushi | 2010-02-21 06:07:58 -0500
Bogus require
r23396@hlagh (orig r8776):  ribasushi | 2010-02-21 06:08:21 -0500
Bogus unnecessary dep
r23407@hlagh (orig r8787):  ribasushi | 2010-02-21 07:37:53 -0500
 r8748@Thesaurus (orig r8735):  goraxe | 2010-02-17 23:17:15 +0100
 branch for dbicadmin pod fixes

 r8778@Thesaurus (orig r8765):  goraxe | 2010-02-20 20:35:00 +0100
 add G:L:D sub classes to generate pod
 r8779@Thesaurus (orig r8766):  goraxe | 2010-02-20 20:56:16 +0100
 dbicadmin: use subclassed G:L:D to generate some pod
 r8782@Thesaurus (orig r8769):  goraxe | 2010-02-20 21:48:29 +0100
 adjust Makefile.pl to generate dbicadmin.pod
 r8783@Thesaurus (orig r8770):  goraxe | 2010-02-20 21:50:55 +0100
 add svn-ignore for dbicadmin.pod
 r8784@Thesaurus (orig r8771):  goraxe | 2010-02-20 22:01:41 +0100
 change Options to Arguments
 r8785@Thesaurus (orig r8772):  goraxe | 2010-02-20 22:10:29 +0100
 add DBIx::Class::Admin::{Descriptive,Usage} to podcover ignore list
 r8790@Thesaurus (orig r8777):  rabbit | 2010-02-21 12:35:38 +0100
 Cleanup the makefile regen a bit
 r8792@Thesaurus (orig r8779):  rabbit | 2010-02-21 12:53:01 +0100
 Bah humbug
 r8793@Thesaurus (orig r8780):  rabbit | 2010-02-21 12:55:18 +0100
 And another one
 r8797@Thesaurus (orig r8784):  rabbit | 2010-02-21 13:32:03 +0100
 The minimal pod seems to confuse the manpage generator, commenting out for now
 r8798@Thesaurus (orig r8785):  rabbit | 2010-02-21 13:38:03 +0100
 Add license/author to dbicadmin autogen POD
 r8799@Thesaurus (orig r8786):  rabbit | 2010-02-21 13:38:58 +0100
 Reorder makefile author actions to make output more readable

r23410@hlagh (orig r8790):  ribasushi | 2010-02-21 08:24:15 -0500
Fix exception text
r23411@hlagh (orig r8791):  ribasushi | 2010-02-21 09:14:58 -0500
Extra testdep

lib/DBIx/Class/Row.pm
lib/DBIx/Class/SQLAHacks.pm
lib/DBIx/Class/Storage/DBI.pm
lib/DBIx/Class/Storage/DBI/InterBase.pm [new file with mode: 0644]
lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm [new file with mode: 0644]
t/750firebird.t [new file with mode: 0644]
t/inflate/datetime_firebird.t [new file with mode: 0644]
t/lib/DBICTest/Schema.pm
t/lib/DBICTest/Schema/BindType2.pm [new file with mode: 0644]
t/lib/DBICTest/Schema/Event.pm
t/lib/sqlite.sql

index a397ceb..bace837 100644 (file)
@@ -347,6 +347,26 @@ sub insert {
     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
   }
 
+  # get non-PK auto-incs
+  {
+    my $rsrc = $self->result_source;
+    my %pk;
+    @pk{ $rsrc->primary_columns } = (); 
+
+    my @non_pk_autoincs = grep {
+      (not exists $pk{$_})
+      && (not defined $self->get_column($_))
+      && $rsrc->column_info($_)->{is_auto_increment}
+    } $rsrc->columns;
+
+    if (@non_pk_autoincs) {
+      my @ids = $rsrc->storage->last_insert_id($rsrc, @non_pk_autoincs);
+
+      if (@ids == @non_pk_autoincs) {
+        $self->store_column($non_pk_autoincs[$_] => $ids[$_]) for 0 .. $#ids;
+      }
+    }
+  }
 
   $self->{_dirty_columns} = {};
   $self->{related_resultsets} = {};
index 5c374b0..13f0d97 100644 (file)
@@ -102,6 +102,24 @@ sub _SkipFirst {
   );
 }
 
+# Firebird specific limit, reverse of _SkipFirst for Informix
+sub _FirstSkip {
+  my ($self, $sql, $order, $rows, $offset) = @_;
+
+  $sql =~ s/^ \s* SELECT \s+ //ix
+    or croak "Unrecognizable SELECT: $sql";
+
+  return sprintf ('SELECT %s%s%s%s',
+    sprintf ('FIRST %d ', $rows),
+    $offset
+      ? sprintf ('SKIP %d ', $offset)
+      : ''
+    ,
+    $sql,
+    $self->_order_by ($order),
+  );
+}
+
 # Crappy Top based Limit/Offset support. Legacy from MSSQL.
 sub _Top {
   my ( $self, $sql, $order, $rows, $offset ) = @_;
index d56cd44..4eaefc0 100644 (file)
@@ -1513,7 +1513,11 @@ sub _execute_array {
 
     my @data = map { $_->[$data_index] } @$data;
 
-    $sth->bind_param_array( $placeholder_index, [@data], $attributes );
+    $sth->bind_param_array(
+      $placeholder_index,
+      [@data],
+      (%$attributes ?  $attributes : ()),
+    );
     $placeholder_index++;
   }
 
diff --git a/lib/DBIx/Class/Storage/DBI/InterBase.pm b/lib/DBIx/Class/Storage/DBI/InterBase.pm
new file mode 100644 (file)
index 0000000..085da6e
--- /dev/null
@@ -0,0 +1,284 @@
+package DBIx::Class::Storage::DBI::InterBase;
+
+# partly stolen from DBIx::Class::Storage::DBI::MSSQL
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+use List::Util();
+
+__PACKAGE__->mk_group_accessors(simple => qw/
+  _auto_incs
+/);
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::InterBase - Driver for the Firebird RDBMS
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for Firebird using C<RETURNING>, sets the
+limit dialect to C<FIRST X SKIP X> and provides preliminary
+L<DBIx::Class::InflateColumn::DateTime> support.
+
+For ODBC support, see L<DBIx::Class::Storage::DBI::ODBC::Firebird>.
+
+To turn on L<DBIx::Class::InflateColumn::DateTime> support, see
+L</connect_call_datetime_setup>.
+
+=cut
+
+sub _prep_for_execute {
+  my $self = shift;
+  my ($op, $extra_bind, $ident, $args) = @_;
+
+  if ($op eq 'insert') {
+    my @pk = $ident->_pri_cols;
+    my %pk;
+    @pk{@pk} = ();
+
+    my @auto_inc_cols = grep {
+      my $inserting = $args->[0]{$_};
+
+      ($ident->column_info($_)->{is_auto_increment}
+        || exists $pk{$_})
+      && (
+        (not defined $inserting)
+        ||
+        (ref $inserting eq 'SCALAR' && $$inserting =~ /^null\z/i)
+      )
+    } $ident->columns;
+
+    if (@auto_inc_cols) {
+      $args->[1]{returning} = \@auto_inc_cols;
+
+      $self->_auto_incs([]);
+      $self->_auto_incs->[0] = \@auto_inc_cols;
+    }
+  }
+
+  return $self->next::method(@_);
+}
+
+sub _execute {
+  my $self = shift;
+  my ($op) = @_;
+
+  my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
+
+  if ($op eq 'insert' && $self->_auto_incs) {
+    local $@;
+    my (@auto_incs) = eval {
+      local $SIG{__WARN__} = sub {};
+      $sth->fetchrow_array
+    };
+    $self->_auto_incs->[1] = \@auto_incs;
+    $sth->finish;
+  }
+
+  return wantarray ? ($rv, $sth, @bind) : $rv;
+}
+
+sub last_insert_id {
+  my ($self, $source, @cols) = @_;
+  my @result;
+
+  my %auto_incs;
+  @auto_incs{ @{ $self->_auto_incs->[0] } } =
+    @{ $self->_auto_incs->[1] };
+
+  push @result, $auto_incs{$_} for @cols;
+
+  return @result;
+}
+
+# this sub stolen from DB2
+
+sub _sql_maker_opts {
+  my ( $self, $opts ) = @_;
+
+  if ( $opts ) {
+    $self->{_sql_maker_opts} = { %$opts };
+  }
+
+  return { limit_dialect => 'FirstSkip', %{$self->{_sql_maker_opts}||{}} };
+}
+
+sub _svp_begin {
+    my ($self, $name) = @_;
+
+    $self->_get_dbh->do("SAVEPOINT $name");
+}
+
+sub _svp_release {
+    my ($self, $name) = @_;
+
+    $self->_get_dbh->do("RELEASE SAVEPOINT $name");
+}
+
+sub _svp_rollback {
+    my ($self, $name) = @_;
+
+    $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
+sub _ping {
+  my $self = shift;
+
+  my $dbh = $self->_dbh or return 0;
+
+  local $dbh->{RaiseError} = 1;
+
+  eval {
+    $dbh->do('select 1 from rdb$database');
+  };
+
+  return $@ ? 0 : 1;
+}
+
+# We want dialect 3 for new features and quoting to work, DBD::InterBase uses
+# dialect 1 (interbase compat) by default.
+sub _init {
+  my $self = shift;
+  $self->_set_sql_dialect(3);
+}
+
+sub _set_sql_dialect {
+  my $self = shift;
+  my $val  = shift || 3;
+
+  my $dsn = $self->_dbi_connect_info->[0];
+
+  return if ref($dsn) eq 'CODE';
+
+  if ($dsn !~ /ib_dialect=/) {
+    $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val";
+    my $connected = defined $self->_dbh;
+    $self->disconnect;
+    $self->ensure_connected if $connected;
+  }
+}
+
+# softcommit makes savepoints work
+sub _run_connection_actions {
+  my $self = shift;
+
+  $self->_dbh->{ib_softcommit} = 1;
+
+  $self->next::method(@_);
+}
+
+=head2 connect_call_datetime_setup
+
+Used as:
+
+  on_connect_call => 'datetime_setup'
+
+In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the date and
+timestamp formats using:
+
+  $dbh->{ib_time_all} = 'ISO';
+
+See L<DBD::InterBase> for more details.
+
+The C<TIMESTAMP> data type supports up to 4 digits after the decimal point for
+second precision. The full precision is used.
+
+The C<DATE> data type stores the date portion only, and it B<MUST> be declared
+with:
+
+  data_type => 'date'
+
+in your Result class.
+
+Timestamp columns can be declared with either C<datetime> or C<timestamp>.
+
+You will need the L<DateTime::Format::Strptime> module for inflation to work.
+
+For L<DBIx::Class::Storage::DBI::ODBC::Firebird>, this is a noop and sub-second
+precision is not currently available.
+
+=cut
+
+sub connect_call_datetime_setup {
+  my $self = shift;
+
+  $self->_get_dbh->{ib_time_all} = 'ISO';
+}
+
+sub datetime_parser_type {
+  'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
+}
+
+package # hide from PAUSE
+  DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
+
+my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
+my $date_format      = '%Y-%m-%d';
+
+my ($timestamp_parser, $date_parser);
+
+sub parse_datetime {
+  shift;
+  require DateTime::Format::Strptime;
+  $timestamp_parser ||= DateTime::Format::Strptime->new(
+    pattern  => $timestamp_format,
+    on_error => 'croak',
+  );
+  return $timestamp_parser->parse_datetime(shift);
+}
+
+sub format_datetime {
+  shift;
+  require DateTime::Format::Strptime;
+  $timestamp_parser ||= DateTime::Format::Strptime->new(
+    pattern  => $timestamp_format,
+    on_error => 'croak',
+  );
+  return $timestamp_parser->format_datetime(shift);
+}
+
+sub parse_date {
+  shift;
+  require DateTime::Format::Strptime;
+  $date_parser ||= DateTime::Format::Strptime->new(
+    pattern  => $date_format,
+    on_error => 'croak',
+  );
+  return $date_parser->parse_datetime(shift);
+}
+
+sub format_date {
+  shift;
+  require DateTime::Format::Strptime;
+  $date_parser ||= DateTime::Format::Strptime->new(
+    pattern  => $date_format,
+    on_error => 'croak',
+  );
+  return $date_parser->format_datetime(shift);
+}
+
+1;
+
+=head1 CAVEATS
+
+=over 4
+
+=item *
+
+C<last_insert_id> support only works for Firebird versions 2 or greater. To
+work with earlier versions, we'll need to figure out how to retrieve the bodies
+of C<BEFORE INSERT> triggers and parse them for the C<GENERATOR> name.
+
+=back
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm
new file mode 100644 (file)
index 0000000..cb36879
--- /dev/null
@@ -0,0 +1,90 @@
+package DBIx::Class::Storage::DBI::ODBC::Firebird;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI::InterBase/;
+use mro 'c3';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ODBC::Firebird - Driver for using the Firebird RDBMS
+through ODBC
+
+=head1 SYNOPSIS
+
+Most functionality is provided by L<DBIx::Class::Storage::DBI::Interbase>, see
+that module for details.
+
+To build the ODBC driver for Firebird on Linux for unixODBC, see:
+
+L<http://www.firebirdnews.org/?p=1324>
+
+=cut
+
+# XXX seemingly no equivalent to ib_time_all from DBD::InterBase via ODBC
+sub connect_call_datetime_setup { 1 }
+
+# we don't need DBD::InterBase-specific initialization
+sub _init { 1 }
+
+# ODBC uses dialect 3 by default, good
+sub _set_sql_dialect { 1 }
+
+# releasing savepoints doesn't work, but that shouldn't matter
+sub _svp_release { 1 }
+
+sub datetime_parser_type {
+  'DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format'
+}
+
+package # hide from PAUSE
+  DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format;
+
+# inherit parse/format date
+our @ISA = 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format';
+
+my $timestamp_format = '%Y-%m-%d %H:%M:%S'; # %F %T, no fractional part
+my $timestamp_parser;
+
+sub parse_datetime {
+  shift;
+  require DateTime::Format::Strptime;
+  $timestamp_parser ||= DateTime::Format::Strptime->new(
+    pattern  => $timestamp_format,
+    on_error => 'croak',
+  );
+  return $timestamp_parser->parse_datetime(shift);
+}
+
+sub format_datetime {
+  shift;
+  require DateTime::Format::Strptime;
+  $timestamp_parser ||= DateTime::Format::Strptime->new(
+    pattern  => $timestamp_format,
+    on_error => 'croak',
+  );
+  return $timestamp_parser->format_datetime(shift);
+}
+
+1;
+
+=head1 CAVEATS
+
+=over 4
+
+=item *
+
+This driver (unlike L<DBD::InterBase>) does not currently support reading or
+writing C<TIMESTAMP> values with sub-second precision.
+
+=back
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
diff --git a/t/750firebird.t b/t/750firebird.t
new file mode 100644 (file)
index 0000000..88899a7
--- /dev/null
@@ -0,0 +1,230 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+use Scope::Guard ();
+
+# tests stolen from 749sybase_asa.t
+
+my ($dsn, $user, $pass)    = @ENV{map { "DBICTEST_FIREBIRD_${_}" }      qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_FIREBIRD_ODBC_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => <<'EOF' unless $dsn || $dsn2;
+Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},
+_USER and _PASS to run these tests
+EOF
+
+my @info = (
+  [ $dsn,  $user,  $pass  ],
+  [ $dsn2, $user2, $pass2 ],
+);
+
+my $schema;
+
+foreach my $conn_idx (0..$#info) {
+  my ($dsn, $user, $pass) = @{ $info[$conn_idx] || [] };
+
+  next unless $dsn;
+
+  $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+    auto_savepoint => 1,
+    quote_char     => q["],
+    name_sep       => q[.],
+  });
+  my $dbh = $schema->storage->dbh;
+
+  my $sg = Scope::Guard->new(\&cleanup);
+
+  eval { $dbh->do(q[DROP TABLE "artist"]) };
+  $dbh->do(<<EOF);
+  CREATE TABLE "artist" (
+    "artistid" INT PRIMARY KEY,
+    "name" VARCHAR(255),
+    "charfield" CHAR(10),
+    "rank" INT DEFAULT 13
+  )
+EOF
+  eval { $dbh->do(q[DROP GENERATOR "gen_artist_artistid"]) };
+  $dbh->do('CREATE GENERATOR "gen_artist_artistid"');
+  eval { $dbh->do('DROP TRIGGER "artist_bi"') };
+  $dbh->do(<<EOF);
+  CREATE TRIGGER "artist_bi" FOR "artist"
+  ACTIVE BEFORE INSERT POSITION 0
+  AS
+  BEGIN
+   IF (NEW."artistid" IS NULL) THEN
+    NEW."artistid" = GEN_ID("gen_artist_artistid",1);
+  END
+EOF
+
+  my $ars = $schema->resultset('Artist');
+  is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+  my $new = $ars->create({ name => 'foo' });
+  ok($new->artistid, "Auto-PK worked");
+
+# test savepoints
+  eval {
+    $schema->txn_do(sub {
+      eval {
+        $schema->txn_do(sub {
+          $ars->create({ name => 'in_savepoint' });
+          die "rolling back savepoint";
+        });
+      };
+      ok ((not $ars->search({ name => 'in_savepoint' })->first),
+        'savepoint rolled back');
+      $ars->create({ name => 'in_outer_txn' });
+      die "rolling back outer txn";
+    });
+  };
+
+  like $@, qr/rolling back outer txn/,
+    'correct exception for rollback';
+
+  ok ((not $ars->search({ name => 'in_outer_txn' })->first),
+    'outer txn rolled back');
+
+# test explicit key spec
+  $new = $ars->create ({ name => 'bar', artistid => 66 });
+  is($new->artistid, 66, 'Explicit PK worked');
+  $new->discard_changes;
+  is($new->artistid, 66, 'Explicit PK assigned');
+
+  lives_ok {
+    $new->update({ name => 'baz' })
+  } 'update survived';
+  $new->discard_changes;
+  is $new->name, 'baz', 'row updated';
+
+# test populate
+  lives_ok (sub {
+    my @pop;
+    for (1..2) {
+      push @pop, { name => "Artist_$_" };
+    }
+    $ars->populate (\@pop);
+  });
+
+# test populate with explicit key
+  lives_ok (sub {
+    my @pop;
+    for (1..2) {
+      push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+    }
+    $ars->populate (\@pop);
+  });
+
+# count what we did so far
+  is ($ars->count, 6, 'Simple count works');
+
+# test UPDATE
+  lives_and {
+    $ars->search({ name => 'foo' })->update({ rank => 4 });
+
+    is $ars->search({ name => 'foo' })->first->rank, 4;
+  } 'Can update a column';
+
+  my ($updated) = $schema->resultset('Artist')->search({name => 'foo'});
+  is $updated->rank, 4, 'and the update made it to the database';
+
+
+# test LIMIT support
+  my $lim = $ars->search( {},
+    {
+      rows => 3,
+      offset => 4,
+      order_by => 'artistid'
+    }
+  );
+  is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+  is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+  $lim->reset;
+  is( $lim->next->artistid, 101, "iterator->next ok" );
+  is( $lim->next->artistid, 102, "iterator->next ok" );
+  is( $lim->next, undef, "next past end of resultset ok" );
+
+# test multiple executing cursors
+  {
+    my $rs1 = $ars->search({}, { order_by => { -asc  => 'artistid' }});
+    my $rs2 = $ars->search({}, { order_by => { -desc => 'artistid' }});
+
+    is $rs1->next->artistid, 1,   'multiple cursors';
+    is $rs2->next->artistid, 102, 'multiple cursors';
+  }
+
+# test empty insert
+  {
+    local $ars->result_source->column_info('artistid')->{is_auto_increment} = 0;
+
+    lives_ok { $ars->create({}) }
+      'empty insert works';
+  }
+
+# test blobs (stolen from 73oracle.t)
+  SKIP: {
+    eval { $dbh->do('DROP TABLE "bindtype_test2"') };
+    $dbh->do(q[
+    CREATE TABLE "bindtype_test2"
+    (
+      "id"     INT PRIMARY KEY,
+      "bytea"  INT,
+      "a_blob" BLOB,
+      "a_clob" BLOB SUB_TYPE TEXT
+    )
+    ]);
+
+    my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+    $binstr{'large'} = $binstr{'small'} x 1024;
+
+    my $maxloblen = length $binstr{'large'};
+    local $dbh->{'LongReadLen'} = $maxloblen;
+
+    my $rs = $schema->resultset('BindType2');
+    my $id = 0;
+
+    foreach my $type (qw( a_blob a_clob )) {
+      foreach my $size (qw( small large )) {
+        $id++;
+
+# turn off horrendous binary DBIC_TRACE output
+        local $schema->storage->{debug} = 0;
+
+        lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+        "inserted $size $type without dying";
+
+        ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
+      }
+    }
+  }
+}
+
+done_testing;
+
+# clean up our mess
+
+sub cleanup {
+  my $dbh;
+  eval {
+    $schema->storage->disconnect; # to avoid object FOO is in use errors
+    $dbh = $schema->storage->dbh;
+  };
+  return unless $dbh;
+
+  eval { $dbh->do('DROP TRIGGER "artist_bi"') };
+  diag $@ if $@;
+
+  eval { $dbh->do('DROP GENERATOR "gen_artist_artistid"') };
+  diag $@ if $@;
+
+  foreach my $table (qw/artist bindtype_test/) {
+    eval { $dbh->do(qq[DROP TABLE "$table"]) };
+    #diag $@ if $@;
+  }
+}
diff --git a/t/inflate/datetime_firebird.t b/t/inflate/datetime_firebird.t
new file mode 100644 (file)
index 0000000..1a3136e
--- /dev/null
@@ -0,0 +1,94 @@
+use strict;
+use warnings;  
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+use Scope::Guard ();
+
+# XXX we're only testing TIMESTAMP here
+
+my ($dsn, $user, $pass)    = @ENV{map { "DBICTEST_FIREBIRD_${_}" }      qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_FIREBIRD_ODBC_${_}" } qw/DSN USER PASS/};
+
+if (not ($dsn || $dsn2)) {
+  plan skip_all => <<'EOF';
+Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN}
+_USER and _PASS to run this test'.
+Warning: This test drops and creates a table called 'event'";
+EOF
+} else {
+  eval "use DateTime; use DateTime::Format::Strptime;";
+  if ($@) {
+    plan skip_all => 'needs DateTime and DateTime::Format::Strptime for testing';
+  }
+}
+
+my @info = (
+  [ $dsn,  $user,  $pass  ],
+  [ $dsn2, $user2, $pass2 ],
+);
+
+my $schema;
+
+foreach my $conn_idx (0..$#info) {
+  my ($dsn, $user, $pass) = @{ $info[$conn_idx] || [] };
+
+  next unless $dsn;
+
+  $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+    quote_char => '"',
+    name_sep   => '.', 
+    on_connect_call => [ 'datetime_setup' ],
+  });
+
+  my $sg = Scope::Guard->new(\&cleanup);
+
+  eval { $schema->storage->dbh->do('DROP TABLE "event"') };
+  $schema->storage->dbh->do(<<'SQL');
+  CREATE TABLE "event" (
+    "id" INT PRIMARY KEY,
+    "starts_at" DATE,
+    "created_on" TIMESTAMP
+  )
+SQL
+  my $rs   = $schema->resultset('Event');
+
+  my $dt = DateTime->now;
+  $dt->set_nanosecond($dsn =~ /odbc/i ? 0 : 555600000);
+
+  my $date_only = DateTime->new(
+    year => $dt->year, month => $dt->month, day => $dt->day
+  );
+
+  my $row;
+  ok( $row = $rs->create({
+    id => 1,
+    starts_at => $date_only, 
+    created_on => $dt,
+  }));
+  ok( $row = $rs->search({ id => 1 }, { select => [qw/starts_at created_on/] })
+    ->first
+  );
+  is $row->created_on, $dt, 'TIMESTAMP as DateTime roundtrip';
+
+  cmp_ok $row->created_on->nanosecond, '==', $dt->nanosecond,
+    'fractional part of a second survived' if 0+$dt->nanosecond;
+
+  is $row->starts_at, $date_only, 'DATE as DateTime roundtrip';
+}
+
+done_testing;
+
+# clean up our mess
+sub cleanup {
+  my $dbh; 
+  eval {
+    $schema->storage->disconnect; # to avoid object FOO is in use errors
+    $dbh = $schema->storage->dbh;
+  };
+  return unless $dbh;
+
+  eval { $dbh->do(qq{DROP TABLE "$_"}) } for qw/event/;
+}
index a3e4484..6f5169c 100644 (file)
@@ -9,6 +9,7 @@ __PACKAGE__->load_classes(qw/
   Artist
   SequenceTest
   BindType
+  BindType2
   Employee
   CD
   FileColumn
diff --git a/t/lib/DBICTest/Schema/BindType2.pm b/t/lib/DBICTest/Schema/BindType2.pm
new file mode 100644 (file)
index 0000000..0ebbb8e
--- /dev/null
@@ -0,0 +1,29 @@
+package # hide from PAUSE 
+    DBICTest::Schema::BindType2;
+
+use base qw/DBICTest::BaseResult/;
+
+__PACKAGE__->table('bindtype_test2');
+
+__PACKAGE__->add_columns(
+  'id' => {
+    data_type => 'integer',
+    is_auto_increment => 1,
+  },
+  'bytea' => {
+    data_type => 'bytea',
+    is_nullable => 1,
+  },
+  'a_blob' => {
+    data_type => 'blob',
+    is_nullable => 1,
+  },
+  'a_clob' => {
+    data_type => 'clob',
+    is_nullable => 1,
+  },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
index 22b655e..0c477c8 100644 (file)
@@ -10,7 +10,10 @@ __PACKAGE__->table('event');
 
 __PACKAGE__->add_columns(
   id => { data_type => 'integer', is_auto_increment => 1 },
-  starts_at => { data_type => 'datetime' },
+
+# this MUST be 'date' for the Firebird tests
+  starts_at => { data_type => 'date' },
+
   created_on => { data_type => 'timestamp' },
   varchar_date => { data_type => 'varchar', inflate_date => 1, size => 20, is_nullable => 1 },
   varchar_datetime => { data_type => 'varchar', inflate_datetime => 1, size => 20, is_nullable => 1 },
index 4d7905f..4dcc31b 100644 (file)
@@ -1,6 +1,6 @@
 -- 
 -- Created by SQL::Translator::Producer::SQLite
--- Created on Sat Jan 30 19:18:55 2010
+-- Created on Thu Feb 11 07:23:33 2010
 -- 
 ;
 
@@ -27,6 +27,16 @@ CREATE TABLE bindtype_test (
 );
 
 --
+-- Table: bindtype_test2
+--
+CREATE TABLE bindtype_test2 (
+  id INTEGER PRIMARY KEY NOT NULL,
+  bytea blob,
+  a_blob blob,
+  a_clob clob
+);
+
+--
 -- Table: collection
 --
 CREATE TABLE collection (
@@ -59,7 +69,7 @@ CREATE TABLE encoded (
 --
 CREATE TABLE event (
   id INTEGER PRIMARY KEY NOT NULL,
-  starts_at datetime NOT NULL,
+  starts_at date NOT NULL,
   created_on timestamp NOT NULL,
   varchar_date varchar(20),
   varchar_datetime varchar(20),