1package DBIx::Class::Schema::Loader::DBI::SQLite; 2 3use strict; 4use warnings; 5use base qw/ 6 DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault 7 DBIx::Class::Schema::Loader::DBI 8/; 9use Carp::Clan qw/^DBIx::Class/; 10use Text::Balanced qw( extract_bracketed ); 11use Class::C3; 12 13our $VERSION = '0.05003'; 14 15=head1 NAME 16 17DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation. 18 19=head1 SYNOPSIS 20 21 package My::Schema; 22 use base qw/DBIx::Class::Schema::Loader/; 23 24 __PACKAGE__->loader_options( debug => 1 ); 25 26 1; 27 28=head1 DESCRIPTION 29 30See L<DBIx::Class::Schema::Loader::Base>. 31 32=head1 METHODS 33 34=head2 rescan 35 36SQLite will fail all further commands on a connection if the 37underlying schema has been modified. Therefore, any runtime 38changes requiring C<rescan> also require us to re-connect 39to the database. The C<rescan> method here handles that 40reconnection for you, but beware that this must occur for 41any other open sqlite connections as well. 42 43=cut 44 45sub rescan { 46 my ($self, $schema) = @_; 47 48 $schema->storage->disconnect if $schema->storage; 49 $self->next::method($schema); 50} 51 52# XXX this really needs a re-factor 53sub _sqlite_parse_table { 54 my ($self, $table) = @_; 55 56 my @rels; 57 my @uniqs; 58 my %auto_inc; 59 60 my $dbh = $self->schema->storage->dbh; 61 my $sth = $self->{_cache}->{sqlite_master} 62 ||= $dbh->prepare(q{SELECT sql FROM sqlite_master WHERE tbl_name = ?}); 63 64 $sth->execute($table); 65 my ($sql) = $sth->fetchrow_array; 66 $sth->finish; 67 68 # Cut "CREATE TABLE ( )" blabla... 69 $sql =~ /^[\w\s"]+\((.*)\)$/si; 70 my $cols = $1; 71 72 # strip single-line comments 73 $cols =~ s/\-\-.*\n/\n/g; 74 75 # temporarily replace any commas inside parens, 76 # so we don't incorrectly split on them below 77 my $cols_no_bracketed_commas = $cols; 78 while ( my $extracted = 79 ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] ) 80 { 81 my $replacement = $extracted; 82 $replacement =~ s/,/--comma--/g; 83 $replacement =~ s/^\(//; 84 $replacement =~ s/\)$//; 85 $cols_no_bracketed_commas =~ s/$extracted/$replacement/m; 86 } 87 88 # Split column definitions 89 for my $col ( split /,/, $cols_no_bracketed_commas ) { 90 91 # put the paren-bracketed commas back, to help 92 # find multi-col fks below 93 $col =~ s/\-\-comma\-\-/,/g; 94 95 $col =~ s/^\s*FOREIGN\s+KEY\s*//i; 96 97 # Strip punctuations around key and table names 98 $col =~ s/[\[\]'"]/ /g; 99 $col =~ s/^\s+//gs; 100 101 # Grab reference 102 chomp $col; 103 104 if($col =~ /^(.*)\s+UNIQUE/i) { 105 my $colname = $1; 106 $colname =~ s/\s+.*$//; 107 push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]); 108 } 109 elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/i) { 110 my $cols = $1; 111 $cols =~ s/\s+$//; 112 my @cols = map { lc } split(/\s*,\s*/, $cols); 113 my $name = join(q{_}, @cols) . '_unique'; 114 push(@uniqs, [ $name => \@cols ]); 115 } 116 117 if ($col =~ /AUTOINCREMENT/i) { 118 $col =~ /^(\S+)/; 119 $auto_inc{lc $1} = 1; 120 } 121 122 next if $col !~ /^(.*\S)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /six; 123 124 my ($cols, $f_table, $f_cols) = ($1, $2, $3); 125 126 if($cols =~ /^\(/) { # Table-level 127 $cols =~ s/^\(\s*//; 128 $cols =~ s/\s*\)$//; 129 } 130 else { # Inline 131 $cols =~ s/\s+.*$//s; 132 } 133 134 my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols); 135 my $rcols; 136 if($f_cols) { 137 my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols); 138 croak "Mismatched column count in rel for $table => $f_table" 139 if @cols != @f_cols; 140 $rcols = \@f_cols; 141 } 142 push(@rels, { 143 local_columns => \@cols, 144 remote_columns => $rcols, 145 remote_table => $f_table, 146 }); 147 } 148 149 return { rels => \@rels, uniqs => \@uniqs, auto_inc => \%auto_inc }; 150} 151 152sub _extra_column_info { 153 my ($self, $table, $col_name, $sth, $col_num) = @_; 154 ($table, $col_name) = @{$table}{qw/TABLE_NAME COLUMN_NAME/} if ref $table; 155 my %extra_info; 156 157 $self->{_sqlite_parse_data}->{$table} ||= 158 $self->_sqlite_parse_table($table); 159 160 if ($self->{_sqlite_parse_data}->{$table}->{auto_inc}->{$col_name}) { 161 $extra_info{is_auto_increment} = 1; 162 } 163 164 return \%extra_info; 165} 166 167sub _table_fk_info { 168 my ($self, $table) = @_; 169 170 $self->{_sqlite_parse_data}->{$table} ||= 171 $self->_sqlite_parse_table($table); 172 173 return $self->{_sqlite_parse_data}->{$table}->{rels}; 174} 175 176sub _table_uniq_info { 177 my ($self, $table) = @_; 178 179 $self->{_sqlite_parse_data}->{$table} ||= 180 $self->_sqlite_parse_table($table); 181 182 return $self->{_sqlite_parse_data}->{$table}->{uniqs}; 183} 184 185sub _tables_list { 186 my $self = shift; 187 188 my $dbh = $self->schema->storage->dbh; 189 my $sth = $dbh->prepare("SELECT * FROM sqlite_master"); 190 $sth->execute; 191 my @tables; 192 while ( my $row = $sth->fetchrow_hashref ) { 193 next unless lc( $row->{type} ) eq 'table'; 194 next if $row->{tbl_name} =~ /^sqlite_/; 195 push @tables, $row->{tbl_name}; 196 } 197 $sth->finish; 198 return @tables; 199} 200 201=head1 SEE ALSO 202 203L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 204L<DBIx::Class::Schema::Loader::DBI> 205 206=head1 AUTHOR 207 208See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 209 210=head1 LICENSE 211 212This library is free software; you can redistribute it and/or modify it under 213the same terms as Perl itself. 214 215=cut 216 2171; 218