DBSchema/DBD/SQLite.pm

   1 package DBIx::DBSchema::DBD::SQLite;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA %typemap);
   5 use DBIx::DBSchema::DBD;
   6
   7 $VERSION = '0.02';
   8 @ISA = qw(DBIx::DBSchema::DBD);
   9
  10 %typemap = (
  11   'SERIAL' => 'INTEGER PRIMARY KEY AUTOINCREMENT',
  12 );
  13
  14 =head1 NAME
  15
  16 DBIx::DBSchema::DBD::SQLite - SQLite native driver for DBIx::DBSchema
  17
  18 =head1 SYNOPSIS
  19
  20 use DBI;
  21 use DBIx::DBSchema;
  22
  23 $dbh = DBI->connect('dbi:SQLite:tns_service_name', 'user','pass');
  24 $schema = new_native DBIx::DBSchema $dbh;
  25
  26 =head1 DESCRIPTION
  27
  28 This module implements a SQLite-native driver for DBIx::DBSchema.
  29
  30 =head1 AUTHOR
  31
  32 Jesse Vincent <jesse@bestpractical.com>
  33
  34 =cut
  35
  36 =head1 API
  37
  38 =over
  39
  40
  41 =item columns CLASS DBI_DBH TABLE
  42
  43 Given an active DBI database handle, return a listref of listrefs (see
  44 L<perllol>), each containing six elements: column name, column type,
  45 nullability, column length, column default, and a field reserved for
  46 driver-specific use (which for sqlite is whether this col is a primary key)
  47
  48
  49 =cut
  50
  51 sub columns {
  52     my ( $proto, $dbh, $table ) = @_;
  53     my $sth  = $dbh->prepare('PRAGMA table_info($table)');
  54         $sth->execute();
  55     my $rows = [];
  56
  57     while ( my $row = $sth->fetchrow_hashref ) {
  58
  59         #  notnull #  pk #  name #  type #  cid #  dflt_value
  60         push @$rows,
  61             [
  62             $row->{'name'},
  63             $row->{'type'},
  64             ( $row->{'notnull'} ? 0 : 1 ),
  65             undef,
  66             $row->{'dflt_value'},
  67             $row->{'pk'}
  68             ];
  69
  70     }
  71
  72     return $rows;
  73 }
  74
  75
  76 =item primary_key CLASS DBI_DBH TABLE
  77
  78 Given an active DBI database handle, return the primary key for the specified
  79 table.
  80
  81 =cut
  82
  83 sub primary_key {
  84   my ($proto, $dbh, $table) = @_;
  85
  86         my $cols = $proto->columns($dbh,$table);
  87         foreach my $col (@$cols) {
  88                 return ($col->[1]) if ($col->[5]);
  89         }
  90
  91         return undef;
  92 }
  93
  94
  95
  96 =item unique CLASS DBI_DBH TABLE
  97
  98 Given an active DBI database handle, return a hashref of unique indices.  The
  99 keys of the hashref are index names, and the values are arrayrefs which point
 100 a list of column names for each.  See L<perldsc/"HASHES OF LISTS"> and
 101 L<DBIx::DBSchema::ColGroup>.
 102
 103 =cut
 104
 105 sub unique {
 106   my ($proto, $dbh, $table) = @_;
 107   my @names;
 108         my $indexes = $proto->_index_info($dbh, $table);
 109    foreach my $row (@$indexes) {
 110         push @names, $row->{'name'} if ($row->{'unique'});
 111
 112     }
 113     my $info  = {};
 114         foreach my $name (@names) {
 115                 $info->{'name'} = $proto->_index_cols($dbh, $name);
 116         }
 117     return $info;
 118 }
 119
 120
 121 =item index CLASS DBI_DBH TABLE
 122
 123 Given an active DBI database handle, return a hashref of (non-unique) indices.
 124 The keys of the hashref are index names, and the values are arrayrefs which
 125 point a list of column names for each.  See L<perldsc/"HASHES OF LISTS"> and
 126 L<DBIx::DBSchema::ColGroup>.
 127
 128 =cut
 129
 130 sub index {
 131   my ($proto, $dbh, $table) = @_;
 132   my @names;
 133         my $indexes = $proto->_index_info($dbh, $table);
 134    foreach my $row (@$indexes) {
 135         push @names, $row->{'name'} if not ($row->{'unique'});
 136
 137     }
 138     my $info  = {};
 139         foreach my $name (@names) {
 140                 $info->{'name'} = $proto->_index_cols($dbh, $name);
 141         }
 142
 143   return $info;
 144 }
 145
 146
 147
 148 sub _index_list {
 149
 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 =pod
 191
 192 =back
 193
 194 =cut
 195
 196 1;