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.04';
   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 AUTHORS
  30
  31 Jesse Vincent <jesse@bestpractical.com>
  32
  33 Nathan Anderson <http://1id.com/=nathan.anderson>
  34
  35 =cut
  36
  37 =head1 API
  38
  39 =over
  40
  41
  42 =item columns CLASS DBI_DBH TABLE
  43
  44 Given an active DBI database handle, return a listref of listrefs (see
  45 L<perllol>), each containing six elements: column name, column type,
  46 nullability, column length, column default, and a field reserved for
  47 driver-specific use (which for sqlite is whether this col is a primary key)
  48
  49
  50 =cut
  51
  52 sub columns {
  53   my ( $proto, $dbh, $table ) = @_;
  54   my $sth  = $dbh->prepare("PRAGMA table_info($table)");
  55   $sth->execute();
  56   my $rows = [];
  57
  58   while ( my $row = $sth->fetchrow_hashref ) {
  59
  60     #  notnull #  pk #  name #  type #  cid #  dflt_value
  61     push @$rows,
  62       [
  63         $row->{'name'},
  64         $row->{'type'},
  65         ( $row->{'notnull'} ? 0 : 1 ),
  66         undef,
  67         $row->{'dflt_value'},
  68         $row->{'pk'}
  69       ];
  70
  71   }
  72
  73   return $rows;
  74 }
  75
  76
  77 =item primary_key CLASS DBI_DBH TABLE
  78
  79 Given an active DBI database handle, return the primary key for the specified
  80 table.
  81
  82 =cut
  83
  84 sub primary_key {
  85   my ($proto, $dbh, $table) = @_;
  86
  87   my $cols = $proto->columns($dbh,$table);
  88   foreach my $col (@$cols) {
  89     return ($col->[1]) if ($col->[5]);
  90   }
  91
  92   return undef;
  93 }
  94
  95
  96
  97 =item unique CLASS DBI_DBH TABLE
  98
  99 Given an active DBI database handle, return a hashref of unique indices.  The
 100 keys of the hashref are index names, and the values are arrayrefs which point
 101 a list of column names for each.  See L<perldsc/"HASHES OF LISTS"> and
 102 L<DBIx::DBSchema::ColGroup>.
 103
 104 =cut
 105
 106 sub unique {
 107   my ($proto, $dbh, $table) = @_;
 108   my @names;
 109   my $indexes = $proto->_index_info($dbh, $table);
 110   foreach my $row (@$indexes) {
 111     push @names, $row->{'name'} if ($row->{'unique'});
 112
 113   }
 114   my $info  = {};
 115   foreach my $name (@names) {
 116     $info->{'name'} = $proto->_index_cols($dbh, $name);
 117   }
 118   return $info;
 119 }
 120
 121
 122 =item index CLASS DBI_DBH TABLE
 123
 124 Given an active DBI database handle, return a hashref of (non-unique) indices.
 125 The keys of the hashref are index names, and the values are arrayrefs which
 126 point a list of column names for each.  See L<perldsc/"HASHES OF LISTS"> and
 127 L<DBIx::DBSchema::ColGroup>.
 128
 129 =cut
 130
 131 sub index {
 132   my ($proto, $dbh, $table) = @_;
 133   my @names;
 134   my $indexes = $proto->_index_info($dbh, $table);
 135   foreach my $row (@$indexes) {
 136     push @names, $row->{'name'} if not ($row->{'unique'});
 137
 138   }
 139   my $info  = {};
 140   foreach my $name (@names) {
 141     $info->{'name'} = $proto->_index_cols($dbh, $name);
 142   }
 143
 144   return $info;
 145 }
 146
 147
 148
 149 sub _index_list {
 150   my $proto = shift;
 151   my $dbh = shift;
 152   my $table = shift;
 153
 154   my $sth  = $dbh->prepare('PRAGMA index_list($table)');
 155   $sth->execute();
 156   my $rows = [];
 157
 158   while ( my $row = $sth->fetchrow_hashref ) {
 159     # Keys are "name" and "unique"
 160     push @$rows, $row;
 161
 162   }
 163
 164   return $rows;
 165 }
 166
 167
 168
 169 sub _index_cols {
 170   my $proto  = shift;
 171   my $dbh = shift;
 172   my $index = shift;
 173
 174   my $sth  = $dbh->prepare('PRAGMA index_info($index)');
 175   $sth->execute();
 176   my $data = {};
 177   while ( my $row = $sth->fetchrow_hashref ) {
 178     # Keys are "name" and "seqno"
 179     $data->{$row->{'seqno'}} = $data->{'name'};
 180   }
 181   my @results;
 182   foreach my $key (sort keys %$data) {
 183     push @results, $data->{$key};
 184   }
 185
 186   return \@results;
 187
 188 }
 189
 190 sub default_db_schema  { '%'; }
 191
 192 sub tables {
 193   my($proto, $dbh) = @_;
 194   my $db_catalog = $proto->default_db_catalog;
 195   my $db_schema  = $proto->default_db_schema;
 196
 197   my $sth = $dbh->table_info($db_catalog, $db_schema, '%', 'TABLE')
 198     or die $dbh->errstr;
 199
 200   $proto->SUPER::tables($dbh, $sth);
 201 }
 202
 203 =pod
 204
 205 =back
 206
 207 =cut
 208
 209 1;