lib/DBIx/Class/Schema/Loader/SQLite.pm

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