--- /dev/null
+package DBIx::DBSchema::DBD::SQLite;
+
+use strict;
+use vars qw($VERSION @ISA %typemap);
+use DBIx::DBSchema::DBD;
+
+$VERSION = '0.01';
+@ISA = qw(DBIx::DBSchema::DBD);
+
+%typemap = (
+'SERIAL' => 'INTEGER PRIMARY KEY'
+);
+
+=head1 NAME
+
+DBIx::DBSchema::DBD::SQLite - SQLite native driver for DBIx::DBSchema
+
+=head1 SYNOPSIS
+
+use DBI;
+use DBIx::DBSchema;
+
+$dbh = DBI->connect('dbi:SQLite:tns_service_name', 'user','pass');
+$schema = new_native DBIx::DBSchema $dbh;
+
+=head1 DESCRIPTION
+
+This module implements a SQLite-native driver for DBIx::DBSchema.
+
+=head1 AUTHOR
+
+Jesse Vincent <jesse@bestpractical.com>
+
+=cut
+
+=head1 API
+
+=over
+
+
+=item columns CLASS DBI_DBH TABLE
+
+Given an active DBI database handle, return a listref of listrefs (see
+L<perllol>), each containing six elements: column name, column type,
+nullability, column length, column default, and a field reserved for
+driver-specific use (which for sqlite is whether this col is a primary key)
+
+
+=cut
+
+sub columns {
+ my ( $proto, $dbh, $table ) = @_;
+ my $sth = $dbh->prepare('PRAGMA table_info($table)');
+ $sth->execute();
+ my $rows = [];
+
+ while ( my $row = $sth->fetchrow_hashref ) {
+
+ # notnull # pk # name # type # cid # dflt_value
+ push @$rows,
+ [
+ $row->{'name'},
+ $row->{'type'},
+ ( $row->{'notnull'} ? 0 : 1 ),
+ undef,
+ $row->{'dflt_value'},
+ $row->{'pk'}
+ ];
+
+ }
+
+ return $rows;
+}
+
+
+=item primary_key CLASS DBI_DBH TABLE
+
+Given an active DBI database handle, return the primary key for the specified
+table.
+
+=cut
+
+sub primary_key {
+ my ($proto, $dbh, $table) = @_;
+
+ my $cols = $proto->columns($dbh,$table);
+ foreach my $col (@$cols) {
+ return ($col->[1]) if ($col->[5]);
+ }
+
+ return undef;
+}
+
+
+
+=item unique CLASS DBI_DBH TABLE
+
+Given an active DBI database handle, return a hashref of unique indices. The
+keys of the hashref are index names, and the values are arrayrefs which point
+a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and
+L<DBIx::DBSchema::ColGroup>.
+
+=cut
+
+sub unique {
+ my ($proto, $dbh, $table) = @_;
+ my @names;
+ my $indexes = $proto->_index_info($dbh, $table);
+ foreach my $row (@$indexes) {
+ push @names, $row->{'name'} if ($row->{'unique'});
+
+ }
+ my $info = {};
+ foreach my $name (@names) {
+ $info->{'name'} = $proto->_index_cols($dbh, $name);
+ }
+ return $info;
+}
+
+
+=item index CLASS DBI_DBH TABLE
+
+Given an active DBI database handle, return a hashref of (non-unique) indices.
+The keys of the hashref are index names, and the values are arrayrefs which
+point a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and
+L<DBIx::DBSchema::ColGroup>.
+
+=cut
+
+sub index {
+ my ($proto, $dbh, $table) = @_;
+ my @names;
+ my $indexes = $proto->_index_info($dbh, $table);
+ foreach my $row (@$indexes) {
+ push @names, $row->{'name'} if not ($row->{'unique'});
+
+ }
+ my $info = {};
+ foreach my $name (@names) {
+ $info->{'name'} = $proto->_index_cols($dbh, $name);
+ }
+
+ return $info;
+}
+
+
+
+sub _index_list {
+
+ my $proto = shift;
+ my $dbh = shift;
+ my $table = shift;
+
+my $sth = $dbh->prepare('PRAGMA index_list($table)');
+$sth->execute();
+my $rows = [];
+
+while ( my $row = $sth->fetchrow_hashref ) {
+ # Keys are "name" and "unique"
+ push @$rows, $row;
+
+}
+
+return $rows;
+}
+
+
+
+sub _index_cols {
+ my $proto = shift;
+ my $dbh = shift;
+ my $index = shift;
+
+ my $sth = $dbh->prepare('PRAGMA index_info($index)');
+ $sth->execute();
+ my $data = {};
+while ( my $row = $sth->fetchrow_hashref ) {
+ # Keys are "name" and "seqno"
+ $data->{$row->{'seqno'}} = $data->{'name'};
+}
+ my @results;
+ foreach my $key (sort keys %$data) {
+ push @results, $data->{$key};
+ }
+
+ return \@results;
+
+}
+
+=begin pod
+
+=back
+
+=cut
+
+1;
projects / DBIx-DBSchema.git / commitdiff