1 package DBIx::Class::Schema::Loader::DBI::SQLite;
5 use base qw/DBIx::Class::Schema::Loader::DBI/;
6 use Carp::Clan qw/^DBIx::Class::Schema::Loader/;
7 use Text::Balanced qw( extract_bracketed );
12 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
17 use base qw/DBIx::Class::Schema::Loader/;
19 __PACKAGE__->loader_optoins( relationships => 1 );
25 See L<DBIx::Class::Schema::Loader::Base>.
29 # XXX this really needs a re-factor
30 sub _sqlite_parse_table {
31 my ($self, $table) = @_;
36 my $dbh = $self->schema->storage->dbh;
37 my $sth = $self->{_cache}->{sqlite_master}
38 ||= $dbh->prepare(q{SELECT sql FROM sqlite_master WHERE tbl_name = ?});
40 $sth->execute($table);
41 my ($sql) = $sth->fetchrow_array;
44 # Cut "CREATE TABLE ( )" blabla...
45 $sql =~ /^[\w\s]+\((.*)\)$/si;
48 # strip single-line comments
49 $cols =~ s/\-\-.*\n/\n/g;
51 # temporarily replace any commas inside parens,
52 # so we don't incorrectly split on them below
53 my $cols_no_bracketed_commas = $cols;
54 while ( my $extracted =
55 ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] )
57 my $replacement = $extracted;
58 $replacement =~ s/,/--comma--/g;
59 $replacement =~ s/^\(//;
60 $replacement =~ s/\)$//;
61 $cols_no_bracketed_commas =~ s/$extracted/$replacement/m;
64 # Split column definitions
65 for my $col ( split /,/, $cols_no_bracketed_commas ) {
67 # put the paren-bracketed commas back, to help
68 # find multi-col fks below
69 $col =~ s/\-\-comma\-\-/,/g;
71 $col =~ s/^\s*FOREIGN\s+KEY\s*//i;
73 # Strip punctuations around key and table names
74 $col =~ s/[\[\]'"]/ /g;
80 if($col =~ /^(.*)\s+UNIQUE/) {
82 $colname =~ s/\s+.*$//;
83 push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]);
85 elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/) {
88 my @cols = map { lc } split(/\s*,\s*/, $cols);
89 my $name = join(q{_}, @cols) . '_unique';
90 push(@uniqs, [ $name => \@cols ]);
93 next if $col !~ /^(.*)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
95 my ($cols, $f_table, $f_cols) = ($1, $2, $3);
97 if($cols =~ /^\(/) { # Table-level
105 my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols);
108 my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols);
109 croak "Mismatched column count in rel for $table => $f_table"
114 local_columns => \@cols,
115 remote_columns => $rcols,
116 remote_table => $f_table,
120 return { rels => \@rels, uniqs => \@uniqs };
124 my ($self, $table) = @_;
126 $self->{_sqlite_parse_data}->{$table} ||=
127 $self->_sqlite_parse_table($table);
129 return $self->{_sqlite_parse_data}->{$table}->{rels};
132 sub _table_uniq_info {
133 my ($self, $table) = @_;
135 $self->{_sqlite_parse_data}->{$table} ||=
136 $self->_sqlite_parse_table($table);
138 return $self->{_sqlite_parse_data}->{$table}->{uniqs};
144 my $dbh = $self->schema->storage->dbh;
145 my $sth = $dbh->prepare("SELECT * FROM sqlite_master");
148 while ( my $row = $sth->fetchrow_hashref ) {
149 next unless lc( $row->{type} ) eq 'table';
150 push @tables, $row->{tbl_name};
157 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
158 L<DBIx::Class::Schema::Loader::DBI>