1 package DBIx::Class::Schema::Loader::DBI::SQLite;
5 use base qw/DBIx::Class::Schema::Loader::DBI/;
6 use Carp::Clan qw/^DBIx::Class/;
7 use Text::Balanced qw( extract_bracketed );
10 our $VERSION = '0.03999_01';
14 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
19 use base qw/DBIx::Class::Schema::Loader/;
21 __PACKAGE__->loader_optoins( relationships => 1 );
27 See L<DBIx::Class::Schema::Loader::Base>.
31 # XXX this really needs a re-factor
32 sub _sqlite_parse_table {
33 my ($self, $table) = @_;
38 my $dbh = $self->schema->storage->dbh;
39 my $sth = $self->{_cache}->{sqlite_master}
40 ||= $dbh->prepare(q{SELECT sql FROM sqlite_master WHERE tbl_name = ?});
42 $sth->execute($table);
43 my ($sql) = $sth->fetchrow_array;
46 # Cut "CREATE TABLE ( )" blabla...
47 $sql =~ /^[\w\s]+\((.*)\)$/si;
50 # strip single-line comments
51 $cols =~ s/\-\-.*\n/\n/g;
53 # temporarily replace any commas inside parens,
54 # so we don't incorrectly split on them below
55 my $cols_no_bracketed_commas = $cols;
56 while ( my $extracted =
57 ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] )
59 my $replacement = $extracted;
60 $replacement =~ s/,/--comma--/g;
61 $replacement =~ s/^\(//;
62 $replacement =~ s/\)$//;
63 $cols_no_bracketed_commas =~ s/$extracted/$replacement/m;
66 # Split column definitions
67 for my $col ( split /,/, $cols_no_bracketed_commas ) {
69 # put the paren-bracketed commas back, to help
70 # find multi-col fks below
71 $col =~ s/\-\-comma\-\-/,/g;
73 $col =~ s/^\s*FOREIGN\s+KEY\s*//i;
75 # Strip punctuations around key and table names
76 $col =~ s/[\[\]'"]/ /g;
82 if($col =~ /^(.*)\s+UNIQUE/) {
84 $colname =~ s/\s+.*$//;
85 push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]);
87 elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/) {
90 my @cols = map { lc } split(/\s*,\s*/, $cols);
91 my $name = join(q{_}, @cols) . '_unique';
92 push(@uniqs, [ $name => \@cols ]);
95 next if $col !~ /^(.*)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
97 my ($cols, $f_table, $f_cols) = ($1, $2, $3);
99 if($cols =~ /^\(/) { # Table-level
107 my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols);
110 my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols);
111 croak "Mismatched column count in rel for $table => $f_table"
116 local_columns => \@cols,
117 remote_columns => $rcols,
118 remote_table => $f_table,
122 return { rels => \@rels, uniqs => \@uniqs };
126 my ($self, $table) = @_;
128 $self->{_sqlite_parse_data}->{$table} ||=
129 $self->_sqlite_parse_table($table);
131 return $self->{_sqlite_parse_data}->{$table}->{rels};
134 sub _table_uniq_info {
135 my ($self, $table) = @_;
137 $self->{_sqlite_parse_data}->{$table} ||=
138 $self->_sqlite_parse_table($table);
140 return $self->{_sqlite_parse_data}->{$table}->{uniqs};
146 my $dbh = $self->schema->storage->dbh;
147 my $sth = $dbh->prepare("SELECT * FROM sqlite_master");
150 while ( my $row = $sth->fetchrow_hashref ) {
151 next unless lc( $row->{type} ) eq 'table';
152 push @tables, $row->{tbl_name};
159 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
160 L<DBIx::Class::Schema::Loader::DBI>