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