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 qw/
   6     DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
   7     DBIx::Class::Schema::Loader::DBI
   8 /;
   9 use Carp::Clan qw/^DBIx::Class/;
  10 use Text::Balanced qw( extract_bracketed );
  11 use Class::C3;
  12
  13 our $VERSION = '0.05001';
  14
  15 =head1 NAME
  16
  17 DBIx::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
  30 See L<DBIx::Class::Schema::Loader::Base>.
  31
  32 =head1 METHODS
  33
  34 =head2 rescan
  35
  36 SQLite will fail all further commands on a connection if the
  37 underlying schema has been modified.  Therefore, any runtime
  38 changes requiring C<rescan> also require us to re-connect
  39 to the database.  The C<rescan> method here handles that
  40 reconnection for you, but beware that this must occur for
  41 any other open sqlite connections as well.
  42
  43 =cut
  44
  45 sub 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
  53 sub _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* \( (.*) \) )? /ix;
 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+.*$//;
 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
 152 sub _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
 167 sub _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
 176 sub _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
 185 sub _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
 203 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 204 L<DBIx::Class::Schema::Loader::DBI>
 205
 206 =head1 AUTHOR
 207
 208 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 209
 210 =head1 LICENSE
 211
 212 This library is free software; you can redistribute it and/or modify it under
 213 the same terms as Perl itself.
 214
 215 =cut
 216
 217 1;