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