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 sub _prep_for_execute {
  16   my $self = shift;
  17   my ($op, $extra_bind, $ident, $args) = @_;
  18
  19   if ($op eq 'insert') {
  20     my @pk = $ident->primary_columns;
  21     my %pk;
  22     @pk{@pk} = ();
  23
  24     my @auto_inc_cols = grep {
  25       my $inserting = $args->[0]{$_};
  26
  27       ($ident->column_info($_)->{is_auto_increment}
  28         || exists $pk{$_})
  29       && (
  30         (not defined $inserting)
  31         ||
  32         (ref $inserting eq 'SCALAR' && $$inserting =~ /^null\z/i)
  33       )
  34     } $ident->columns;
  35
  36     if (@auto_inc_cols) {
  37       $args->[1]{returning} = \@auto_inc_cols;
  38
  39       $self->_auto_incs([]);
  40       $self->_auto_incs->[0] = \@auto_inc_cols;
  41     }
  42   }
  43
  44   return $self->next::method(@_);
  45 }
  46
  47 sub _execute {
  48   my $self = shift;
  49   my ($op) = @_;
  50
  51   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
  52
  53   if ($op eq 'insert' && $self->_auto_incs) {
  54     local $@;
  55     my (@auto_incs) = eval {
  56       local $SIG{__WARN__} = sub {};
  57       $sth->fetchrow_array
  58     };
  59     $self->_auto_incs->[1] = \@auto_incs;
  60     $sth->finish;
  61   }
  62
  63   return wantarray ? ($rv, $sth, @bind) : $rv;
  64 }
  65
  66 sub last_insert_id {
  67   my ($self, $source, @cols) = @_;
  68   my @result;
  69
  70   my %auto_incs;
  71   @auto_incs{ @{ $self->_auto_incs->[0] } } =
  72     @{ $self->_auto_incs->[1] };
  73
  74   push @result, $auto_incs{$_} for @cols;
  75
  76   return @result;
  77 }
  78
  79 # this sub stolen from DB2
  80
  81 sub _sql_maker_opts {
  82   my ( $self, $opts ) = @_;
  83
  84   if ( $opts ) {
  85     $self->{_sql_maker_opts} = { %$opts };
  86   }
  87
  88   return { limit_dialect => 'FirstSkip', %{$self->{_sql_maker_opts}||{}} };
  89 }
  90
  91 sub datetime_parser_type { __PACKAGE__ }
  92
  93 my ($datetime_parser, $datetime_formatter);
  94
  95 sub parse_datetime {
  96     shift;
  97     require DateTime::Format::Strptime;
  98     $datetime_parser ||= DateTime::Format::Strptime->new(
  99         pattern => '%a %d %b %Y %r',
 100 # there should be a %Z (TZ) on the end, but it's ambiguous and not parsed
 101         on_error => 'croak',
 102     );
 103     $datetime_parser->parse_datetime(shift);
 104 }
 105
 106 sub format_datetime {
 107     shift;
 108     require DateTime::Format::Strptime;
 109     $datetime_formatter ||= DateTime::Format::Strptime->new(
 110         pattern => '%F %H:%M:%S.%4N',
 111         on_error => 'croak',
 112     );
 113     $datetime_formatter->format_datetime(shift);
 114 }
 115
 116 1;