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 =head1 NAME
  11
  12 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
  13
  14 =head1 SYNOPSIS
  15
  16   package My::Schema;
  17   use base qw/DBIx::Class::Schema::Loader/;
  18
  19   __PACKAGE__->loader_optoins( relationships => 1 );
  20
  21   1;
  22
  23 =head1 DESCRIPTION
  24
  25 See L<DBIx::Class::Schema::Loader::Base>.
  26
  27 =cut
  28
  29 # XXX this really needs a re-factor
  30 sub _sqlite_parse_table {
  31     my ($self, $table) = @_;
  32
  33     my @rels;
  34     my @uniqs;
  35
  36     my $dbh = $self->schema->storage->dbh;
  37     my $sth = $self->{_cache}->{sqlite_master}
  38         ||= $dbh->prepare(q{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         chomp $col;
  79
  80         if($col =~ /^(.*)\s+UNIQUE/i) {
  81             my $colname = $1;
  82             $colname =~ s/\s+.*$//;
  83             push(@uniqs, [ "${colname}_unique" => [ lc $colname ] ]);
  84         }
  85         elsif($col =~/^\s*UNIQUE\s*\(\s*(.*)\)/i) {
  86             my $cols = $1;
  87             $cols =~ s/\s+$//;
  88             my @cols = map { lc } split(/\s*,\s*/, $cols);
  89             my $name = join(q{_}, @cols) . '_unique';
  90             push(@uniqs, [ $name => \@cols ]);
  91         }
  92
  93         next if $col !~ /^(.*\S)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
  94
  95         my ($cols, $f_table, $f_cols) = ($1, $2, $3);
  96
  97         if($cols =~ /^\(/) { # Table-level
  98             $cols =~ s/^\(\s*//;
  99             $cols =~ s/\s*\)$//;
 100         }
 101         else {               # Inline
 102             $cols =~ s/\s+.*$//;
 103         }
 104
 105         my @cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$cols);
 106         my $rcols;
 107         if($f_cols) {
 108             my @f_cols = map { s/\s*//g; lc $_ } split(/\s*,\s*/,$f_cols);
 109             croak "Mismatched column count in rel for $table => $f_table"
 110               if @cols != @f_cols;
 111             $rcols = \@f_cols;
 112         }
 113         push(@rels, {
 114             local_columns => \@cols,
 115             remote_columns => $rcols,
 116             remote_table => $f_table,
 117         });
 118     }
 119
 120     return { rels => \@rels, uniqs => \@uniqs };
 121 }
 122
 123 sub _table_fk_info {
 124     my ($self, $table) = @_;
 125
 126     $self->{_sqlite_parse_data}->{$table} ||=
 127         $self->_sqlite_parse_table($table);
 128
 129     return $self->{_sqlite_parse_data}->{$table}->{rels};
 130 }
 131
 132 sub _table_uniq_info {
 133     my ($self, $table) = @_;
 134
 135     $self->{_sqlite_parse_data}->{$table} ||=
 136         $self->_sqlite_parse_table($table);
 137
 138     return $self->{_sqlite_parse_data}->{$table}->{uniqs};
 139 }
 140
 141 sub _tables_list {
 142     my $self = shift;
 143
 144     my $dbh = $self->schema->storage->dbh;
 145     my $sth = $dbh->prepare("SELECT * FROM sqlite_master");
 146     $sth->execute;
 147     my @tables;
 148     while ( my $row = $sth->fetchrow_hashref ) {
 149         next unless lc( $row->{type} ) eq 'table';
 150         push @tables, $row->{tbl_name};
 151     }
 152     return @tables;
 153 }
 154
 155 =head1 SEE ALSO
 156
 157 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 158 L<DBIx::Class::Schema::Loader::DBI>
 159
 160 =cut
 161
 162 1;