1package DBIx::Class::Schema::Loader::DBI::SQLite; 2 3use strict; 4use warnings; 5use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault'; 6use mro 'c3'; 7use DBIx::Class::Schema::Loader::Table (); 8 9our $VERSION = '0.07033'; 10 11=head1 NAME 12 13DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation. 14 15=head1 DESCRIPTION 16 17See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>. 18 19=head1 METHODS 20 21=head2 rescan 22 23SQLite will fail all further commands on a connection if the underlying schema 24has been modified. Therefore, any runtime changes requiring C<rescan> also 25require us to re-connect to the database. The C<rescan> method here handles 26that reconnection for you, but beware that this must occur for any other open 27sqlite connections as well. 28 29=cut 30 31sub _setup { 32 my $self = shift; 33 34 $self->next::method(@_); 35 36 if (not defined $self->preserve_case) { 37 $self->preserve_case(0); 38 } 39 40 if ($self->db_schema) { 41 warn <<'EOF'; 42db_schema is not supported on SQLite, the option is implemented only for qualify_objects testing. 43EOF 44 if ($self->db_schema->[0] eq '%') { 45 $self->db_schema(undef); 46 } 47 } 48} 49 50sub rescan { 51 my ($self, $schema) = @_; 52 53 $schema->storage->disconnect if $schema->storage; 54 $self->next::method($schema); 55} 56 57sub _columns_info_for { 58 my $self = shift; 59 my ($table) = @_; 60 61 my $result = $self->next::method(@_); 62 63 local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; 64 65 my $sth = $self->dbh->prepare( 66 "pragma table_info(" . $self->dbh->quote_identifier($table) . ")" 67 ); 68 $sth->execute; 69 my $cols = $sth->fetchall_hashref('name'); 70 71 # copy and case according to preserve_case mode 72 # no need to check for collisions, SQLite does not allow them 73 my %cols; 74 while (my ($col, $info) = each %$cols) { 75 $cols{ $self->_lc($col) } = $info; 76 } 77 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 82 # alternatives. 83 while (my ($col_name, $info) = each %$result) { 84 if ($cols{$col_name}{pk}) { 85 $num_pk++; 86 if (lc($cols{$col_name}{type}) eq 'integer') { 87 $pk_col = $col_name; 88 } 89 } 90 } 91 92 while (my ($col, $info) = each %$result) { 93 if ((eval { ${ $info->{default_value} } }||'') eq 'CURRENT_TIMESTAMP') { 94 ${ $info->{default_value} } = 'current_timestamp'; 95 } 96 if ($num_pk == 1 and defined $pk_col and $pk_col eq $col) { 97 $info->{is_auto_increment} = 1; 98 } 99 } 100 101 return $result; 102} 103 104sub _table_fk_info { 105 my ($self, $table) = @_; 106 107 my $sth = $self->dbh->prepare( 108 "pragma foreign_key_list(" . $self->dbh->quote_identifier($table) . ")" 109 ); 110 $sth->execute; 111 112 my @rels; 113 while (my $fk = $sth->fetchrow_hashref) { 114 my $rel = $rels[ $fk->{id} ] ||= { 115 local_columns => [], 116 remote_columns => undef, 117 remote_table => DBIx::Class::Schema::Loader::Table->new( 118 loader => $self, 119 name => $fk->{table}, 120 ($self->db_schema ? ( 121 schema => $self->db_schema->[0], 122 ignore_schema => 1, 123 ) : ()), 124 ), 125 }; 126 127 push @{ $rel->{local_columns} }, $self->_lc($fk->{from}); 128 push @{ $rel->{remote_columns} }, $self->_lc($fk->{to}) if defined $fk->{to}; 129 130 $rel->{attrs} ||= { 131 on_delete => uc $fk->{on_delete}, 132 on_update => uc $fk->{on_update}, 133 }; 134 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}; 138 } 139 $sth->finish; 140 141 # now we need to determine whether each FK is DEFERRABLE, this can only be 142 # done by parsing the DDL from sqlite_master 143 144 my $ddl = $self->dbh->selectcol_arrayref(<<"EOF", undef, $table->name, $table->name)->[0]; 145select sql from sqlite_master 146where name = ? and tbl_name = ? 147EOF 148 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*)? 155 (?:(?: 156 on \s+ (?:delete|update) \s+ (?:set \s+ null|set \s+ default|cascade|restrict|no \s+ action) 157 | 158 match \s* (?:\S+|".+?(?<!")") 159 ) \s*)* 160 ((?:not)? \s* deferrable)? 161 /sxi; 162 163 if ($deferrable_clause) { 164 $fk->{attrs}{is_deferrable} = $deferrable_clause =~ /not/i ? 0 : 1; 165 } 166 else { 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} || [] }; 171 $remote_col ||= ''; 172 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* 176 (?:(?: 177 on \s+ (?:delete|update) \s+ (?:set \s+ null|set \s+ default|cascade|restrict|no \s+ action) 178 | 179 match \s* (?:\S+|".+?(?<!")") 180 ) \s*)* 181 ((?:not)? \s* deferrable)? 182 /sxi; 183 184 if ($deferrable_clause) { 185 $fk->{attrs}{is_deferrable} = $deferrable_clause =~ /not/i ? 0 : 1; 186 } 187 else { 188 $fk->{attrs}{is_deferrable} = 0; 189 } 190 } 191 else { 192 $fk->{attrs}{is_deferrable} = 0; 193 } 194 } 195 } 196 197 return \@rels; 198} 199 200sub _table_uniq_info { 201 my ($self, $table) = @_; 202 203 my $sth = $self->dbh->prepare( 204 "pragma index_list(" . $self->dbh->quote($table) . ")" 205 ); 206 $sth->execute; 207 208 my @uniqs; 209 while (my $idx = $sth->fetchrow_hashref) { 210 next unless $idx->{unique}; 211 212 my $name = $idx->{name}; 213 214 my $get_idx_sth = $self->dbh->prepare("pragma index_info(" . $self->dbh->quote($name) . ")"); 215 $get_idx_sth->execute; 216 my @cols; 217 while (my $idx_row = $get_idx_sth->fetchrow_hashref) { 218 push @cols, $self->_lc($idx_row->{name}); 219 } 220 $get_idx_sth->finish; 221 222 # Rename because SQLite complains about sqlite_ prefixes on identifiers 223 # and ignores constraint names in DDL. 224 $name = (join '_', @cols) . '_unique'; 225 226 push @uniqs, [ $name => \@cols ]; 227 } 228 $sth->finish; 229 return \@uniqs; 230} 231 232sub _tables_list { 233 my ($self, $opts) = @_; 234 235 my $sth = $self->dbh->prepare("SELECT * FROM sqlite_master"); 236 $sth->execute; 237 my @tables; 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( 242 loader => $self, 243 name => $row->{tbl_name}, 244 ($self->db_schema ? ( 245 schema => $self->db_schema->[0], 246 ignore_schema => 1, # for qualify_objects tests 247 ) : ()), 248 ); 249 } 250 $sth->finish; 251 return $self->_filter_tables(\@tables, $opts); 252} 253 254=head1 SEE ALSO 255 256L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 257L<DBIx::Class::Schema::Loader::DBI> 258 259=head1 AUTHOR 260 261See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 262 263=head1 LICENSE 264 265This library is free software; you can redistribute it and/or modify it under 266the same terms as Perl itself. 267 268=cut 269 2701; 271# vim:et sts=4 sw=4 tw=0: 272