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 preliminary
  23 L<DBIx::Class::InflateColumn::DateTime> support.
  24
  25 For ODBC support, see L<DBIx::Class::Storage::DBI::ODBC::Firebird>.
  26
  27 =cut
  28
  29 sub _prep_for_execute {
  30   my $self = shift;
  31   my ($op, $extra_bind, $ident, $args) = @_;
  32
  33   if ($op eq 'insert') {
  34     my @pk = $ident->primary_columns;
  35     my %pk;
  36     @pk{@pk} = ();
  37
  38     my @auto_inc_cols = grep {
  39       my $inserting = $args->[0]{$_};
  40
  41       ($ident->column_info($_)->{is_auto_increment}
  42         || exists $pk{$_})
  43       && (
  44         (not defined $inserting)
  45         ||
  46         (ref $inserting eq 'SCALAR' && $$inserting =~ /^null\z/i)
  47       )
  48     } $ident->columns;
  49
  50     if (@auto_inc_cols) {
  51       $args->[1]{returning} = \@auto_inc_cols;
  52
  53       $self->_auto_incs([]);
  54       $self->_auto_incs->[0] = \@auto_inc_cols;
  55     }
  56   }
  57
  58   return $self->next::method(@_);
  59 }
  60
  61 sub _execute {
  62   my $self = shift;
  63   my ($op) = @_;
  64
  65   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
  66
  67   if ($op eq 'insert' && $self->_auto_incs) {
  68     local $@;
  69     my (@auto_incs) = eval {
  70       local $SIG{__WARN__} = sub {};
  71       $sth->fetchrow_array
  72     };
  73     $self->_auto_incs->[1] = \@auto_incs;
  74     $sth->finish;
  75   }
  76
  77   return wantarray ? ($rv, $sth, @bind) : $rv;
  78 }
  79
  80 sub last_insert_id {
  81   my ($self, $source, @cols) = @_;
  82   my @result;
  83
  84   my %auto_incs;
  85   @auto_incs{ @{ $self->_auto_incs->[0] } } =
  86     @{ $self->_auto_incs->[1] };
  87
  88   push @result, $auto_incs{$_} for @cols;
  89
  90   return @result;
  91 }
  92
  93 # this sub stolen from DB2
  94
  95 sub _sql_maker_opts {
  96   my ( $self, $opts ) = @_;
  97
  98   if ( $opts ) {
  99     $self->{_sql_maker_opts} = { %$opts };
 100   }
 101
 102   return { limit_dialect => 'FirstSkip', %{$self->{_sql_maker_opts}||{}} };
 103 }
 104
 105 sub datetime_parser_type { __PACKAGE__ }
 106
 107 my ($datetime_parser, $datetime_formatter);
 108
 109 sub parse_datetime {
 110     shift;
 111     require DateTime::Format::Strptime;
 112     $datetime_parser ||= DateTime::Format::Strptime->new(
 113         pattern => '%a %d %b %Y %r',
 114 # there should be a %Z (TZ) on the end, but it's ambiguous and not parsed
 115         on_error => 'croak',
 116     );
 117     $datetime_parser->parse_datetime(shift);
 118 }
 119
 120 sub format_datetime {
 121     shift;
 122     require DateTime::Format::Strptime;
 123     $datetime_formatter ||= DateTime::Format::Strptime->new(
 124         pattern => '%F %H:%M:%S.%4N',
 125         on_error => 'croak',
 126     );
 127     $datetime_formatter->format_datetime(shift);
 128 }
 129
 130 1;
 131
 132 =head1 CAVEATS
 133
 134 =over 4
 135
 136 =item *
 137
 138 C<last_insert_id> support only works for Firebird versions 2 or greater. To
 139 work with earlier versions, we'll need to figure out how to retrieve the bodies
 140 of C<BEFORE INSERT> triggers and parse them for the C<GENERATOR> name.
 141
 142 =item *
 143
 144 C<TIMESTAMP> values are written with precision of 4 numbers after the decimal
 145 point for seconds, but read with only second precision.
 146
 147 If you know of a session variable we can set to control how timestamps look as
 148 strings, please let us know (via RT.)
 149
 150 Otherwise we'll need to rewrite the produced SQL for timestamps, at some point.
 151
 152 =back
 153
 154 =head1 AUTHOR
 155
 156 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 157
 158 =head1 LICENSE
 159
 160 You may distribute this code under the same terms as Perl itself.
 161
 162 =cut