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> as well as
  22 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> sets the limit dialect to
  23 C<FIRST X SKIP X> and provides 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. Otherwise you will likely get bizarre error messages
  29 such as C<no statement executing>.
  30
  31 For ODBC support, see L<DBIx::Class::Storage::DBI::ODBC::Firebird>.
  32
  33 To turn on L<DBIx::Class::InflateColumn::DateTime> support, see
  34 L</connect_call_datetime_setup>.
  35
  36 =cut
  37
  38 sub _prep_for_execute {
  39   my $self = shift;
  40   my ($op, $extra_bind, $ident, $args) = @_;
  41
  42   if ($op eq 'insert') {
  43     $self->_auto_incs([]);
  44
  45     @pk{$ident->primary_columns} = ();
  46
  47     my @auto_inc_cols = grep {
  48       my $inserting = $args->[0]{$_};
  49
  50       ($ident->column_info($_)->{is_auto_increment}
  51         || exists $pk{$_})
  52       && (
  53         (not defined $inserting)
  54         ||
  55         (ref $inserting eq 'SCALAR' && $$inserting =~ /^null\z/i)
  56       )
  57     } $ident->columns;
  58
  59     if (@auto_inc_cols) {
  60       $args->[1]{returning} = \@auto_inc_cols;
  61
  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 _sequence_fetch {
  89   my ($self, $nextval, $sequence) = @_;
  90
  91   if ($nextval ne 'nextval') {
  92     $self->throw_exception("Can only fetch 'nextval' for a sequence");
  93   }
  94
  95   $self->throw_exception('No sequence to fetch') unless $sequence;
  96
  97   my ($val) = $self->_get_dbh->selectrow_array(
  98 'SELECT GEN_ID(' . $self->sql_maker->_quote($sequence) .
  99 ', 1) FROM rdb$database');
 100
 101   return $val;
 102 }
 103
 104 sub _dbh_get_autoinc_seq {
 105   my ($self, $dbh, $source, $col) = @_;
 106
 107   my $table_name = $source->from;
 108   $table_name    = $$table_name if ref $table_name;
 109   $table_name    = $self->sql_maker->quote_char ? $table_name : uc($table_name);
 110
 111   local $dbh->{LongReadLen} = 100000;
 112   local $dbh->{LongTruncOk} = 1;
 113
 114   my $sth = $dbh->prepare(<<'EOF');
 115 SELECT t.rdb$trigger_source
 116 FROM rdb$triggers t
 117 WHERE t.rdb$relation_name = ?
 118 AND t.rdb$system_flag = 0 -- user defined
 119 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
 120 EOF
 121   $sth->execute($table_name);
 122
 123   while (my ($trigger) = $sth->fetchrow_array) {
 124     my @trig_cols = map {
 125       /^"([^"]+)/ ? $1 : uc($1)
 126     } $trigger =~ /new\.("?\w+"?)/ig;
 127
 128     my ($quoted, $generator) = $trigger =~
 129 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
 130
 131     if ($generator) {
 132       $generator = uc $generator unless $quoted;
 133
 134       return $generator
 135         if List::Util::first {
 136           $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
 137         } @trig_cols;
 138     }
 139   }
 140
 141   return undef;
 142 }
 143
 144 sub last_insert_id {
 145   my ($self, $source, @cols) = @_;
 146   my @result;
 147
 148   my %auto_incs;
 149   @auto_incs{ @{ $self->_auto_incs->[0] } } =
 150     @{ $self->_auto_incs->[1] };
 151
 152   push @result, $auto_incs{$_} for @cols;
 153
 154   return @result;
 155 }
 156
 157 sub insert {
 158   my $self = shift;
 159
 160   my $updated_cols = $self->next::method(@_);
 161
 162   if ($self->_auto_incs->[0]) {
 163     my %auto_incs;
 164     @auto_incs{ @{ $self->_auto_incs->[0] } } = @{ $self->_auto_incs->[1] };
 165
 166     $updated_cols = { %$updated_cols, %auto_incs };
 167   }
 168
 169   return $updated_cols;
 170 }
 171
 172 # this sub stolen from DB2
 173
 174 sub _sql_maker_opts {
 175   my ( $self, $opts ) = @_;
 176
 177   if ( $opts ) {
 178     $self->{_sql_maker_opts} = { %$opts };
 179   }
 180
 181   return { limit_dialect => 'FirstSkip', %{$self->{_sql_maker_opts}||{}} };
 182 }
 183
 184 sub _svp_begin {
 185     my ($self, $name) = @_;
 186
 187     $self->_get_dbh->do("SAVEPOINT $name");
 188 }
 189
 190 sub _svp_release {
 191     my ($self, $name) = @_;
 192
 193     $self->_get_dbh->do("RELEASE SAVEPOINT $name");
 194 }
 195
 196 sub _svp_rollback {
 197     my ($self, $name) = @_;
 198
 199     $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 200 }
 201
 202 sub _ping {
 203   my $self = shift;
 204
 205   my $dbh = $self->_dbh or return 0;
 206
 207   local $dbh->{RaiseError} = 1;
 208
 209   eval {
 210     $dbh->do('select 1 from rdb$database');
 211   };
 212
 213   return $@ ? 0 : 1;
 214 }
 215
 216 # We want dialect 3 for new features and quoting to work, DBD::InterBase uses
 217 # dialect 1 (interbase compat) by default.
 218 sub _init {
 219   my $self = shift;
 220   $self->_set_sql_dialect(3);
 221 }
 222
 223 sub _set_sql_dialect {
 224   my $self = shift;
 225   my $val  = shift || 3;
 226
 227   my $dsn = $self->_dbi_connect_info->[0];
 228
 229   return if ref($dsn) eq 'CODE';
 230
 231   if ($dsn !~ /ib_dialect=/) {
 232     $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val";
 233     my $connected = defined $self->_dbh;
 234     $self->disconnect;
 235     $self->ensure_connected if $connected;
 236   }
 237 }
 238
 239 =head2 connect_call_use_softcommit
 240
 241 Used as:
 242
 243   on_connect_call => 'use_softcommit'
 244
 245 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the
 246 L<DBD::InterBase> C<ib_softcommit> option.
 247
 248 You need either this option or C<< disable_sth_caching => 1 >> for
 249 L<DBIx::Class> code to function correctly (otherwise you may get C<no statement
 250 executing> errors.)
 251
 252 The downside of using this option is that your process will B<NOT> see UPDATEs,
 253 INSERTs and DELETEs from other processes for already open statements.
 254
 255 =cut
 256
 257 sub connect_call_use_softcommit {
 258   my $self = shift;
 259
 260   $self->_dbh->{ib_softcommit} = 1;
 261 }
 262
 263 =head2 connect_call_datetime_setup
 264
 265 Used as:
 266
 267   on_connect_call => 'datetime_setup'
 268
 269 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the date and
 270 timestamp formats using:
 271
 272   $dbh->{ib_time_all} = 'ISO';
 273
 274 See L<DBD::InterBase> for more details.
 275
 276 The C<TIMESTAMP> data type supports up to 4 digits after the decimal point for
 277 second precision. The full precision is used.
 278
 279 The C<DATE> data type stores the date portion only, and it B<MUST> be declared
 280 with:
 281
 282   data_type => 'date'
 283
 284 in your Result class.
 285
 286 Timestamp columns can be declared with either C<datetime> or C<timestamp>.
 287
 288 You will need the L<DateTime::Format::Strptime> module for inflation to work.
 289
 290 For L<DBIx::Class::Storage::DBI::ODBC::Firebird>, this is a noop and sub-second
 291 precision is not currently available.
 292
 293 =cut
 294
 295 sub connect_call_datetime_setup {
 296   my $self = shift;
 297
 298   $self->_get_dbh->{ib_time_all} = 'ISO';
 299 }
 300
 301 sub datetime_parser_type {
 302   'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
 303 }
 304
 305 package # hide from PAUSE
 306   DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
 307
 308 my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
 309 my $date_format      = '%Y-%m-%d';
 310
 311 my ($timestamp_parser, $date_parser);
 312
 313 sub parse_datetime {
 314   shift;
 315   require DateTime::Format::Strptime;
 316   $timestamp_parser ||= DateTime::Format::Strptime->new(
 317     pattern  => $timestamp_format,
 318     on_error => 'croak',
 319   );
 320   return $timestamp_parser->parse_datetime(shift);
 321 }
 322
 323 sub format_datetime {
 324   shift;
 325   require DateTime::Format::Strptime;
 326   $timestamp_parser ||= DateTime::Format::Strptime->new(
 327     pattern  => $timestamp_format,
 328     on_error => 'croak',
 329   );
 330   return $timestamp_parser->format_datetime(shift);
 331 }
 332
 333 sub parse_date {
 334   shift;
 335   require DateTime::Format::Strptime;
 336   $date_parser ||= DateTime::Format::Strptime->new(
 337     pattern  => $date_format,
 338     on_error => 'croak',
 339   );
 340   return $date_parser->parse_datetime(shift);
 341 }
 342
 343 sub format_date {
 344   shift;
 345   require DateTime::Format::Strptime;
 346   $date_parser ||= DateTime::Format::Strptime->new(
 347     pattern  => $date_format,
 348     on_error => 'croak',
 349   );
 350   return $date_parser->format_datetime(shift);
 351 }
 352
 353 1;
 354
 355 =head1 CAVEATS
 356
 357 =over 4
 358
 359 =item *
 360
 361 with L</connect_call_use_softcommit>, you will not be able to see changes made
 362 to data in other processes. If this is an issue, use
 363 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> as a
 364 workaround for the C<no statement executing> errors, this of course adversely
 365 affects performance.
 366
 367 =item *
 368
 369 C<last_insert_id> support by default only works for Firebird versions 2 or
 370 greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
 371 work with earlier versions.
 372
 373 =item *
 374
 375 Sub-second precision for TIMESTAMPs is not currently available with ODBC.
 376
 377 =back
 378
 379 =head1 AUTHOR
 380
 381 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 382
 383 =head1 LICENSE
 384
 385 You may distribute this code under the same terms as Perl itself.
 386
 387 =cut