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