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             chomp $col;
  79             next if $col !~ /^(.*)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
  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 $cond;
  92
  93             if($f_cols) {
  94                 my @cols = map { s/\s*//g; $_ } split(/\s*,\s*/,$cols);
  95                 my @f_cols = map { s/\s*//g; $_ } split(/\s*,\s*/,$f_cols);
  96                 die "Mismatched column count in rel for $table => $f_table"
  97                   if @cols != @f_cols;
  98                 $cond = {};
  99                 for(my $i = 0 ; $i < @cols; $i++) {
 100                     $cond->{$f_cols[$i]} = $cols[$i];
 101                 }
 102                 eval { $class->_loader_make_cond_rel( $table, $f_table, $cond ) };
 103             }
 104             else {
 105                 eval { $class->_loader_make_simple_rel( $table, $f_table, $cols ) };
 106             }
 107
 108             warn qq/\# belongs_to_many failed "$@"\n\n/
 109               if $@ && $class->_loader_debug;
 110         }
 111     }
 112 }
 113
 114 sub _loader_tables {
 115     my $class = shift;
 116     my $dbh = $class->storage->dbh;
 117     my $sth  = $dbh->prepare("SELECT * FROM sqlite_master");
 118     $sth->execute;
 119     my @tables;
 120     while ( my $row = $sth->fetchrow_hashref ) {
 121         next unless lc( $row->{type} ) eq 'table';
 122         push @tables, $row->{tbl_name};
 123     }
 124     return @tables;
 125 }
 126
 127 sub _loader_table_info {
 128     my ( $class, $table ) = @_;
 129
 130     # find all columns.
 131     my $dbh = $class->storage->dbh;
 132     my $sth = $dbh->prepare("PRAGMA table_info('$table')");
 133     $sth->execute();
 134     my @columns;
 135     while ( my $row = $sth->fetchrow_hashref ) {
 136         push @columns, $row->{name};
 137     }
 138     $sth->finish;
 139
 140     # find primary key. so complex ;-(
 141     $sth = $dbh->prepare(<<'SQL');
 142 SELECT sql FROM sqlite_master WHERE tbl_name = ?
 143 SQL
 144     $sth->execute($table);
 145     my ($sql) = $sth->fetchrow_array;
 146     $sth->finish;
 147     my ($primary) = $sql =~ m/
 148     (?:\(|\,) # either a ( to start the definition or a , for next
 149     \s*       # maybe some whitespace
 150     (\w+)     # the col name
 151     [^,]*     # anything but the end or a ',' for next column
 152     PRIMARY\sKEY/sxi;
 153     my @pks;
 154
 155     if ($primary) {
 156         @pks = ($primary);
 157     }
 158     else {
 159         my ($pks) = $sql =~ m/PRIMARY\s+KEY\s*\(\s*([^)]+)\s*\)/i;
 160         @pks = split( m/\s*\,\s*/, $pks ) if $pks;
 161     }
 162     return ( \@columns, \@pks );
 163 }
 164
 165 =head1 SEE ALSO
 166
 167 L<DBIx::Schema::Class::Loader>
 168
 169 =cut
 170
 171 1;