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

   1 package DBIx::Class::Schema::Loader::SQLite;
   2
   3 use strict;
   4 use warnings;
   5 use Class::C3;
   6 use base qw/DBIx::Class::Schema::Loader::Generic/;
   7
   8 use Text::Balanced qw( extract_bracketed );
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Schema::Loader::SQLite - DBIx::Class::Schema::Loader SQLite Implementation.
  13
  14 =head1 SYNOPSIS
  15
  16   use DBIx::Class::Schema::Loader;
  17
  18   # $loader is a DBIx::Class::Schema::Loader::SQLite
  19   my $loader = DBIx::Class::Schema::Loader->new(
  20     dsn       => "dbi:SQLite:dbname=/path/to/dbfile",
  21   );
  22
  23 =head1 DESCRIPTION
  24
  25 See L<DBIx::Class::Schema::Loader>.
  26
  27 =cut
  28
  29 sub _db_classes {
  30     return qw/DBIx::Class::PK::Auto::SQLite/;
  31 }
  32
  33 # XXX this really needs a re-factor
  34 sub _load_relationships {
  35     my $self = shift;
  36     foreach my $table ( $self->tables ) {
  37
  38         my $dbh = $self->schema->storage->dbh;
  39         my $sth = $dbh->prepare(<<"");
  40 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             next if $col !~ /^(.*)\s+REFERENCES\s+(\w+) (?: \s* \( (.*) \) )? /ix;
  82
  83             my ($cols, $f_table, $f_cols) = ($1, $2, $3);
  84
  85             if($cols =~ /^\(/) { # Table-level
  86                 $cols =~ s/^\(\s*//;
  87                 $cols =~ s/\s*\)$//;
  88             }
  89             else {               # Inline
  90                 $cols =~ s/\s+.*$//;
  91             }
  92
  93             my $cond;
  94
  95             if($f_cols) {
  96                 my @cols = map { s/\s*//g; $_ } split(/\s*,\s*/,$cols);
  97                 my @f_cols = map { s/\s*//g; $_ } split(/\s*,\s*/,$f_cols);
  98                 die "Mismatched column count in rel for $table => $f_table"
  99                   if @cols != @f_cols;
 100                 $cond = {};
 101                 for(my $i = 0 ; $i < @cols; $i++) {
 102                     $cond->{$f_cols[$i]} = $cols[$i];
 103                 }
 104                 eval { $self->_make_cond_rel( $table, $f_table, $cond ) };
 105             }
 106             else {
 107                 eval { $self->_make_simple_rel( $table, $f_table, $cols ) };
 108             }
 109
 110             warn qq/\# belongs_to_many failed "$@"\n\n/
 111               if $@ && $self->debug;
 112         }
 113     }
 114 }
 115
 116 sub _tables {
 117     my $self = shift;
 118     my $dbh = $self->schema->storage->dbh;
 119     my $sth  = $dbh->prepare("SELECT * FROM sqlite_master");
 120     $sth->execute;
 121     my @tables;
 122     while ( my $row = $sth->fetchrow_hashref ) {
 123         next unless lc( $row->{type} ) eq 'table';
 124         push @tables, $row->{tbl_name};
 125     }
 126     return @tables;
 127 }
 128
 129 sub _table_info {
 130     my ( $self, $table ) = @_;
 131
 132     # find all columns.
 133     my $dbh = $self->schema->storage->dbh;
 134     my $sth = $dbh->prepare("PRAGMA table_info('$table')");
 135     $sth->execute();
 136     my @columns;
 137     while ( my $row = $sth->fetchrow_hashref ) {
 138         push @columns, $row->{name};
 139     }
 140     $sth->finish;
 141
 142     # find primary key. so complex ;-(
 143     $sth = $dbh->prepare(<<'SQL');
 144 SELECT sql FROM sqlite_master WHERE tbl_name = ?
 145 SQL
 146     $sth->execute($table);
 147     my ($sql) = $sth->fetchrow_array;
 148     $sth->finish;
 149     my ($primary) = $sql =~ m/
 150     (?:\(|\,) # either a ( to start the definition or a , for next
 151     \s*       # maybe some whitespace
 152     (\w+)     # the col name
 153     [^,]*     # anything but the end or a ',' for next column
 154     PRIMARY\sKEY/sxi;
 155     my @pks;
 156
 157     if ($primary) {
 158         @pks = ($primary);
 159     }
 160     else {
 161         my ($pks) = $sql =~ m/PRIMARY\s+KEY\s*\(\s*([^)]+)\s*\)/i;
 162         @pks = split( m/\s*\,\s*/, $pks ) if $pks;
 163     }
 164     return ( \@columns, \@pks );
 165 }
 166
 167 =head1 SEE ALSO
 168
 169 L<DBIx::Schema::Class::Loader>
 170
 171 =cut
 172
 173 1;