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 _db_classes {
  28     return qw/DBIx::Class::PK::Auto::SQLite/;
  29 }
  30
  31 sub _relationships {
  32     my $class = shift;
  33     foreach my $table ( $class->tables ) {
  34
  35         my $dbh = $class->storage->dbh;
  36         my $sth = $dbh->prepare(<<"");
  37 SELECT sql FROM sqlite_master WHERE tbl_name = ?
  38
  39         $sth->execute($table);
  40         my ($sql) = $sth->fetchrow_array;
  41         $sth->finish;
  42
  43         # Cut "CREATE TABLE ( )" blabla...
  44         $sql =~ /^[\w\s]+\((.*)\)$/si;
  45         my $cols = $1;
  46
  47         # strip single-line comments
  48         $cols =~ s/\-\-.*\n/\n/g;
  49
  50         # temporarily replace any commas inside parens,
  51         # so we don't incorrectly split on them below
  52         my $cols_no_bracketed_commas = $cols;
  53         while ( my $extracted =
  54             ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] )
  55         {
  56             my $replacement = $extracted;
  57             $replacement              =~ s/,/--comma--/g;
  58             $replacement              =~ s/^\(//;
  59             $replacement              =~ s/\)$//;
  60             $cols_no_bracketed_commas =~ s/$extracted/$replacement/m;
  61         }
  62
  63         # Split column definitions
  64         for my $col ( split /,/, $cols_no_bracketed_commas ) {
  65
  66             # put the paren-bracketed commas back, to help
  67             # find multi-col fks below
  68             $col =~ s/\-\-comma\-\-/,/g;
  69
  70             # CDBI doesn't have built-in support multi-col fks, so ignore them
  71             next if $col =~ s/^\s*FOREIGN\s+KEY\s*//i && $col =~ /^\([^,)]+,/;
  72
  73             # Strip punctuations around key and table names
  74             $col =~ s/[()\[\]'"]/ /g;
  75             $col =~ s/^\s+//gs;
  76
  77             # Grab reference
  78             if ( $col =~ /^(\w+).*REFERENCES\s+(\w+)\s*(\w+)?/i ) {
  79                 chomp $col;
  80                 warn qq/\# Found foreign key definition "$col"\n\n/
  81                   if $class->debug_loader;
  82                 eval { $class->_belongs_to_many( $table, $1, $2, $3 ) };
  83                 warn qq/\# belongs_to_many failed "$@"\n\n/
  84                   if $@ && $class->debug_loader;
  85             }
  86         }
  87     }
  88 }
  89
  90 sub _tables {
  91     my $class = shift;
  92     my $dbh = $class->storage->dbh;
  93     my $sth  = $dbh->prepare("SELECT * FROM sqlite_master");
  94     $sth->execute;
  95     my @tables;
  96     while ( my $row = $sth->fetchrow_hashref ) {
  97         next unless lc( $row->{type} ) eq 'table';
  98         push @tables, $row->{tbl_name};
  99     }
 100     return @tables;
 101 }
 102
 103 sub _table_info {
 104     my ( $class, $table ) = @_;
 105
 106     # find all columns.
 107     my $dbh = $class->storage->dbh;
 108     my $sth = $dbh->prepare("PRAGMA table_info('$table')");
 109     $sth->execute();
 110     my @columns;
 111     while ( my $row = $sth->fetchrow_hashref ) {
 112         push @columns, $row->{name};
 113     }
 114     $sth->finish;
 115
 116     # find primary key. so complex ;-(
 117     $sth = $dbh->prepare(<<'SQL');
 118 SELECT sql FROM sqlite_master WHERE tbl_name = ?
 119 SQL
 120     $sth->execute($table);
 121     my ($sql) = $sth->fetchrow_array;
 122     $sth->finish;
 123     my ($primary) = $sql =~ m/
 124     (?:\(|\,) # either a ( to start the definition or a , for next
 125     \s*       # maybe some whitespace
 126     (\w+)     # the col name
 127     [^,]*     # anything but the end or a ',' for next column
 128     PRIMARY\sKEY/sxi;
 129     my @pks;
 130
 131     if ($primary) {
 132         @pks = ($primary);
 133     }
 134     else {
 135         my ($pks) = $sql =~ m/PRIMARY\s+KEY\s*\(\s*([^)]+)\s*\)/i;
 136         @pks = split( m/\s*\,\s*/, $pks ) if $pks;
 137     }
 138     return ( \@columns, \@pks );
 139 }
 140
 141 =head1 SEE ALSO
 142
 143 L<DBIx::Schema::Class::Loader>
 144
 145 =cut
 146
 147 1;