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
  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. 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     my @pk = $ident->_pri_cols;
  44     my %pk;
  45     @pk{@pk} = ();
  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([]);
  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 # this sub stolen from DB2
 159
 160 sub _sql_maker_opts {
 161   my ( $self, $opts ) = @_;
 162
 163   if ( $opts ) {
 164     $self->{_sql_maker_opts} = { %$opts };
 165   }
 166
 167   return { limit_dialect => 'FirstSkip', %{$self->{_sql_maker_opts}||{}} };
 168 }
 169
 170 sub _svp_begin {
 171     my ($self, $name) = @_;
 172
 173     $self->_get_dbh->do("SAVEPOINT $name");
 174 }
 175
 176 sub _svp_release {
 177     my ($self, $name) = @_;
 178
 179     $self->_get_dbh->do("RELEASE SAVEPOINT $name");
 180 }
 181
 182 sub _svp_rollback {
 183     my ($self, $name) = @_;
 184
 185     $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 186 }
 187
 188 sub _ping {
 189   my $self = shift;
 190
 191   my $dbh = $self->_dbh or return 0;
 192
 193   local $dbh->{RaiseError} = 1;
 194
 195   eval {
 196     $dbh->do('select 1 from rdb$database');
 197   };
 198
 199   return $@ ? 0 : 1;
 200 }
 201
 202 # We want dialect 3 for new features and quoting to work, DBD::InterBase uses
 203 # dialect 1 (interbase compat) by default.
 204 sub _init {
 205   my $self = shift;
 206   $self->_set_sql_dialect(3);
 207 }
 208
 209 sub _set_sql_dialect {
 210   my $self = shift;
 211   my $val  = shift || 3;
 212
 213   my $dsn = $self->_dbi_connect_info->[0];
 214
 215   return if ref($dsn) eq 'CODE';
 216
 217   if ($dsn !~ /ib_dialect=/) {
 218     $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val";
 219     my $connected = defined $self->_dbh;
 220     $self->disconnect;
 221     $self->ensure_connected if $connected;
 222   }
 223 }
 224
 225 =head2 connect_call_use_softcommit
 226
 227 Used as:
 228
 229   on_connect_call => 'use_softcommit'
 230
 231 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the
 232 L<DBD::InterBase> C<ib_softcommit> option.
 233
 234 You need either this option or C<< disable_sth_caching => 1 >> for
 235 L<DBIx::Class> code to function correctly (otherwise you may get C<no statement
 236 executing> errors.)
 237
 238 The downside of using this option is that your process will B<NOT> see UPDATEs,
 239 INSERTs and DELETEs from other processes for already open statements.
 240
 241 =cut
 242
 243 sub connect_call_use_softcommit {
 244   my $self = shift;
 245
 246   $self->_dbh->{ib_softcommit} = 1;
 247 }
 248
 249 =head2 connect_call_datetime_setup
 250
 251 Used as:
 252
 253   on_connect_call => 'datetime_setup'
 254
 255 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the date and
 256 timestamp formats using:
 257
 258   $dbh->{ib_time_all} = 'ISO';
 259
 260 See L<DBD::InterBase> for more details.
 261
 262 The C<TIMESTAMP> data type supports up to 4 digits after the decimal point for
 263 second precision. The full precision is used.
 264
 265 The C<DATE> data type stores the date portion only, and it B<MUST> be declared
 266 with:
 267
 268   data_type => 'date'
 269
 270 in your Result class.
 271
 272 Timestamp columns can be declared with either C<datetime> or C<timestamp>.
 273
 274 You will need the L<DateTime::Format::Strptime> module for inflation to work.
 275
 276 For L<DBIx::Class::Storage::DBI::ODBC::Firebird>, this is a noop and sub-second
 277 precision is not currently available.
 278
 279 =cut
 280
 281 sub connect_call_datetime_setup {
 282   my $self = shift;
 283
 284   $self->_get_dbh->{ib_time_all} = 'ISO';
 285 }
 286
 287 sub datetime_parser_type {
 288   'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
 289 }
 290
 291 package # hide from PAUSE
 292   DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
 293
 294 my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
 295 my $date_format      = '%Y-%m-%d';
 296
 297 my ($timestamp_parser, $date_parser);
 298
 299 sub parse_datetime {
 300   shift;
 301   require DateTime::Format::Strptime;
 302   $timestamp_parser ||= DateTime::Format::Strptime->new(
 303     pattern  => $timestamp_format,
 304     on_error => 'croak',
 305   );
 306   return $timestamp_parser->parse_datetime(shift);
 307 }
 308
 309 sub format_datetime {
 310   shift;
 311   require DateTime::Format::Strptime;
 312   $timestamp_parser ||= DateTime::Format::Strptime->new(
 313     pattern  => $timestamp_format,
 314     on_error => 'croak',
 315   );
 316   return $timestamp_parser->format_datetime(shift);
 317 }
 318
 319 sub parse_date {
 320   shift;
 321   require DateTime::Format::Strptime;
 322   $date_parser ||= DateTime::Format::Strptime->new(
 323     pattern  => $date_format,
 324     on_error => 'croak',
 325   );
 326   return $date_parser->parse_datetime(shift);
 327 }
 328
 329 sub format_date {
 330   shift;
 331   require DateTime::Format::Strptime;
 332   $date_parser ||= DateTime::Format::Strptime->new(
 333     pattern  => $date_format,
 334     on_error => 'croak',
 335   );
 336   return $date_parser->format_datetime(shift);
 337 }
 338
 339 1;
 340
 341 =head1 CAVEATS
 342
 343 =over 4
 344
 345 =item *
 346
 347 with L</connect_call_use_softcommit>, you will not be able to see changes made
 348 to data in other processes. If this is an issue, use
 349 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> as a
 350 workaround for the C<no statement executing> errors, this of course adversely
 351 affects performance.
 352
 353 =item *
 354
 355 C<last_insert_id> support by default only works for Firebird versions 2 or
 356 greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
 357 work with earlier versions.
 358
 359 =item *
 360
 361 Sub-second precision for TIMESTAMPs is not currently available with ODBC.
 362
 363 =back
 364
 365 =head1 AUTHOR
 366
 367 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 368
 369 =head1 LICENSE
 370
 371 You may distribute this code under the same terms as Perl itself.
 372
 373 =cut