1 package DBIx::Class::Schema::Loader::DBI::SQLite;
5 use base qw/DBIx::Class::Schema::Loader::DBI/;
7 use Text::Balanced qw( extract_bracketed );
11 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
16 use base qw/DBIx::Class::Schema::Loader/;
18 __PACKAGE__->loader_optoins( relationships => 1 );
24 See L<DBIx::Class::Schema::Loader::Base>.
28 # XXX this really needs a re-factor
29 sub _sqlite_parse_table {
30 my ($self, $table) = @_;
35 my $dbh = $self->schema->storage->dbh;
36 my $sth = $self->{_cache}->{sqlite_master}
37 ||= $dbh->prepare(q{SELECT sql FROM sqlite_master WHERE tbl_name = ?});
39 $sth->execute($table);
40 my ($sql) = $sth->fetchrow_array;
43 # Cut "CREATE TABLE ( )" blabla...
44 $sql =~ /^[\w\s]+\((.*)\)$/si;
47 # strip single-line comments
48 $cols =~ s/\-\-.*\n/\n/g;
50 # temporarily replace any commas inside parens,
51 # so we don't incorrectly split on them below
52 my $cols_no_bracketed_commas = $cols;
53 while ( my $extracted =
54 ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] )
56 my $replacement = $extracted;
57 $replacement =~ s/,/--comma--/g;
58 $replacement =~ s/^\(//;
59 $replacement =~ s/\)$//;
60 $cols_no_bracketed_commas =~ s/$extracted/$replacement/m;
63 # Split column definitions
64 for my $col ( split /,/, $cols_no_bracketed_commas ) {
66 # put the paren-bracketed commas back, to help
67 # find multi-col fks below
68 $col =~ s/\-\-comma\-\-/,/g;
70 $col =~ s/^\s*FOREIGN\s+KEY\s*//i;
72 # Strip punctuations around key and table names
73 $col =~ s/[\[\]'"]/ /g;
79 if($col =~ /^(.*)\s+UNIQUE/) {
81 $colname =~ s/\s+.*$//;
82 push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]);
84 elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/) {
87 my @cols = map { lc } split(/\s*,\s*/, $cols);
88 my $name = join(q{_}, @cols) . '_unique';
89 push(@uniqs, [ $name => \@cols ]);
92 next if $col !~ /^(.*)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
94 my ($cols, $f_table, $f_cols) = ($1, $2, $3);
96 if($cols =~ /^\(/) { # Table-level
104 my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols);
107 my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols);
108 die "Mismatched column count in rel for $table => $f_table"
113 local_columns => \@cols,
114 remote_columns => $rcols,
115 remote_table => $f_table,
119 return { rels => \@rels, uniqs => \@uniqs };
123 my ($self, $table) = @_;
125 $self->{_sqlite_parse_data}->{$table} ||=
126 $self->_sqlite_parse_table($table);
128 return $self->{_sqlite_parse_data}->{$table}->{rels};
131 sub _table_uniq_info {
132 my ($self, $table) = @_;
134 $self->{_sqlite_parse_data}->{$table} ||=
135 $self->_sqlite_parse_table($table);
137 return $self->{_sqlite_parse_data}->{$table}->{uniqs};
143 my $dbh = $self->schema->storage->dbh;
144 my $sth = $dbh->prepare("SELECT * FROM sqlite_master");
147 while ( my $row = $sth->fetchrow_hashref ) {
148 next unless lc( $row->{type} ) eq 'table';
149 push @tables, $row->{tbl_name};
156 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
157 L<DBIx::Class::Schema::Loader::DBI>