1 package DBIx::Class::Schema::Loader::DBI::SQLite;
5 use base qw/DBIx::Class::Schema::Loader::DBI/;
6 use Carp::Clan qw/^DBIx::Class/;
7 use Text::Balanced qw( extract_bracketed );
10 our $VERSION = '0.04006';
14 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
19 use base qw/DBIx::Class::Schema::Loader/;
21 __PACKAGE__->loader_options( debug => 1 );
27 See L<DBIx::Class::Schema::Loader::Base>.
33 SQLite will fail all further commands on a connection if the
34 underlying schema has been modified. Therefore, any runtime
35 changes requiring C<rescan> also require us to re-connect
36 to the database. The C<rescan> method here handles that
37 reconnection for you, but beware that this must occur for
38 any other open sqlite connections as well.
43 my ($self, $schema) = @_;
45 $schema->storage->disconnect if $schema->storage;
46 $self->next::method($schema);
49 # XXX this really needs a re-factor
50 sub _sqlite_parse_table {
51 my ($self, $table) = @_;
56 my $dbh = $self->schema->storage->dbh;
57 my $sth = $self->{_cache}->{sqlite_master}
58 ||= $dbh->prepare(q{SELECT sql FROM sqlite_master WHERE tbl_name = ?});
60 $sth->execute($table);
61 my ($sql) = $sth->fetchrow_array;
64 # Cut "CREATE TABLE ( )" blabla...
65 $sql =~ /^[\w\s']+\((.*)\)$/si;
68 # strip single-line comments
69 $cols =~ s/\-\-.*\n/\n/g;
71 # temporarily replace any commas inside parens,
72 # so we don't incorrectly split on them below
73 my $cols_no_bracketed_commas = $cols;
74 while ( my $extracted =
75 ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] )
77 my $replacement = $extracted;
78 $replacement =~ s/,/--comma--/g;
79 $replacement =~ s/^\(//;
80 $replacement =~ s/\)$//;
81 $cols_no_bracketed_commas =~ s/$extracted/$replacement/m;
84 # Split column definitions
85 for my $col ( split /,/, $cols_no_bracketed_commas ) {
87 # put the paren-bracketed commas back, to help
88 # find multi-col fks below
89 $col =~ s/\-\-comma\-\-/,/g;
91 $col =~ s/^\s*FOREIGN\s+KEY\s*//i;
93 # Strip punctuations around key and table names
94 $col =~ s/[\[\]'"]/ /g;
100 if($col =~ /^(.*)\s+UNIQUE/i) {
102 $colname =~ s/\s+.*$//;
103 push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]);
105 elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/i) {
108 my @cols = map { lc } split(/\s*,\s*/, $cols);
109 my $name = join(q{_}, @cols) . '_unique';
110 push(@uniqs, [ $name => \@cols ]);
113 next if $col !~ /^(.*\S)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
115 my ($cols, $f_table, $f_cols) = ($1, $2, $3);
117 if($cols =~ /^\(/) { # Table-level
125 my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols);
128 my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols);
129 croak "Mismatched column count in rel for $table => $f_table"
134 local_columns => \@cols,
135 remote_columns => $rcols,
136 remote_table => $f_table,
140 return { rels => \@rels, uniqs => \@uniqs };
144 my ($self, $table) = @_;
146 $self->{_sqlite_parse_data}->{$table} ||=
147 $self->_sqlite_parse_table($table);
149 return $self->{_sqlite_parse_data}->{$table}->{rels};
152 sub _table_uniq_info {
153 my ($self, $table) = @_;
155 $self->{_sqlite_parse_data}->{$table} ||=
156 $self->_sqlite_parse_table($table);
158 return $self->{_sqlite_parse_data}->{$table}->{uniqs};
164 my $dbh = $self->schema->storage->dbh;
165 my $sth = $dbh->prepare("SELECT * FROM sqlite_master");
168 while ( my $row = $sth->fetchrow_hashref ) {
169 next unless lc( $row->{type} ) eq 'table';
170 next if $row->{tbl_name} =~ /^sqlite_/;
171 push @tables, $row->{tbl_name};
179 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
180 L<DBIx::Class::Schema::Loader::DBI>