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
 151         my $proto = shift;
 152         my $dbh = shift;
 153         my $table = shift;
 154
 155 my $sth  = $dbh->prepare('PRAGMA index_list($table)');
 156 $sth->execute();
 157 my $rows = [];
 158
 159 while ( my $row = $sth->fetchrow_hashref ) {
 160     # Keys are "name" and "unique"
 161     push @$rows, $row;
 162
 163 }
 164
 165 return $rows;
 166 }
 167
 168
 169
 170 sub _index_cols {
 171         my $proto  = shift;
 172         my $dbh = shift;
 173         my $index = shift;
 174
 175         my $sth  = $dbh->prepare('PRAGMA index_info($index)');
 176         $sth->execute();
 177         my $data = {};
 178 while ( my $row = $sth->fetchrow_hashref ) {
 179     # Keys are "name" and "seqno"
 180         $data->{$row->{'seqno'}} = $data->{'name'};
 181 }
 182         my @results;
 183         foreach my $key (sort keys %$data) {
 184               push @results, $data->{$key};
 185         }
 186
 187         return \@results;
 188
 189 }
 190
 191 sub default_db_schema  { '%'; }
 192
 193 sub tables {
 194   my($proto, $dbh) = @_;
 195   my $db_catalog = $proto->default_db_catalog;
 196   my $db_schema  = $proto->default_db_schema;
 197
 198   my $sth = $dbh->table_info($db_catalog, $db_schema, '%', 'TABLE')
 199     or die $dbh->errstr;
 200
 201   $proto->SUPER::tables($dbh, $sth);
 202 }
 203
 204 =pod
 205
 206 =back
 207
 208 =cut
 209
 210 1;