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

   1 package DBIx::Class::Schema::Loader::SQLite;
   2
   3 use strict;
   4 use base 'DBIx::Class::Schema::Loader::Generic';
   5 use Text::Balanced qw( extract_bracketed );
   6 use DBI;
   7 use Carp;
   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     namespace => "Data",
  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 sub _relationships {
  34     my $self = shift;
  35     foreach my $table ( $self->tables ) {
  36
  37         my $dbh = $self->{_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             # CDBI doesn't have built-in support multi-col fks, so ignore them
  73             next if $col =~ s/^\s*FOREIGN\s+KEY\s*//i && $col =~ /^\([^,)]+,/;
  74
  75             # Strip punctuations around key and table names
  76             $col =~ s/[()\[\]'"]/ /g;
  77             $col =~ s/^\s+//gs;
  78
  79             # Grab reference
  80             if ( $col =~ /^(\w+).*REFERENCES\s+(\w+)\s*(\w+)?/i ) {
  81                 chomp $col;
  82                 warn qq/\# Found foreign key definition "$col"\n\n/
  83                   if $self->debug;
  84                 eval { $self->_belongs_to_many( $table, $1, $2, $3 ) };
  85                 warn qq/\# belongs_to_many failed "$@"\n\n/
  86                   if $@ && $self->debug;
  87             }
  88         }
  89     }
  90 }
  91
  92 sub _tables {
  93     my $self = shift;
  94     my $dbh = $self->{_storage}->dbh;
  95     my $sth  = $dbh->prepare("SELECT * FROM sqlite_master");
  96     $sth->execute;
  97     my @tables;
  98     while ( my $row = $sth->fetchrow_hashref ) {
  99         next unless lc( $row->{type} ) eq 'table';
 100         push @tables, $row->{tbl_name};
 101     }
 102     return @tables;
 103 }
 104
 105 sub _table_info {
 106     my ( $self, $table ) = @_;
 107
 108     # find all columns.
 109     my $dbh = $self->{_storage}->dbh;
 110     my $sth = $dbh->prepare("PRAGMA table_info('$table')");
 111     $sth->execute();
 112     my @columns;
 113     while ( my $row = $sth->fetchrow_hashref ) {
 114         push @columns, $row->{name};
 115     }
 116     $sth->finish;
 117
 118     # find primary key. so complex ;-(
 119     $sth = $dbh->prepare(<<'SQL');
 120 SELECT sql FROM sqlite_master WHERE tbl_name = ?
 121 SQL
 122     $sth->execute($table);
 123     my ($sql) = $sth->fetchrow_array;
 124     $sth->finish;
 125     my ($primary) = $sql =~ m/
 126     (?:\(|\,) # either a ( to start the definition or a , for next
 127     \s*       # maybe some whitespace
 128     (\w+)     # the col name
 129     [^,]*     # anything but the end or a ',' for next column
 130     PRIMARY\sKEY/sxi;
 131     my @pks;
 132
 133     if ($primary) {
 134         @pks = ($primary);
 135     }
 136     else {
 137         my ($pks) = $sql =~ m/PRIMARY\s+KEY\s*\(\s*([^)]+)\s*\)/;
 138         @pks = split( m/\s*\,\s*/, $pks ) if $pks;
 139     }
 140     return ( \@columns, \@pks );
 141 }
 142
 143 =head1 SEE ALSO
 144
 145 L<DBIx::Schema::Class::Loader>
 146
 147 =cut
 148
 149 1;