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.03999_02';
  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
  56     my $dbh = $self->schema->storage->dbh;
  57     my $sth = $self->{_cache}->{sqlite_master}
  58         ||= $dbh->prepare(q{SELECT sql FROM sqlite_master WHERE tbl_name = ?});
  59
  60     $sth->execute($table);
  61     my ($sql) = $sth->fetchrow_array;
  62     $sth->finish;
  63
  64     # Cut "CREATE TABLE ( )" blabla...
  65     $sql =~ /^[\w\s']+\((.*)\)$/si;
  66     my $cols = $1;
  67
  68     # strip single-line comments
  69     $cols =~ s/\-\-.*\n/\n/g;
  70
  71     # temporarily replace any commas inside parens,
  72     # so we don't incorrectly split on them below
  73     my $cols_no_bracketed_commas = $cols;
  74     while ( my $extracted =
  75         ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] )
  76     {
  77         my $replacement = $extracted;
  78         $replacement              =~ s/,/--comma--/g;
  79         $replacement              =~ s/^\(//;
  80         $replacement              =~ s/\)$//;
  81         $cols_no_bracketed_commas =~ s/$extracted/$replacement/m;
  82     }
  83
  84     # Split column definitions
  85     for my $col ( split /,/, $cols_no_bracketed_commas ) {
  86
  87         # put the paren-bracketed commas back, to help
  88         # find multi-col fks below
  89         $col =~ s/\-\-comma\-\-/,/g;
  90
  91         $col =~ s/^\s*FOREIGN\s+KEY\s*//i;
  92
  93         # Strip punctuations around key and table names
  94         $col =~ s/[\[\]'"]/ /g;
  95         $col =~ s/^\s+//gs;
  96
  97         # Grab reference
  98         chomp $col;
  99
 100         if($col =~ /^(.*)\s+UNIQUE/i) {
 101             my $colname = $1;
 102             $colname =~ s/\s+.*$//;
 103             push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]);
 104         }
 105         elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/i) {
 106             my $cols = $1;
 107             $cols =~ s/\s+$//;
 108             my @cols = map { lc } split(/\s*,\s*/, $cols);
 109             my $name = join(q{_}, @cols) . '_unique';
 110             push(@uniqs, [ $name => \@cols ]);
 111         }
 112
 113         next if $col !~ /^(.*\S)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
 114
 115         my ($cols, $f_table, $f_cols) = ($1, $2, $3);
 116
 117         if($cols =~ /^\(/) { # Table-level
 118             $cols =~ s/^\(\s*//;
 119             $cols =~ s/\s*\)$//;
 120         }
 121         else {               # Inline
 122             $cols =~ s/\s+.*$//;
 123         }
 124
 125         my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols);
 126         my $rcols;
 127         if($f_cols) {
 128             my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols);
 129             croak "Mismatched column count in rel for $table => $f_table"
 130               if @cols != @f_cols;
 131             $rcols = \@f_cols;
 132         }
 133         push(@rels, {
 134             local_columns => \@cols,
 135             remote_columns => $rcols,
 136             remote_table => $f_table,
 137         });
 138     }
 139
 140     return { rels => \@rels, uniqs => \@uniqs };
 141 }
 142
 143 sub _table_fk_info {
 144     my ($self, $table) = @_;
 145
 146     $self->{_sqlite_parse_data}->{$table} ||=
 147         $self->_sqlite_parse_table($table);
 148
 149     return $self->{_sqlite_parse_data}->{$table}->{rels};
 150 }
 151
 152 sub _table_uniq_info {
 153     my ($self, $table) = @_;
 154
 155     $self->{_sqlite_parse_data}->{$table} ||=
 156         $self->_sqlite_parse_table($table);
 157
 158     return $self->{_sqlite_parse_data}->{$table}->{uniqs};
 159 }
 160
 161 sub _tables_list {
 162     my $self = shift;
 163
 164     my $dbh = $self->schema->storage->dbh;
 165     my $sth = $dbh->prepare("SELECT * FROM sqlite_master");
 166     $sth->execute;
 167     my @tables;
 168     while ( my $row = $sth->fetchrow_hashref ) {
 169         next unless lc( $row->{type} ) eq 'table';
 170         next if $row->{tbl_name} =~ /^sqlite_/;
 171         push @tables, $row->{tbl_name};
 172     }
 173     $sth->finish;
 174     return @tables;
 175 }
 176
 177 =head1 SEE ALSO
 178
 179 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 180 L<DBIx::Class::Schema::Loader::DBI>
 181
 182 =cut
 183
 184 1;