1package DBIx::DBSchema::DBD::SQLite; 2use base qw( DBIx::DBSchema::DBD ); 3 4use strict; 5use vars qw($VERSION %typemap); 6 7$VERSION = '0.03'; 8 9%typemap = ( 10 'SERIAL' => 'INTEGER PRIMARY KEY AUTOINCREMENT', 11); 12 13=head1 NAME 14 15DBIx::DBSchema::DBD::SQLite - SQLite native driver for DBIx::DBSchema 16 17=head1 SYNOPSIS 18 19use DBI; 20use DBIx::DBSchema; 21 22$dbh = DBI->connect('dbi:SQLite:tns_service_name', 'user','pass'); 23$schema = new_native DBIx::DBSchema $dbh; 24 25=head1 DESCRIPTION 26 27This module implements a SQLite-native driver for DBIx::DBSchema. 28 29=head1 AUTHOR 30 31Jesse Vincent <jesse@bestpractical.com> 32 33=cut 34 35=head1 API 36 37=over 38 39 40=item columns CLASS DBI_DBH TABLE 41 42Given an active DBI database handle, return a listref of listrefs (see 43L<perllol>), each containing six elements: column name, column type, 44nullability, column length, column default, and a field reserved for 45driver-specific use (which for sqlite is whether this col is a primary key) 46 47 48=cut 49 50sub columns { 51 my ( $proto, $dbh, $table ) = @_; 52 my $sth = $dbh->prepare("PRAGMA table_info($table)"); 53 $sth->execute(); 54 my $rows = []; 55 56 while ( my $row = $sth->fetchrow_hashref ) { 57 58 # notnull # pk # name # type # cid # dflt_value 59 push @$rows, 60 [ 61 $row->{'name'}, 62 $row->{'type'}, 63 ( $row->{'notnull'} ? 0 : 1 ), 64 undef, 65 $row->{'dflt_value'}, 66 $row->{'pk'} 67 ]; 68 69 } 70 71 return $rows; 72} 73 74 75=item primary_key CLASS DBI_DBH TABLE 76 77Given an active DBI database handle, return the primary key for the specified 78table. 79 80=cut 81 82sub primary_key { 83 my ($proto, $dbh, $table) = @_; 84 85 my $cols = $proto->columns($dbh,$table); 86 foreach my $col (@$cols) { 87 return ($col->[1]) if ($col->[5]); 88 } 89 90 return undef; 91} 92 93 94 95=item unique CLASS DBI_DBH TABLE 96 97Given an active DBI database handle, return a hashref of unique indices. The 98keys of the hashref are index names, and the values are arrayrefs which point 99a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and 100L<DBIx::DBSchema::ColGroup>. 101 102=cut 103 104sub unique { 105 my ($proto, $dbh, $table) = @_; 106 my @names; 107 my $indexes = $proto->_index_info($dbh, $table); 108 foreach my $row (@$indexes) { 109 push @names, $row->{'name'} if ($row->{'unique'}); 110 111 } 112 my $info = {}; 113 foreach my $name (@names) { 114 $info->{'name'} = $proto->_index_cols($dbh, $name); 115 } 116 return $info; 117} 118 119 120=item index CLASS DBI_DBH TABLE 121 122Given an active DBI database handle, return a hashref of (non-unique) indices. 123The keys of the hashref are index names, and the values are arrayrefs which 124point a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and 125L<DBIx::DBSchema::ColGroup>. 126 127=cut 128 129sub index { 130 my ($proto, $dbh, $table) = @_; 131 my @names; 132 my $indexes = $proto->_index_info($dbh, $table); 133 foreach my $row (@$indexes) { 134 push @names, $row->{'name'} if not ($row->{'unique'}); 135 136 } 137 my $info = {}; 138 foreach my $name (@names) { 139 $info->{'name'} = $proto->_index_cols($dbh, $name); 140 } 141 142 return $info; 143} 144 145 146 147sub _index_list { 148 149 my $proto = shift; 150 my $dbh = shift; 151 my $table = shift; 152 153my $sth = $dbh->prepare('PRAGMA index_list($table)'); 154$sth->execute(); 155my $rows = []; 156 157while ( my $row = $sth->fetchrow_hashref ) { 158 # Keys are "name" and "unique" 159 push @$rows, $row; 160 161} 162 163return $rows; 164} 165 166 167 168sub _index_cols { 169 my $proto = shift; 170 my $dbh = shift; 171 my $index = shift; 172 173 my $sth = $dbh->prepare('PRAGMA index_info($index)'); 174 $sth->execute(); 175 my $data = {}; 176while ( my $row = $sth->fetchrow_hashref ) { 177 # Keys are "name" and "seqno" 178 $data->{$row->{'seqno'}} = $data->{'name'}; 179} 180 my @results; 181 foreach my $key (sort keys %$data) { 182 push @results, $data->{$key}; 183 } 184 185 return \@results; 186 187} 188 189=pod 190 191=back 192 193=cut 194 1951; 196