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 'first';
   8 use Try::Tiny;
   9 use namespace::clean;
  10
  11 =head1 NAME
  12
  13 DBIx::Class::Storage::DBI::InterBase - Driver for the Firebird RDBMS
  14
  15 =head1 DESCRIPTION
  16
  17 This class implements autoincrements for Firebird using C<RETURNING> as well as
  18 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> and provides
  19 L<DBIx::Class::InflateColumn::DateTime> support.
  20
  21 You need to use either the
  22 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> option or
  23 L</connect_call_use_softcommit> (see L</CAVEATS>) for your code to function
  24 correctly with this driver. Otherwise you will likely get bizarre error messages
  25 such as C<no statement executing>. The alternative is to use the
  26 L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver, which is more suitable
  27 for long running processes such as under L<Catalyst>.
  28
  29 To turn on L<DBIx::Class::InflateColumn::DateTime> support, see
  30 L</connect_call_datetime_setup>.
  31
  32 =cut
  33
  34 # set default
  35 __PACKAGE__->_use_insert_returning (1);
  36 __PACKAGE__->sql_limit_dialect ('FirstSkip');
  37 __PACKAGE__->sql_quote_char ('"');
  38
  39 sub _sequence_fetch {
  40   my ($self, $nextval, $sequence) = @_;
  41
  42   $self->throw_exception("Can only fetch 'nextval' for a sequence")
  43     if $nextval !~ /^nextval$/i;
  44
  45   $self->throw_exception('No sequence to fetch') unless $sequence;
  46
  47   my ($val) = $self->_get_dbh->selectrow_array(sprintf
  48     'SELECT GEN_ID(%s, 1) FROM rdb$database',
  49     $self->sql_maker->_quote($sequence)
  50   );
  51
  52   return $val;
  53 }
  54
  55 sub _dbh_get_autoinc_seq {
  56   my ($self, $dbh, $source, $col) = @_;
  57
  58   my $table_name = $source->from;
  59   $table_name    = $$table_name if ref $table_name;
  60   $table_name    = $self->sql_maker->quote_char ? $table_name : uc($table_name);
  61
  62   local $dbh->{LongReadLen} = 100000;
  63   local $dbh->{LongTruncOk} = 1;
  64
  65   my $sth = $dbh->prepare(<<'EOF');
  66 SELECT t.rdb$trigger_source
  67 FROM rdb$triggers t
  68 WHERE t.rdb$relation_name = ?
  69 AND t.rdb$system_flag = 0 -- user defined
  70 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
  71 EOF
  72   $sth->execute($table_name);
  73
  74   while (my ($trigger) = $sth->fetchrow_array) {
  75     my @trig_cols = map {
  76       /^"([^"]+)/ ? $1 : uc($1)
  77     } $trigger =~ /new\.("?\w+"?)/ig;
  78
  79     my ($quoted, $generator) = $trigger =~
  80 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
  81
  82     if ($generator) {
  83       $generator = uc $generator unless $quoted;
  84
  85       return $generator
  86         if first {
  87           $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
  88         } @trig_cols;
  89     }
  90   }
  91
  92   return undef;
  93 }
  94
  95 sub _svp_begin {
  96     my ($self, $name) = @_;
  97
  98     $self->_get_dbh->do("SAVEPOINT $name");
  99 }
 100
 101 sub _svp_release {
 102     my ($self, $name) = @_;
 103
 104     $self->_get_dbh->do("RELEASE SAVEPOINT $name");
 105 }
 106
 107 sub _svp_rollback {
 108     my ($self, $name) = @_;
 109
 110     $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 111 }
 112
 113 sub _ping {
 114   my $self = shift;
 115
 116   my $dbh = $self->_dbh or return 0;
 117
 118   local $dbh->{RaiseError} = 1;
 119   local $dbh->{PrintError} = 0;
 120
 121   return try {
 122     $dbh->do('select 1 from rdb$database');
 123     1;
 124   } catch {
 125     0;
 126   };
 127 }
 128
 129 # We want dialect 3 for new features and quoting to work, DBD::InterBase uses
 130 # dialect 1 (interbase compat) by default.
 131 sub _init {
 132   my $self = shift;
 133   $self->_set_sql_dialect(3);
 134 }
 135
 136 sub _set_sql_dialect {
 137   my $self = shift;
 138   my $val  = shift || 3;
 139
 140   my $dsn = $self->_dbi_connect_info->[0];
 141
 142   return if ref($dsn) eq 'CODE';
 143
 144   if ($dsn !~ /ib_dialect=/) {
 145     $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val";
 146     my $connected = defined $self->_dbh;
 147     $self->disconnect;
 148     $self->ensure_connected if $connected;
 149   }
 150 }
 151
 152 sub _get_server_version {
 153   my $self = shift;
 154
 155   return $self->next::method(@_) if ref $self ne __PACKAGE__;
 156
 157   local $SIG{__WARN__} = sub {}; # silence warning due to bug in DBD::InterBase
 158
 159   return $self->next::method(@_);
 160 }
 161
 162 =head2 connect_call_use_softcommit
 163
 164 Used as:
 165
 166   on_connect_call => 'use_softcommit'
 167
 168 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the
 169 L<DBD::InterBase> C<ib_softcommit> option.
 170
 171 You need either this option or C<< disable_sth_caching => 1 >> for
 172 L<DBIx::Class> code to function correctly (otherwise you may get C<no statement
 173 executing> errors.) Or use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird>
 174 driver.
 175
 176 The downside of using this option is that your process will B<NOT> see UPDATEs,
 177 INSERTs and DELETEs from other processes for already open statements.
 178
 179 =cut
 180
 181 sub connect_call_use_softcommit {
 182   my $self = shift;
 183
 184   $self->_dbh->{ib_softcommit} = 1;
 185 }
 186
 187 =head2 connect_call_datetime_setup
 188
 189 Used as:
 190
 191   on_connect_call => 'datetime_setup'
 192
 193 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the date and
 194 timestamp formats using:
 195
 196   $dbh->{ib_time_all} = 'ISO';
 197
 198 See L<DBD::InterBase> for more details.
 199
 200 The C<TIMESTAMP> data type supports up to 4 digits after the decimal point for
 201 second precision. The full precision is used.
 202
 203 The C<DATE> data type stores the date portion only, and it B<MUST> be declared
 204 with:
 205
 206   data_type => 'date'
 207
 208 in your Result class.
 209
 210 Timestamp columns can be declared with either C<datetime> or C<timestamp>.
 211
 212 You will need the L<DateTime::Format::Strptime> module for inflation to work.
 213
 214 For L<DBIx::Class::Storage::DBI::ODBC::Firebird>, this is a noop and sub-second
 215 precision is not currently available.
 216
 217 =cut
 218
 219 sub connect_call_datetime_setup {
 220   my $self = shift;
 221
 222   $self->_get_dbh->{ib_time_all} = 'ISO';
 223 }
 224
 225 sub datetime_parser_type {
 226   'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
 227 }
 228
 229 package # hide from PAUSE
 230   DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
 231
 232 my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
 233 my $date_format      = '%Y-%m-%d';
 234
 235 my ($timestamp_parser, $date_parser);
 236
 237 sub parse_datetime {
 238   shift;
 239   require DateTime::Format::Strptime;
 240   $timestamp_parser ||= DateTime::Format::Strptime->new(
 241     pattern  => $timestamp_format,
 242     on_error => 'croak',
 243   );
 244   return $timestamp_parser->parse_datetime(shift);
 245 }
 246
 247 sub format_datetime {
 248   shift;
 249   require DateTime::Format::Strptime;
 250   $timestamp_parser ||= DateTime::Format::Strptime->new(
 251     pattern  => $timestamp_format,
 252     on_error => 'croak',
 253   );
 254   return $timestamp_parser->format_datetime(shift);
 255 }
 256
 257 sub parse_date {
 258   shift;
 259   require DateTime::Format::Strptime;
 260   $date_parser ||= DateTime::Format::Strptime->new(
 261     pattern  => $date_format,
 262     on_error => 'croak',
 263   );
 264   return $date_parser->parse_datetime(shift);
 265 }
 266
 267 sub format_date {
 268   shift;
 269   require DateTime::Format::Strptime;
 270   $date_parser ||= DateTime::Format::Strptime->new(
 271     pattern  => $date_format,
 272     on_error => 'croak',
 273   );
 274   return $date_parser->format_datetime(shift);
 275 }
 276
 277 1;
 278
 279 =head1 CAVEATS
 280
 281 =over 4
 282
 283 =item *
 284
 285 with L</connect_call_use_softcommit>, you will not be able to see changes made
 286 to data in other processes. If this is an issue, use
 287 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> as a
 288 workaround for the C<no statement executing> errors, this of course adversely
 289 affects performance.
 290
 291 Alternately, use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver.
 292
 293 =item *
 294
 295 C<last_insert_id> support by default only works for Firebird versions 2 or
 296 greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
 297 work with earlier versions.
 298
 299 =item *
 300
 301 Sub-second precision for TIMESTAMPs is not currently available when using the
 302 L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver.
 303
 304 =back
 305
 306 =head1 AUTHOR
 307
 308 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 309
 310 =head1 LICENSE
 311
 312 You may distribute this code under the same terms as Perl itself.
 313
 314 =cut