lib/DBIx/Class/Loader/SQLite.pm

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