X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FSQLite.pm;h=9a93072629caa353b035783ef184054ba9a76d03;hb=f671b6308c4f2210255b2eaa12fc47a49621d436;hp=aadaf579132dd7d41f5ec0f339888200cd5ef64f;hpb=dca5cd028274876a0c531c007aae5d20611b617d;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm index aadaf57..9a93072 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm @@ -7,41 +7,40 @@ use base qw/ DBIx::Class::Schema::Loader::DBI /; use Carp::Clan qw/^DBIx::Class/; -use Text::Balanced qw( extract_bracketed ); -use Class::C3; +use mro 'c3'; -our $VERSION = '0.05003'; +our $VERSION = '0.07002'; =head1 NAME DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation. -=head1 SYNOPSIS - - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; - - __PACKAGE__->loader_options( debug => 1 ); - - 1; - =head1 DESCRIPTION -See L. +See L and L. =head1 METHODS =head2 rescan -SQLite will fail all further commands on a connection if the -underlying schema has been modified. Therefore, any runtime -changes requiring C also require us to re-connect -to the database. The C method here handles that -reconnection for you, but beware that this must occur for -any other open sqlite connections as well. +SQLite will fail all further commands on a connection if the underlying schema +has been modified. Therefore, any runtime changes requiring C also +require us to re-connect to the database. The C method here handles +that reconnection for you, but beware that this must occur for any other open +sqlite connections as well. =cut +sub _setup { + my $self = shift; + + $self->next::method(@_); + + if (not defined $self->preserve_case) { + $self->preserve_case(0); + } +} + sub rescan { my ($self, $schema) = @_; @@ -49,34 +48,61 @@ sub rescan { $self->next::method($schema); } -sub _extra_column_info { - my ($self, $table, $col_name, $sth, $col_num) = @_; - ($table, $col_name) = @{$table}{qw/TABLE_NAME COLUMN_NAME/} if ref $table; - my %extra_info; +# A hack so that qualify_objects can be tested on SQLite, SQLite does not +# actually have schemas. +{ + sub _table_as_sql { + my $self = shift; + local $self->{db_schema}; + return $self->next::method(@_); + } + + sub _table_pk_info { + my $self = shift; + local $self->{db_schema}; + return $self->next::method(@_); + } +} + +sub _columns_info_for { + my $self = shift; + my ($table) = @_; + + my $result = $self->next::method(@_); my $dbh = $self->schema->storage->dbh; - my $get_seq; - eval { - $get_seq = $self->{_cache}->{sqlite_sequence} - ||= $dbh->prepare(q{SELECT count(*) FROM sqlite_sequence WHERE name = ?}); - $get_seq->execute($table); - }; - return {} if $@; - my ($has_autoinc) = $get_seq->fetchrow_array; - $get_seq->finish; - - if ($has_autoinc) { - my $sth = $dbh->prepare( - "pragma table_info(" . $dbh->quote_identifier($table) . ")" - ); - $sth->execute; - my $cols = $sth->fetchall_hashref('name'); - if ($cols->{$col_name}{pk}) { - $extra_info{is_auto_increment} = 1; + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $sth = $dbh->prepare( + "pragma table_info(" . $dbh->quote_identifier($table) . ")" + ); + $sth->execute; + my $cols = $sth->fetchall_hashref('name'); + + my ($num_pk, $pk_col) = (0); + # SQLite doesn't give us the info we need to do this nicely :( + # If there is exactly one column marked PK, and its type is integer, + # set it is_auto_increment. This isn't 100%, but it's better than the + # alternatives. + while (my ($col_name, $info) = each %$result) { + if ($cols->{$col_name}{pk}) { + $num_pk ++; + if (lc($cols->{$col_name}{type}) eq 'integer') { + $pk_col = $col_name; + } + } + } + + while (my ($col, $info) = each %$result) { + if ((eval { ${ $info->{default_value} } }||'') eq 'CURRENT_TIMESTAMP') { + ${ $info->{default_value} } = 'current_timestamp'; + } + if ($num_pk == 1 and defined $pk_col and $pk_col eq $col) { + $info->{is_auto_increment} = 1; } } - return \%extra_info; + return $result; } sub _table_fk_info { @@ -93,14 +119,14 @@ sub _table_fk_info { my $rel = $rels[ $fk->{id} ] ||= { local_columns => [], remote_columns => undef, - remote_table => lc $fk->{table} + remote_table => $fk->{table} }; - push @{ $rel->{local_columns} }, lc $fk->{from}; - push @{ $rel->{remote_columns} }, lc $fk->{to} if defined $fk->{to}; + push @{ $rel->{local_columns} }, $self->_lc($fk->{from}); + push @{ $rel->{remote_columns} }, $self->_lc($fk->{to}) if defined $fk->{to}; warn "This is supposed to be the same rel but remote_table changed from ", $rel->{remote_table}, " to ", $fk->{table} - if $rel->{remote_table} ne lc $fk->{table}; + if $rel->{remote_table} ne $fk->{table}; } $sth->finish; return \@rels; @@ -118,15 +144,21 @@ sub _table_uniq_info { my @uniqs; while (my $idx = $sth->fetchrow_hashref) { next unless $idx->{unique}; + my $name = $idx->{name}; my $get_idx_sth = $dbh->prepare("pragma index_info(" . $dbh->quote($name) . ")"); $get_idx_sth->execute; my @cols; while (my $idx_row = $get_idx_sth->fetchrow_hashref) { - push @cols, lc $idx_row->{name}; + push @cols, $self->_lc($idx_row->{name}); } $get_idx_sth->finish; + + # Rename because SQLite complains about sqlite_ prefixes on identifiers + # and ignores constraint names in DDL. + $name = (join '_', @cols) . '_unique'; + push @uniqs, [ $name => \@cols ]; } $sth->finish; @@ -134,19 +166,19 @@ sub _table_uniq_info { } sub _tables_list { - my $self = shift; + my ($self, $opts) = @_; my $dbh = $self->schema->storage->dbh; my $sth = $dbh->prepare("SELECT * FROM sqlite_master"); $sth->execute; my @tables; while ( my $row = $sth->fetchrow_hashref ) { - next unless lc( $row->{type} ) eq 'table'; + next unless $row->{type} =~ /^(?:table|view)\z/i; next if $row->{tbl_name} =~ /^sqlite_/; push @tables, $row->{tbl_name}; } $sth->finish; - return @tables; + return $self->_filter_tables(\@tables, $opts); } =head1 SEE ALSO