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