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

   1 package DBIx::Class::Storage::DBI::InterBase;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/DBIx::Class::Storage::DBI/;
   6 use mro 'c3';
   7 use List::Util();
   8
   9 __PACKAGE__->mk_group_accessors(simple => qw/
  10   _auto_incs
  11 /);
  12
  13 =head1 NAME
  14
  15 DBIx::Class::Storage::DBI::InterBase - Driver for the Firebird RDBMS
  16
  17 =head1 DESCRIPTION
  18
  19 This class implements autoincrements for Firebird using C<RETURNING> as well as
  20 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> sets the limit dialect to
  21 C<FIRST X SKIP X> and provides L<DBIx::Class::InflateColumn::DateTime> support.
  22
  23 You need to use either the
  24 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> option or
  25 L</connect_call_use_softcommit> (see L</CAVEATS>) for your code to function
  26 correctly with this driver. Otherwise you will likely get bizarre error messages
  27 such as C<no statement executing>. The alternative is to use the
  28 L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver, which is more suitable
  29 for long running processes such as under L<Catalyst>.
  30
  31 To turn on L<DBIx::Class::InflateColumn::DateTime> support, see
  32 L</connect_call_datetime_setup>.
  33
  34 =cut
  35
  36 sub _prep_for_execute {
  37   my $self = shift;
  38   my ($op, $extra_bind, $ident, $args) = @_;
  39
  40   if ($op eq 'insert') {
  41     $self->_auto_incs([]);
  42
  43     my %pk;
  44     @pk{$ident->primary_columns} = ();
  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->[0] = \@auto_inc_cols;
  62     }
  63   }
  64
  65   return $self->next::method(@_);
  66 }
  67
  68 sub _execute {
  69   my $self = shift;
  70   my ($op) = @_;
  71
  72   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
  73
  74   if ($op eq 'insert' && $self->_auto_incs) {
  75     local $@;
  76     my (@auto_incs) = eval {
  77       local $SIG{__WARN__} = sub {};
  78       $sth->fetchrow_array
  79     };
  80     $self->_auto_incs->[1] = \@auto_incs;
  81     $sth->finish;
  82   }
  83
  84   return wantarray ? ($rv, $sth, @bind) : $rv;
  85 }
  86
  87 sub _sequence_fetch {
  88   my ($self, $nextval, $sequence) = @_;
  89
  90   if ($nextval ne 'nextval') {
  91     $self->throw_exception("Can only fetch 'nextval' for a sequence");
  92   }
  93
  94   $self->throw_exception('No sequence to fetch') unless $sequence;
  95
  96   my ($val) = $self->_get_dbh->selectrow_array(
  97 'SELECT GEN_ID(' . $self->sql_maker->_quote($sequence) .
  98 ', 1) FROM rdb$database');
  99
 100   return $val;
 101 }
 102
 103 sub _dbh_get_autoinc_seq {
 104   my ($self, $dbh, $source, $col) = @_;
 105
 106   my $table_name = $source->from;
 107   $table_name    = $$table_name if ref $table_name;
 108   $table_name    = $self->sql_maker->quote_char ? $table_name : uc($table_name);
 109
 110   local $dbh->{LongReadLen} = 100000;
 111   local $dbh->{LongTruncOk} = 1;
 112
 113   my $sth = $dbh->prepare(<<'EOF');
 114 SELECT t.rdb$trigger_source
 115 FROM rdb$triggers t
 116 WHERE t.rdb$relation_name = ?
 117 AND t.rdb$system_flag = 0 -- user defined
 118 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
 119 EOF
 120   $sth->execute($table_name);
 121
 122   while (my ($trigger) = $sth->fetchrow_array) {
 123     my @trig_cols = map {
 124       /^"([^"]+)/ ? $1 : uc($1)
 125     } $trigger =~ /new\.("?\w+"?)/ig;
 126
 127     my ($quoted, $generator) = $trigger =~
 128 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
 129
 130     if ($generator) {
 131       $generator = uc $generator unless $quoted;
 132
 133       return $generator
 134         if List::Util::first {
 135           $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
 136         } @trig_cols;
 137     }
 138   }
 139
 140   return undef;
 141 }
 142
 143 sub last_insert_id {
 144   my ($self, $source, @cols) = @_;
 145   my @result;
 146
 147   my %auto_incs;
 148   @auto_incs{ @{ $self->_auto_incs->[0] } } =
 149     @{ $self->_auto_incs->[1] };
 150
 151   push @result, $auto_incs{$_} for @cols;
 152
 153   return @result;
 154 }
 155
 156 sub insert {
 157   my $self = shift;
 158
 159   my $updated_cols = $self->next::method(@_);
 160
 161   if ($self->_auto_incs->[0]) {
 162     my %auto_incs;
 163     @auto_incs{ @{ $self->_auto_incs->[0] } } = @{ $self->_auto_incs->[1] };
 164
 165     $updated_cols = { %$updated_cols, %auto_incs };
 166   }
 167
 168   return $updated_cols;
 169 }
 170
 171 # this sub stolen from DB2
 172
 173 sub _sql_maker_opts {
 174   my ( $self, $opts ) = @_;
 175
 176   if ( $opts ) {
 177     $self->{_sql_maker_opts} = { %$opts };
 178   }
 179
 180   return { limit_dialect => 'FirstSkip', %{$self->{_sql_maker_opts}||{}} };
 181 }
 182
 183 sub _svp_begin {
 184     my ($self, $name) = @_;
 185
 186     $self->_get_dbh->do("SAVEPOINT $name");
 187 }
 188
 189 sub _svp_release {
 190     my ($self, $name) = @_;
 191
 192     $self->_get_dbh->do("RELEASE SAVEPOINT $name");
 193 }
 194
 195 sub _svp_rollback {
 196     my ($self, $name) = @_;
 197
 198     $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 199 }
 200
 201 sub _ping {
 202   my $self = shift;
 203
 204   my $dbh = $self->_dbh or return 0;
 205
 206   local $dbh->{RaiseError} = 1;
 207   local $dbh->{PrintError} = 0;
 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.) Or use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird>
 251 driver.
 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 Alternately, use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver.
 369
 370 =item *
 371
 372 C<last_insert_id> support by default only works for Firebird versions 2 or
 373 greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
 374 work with earlier versions.
 375
 376 =item *
 377
 378 Sub-second precision for TIMESTAMPs is not currently available when using the
 379 L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver.
 380
 381 =back
 382
 383 =head1 AUTHOR
 384
 385 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 386
 387 =head1 LICENSE
 388
 389 You may distribute this code under the same terms as Perl itself.
 390
 391 =cut