X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FSQLite.pm;h=57b5202d07e70630b70aa4be6825e7b2ee765d84;hb=268cc2469d1405a421e64ff487c0f18d7d8ba9a1;hp=807af5ee6f7344ff732fb80fe6db4bce49148d61;hpb=e0510424237e567ad9fab64f21df01b3dff0e320;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 807af5e..57b5202 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm @@ -2,43 +2,46 @@ package DBIx::Class::Schema::Loader::DBI::SQLite; use strict; use warnings; -use base qw/DBIx::Class::Schema::Loader::DBI/; +use base qw/ + DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault + DBIx::Class::Schema::Loader::DBI +/; use Carp::Clan qw/^DBIx::Class/; use Text::Balanced qw( extract_bracketed ); use Class::C3; -our $VERSION = '0.03999_01'; +our $VERSION = '0.07000'; =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) = @_; @@ -46,132 +49,115 @@ sub rescan { $self->next::method($schema); } -# XXX this really needs a re-factor -sub _sqlite_parse_table { - my ($self, $table) = @_; +sub _columns_info_for { + my $self = shift; + my ($table) = @_; - my @rels; - my @uniqs; + my $result = $self->next::method(@_); my $dbh = $self->schema->storage->dbh; - my $sth = $self->{_cache}->{sqlite_master} - ||= $dbh->prepare(q{SELECT sql FROM sqlite_master WHERE tbl_name = ?}); - - $sth->execute($table); - my ($sql) = $sth->fetchrow_array; - $sth->finish; - - # Cut "CREATE TABLE ( )" blabla... - $sql =~ /^[\w\s]+\((.*)\)$/si; - my $cols = $1; - - # strip single-line comments - $cols =~ s/\-\-.*\n/\n/g; - - # temporarily replace any commas inside parens, - # so we don't incorrectly split on them below - my $cols_no_bracketed_commas = $cols; - while ( my $extracted = - ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] ) - { - my $replacement = $extracted; - $replacement =~ s/,/--comma--/g; - $replacement =~ s/^\(//; - $replacement =~ s/\)$//; - $cols_no_bracketed_commas =~ s/$extracted/$replacement/m; - } - - # Split column definitions - for my $col ( split /,/, $cols_no_bracketed_commas ) { - - # put the paren-bracketed commas back, to help - # find multi-col fks below - $col =~ s/\-\-comma\-\-/,/g; - - $col =~ s/^\s*FOREIGN\s+KEY\s*//i; - - # Strip punctuations around key and table names - $col =~ s/[\[\]'"]/ /g; - $col =~ s/^\s+//gs; - - # Grab reference - chomp $col; - - if($col =~ /^(.*)\s+UNIQUE/i) { - my $colname = $1; - $colname =~ s/\s+.*$//; - push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]); - } - elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/i) { - my $cols = $1; - $cols =~ s/\s+$//; - my @cols = map { lc } split(/\s*,\s*/, $cols); - my $name = join(q{_}, @cols) . '_unique'; - push(@uniqs, [ $name => \@cols ]); - } - - next if $col !~ /^(.*\S)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix; - - my ($cols, $f_table, $f_cols) = ($1, $2, $3); - - if($cols =~ /^\(/) { # Table-level - $cols =~ s/^\(\s*//; - $cols =~ s/\s*\)$//; - } - else { # Inline - $cols =~ s/\s+.*$//; + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $has_autoinc = eval { + my $get_seq = $self->{_cache}{sqlite_sequence} + ||= $dbh->prepare(q{SELECT count(*) FROM sqlite_sequence WHERE name = ?}); + $get_seq->execute($table); + my ($ret) = $get_seq->fetchrow_array; + $get_seq->finish; + $ret; + }; + + if (!$@ && $has_autoinc) { + my $sth = $dbh->prepare( + "pragma table_info(" . $dbh->quote_identifier($table) . ")" + ); + $sth->execute; + my $cols = $sth->fetchall_hashref('name'); + + while (my ($col_name, $info) = each %$result) { + if ($cols->{$col_name}{pk}) { + $info->{is_auto_increment} = 1; + } } + } - my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols); - my $rcols; - if($f_cols) { - my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols); - croak "Mismatched column count in rel for $table => $f_table" - if @cols != @f_cols; - $rcols = \@f_cols; + while (my ($col, $info) = each %$result) { + if ((eval { ${ $info->{default_value} } }||'') eq 'CURRENT_TIMESTAMP') { + ${ $info->{default_value} } = 'current_timestamp'; } - push(@rels, { - local_columns => \@cols, - remote_columns => $rcols, - remote_table => $f_table, - }); } - return { rels => \@rels, uniqs => \@uniqs }; + return $result; } sub _table_fk_info { my ($self, $table) = @_; - $self->{_sqlite_parse_data}->{$table} ||= - $self->_sqlite_parse_table($table); + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare( + "pragma foreign_key_list(" . $dbh->quote_identifier($table) . ")" + ); + $sth->execute; - return $self->{_sqlite_parse_data}->{$table}->{rels}; + my @rels; + while (my $fk = $sth->fetchrow_hashref) { + my $rel = $rels[ $fk->{id} ] ||= { + local_columns => [], + remote_columns => undef, + remote_table => $fk->{table} + }; + + 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 $fk->{table}; + } + $sth->finish; + return \@rels; } sub _table_uniq_info { my ($self, $table) = @_; - $self->{_sqlite_parse_data}->{$table} ||= - $self->_sqlite_parse_table($table); + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare( + "pragma index_list(" . $dbh->quote($table) . ")" + ); + $sth->execute; - return $self->{_sqlite_parse_data}->{$table}->{uniqs}; + 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, $self->_lc($idx_row->{name}); + } + $get_idx_sth->finish; + push @uniqs, [ $name => \@cols ]; + } + $sth->finish; + return \@uniqs; } 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 @@ -179,6 +165,15 @@ sub _tables_list { L, L, L +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + =cut 1;