lib/DBIx/Class/Storage/DBI/InterBase.pm

   1 package DBIx::Class::Storage::DBI::InterBase;
   2
   3 # partly stolen from DBIx::Class::Storage::DBI::MSSQL
   4
   5 use strict;
   6 use warnings;
   7 use base qw/DBIx::Class::Storage::DBI/;
   8 use mro 'c3';
   9 use List::Util();
  10
  11 __PACKAGE__->mk_group_accessors(simple => qw/
  12   _auto_incs
  13 /);
  14
  15 =head1 NAME
  16
  17 DBIx::Class::Storage::DBI::InterBase - Driver for the Firebird RDBMS
  18
  19 =head1 DESCRIPTION
  20
  21 This class implements autoincrements for Firebird using C<RETURNING>, sets the
  22 limit dialect to C<FIRST X SKIP X> and provides preliminary
  23 L<DBIx::Class::InflateColumn::DateTime> support.
  24
  25 You need to use either the
  26 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> option or
  27 L</connect_call_use_softcommit> (see L</CAVEATS>) for your code to function
  28 correctly with this driver.
  29
  30 For ODBC support, see L<DBIx::Class::Storage::DBI::ODBC::Firebird>.
  31
  32 To turn on L<DBIx::Class::InflateColumn::DateTime> support, see
  33 L</connect_call_datetime_setup>.
  34
  35 =cut
  36
  37 sub _prep_for_execute {
  38   my $self = shift;
  39   my ($op, $extra_bind, $ident, $args) = @_;
  40
  41   if ($op eq 'insert') {
  42     my @pk = $ident->_pri_cols;
  43     my %pk;
  44     @pk{@pk} = ();
  45
  46     my @auto_inc_cols = grep {
  47       my $inserting = $args->[0]{$_};
  48
  49       ($ident->column_info($_)->{is_auto_increment}
  50         || exists $pk{$_})
  51       && (
  52         (not defined $inserting)
  53         ||
  54         (ref $inserting eq 'SCALAR' && $$inserting =~ /^null\z/i)
  55       )
  56     } $ident->columns;
  57
  58     if (@auto_inc_cols) {
  59       $args->[1]{returning} = \@auto_inc_cols;
  60
  61       $self->_auto_incs([]);
  62       $self->_auto_incs->[0] = \@auto_inc_cols;
  63     }
  64   }
  65
  66   return $self->next::method(@_);
  67 }
  68
  69 sub _execute {
  70   my $self = shift;
  71   my ($op) = @_;
  72
  73   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
  74
  75   if ($op eq 'insert' && $self->_auto_incs) {
  76     local $@;
  77     my (@auto_incs) = eval {
  78       local $SIG{__WARN__} = sub {};
  79       $sth->fetchrow_array
  80     };
  81     $self->_auto_incs->[1] = \@auto_incs;
  82     $sth->finish;
  83   }
  84
  85   return wantarray ? ($rv, $sth, @bind) : $rv;
  86 }
  87
  88 sub last_insert_id {
  89   my ($self, $source, @cols) = @_;
  90   my @result;
  91
  92   my %auto_incs;
  93   @auto_incs{ @{ $self->_auto_incs->[0] } } =
  94     @{ $self->_auto_incs->[1] };
  95
  96   push @result, $auto_incs{$_} for @cols;
  97
  98   return @result;
  99 }
 100
 101 # this sub stolen from DB2
 102
 103 sub _sql_maker_opts {
 104   my ( $self, $opts ) = @_;
 105
 106   if ( $opts ) {
 107     $self->{_sql_maker_opts} = { %$opts };
 108   }
 109
 110   return { limit_dialect => 'FirstSkip', %{$self->{_sql_maker_opts}||{}} };
 111 }
 112
 113 sub _svp_begin {
 114     my ($self, $name) = @_;
 115
 116     $self->_get_dbh->do("SAVEPOINT $name");
 117 }
 118
 119 sub _svp_release {
 120     my ($self, $name) = @_;
 121
 122     $self->_get_dbh->do("RELEASE SAVEPOINT $name");
 123 }
 124
 125 sub _svp_rollback {
 126     my ($self, $name) = @_;
 127
 128     $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 129 }
 130
 131 sub _ping {
 132   my $self = shift;
 133
 134   my $dbh = $self->_dbh or return 0;
 135
 136   local $dbh->{RaiseError} = 1;
 137
 138   eval {
 139     $dbh->do('select 1 from rdb$database');
 140   };
 141
 142   return $@ ? 0 : 1;
 143 }
 144
 145 # We want dialect 3 for new features and quoting to work, DBD::InterBase uses
 146 # dialect 1 (interbase compat) by default.
 147 sub _init {
 148   my $self = shift;
 149   $self->_set_sql_dialect(3);
 150 }
 151
 152 sub _set_sql_dialect {
 153   my $self = shift;
 154   my $val  = shift || 3;
 155
 156   my $dsn = $self->_dbi_connect_info->[0];
 157
 158   return if ref($dsn) eq 'CODE';
 159
 160   if ($dsn !~ /ib_dialect=/) {
 161     $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val";
 162     my $connected = defined $self->_dbh;
 163     $self->disconnect;
 164     $self->ensure_connected if $connected;
 165   }
 166 }
 167
 168 =head2 connect_call_use_softcommit
 169
 170 Used as:
 171
 172   on_connect_call => 'use_softcommit'
 173
 174 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the
 175 L<DBD::InterBase> C<ib_softcommit> option.
 176
 177 You need either this option or C<< disable_sth_caching => 1 >> for
 178 L<DBIx::Class> code to function correctly.
 179
 180 The downside of using this option is that your process will B<NOT> see UPDATEs,
 181 INSERTs and DELETEs from other processes for already open statements.
 182
 183 =cut
 184
 185 sub connect_call_use_softcommit {
 186   my $self = shift;
 187
 188   $self->_dbh->{ib_softcommit} = 1;
 189 }
 190
 191 =head2 connect_call_datetime_setup
 192
 193 Used as:
 194
 195   on_connect_call => 'datetime_setup'
 196
 197 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the date and
 198 timestamp formats using:
 199
 200   $dbh->{ib_time_all} = 'ISO';
 201
 202 See L<DBD::InterBase> for more details.
 203
 204 The C<TIMESTAMP> data type supports up to 4 digits after the decimal point for
 205 second precision. The full precision is used.
 206
 207 The C<DATE> data type stores the date portion only, and it B<MUST> be declared
 208 with:
 209
 210   data_type => 'date'
 211
 212 in your Result class.
 213
 214 Timestamp columns can be declared with either C<datetime> or C<timestamp>.
 215
 216 You will need the L<DateTime::Format::Strptime> module for inflation to work.
 217
 218 For L<DBIx::Class::Storage::DBI::ODBC::Firebird>, this is a noop and sub-second
 219 precision is not currently available.
 220
 221 =cut
 222
 223 sub connect_call_datetime_setup {
 224   my $self = shift;
 225
 226   $self->_get_dbh->{ib_time_all} = 'ISO';
 227 }
 228
 229 sub datetime_parser_type {
 230   'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
 231 }
 232
 233 package # hide from PAUSE
 234   DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
 235
 236 my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
 237 my $date_format      = '%Y-%m-%d';
 238
 239 my ($timestamp_parser, $date_parser);
 240
 241 sub parse_datetime {
 242   shift;
 243   require DateTime::Format::Strptime;
 244   $timestamp_parser ||= DateTime::Format::Strptime->new(
 245     pattern  => $timestamp_format,
 246     on_error => 'croak',
 247   );
 248   return $timestamp_parser->parse_datetime(shift);
 249 }
 250
 251 sub format_datetime {
 252   shift;
 253   require DateTime::Format::Strptime;
 254   $timestamp_parser ||= DateTime::Format::Strptime->new(
 255     pattern  => $timestamp_format,
 256     on_error => 'croak',
 257   );
 258   return $timestamp_parser->format_datetime(shift);
 259 }
 260
 261 sub parse_date {
 262   shift;
 263   require DateTime::Format::Strptime;
 264   $date_parser ||= DateTime::Format::Strptime->new(
 265     pattern  => $date_format,
 266     on_error => 'croak',
 267   );
 268   return $date_parser->parse_datetime(shift);
 269 }
 270
 271 sub format_date {
 272   shift;
 273   require DateTime::Format::Strptime;
 274   $date_parser ||= DateTime::Format::Strptime->new(
 275     pattern  => $date_format,
 276     on_error => 'croak',
 277   );
 278   return $date_parser->format_datetime(shift);
 279 }
 280
 281 1;
 282
 283 =head1 CAVEATS
 284
 285 =over 4
 286
 287 =item *
 288
 289 with L</connect_call_use_softcommit>, you will not be able to see changes made
 290 to data in other processes. If this is an issue, use
 291 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching>, this of
 292 course adversely affects performance.
 293
 294 =item *
 295
 296 C<last_insert_id> support only works for Firebird versions 2 or greater. To
 297 work with earlier versions, we'll need to figure out how to retrieve the bodies
 298 of C<BEFORE INSERT> triggers and parse them for the C<GENERATOR> name.
 299
 300 =back
 301
 302 =head1 AUTHOR
 303
 304 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 305
 306 =head1 LICENSE
 307
 308 You may distribute this code under the same terms as Perl itself.
 309
 310 =cut