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 __PACKAGE__->datetime_parser_type(
  39   'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
  40 );
  41
  42 sub _sequence_fetch {
  43   my ($self, $nextval, $sequence) = @_;
  44
  45   $self->throw_exception("Can only fetch 'nextval' for a sequence")
  46     if $nextval !~ /^nextval$/i;
  47
  48   $self->throw_exception('No sequence to fetch') unless $sequence;
  49
  50   my ($val) = $self->_get_dbh->selectrow_array(sprintf
  51     'SELECT GEN_ID(%s, 1) FROM rdb$database',
  52     $self->sql_maker->_quote($sequence)
  53   );
  54
  55   return $val;
  56 }
  57
  58 sub _dbh_get_autoinc_seq {
  59   my ($self, $dbh, $source, $col) = @_;
  60
  61   my $table_name = $source->from;
  62   $table_name    = $$table_name if ref $table_name;
  63   $table_name    = $self->sql_maker->quote_char ? $table_name : uc($table_name);
  64
  65   local $dbh->{LongReadLen} = 100000;
  66   local $dbh->{LongTruncOk} = 1;
  67
  68   my $sth = $dbh->prepare(<<'EOF');
  69 SELECT t.rdb$trigger_source
  70 FROM rdb$triggers t
  71 WHERE t.rdb$relation_name = ?
  72 AND t.rdb$system_flag = 0 -- user defined
  73 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
  74 EOF
  75   $sth->execute($table_name);
  76
  77   while (my ($trigger) = $sth->fetchrow_array) {
  78     my @trig_cols = map {
  79       /^"([^"]+)/ ? $1 : uc($1)
  80     } $trigger =~ /new\.("?\w+"?)/ig;
  81
  82     my ($quoted, $generator) = $trigger =~
  83 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
  84
  85     if ($generator) {
  86       $generator = uc $generator unless $quoted;
  87
  88       return $generator
  89         if first {
  90           $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
  91         } @trig_cols;
  92     }
  93   }
  94
  95   return undef;
  96 }
  97
  98 sub _svp_begin {
  99     my ($self, $name) = @_;
 100
 101     $self->_get_dbh->do("SAVEPOINT $name");
 102 }
 103
 104 sub _svp_release {
 105     my ($self, $name) = @_;
 106
 107     $self->_get_dbh->do("RELEASE SAVEPOINT $name");
 108 }
 109
 110 sub _svp_rollback {
 111     my ($self, $name) = @_;
 112
 113     $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 114 }
 115
 116 sub _ping {
 117   my $self = shift;
 118
 119   my $dbh = $self->_dbh or return 0;
 120
 121   local $dbh->{RaiseError} = 1;
 122   local $dbh->{PrintError} = 0;
 123
 124   return try {
 125     $dbh->do('select 1 from rdb$database');
 126     1;
 127   } catch {
 128     0;
 129   };
 130 }
 131
 132 # We want dialect 3 for new features and quoting to work, DBD::InterBase uses
 133 # dialect 1 (interbase compat) by default.
 134 sub _init {
 135   my $self = shift;
 136   $self->_set_sql_dialect(3);
 137 }
 138
 139 sub _set_sql_dialect {
 140   my $self = shift;
 141   my $val  = shift || 3;
 142
 143   my $dsn = $self->_dbi_connect_info->[0];
 144
 145   return if ref($dsn) eq 'CODE';
 146
 147   if ($dsn !~ /ib_dialect=/) {
 148     $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val";
 149     my $connected = defined $self->_dbh;
 150     $self->disconnect;
 151     $self->ensure_connected if $connected;
 152   }
 153 }
 154
 155 sub _get_server_version {
 156   my $self = shift;
 157
 158   return $self->next::method(@_) if ref $self ne __PACKAGE__;
 159
 160   local $SIG{__WARN__} = sub {}; # silence warning due to bug in DBD::InterBase
 161
 162   return $self->next::method(@_);
 163 }
 164
 165 =head2 connect_call_use_softcommit
 166
 167 Used as:
 168
 169   on_connect_call => 'use_softcommit'
 170
 171 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the
 172 L<DBD::InterBase> C<ib_softcommit> option.
 173
 174 You need either this option or C<< disable_sth_caching => 1 >> for
 175 L<DBIx::Class> code to function correctly (otherwise you may get C<no statement
 176 executing> errors.) Or use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird>
 177 driver.
 178
 179 The downside of using this option is that your process will B<NOT> see UPDATEs,
 180 INSERTs and DELETEs from other processes for already open statements.
 181
 182 =cut
 183
 184 sub connect_call_use_softcommit {
 185   my $self = shift;
 186
 187   $self->_dbh->{ib_softcommit} = 1;
 188 }
 189
 190 =head2 connect_call_datetime_setup
 191
 192 Used as:
 193
 194   on_connect_call => 'datetime_setup'
 195
 196 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the date and
 197 timestamp formats using:
 198
 199   $dbh->{ib_time_all} = 'ISO';
 200
 201 See L<DBD::InterBase> for more details.
 202
 203 The C<TIMESTAMP> data type supports up to 4 digits after the decimal point for
 204 second precision. The full precision is used.
 205
 206 The C<DATE> data type stores the date portion only, and it B<MUST> be declared
 207 with:
 208
 209   data_type => 'date'
 210
 211 in your Result class.
 212
 213 Timestamp columns can be declared with either C<datetime> or C<timestamp>.
 214
 215 You will need the L<DateTime::Format::Strptime> module for inflation to work.
 216
 217 For L<DBIx::Class::Storage::DBI::ODBC::Firebird>, this is a noop and sub-second
 218 precision is not currently available.
 219
 220 =cut
 221
 222 sub connect_call_datetime_setup {
 223   my $self = shift;
 224
 225   $self->_get_dbh->{ib_time_all} = 'ISO';
 226 }
 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