1 package DBIx::Class::Schema::Loader::DBI::SQLite;
5 use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault';
7 use DBIx::Class::Schema::Loader::Table ();
9 our $VERSION = '0.07040';
13 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
17 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
23 SQLite will fail all further commands on a connection if the underlying schema
24 has been modified. Therefore, any runtime changes requiring C<rescan> also
25 require us to re-connect to the database. The C<rescan> method here handles
26 that reconnection for you, but beware that this must occur for any other open
27 sqlite connections as well.
34 $self->next::method(@_);
36 if (not defined $self->preserve_case) {
37 $self->preserve_case(0);
40 if ($self->db_schema) {
42 db_schema is not supported on SQLite, the option is implemented only for qualify_objects testing.
44 if ($self->db_schema->[0] eq '%') {
45 $self->db_schema(undef);
51 my ($self, $schema) = @_;
53 $schema->storage->disconnect if $schema->storage;
54 $self->next::method($schema);
57 sub _columns_info_for {
61 my $result = $self->next::method(@_);
63 local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
65 my $sth = $self->dbh->prepare(
66 "pragma table_info(" . $self->dbh->quote_identifier($table) . ")"
69 my $cols = $sth->fetchall_hashref('name');
71 # copy and case according to preserve_case mode
72 # no need to check for collisions, SQLite does not allow them
74 while (my ($col, $info) = each %$cols) {
75 $cols{ $self->_lc($col) } = $info;
78 my ($num_pk, $pk_col) = (0);
79 # SQLite doesn't give us the info we need to do this nicely :(
80 # If there is exactly one column marked PK, and its type is integer,
81 # set it is_auto_increment. This isn't 100%, but it's better than the
83 while (my ($col_name, $info) = each %$result) {
84 if ($cols{$col_name}{pk}) {
86 if (lc($cols{$col_name}{type}) eq 'integer') {
92 while (my ($col, $info) = each %$result) {
93 if ((eval { ${ $info->{default_value} } }||'') eq 'CURRENT_TIMESTAMP') {
94 ${ $info->{default_value} } = 'current_timestamp';
96 if ($num_pk == 1 and defined $pk_col and $pk_col eq $col) {
97 $info->{is_auto_increment} = 1;
105 my ($self, $table) = @_;
107 my $sth = $self->dbh->prepare(
108 "pragma foreign_key_list(" . $self->dbh->quote_identifier($table) . ")"
113 while (my $fk = $sth->fetchrow_hashref) {
114 my $rel = $rels[ $fk->{id} ] ||= {
116 remote_columns => undef,
117 remote_table => DBIx::Class::Schema::Loader::Table->new(
119 name => $fk->{table},
120 ($self->db_schema ? (
121 schema => $self->db_schema->[0],
127 push @{ $rel->{local_columns} }, $self->_lc($fk->{from});
128 push @{ $rel->{remote_columns} }, $self->_lc($fk->{to}) if defined $fk->{to};
131 on_delete => uc $fk->{on_delete},
132 on_update => uc $fk->{on_update},
135 warn "This is supposed to be the same rel but remote_table changed from ",
136 $rel->{remote_table}->name, " to ", $fk->{table}
137 if $rel->{remote_table}->name ne $fk->{table};
141 # now we need to determine whether each FK is DEFERRABLE, this can only be
142 # done by parsing the DDL from sqlite_master
144 my $ddl = $self->dbh->selectcol_arrayref(<<"EOF", undef, $table->name, $table->name)->[0];
145 select sql from sqlite_master
146 where name = ? and tbl_name = ?
149 foreach my $fk (@rels) {
150 my $local_cols = '"?' . (join '"? \s* , \s* "?', map quotemeta, @{ $fk->{local_columns} }) . '"?';
151 my $remote_cols = '"?' . (join '"? \s* , \s* "?', map quotemeta, @{ $fk->{remote_columns} || [] }) . '"?';
152 my ($deferrable_clause) = $ddl =~ /
153 foreign \s+ key \s* \( \s* $local_cols \s* \) \s* references \s* (?:\S+|".+?(?<!")") \s*
154 (?:\( \s* $remote_cols \s* \) \s*)?
156 on \s+ (?:delete|update) \s+ (?:set \s+ null|set \s+ default|cascade|restrict|no \s+ action)
158 match \s* (?:\S+|".+?(?<!")")
160 ((?:not)? \s* deferrable)?
163 if ($deferrable_clause) {
164 $fk->{attrs}{is_deferrable} = $deferrable_clause =~ /not/i ? 0 : 1;
167 # check for inline constraint if 1 local column
168 if (@{ $fk->{local_columns} } == 1) {
169 my ($local_col) = @{ $fk->{local_columns} };
170 my ($remote_col) = @{ $fk->{remote_columns} || [] };
173 my ($deferrable_clause) = $ddl =~ /
174 "?\Q$local_col\E"? \s* (?:\w+\s*)* (?: \( \s* \d\+ (?:\s*,\s*\d+)* \s* \) )? \s*
175 references \s+ (?:\S+|".+?(?<!")") (?:\s* \( \s* "?\Q$remote_col\E"? \s* \))? \s*
177 on \s+ (?:delete|update) \s+ (?:set \s+ null|set \s+ default|cascade|restrict|no \s+ action)
179 match \s* (?:\S+|".+?(?<!")")
181 ((?:not)? \s* deferrable)?
184 if ($deferrable_clause) {
185 $fk->{attrs}{is_deferrable} = $deferrable_clause =~ /not/i ? 0 : 1;
188 $fk->{attrs}{is_deferrable} = 0;
192 $fk->{attrs}{is_deferrable} = 0;
200 sub _table_uniq_info {
201 my ($self, $table) = @_;
203 my $sth = $self->dbh->prepare(
204 "pragma index_list(" . $self->dbh->quote($table) . ")"
209 while (my $idx = $sth->fetchrow_hashref) {
210 next unless $idx->{unique};
212 my $name = $idx->{name};
214 my $get_idx_sth = $self->dbh->prepare("pragma index_info(" . $self->dbh->quote($name) . ")");
215 $get_idx_sth->execute;
217 while (my $idx_row = $get_idx_sth->fetchrow_hashref) {
218 push @cols, $self->_lc($idx_row->{name});
220 $get_idx_sth->finish;
222 # Rename because SQLite complains about sqlite_ prefixes on identifiers
223 # and ignores constraint names in DDL.
224 $name = (join '_', @cols) . '_unique';
226 push @uniqs, [ $name => \@cols ];
229 return [ sort { $a->[0] cmp $b->[0] } @uniqs ];
233 my ($self, $opts) = @_;
235 my $sth = $self->dbh->prepare("SELECT * FROM sqlite_master");
238 while ( my $row = $sth->fetchrow_hashref ) {
239 next unless $row->{type} =~ /^(?:table|view)\z/i;
240 next if $row->{tbl_name} =~ /^sqlite_/;
241 push @tables, DBIx::Class::Schema::Loader::Table->new(
243 name => $row->{tbl_name},
244 ($self->db_schema ? (
245 schema => $self->db_schema->[0],
246 ignore_schema => 1, # for qualify_objects tests
251 return $self->_filter_tables(\@tables, $opts);
254 sub _table_info_matches {
255 my ($self, $table, $info) = @_;
257 my $table_schema = $table->schema;
258 $table_schema = 'main' if !defined $table_schema;
259 return $info->{TABLE_SCHEM} eq $table_schema
260 && $info->{TABLE_NAME} eq $table->name;
265 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
266 L<DBIx::Class::Schema::Loader::DBI>
270 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
274 This library is free software; you can redistribute it and/or modify it under
275 the same terms as Perl itself.
280 # vim:et sts=4 sw=4 tw=0: