lib/DBIx/Class/Storage/DBI/Firebird/Common.pm

   1 package DBIx::Class::Storage::DBI::Firebird::Common;
   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 namespace::clean;
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Storage::DBI::Firebird::Common - Driver Base Class for the Firebird RDBMS
  13
  14 =head1 DESCRIPTION
  15
  16 This class implements autoincrements for Firebird using C<RETURNING> as well as
  17 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>, savepoints and server
  18 version detection.
  19
  20 =cut
  21
  22 # set default
  23 __PACKAGE__->_use_insert_returning (1);
  24 __PACKAGE__->sql_limit_dialect ('FirstSkip');
  25 __PACKAGE__->sql_quote_char ('"');
  26
  27 __PACKAGE__->datetime_parser_type(
  28   'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
  29 );
  30
  31 sub _sequence_fetch {
  32   my ($self, $nextval, $sequence) = @_;
  33
  34   $self->throw_exception("Can only fetch 'nextval' for a sequence")
  35     if $nextval !~ /^nextval$/i;
  36
  37   $self->throw_exception('No sequence to fetch') unless $sequence;
  38
  39   my ($val) = $self->_get_dbh->selectrow_array(sprintf
  40     'SELECT GEN_ID(%s, 1) FROM rdb$database',
  41     $self->sql_maker->_quote($sequence)
  42   );
  43
  44   return $val;
  45 }
  46
  47 sub _dbh_get_autoinc_seq {
  48   my ($self, $dbh, $source, $col) = @_;
  49
  50   my $table_name = $source->from;
  51   $table_name    = $$table_name if ref $table_name;
  52   $table_name    = $self->sql_maker->quote_char ? $table_name : uc($table_name);
  53
  54   local $dbh->{LongReadLen} = 100000;
  55   local $dbh->{LongTruncOk} = 1;
  56
  57   my $sth = $dbh->prepare(<<'EOF');
  58 SELECT t.rdb$trigger_source
  59 FROM rdb$triggers t
  60 WHERE t.rdb$relation_name = ?
  61 AND t.rdb$system_flag = 0 -- user defined
  62 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
  63 EOF
  64   $sth->execute($table_name);
  65
  66   while (my ($trigger) = $sth->fetchrow_array) {
  67     my @trig_cols = map
  68       { /^"([^"]+)/ ? $1 : uc($_) }
  69       $trigger =~ /new\.("?\w+"?)/ig
  70     ;
  71
  72     my ($quoted, $generator) = $trigger =~
  73 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
  74
  75     if ($generator) {
  76       $generator = uc $generator unless $quoted;
  77
  78       return $generator
  79         if first {
  80           $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
  81         } @trig_cols;
  82     }
  83   }
  84
  85   return undef;
  86 }
  87
  88 sub _exec_svp_begin {
  89   my ($self, $name) = @_;
  90
  91   $self->_dbh->do("SAVEPOINT $name");
  92 }
  93
  94 sub _exec_svp_release {
  95   my ($self, $name) = @_;
  96
  97   $self->_dbh->do("RELEASE SAVEPOINT $name");
  98 }
  99
 100 sub _exec_svp_rollback {
 101   my ($self, $name) = @_;
 102
 103   $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
 104 }
 105
 106 # http://www.firebirdfaq.org/faq223/
 107 sub _get_server_version {
 108   my $self = shift;
 109
 110   return $self->_get_dbh->selectrow_array(q{
 111 SELECT rdb$get_context('SYSTEM', 'ENGINE_VERSION') FROM rdb$database
 112   });
 113 }
 114
 115 package # hide from PAUSE
 116   DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
 117
 118 my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
 119 my $date_format      = '%Y-%m-%d';
 120
 121 my ($timestamp_parser, $date_parser);
 122
 123 sub parse_datetime {
 124   shift;
 125   require DateTime::Format::Strptime;
 126   $timestamp_parser ||= DateTime::Format::Strptime->new(
 127     pattern  => $timestamp_format,
 128     on_error => 'croak',
 129   );
 130   return $timestamp_parser->parse_datetime(shift);
 131 }
 132
 133 sub format_datetime {
 134   shift;
 135   require DateTime::Format::Strptime;
 136   $timestamp_parser ||= DateTime::Format::Strptime->new(
 137     pattern  => $timestamp_format,
 138     on_error => 'croak',
 139   );
 140   return $timestamp_parser->format_datetime(shift);
 141 }
 142
 143 sub parse_date {
 144   shift;
 145   require DateTime::Format::Strptime;
 146   $date_parser ||= DateTime::Format::Strptime->new(
 147     pattern  => $date_format,
 148     on_error => 'croak',
 149   );
 150   return $date_parser->parse_datetime(shift);
 151 }
 152
 153 sub format_date {
 154   shift;
 155   require DateTime::Format::Strptime;
 156   $date_parser ||= DateTime::Format::Strptime->new(
 157     pattern  => $date_format,
 158     on_error => 'croak',
 159   );
 160   return $date_parser->format_datetime(shift);
 161 }
 162
 163 1;
 164
 165 =head1 CAVEATS
 166
 167 =over 4
 168
 169 =item *
 170
 171 C<last_insert_id> support by default only works for Firebird versions 2 or
 172 greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
 173 work with earlier versions.
 174
 175 =back
 176
 177 =head1 AUTHOR
 178
 179 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 180
 181 =head1 LICENSE
 182
 183 You may distribute this code under the same terms as Perl itself.
 184
 185 =cut
 186 # vim:sts=2 sw=2: