lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm

   1 package DBIx::Class::Schema::Loader::DBI::SQLite;
   2
   3 use strict;
   4 use warnings;
   5 use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault';
   6 use mro 'c3';
   7 use DBIx::Class::Schema::Loader::Table ();
   8
   9 our $VERSION = '0.07047';
  10
  11 =head1 NAME
  12
  13 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
  14
  15 =head1 DESCRIPTION
  16
  17 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
  18
  19 =head1 METHODS
  20
  21 =head2 rescan
  22
  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.
  28
  29 =cut
  30
  31 sub _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';
  42 db_schema is not supported on SQLite, the option is implemented only for qualify_objects testing.
  43 EOF
  44         if ($self->db_schema->[0] eq '%') {
  45             $self->db_schema(undef);
  46         }
  47     }
  48 }
  49
  50 sub rescan {
  51     my ($self, $schema) = @_;
  52
  53     $schema->storage->disconnect if $schema->storage;
  54     $self->next::method($schema);
  55 }
  56
  57 sub _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
 104 sub _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];
 145 select sql from sqlite_master
 146 where name = ? and tbl_name = ?
 147 EOF
 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
 200 sub _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 [ sort { $a->[0] cmp $b->[0] } @uniqs ];
 230 }
 231
 232 sub _tables_list {
 233     my ($self) = @_;
 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);
 252 }
 253
 254 sub _table_info_matches {
 255     my ($self, $table, $info) = @_;
 256
 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;
 261 }
 262
 263 =head1 SEE ALSO
 264
 265 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 266 L<DBIx::Class::Schema::Loader::DBI>
 267
 268 =head1 AUTHORS
 269
 270 See L<DBIx::Class::Schema::Loader/AUTHORS>.
 271
 272 =head1 LICENSE
 273
 274 This library is free software; you can redistribute it and/or modify it under
 275 the same terms as Perl itself.
 276
 277 =cut
 278
 279 1;
 280 # vim:et sts=4 sw=4 tw=0: