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