fix sqlite FKs (broken during multi-fk work)
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / SQLite.pm
1 package DBIx::Class::Schema::Loader::SQLite;
2
3 use strict;
4 use base qw/DBIx::Class::Schema::Loader::Generic/;
5 use Text::Balanced qw( extract_bracketed );
6 use Carp;
7
8 =head1 NAME
9
10 DBIx::Class::Schema::Loader::SQLite - DBIx::Class::Schema::Loader SQLite Implementation.
11
12 =head1 SYNOPSIS
13
14   use DBIx::Class::Schema::Loader;
15
16   # $loader is a DBIx::Class::Schema::Loader::SQLite
17   my $loader = DBIx::Class::Schema::Loader->new(
18     dsn       => "dbi:SQLite:dbname=/path/to/dbfile",
19   );
20
21 =head1 DESCRIPTION
22
23 See L<DBIx::Class::Schema::Loader>.
24
25 =cut
26
27 sub _loader_db_classes {
28     return qw/DBIx::Class::PK::Auto::SQLite/;
29 }
30
31 # XXX this really needs a re-factor
32 sub _loader_relationships {
33     my $class = shift;
34     foreach my $table ( $class->tables ) {
35
36         my $dbh = $class->storage->dbh;
37         my $sth = $dbh->prepare(<<"");
38 SELECT sql FROM sqlite_master WHERE tbl_name = ?
39
40         $sth->execute($table);
41         my ($sql) = $sth->fetchrow_array;
42         $sth->finish;
43
44         # Cut "CREATE TABLE ( )" blabla...
45         $sql =~ /^[\w\s]+\((.*)\)$/si;
46         my $cols = $1;
47
48         # strip single-line comments
49         $cols =~ s/\-\-.*\n/\n/g;
50
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] )
56         {
57             my $replacement = $extracted;
58             $replacement              =~ s/,/--comma--/g;
59             $replacement              =~ s/^\(//;
60             $replacement              =~ s/\)$//;
61             $cols_no_bracketed_commas =~ s/$extracted/$replacement/m;
62         }
63
64         # Split column definitions
65         for my $col ( split /,/, $cols_no_bracketed_commas ) {
66
67             # put the paren-bracketed commas back, to help
68             # find multi-col fks below
69             $col =~ s/\-\-comma\-\-/,/g;
70
71             $col =~ s/^\s*FOREIGN\s+KEY\s*//i;
72
73             # Strip punctuations around key and table names
74             $col =~ s/[\[\]'"]/ /g;
75             $col =~ s/^\s+//gs;
76
77             # Grab reference
78             if( $col =~ /^(.*)\s+REFERENCES\s+(\w+)\s*\((.*)\)/i ) {
79                 chomp $col;
80
81                 my ($cols, $f_table, $f_cols) = ($1, $2, $3);
82
83                 if($cols =~ /^\(/) { # Table-level
84                     $cols =~ s/^\(\s*//;
85                     $cols =~ s/\s*\)$//;
86                 }
87                 else {               # Inline
88                     $cols =~ s/\s+.*$//;
89                 }
90
91                 my @cols = map { s/\s*//g; $_ } split(/\s*,\s*/,$cols);
92                 my @f_cols = map { s/\s*//g; $_ } split(/\s*,\s*/,$f_cols);
93
94                 die "Mismatched column count in rel for $table => $f_table"
95                   if @cols != @f_cols;
96             
97                 my $cond = {};
98                 for(my $i = 0 ; $i < @cols; $i++) {
99                     $cond->{$f_cols[$i]} = $cols[$i];
100                 }
101
102                 eval { $class->_loader_make_relations( $table, $f_table, $cond ) };
103                 warn qq/\# belongs_to_many failed "$@"\n\n/
104                   if $@ && $class->_loader_debug;
105             }
106         }
107     }
108 }
109
110 sub _loader_tables {
111     my $class = shift;
112     my $dbh = $class->storage->dbh;
113     my $sth  = $dbh->prepare("SELECT * FROM sqlite_master");
114     $sth->execute;
115     my @tables;
116     while ( my $row = $sth->fetchrow_hashref ) {
117         next unless lc( $row->{type} ) eq 'table';
118         push @tables, $row->{tbl_name};
119     }
120     return @tables;
121 }
122
123 sub _loader_table_info {
124     my ( $class, $table ) = @_;
125
126     # find all columns.
127     my $dbh = $class->storage->dbh;
128     my $sth = $dbh->prepare("PRAGMA table_info('$table')");
129     $sth->execute();
130     my @columns;
131     while ( my $row = $sth->fetchrow_hashref ) {
132         push @columns, $row->{name};
133     }
134     $sth->finish;
135
136     # find primary key. so complex ;-(
137     $sth = $dbh->prepare(<<'SQL');
138 SELECT sql FROM sqlite_master WHERE tbl_name = ?
139 SQL
140     $sth->execute($table);
141     my ($sql) = $sth->fetchrow_array;
142     $sth->finish;
143     my ($primary) = $sql =~ m/
144     (?:\(|\,) # either a ( to start the definition or a , for next
145     \s*       # maybe some whitespace
146     (\w+)     # the col name
147     [^,]*     # anything but the end or a ',' for next column
148     PRIMARY\sKEY/sxi;
149     my @pks;
150
151     if ($primary) {
152         @pks = ($primary);
153     }
154     else {
155         my ($pks) = $sql =~ m/PRIMARY\s+KEY\s*\(\s*([^)]+)\s*\)/i;
156         @pks = split( m/\s*\,\s*/, $pks ) if $pks;
157     }
158     return ( \@columns, \@pks );
159 }
160
161 =head1 SEE ALSO
162
163 L<DBIx::Schema::Class::Loader>
164
165 =cut
166
167 1;