File Coverage

blib/lib/Metabrik/Client/Sqlite.pm
Criterion Covered Total %
statement 9 122 7.3
branch 0 46 0.0
condition 0 8 0.0
subroutine 3 14 21.4
pod 1 11 9.0
total 13 201 6.4


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # client::sqlite Brik
5             #
6             package Metabrik::Client::Sqlite;
7 1     1   8 use strict;
  1         2  
  1         30  
8 1     1   4 use warnings;
  1         3  
  1         25  
9              
10 1     1   5 use base qw(Metabrik);
  1         2  
  1         1475  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             attributes => {
19             db => [ qw(sqlite_file) ],
20             autocommit => [ qw(0|1) ],
21             dbh => [ qw(INTERNAL) ],
22             },
23             attributes_default => {
24             autocommit => 1,
25             },
26             commands => {
27             open => [ qw(sqlite_file|OPTIONAL) ],
28             execute => [ qw(sql_query) ],
29             create => [ qw(table_name fields_array key|OPTIONAL) ],
30             insert => [ qw(table_name data_hash) ],
31             select => [ qw(table_name fields_array|OPTIONAL key|OPTIONAL) ],
32             commit => [ ],
33             show_tables => [ ],
34             describe_table => [ ],
35             list_types => [ ],
36             close => [ ],
37             },
38             require_modules => {
39             'DBI' => [ ],
40             'DBD::SQLite' => [ ],
41             },
42             };
43             }
44              
45             sub open {
46 0     0 0   my $self = shift;
47 0           my ($db) = @_;
48              
49 0   0       $db ||= $self->db;
50 0 0         $self->brik_help_run_undef_arg('open', $db) or return;
51              
52 0           my $dbh = DBI->connect('dbi:SQLite:dbname='.$db,'','', {
53             AutoCommit => $self->autocommit,
54             RaiseError => 1,
55             PrintError => 0,
56             PrintWarn => 0,
57             #HandleError => sub {
58             #my ($errstr, $dbh, $arg) = @_;
59             #die("DBI: $errstr\n");
60             #},
61             });
62 0 0         if (! $dbh) {
63 0           return $self->log->error("open: DBI: $DBI::errstr");
64             }
65              
66 0           $self->dbh($dbh);
67              
68 0           return 1;
69             }
70              
71             sub execute {
72 0     0 0   my $self = shift;
73 0           my ($sql) = @_;
74              
75 0           my $dbh = $self->dbh;
76 0 0         $self->brik_help_run_undef_arg('open', $dbh) or return;
77 0 0         $self->brik_help_run_undef_arg('execute', $sql) or return;
78              
79 0           $self->log->debug("execute: sql[$sql]");
80              
81 0           my $sth = $dbh->prepare($sql);
82              
83 0           return $sth->execute;
84             }
85              
86             sub commit {
87 0     0 0   my $self = shift;
88              
89 0           my $dbh = $self->dbh;
90 0 0         $self->brik_help_run_undef_arg('open', $dbh) or return;
91              
92 0 0         if ($self->autocommit) {
93 0           $self->log->verbose("commit: skipping cause autocommit is on");
94 0           return 1;
95             }
96              
97 0           eval {
98 0           $dbh->commit;
99             };
100 0 0         if ($@) {
101 0           chomp($@);
102 0           return $self->log->warning("commit: $@");
103             }
104              
105 0           return 1;
106             }
107              
108             sub create {
109 0     0 0   my $self = shift;
110 0           my ($table, $fields, $key) = @_;
111              
112 0 0         $self->brik_help_run_undef_arg('create', $table) or return;
113 0 0         $self->brik_help_run_undef_arg('create', $fields) or return;
114 0 0         $self->brik_help_run_invalid_arg('create', $fields, 'ARRAY') or return;
115              
116             # create table TABLE (stuffid INTEGER PRIMARY KEY, field1 VARCHAR(512), field2, date DATE);
117             # insert into TABLE (field1) values ("value1");
118              
119 0           my $sql = 'CREATE TABLE '.$table.' (';
120 0           for my $field (@$fields) {
121             # Fields are table fields, we normalize them (space char not allowed)
122 0           $field =~ s/ /_/g;
123 0           $sql .= $field;
124 0 0 0       if (defined($key) && $field eq $key) {
125 0           $sql .= ' PRIMARY KEY NOT NULL';
126             }
127 0           $sql .= ',';
128             }
129 0           $sql =~ s/,$//;
130 0           $sql .= ');';
131              
132 0           $self->log->verbose("create: $sql");
133              
134 0           return $self->execute($sql);
135             }
136              
137             sub insert {
138 0     0 0   my $self = shift;
139 0           my ($table, $data) = @_;
140              
141 0 0         $self->brik_help_run_undef_arg('insert', $table) or return;
142 0 0         $self->brik_help_run_undef_arg('insert', $data) or return;
143              
144 0           my @data = ();
145 0 0         if (ref($data) eq 'ARRAY') {
146 0           for my $this (@$data) {
147 0 0         if (ref($this) ne 'HASH') {
148 0           $self->log->verbose('insert: not a hash, skipping');
149 0           next;
150             }
151 0           push @data, $this;
152             }
153             }
154             else {
155 0 0         if (ref($data) ne 'HASH') {
156 0           return $self->log->error("insert: Argument 'data' must be HASHREF");
157             }
158 0           push @data, $data;
159             }
160              
161 0           for my $this (@data) {
162 0           my $sql = 'INSERT INTO '.$table.' (';
163             # Fields are table fields, we normalize them (space char not allowed)
164 0           my @fields = map { s/ /_/g; $_ } keys %$this;
  0            
  0            
165 0           my @values = map { $_ } values %$this;
  0            
166 0           $sql .= join(',', @fields);
167 0           $sql .= ') VALUES (';
168 0           for (@values) {
169 0           $sql .= "\"$_\",";
170             }
171 0           $sql =~ s/,$//;
172 0           $sql .= ')';
173              
174 0           $self->log->verbose("insert: $sql");
175              
176 0           $self->execute($sql);
177             }
178              
179 0           return 1;
180             }
181              
182             sub select {
183 0     0 0   my $self = shift;
184 0           my ($table, $fields, $key) = @_;
185              
186 0           my $dbh = $self->dbh;
187 0   0       $fields ||= [ '*' ];
188 0 0         $self->brik_help_run_undef_arg('open', $dbh) or return;
189 0 0         $self->brik_help_run_undef_arg('select', $table) or return;
190 0 0         $self->brik_help_run_invalid_arg('select', $fields, 'ARRAY') or return;
191 0 0         $self->brik_help_run_empty_array_arg('select', $fields) or return;
192              
193 0           my $sql = 'SELECT ';
194 0           for (@$fields) {
195             # Fields are table fields, we normalize them (space char not allowed)
196 0           s/ /_/g;
197 0           $sql .= "$_,";
198             }
199 0           $sql =~ s/,$//;
200 0           $sql .= ' FROM '.$table;
201              
202 0           my $sth = $dbh->prepare($sql);
203 0           my $rv = $sth->execute;
204              
205 0 0         if (! defined($key)) {
206 0           return $sth->fetchall_arrayref;
207             }
208              
209 0           return $sth->fetchall_hashref($key);
210             }
211              
212             sub show_tables {
213 0     0 0   my $self = shift;
214              
215 0           my $dbh = $self->dbh;
216 0 0         $self->brik_help_run_undef_arg('open', $dbh) or return;
217              
218             # $dbh->table_info(undef, $schema, $table, $type, \%attr);
219             # $type := 'TABLE', 'VIEW', 'LOCAL TEMPORARY' and 'SYSTEM TABLE'
220 0           my $sth = $dbh->table_info(undef, 'main', '%', 'TABLE');
221              
222 0           my $h = $sth->fetchall_arrayref;
223 0           my @r = ();
224 0           for my $this (@$h) {
225 0           push @r, $this->[-1]; # Last entry is the CREATE TABLE one.
226             }
227              
228 0           return \@r;
229             }
230              
231             sub list_types {
232 0     0 0   my $self = shift;
233              
234             return [
235 0           'INTEGER',
236             'DATE',
237             'VARCHAR(int)',
238             ];
239             }
240              
241             # https://metacpan.org/pod/DBI#table_info
242       0 0   sub describe_table {
243             #my $sth = $dbh->column_info(undef,'table_name',undef,undef);
244             #$sth->fetchall_arrayref;
245             }
246              
247             sub close {
248 0     0 0   my $self = shift;
249              
250 0           my $dbh = $self->dbh;
251 0 0         if (defined($dbh)) {
252 0           $dbh->commit;
253 0           $dbh->disconnect;
254 0           $self->dbh(undef);
255             }
256              
257 0           return 1;
258             }
259              
260             1;
261              
262             __END__