DBSchema/DBD/SQLite.pm

   1 package DBIx::DBSchema::DBD::SQLite;
   2 use base qw( DBIx::DBSchema::DBD );
   3
   4 use strict;
   5 use vars qw($VERSION %typemap);
   6
   7 $VERSION = '0.03';
   8
   9 %typemap = (
  10   'SERIAL' => 'INTEGER PRIMARY KEY AUTOINCREMENT',
  11 );
  12
  13 =head1 NAME
  14
  15 DBIx::DBSchema::DBD::SQLite - SQLite native driver for DBIx::DBSchema
  16
  17 =head1 SYNOPSIS
  18
  19 use DBI;
  20 use 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
  27 This module implements a SQLite-native driver for DBIx::DBSchema.
  28
  29 =head1 AUTHOR
  30
  31 Jesse Vincent <jesse@bestpractical.com>
  32
  33 =cut
  34
  35 =head1 API
  36
  37 =over
  38
  39
  40 =item columns CLASS DBI_DBH TABLE
  41
  42 Given an active DBI database handle, return a listref of listrefs (see
  43 L<perllol>), each containing six elements: column name, column type,
  44 nullability, column length, column default, and a field reserved for
  45 driver-specific use (which for sqlite is whether this col is a primary key)
  46
  47
  48 =cut
  49
  50 sub 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
  77 Given an active DBI database handle, return the primary key for the specified
  78 table.
  79
  80 =cut
  81
  82 sub 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
  97 Given an active DBI database handle, return a hashref of unique indices.  The
  98 keys of the hashref are index names, and the values are arrayrefs which point
  99 a list of column names for each.  See L<perldsc/"HASHES OF LISTS"> and
 100 L<DBIx::DBSchema::ColGroup>.
 101
 102 =cut
 103
 104 sub 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
 122 Given an active DBI database handle, return a hashref of (non-unique) indices.
 123 The keys of the hashref are index names, and the values are arrayrefs which
 124 point a list of column names for each.  See L<perldsc/"HASHES OF LISTS"> and
 125 L<DBIx::DBSchema::ColGroup>.
 126
 127 =cut
 128
 129 sub 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
 147 sub _index_list {
 148
 149         my $proto = shift;
 150         my $dbh = shift;
 151         my $table = shift;
 152
 153 my $sth  = $dbh->prepare('PRAGMA index_list($table)');
 154 $sth->execute();
 155 my $rows = [];
 156
 157 while ( my $row = $sth->fetchrow_hashref ) {
 158     # Keys are "name" and "unique"
 159     push @$rows, $row;
 160
 161 }
 162
 163 return $rows;
 164 }
 165
 166
 167
 168 sub _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 = {};
 176 while ( 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
 195 1;