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 Class::C3;
   7 use Text::Balanced qw( extract_bracketed );
   8
   9 =head1 NAME
  10
  11 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
  12
  13 =head1 SYNOPSIS
  14
  15   package My::Schema;
  16   use base qw/DBIx::Class::Schema::Loader/;
  17
  18   __PACKAGE__->loader_optoins( relationships => 1 );
  19
  20   1;
  21
  22 =head1 DESCRIPTION
  23
  24 See L<DBIx::Class::Schema::Loader::Base>.
  25
  26 =cut
  27
  28 # XXX this really needs a re-factor
  29 sub _sqlite_parse_table {
  30     my ($self, $table) = @_;
  31
  32     my @rels;
  33     my @uniqs;
  34
  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 = ?});
  38
  39     $sth->execute($table);
  40     my ($sql) = $sth->fetchrow_array;
  41     $sth->finish;
  42
  43     # Cut "CREATE TABLE ( )" blabla...
  44     $sql =~ /^[\w\s]+\((.*)\)$/si;
  45     my $cols = $1;
  46
  47     # strip single-line comments
  48     $cols =~ s/\-\-.*\n/\n/g;
  49
  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] )
  55     {
  56         my $replacement = $extracted;
  57         $replacement              =~ s/,/--comma--/g;
  58         $replacement              =~ s/^\(//;
  59         $replacement              =~ s/\)$//;
  60         $cols_no_bracketed_commas =~ s/$extracted/$replacement/m;
  61     }
  62
  63     # Split column definitions
  64     for my $col ( split /,/, $cols_no_bracketed_commas ) {
  65
  66         # put the paren-bracketed commas back, to help
  67         # find multi-col fks below
  68         $col =~ s/\-\-comma\-\-/,/g;
  69
  70         $col =~ s/^\s*FOREIGN\s+KEY\s*//i;
  71
  72         # Strip punctuations around key and table names
  73         $col =~ s/[\[\]'"]/ /g;
  74         $col =~ s/^\s+//gs;
  75
  76         # Grab reference
  77         chomp $col;
  78
  79         if($col =~ /^(.*)\s+UNIQUE/) {
  80             my $colname = $1;
  81             $colname =~ s/\s+.*$//;
  82             push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]);
  83         }
  84         elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/) {
  85             my $cols = $1;
  86             $cols =~ s/\s+$//;
  87             my @cols = map { lc } split(/\s*,\s*/, $cols);
  88             my $name = join(q{_}, @cols) . '_unique';
  89             push(@uniqs, [ $name => \@cols ]);
  90         }
  91
  92         next if $col !~ /^(.*)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
  93
  94         my ($cols, $f_table, $f_cols) = ($1, $2, $3);
  95
  96         if($cols =~ /^\(/) { # Table-level
  97             $cols =~ s/^\(\s*//;
  98             $cols =~ s/\s*\)$//;
  99         }
 100         else {               # Inline
 101             $cols =~ s/\s+.*$//;
 102         }
 103
 104         my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols);
 105         my $rcols;
 106         if($f_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"
 109               if @cols != @f_cols;
 110             $rcols = \@f_cols;
 111         }
 112         push(@rels, {
 113             local_columns => \@cols,
 114             remote_columns => $rcols,
 115             remote_table => $f_table,
 116         });
 117     }
 118
 119     return { rels => \@rels, uniqs => \@uniqs };
 120 }
 121
 122 sub _table_fk_info {
 123     my ($self, $table) = @_;
 124
 125     $self->{_sqlite_parse_data}->{$table} ||=
 126         $self->_sqlite_parse_table($table);
 127
 128     return $self->{_sqlite_parse_data}->{$table}->{rels};
 129 }
 130
 131 sub _table_uniq_info {
 132     my ($self, $table) = @_;
 133
 134     $self->{_sqlite_parse_data}->{$table} ||=
 135         $self->_sqlite_parse_table($table);
 136
 137     return $self->{_sqlite_parse_data}->{$table}->{uniqs};
 138 }
 139
 140 sub _tables_list {
 141     my $self = shift;
 142
 143     my $dbh = $self->schema->storage->dbh;
 144     my $sth = $dbh->prepare("SELECT * FROM sqlite_master");
 145     $sth->execute;
 146     my @tables;
 147     while ( my $row = $sth->fetchrow_hashref ) {
 148         next unless lc( $row->{type} ) eq 'table';
 149         push @tables, $row->{tbl_name};
 150     }
 151     return @tables;
 152 }
 153
 154 =head1 SEE ALSO
 155
 156 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 157 L<DBIx::Class::Schema::Loader::DBI>
 158
 159 =cut
 160
 161 1;