File Coverage

lib/CPANPLUS/Internals/Source/SQLite.pm
Criterion Covered Total %
statement 22 24 91.6
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 30 32 93.7


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Source::SQLite;
2              
3 2     2   148202 use strict;
  2         6  
  2         67  
4 2     2   12 use warnings;
  2         5  
  2         63  
5              
6 2     2   11 use base 'CPANPLUS::Internals::Source';
  2         6  
  2         856  
7              
8 2     2   24 use CPANPLUS::Error;
  2         6  
  2         150  
9 2     2   15 use CPANPLUS::Internals::Constants;
  2         5  
  2         758  
10 2     2   1048 use CPANPLUS::Internals::Source::SQLite::Tie;
  2         7  
  2         71  
11              
12 2     2   14 use Data::Dumper;
  2         4  
  2         111  
13 2     2   522 use DBIx::Simple;
  0            
  0            
14             use DBD::SQLite;
15              
16             use Params::Check qw[allow check];
17             use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
18              
19             use vars qw[$VERSION];
20             $VERSION = "0.9914";
21              
22             use constant TXN_COMMIT => 1000;
23              
24             =head1 NAME
25              
26             CPANPLUS::Internals::Source::SQLite - SQLite implementation
27              
28             =cut
29              
30             { my $Dbh;
31             my $DbFile;
32              
33             sub __sqlite_file {
34             return $DbFile if $DbFile;
35              
36             my $self = shift;
37             my $conf = $self->configure_object;
38              
39             $DbFile = File::Spec->catdir(
40             $conf->get_conf('base'),
41             SOURCE_SQLITE_DB
42             );
43              
44             return $DbFile;
45             };
46              
47             sub __sqlite_dbh {
48             return $Dbh if $Dbh;
49              
50             my $self = shift;
51             $Dbh = DBIx::Simple->connect(
52             "dbi:SQLite:dbname=" . $self->__sqlite_file,
53             '', '',
54             { AutoCommit => 1 }
55             );
56             #$Dbh->dbh->trace(1);
57             $Dbh->query(qq{PRAGMA synchronous = OFF});
58              
59             return $Dbh;
60             };
61              
62             sub __sqlite_disconnect {
63             return unless $Dbh;
64             $Dbh->disconnect;
65             $Dbh = undef;
66             return;
67             }
68             }
69              
70             { my $used_old_copy = 0;
71              
72             sub _init_trees {
73             my $self = shift;
74             my $conf = $self->configure_object;
75             my %hash = @_;
76              
77             my($path,$uptodate,$verbose,$use_stored);
78             my $tmpl = {
79             path => { default => $conf->get_conf('base'), store => \$path },
80             verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
81             uptodate => { required => 1, store => \$uptodate },
82             use_stored => { default => 1, store => \$use_stored },
83             };
84              
85             check( $tmpl, \%hash ) or return;
86              
87             ### if it's not uptodate, or the file doesn't exist, we need to create
88             ### a new sqlite db
89             if( not $uptodate or not -e $self->__sqlite_file ) {
90             $used_old_copy = 0;
91              
92             ### chuck the file
93             $self->__sqlite_disconnect;
94             1 while unlink $self->__sqlite_file;
95              
96             ### and create a new one
97             $self->__sqlite_create_db or do {
98             error(loc("Could not create new SQLite DB"));
99             return;
100             }
101             } else {
102             $used_old_copy = 1;
103             }
104              
105             ### set up the author tree
106             { my %at;
107             tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie',
108             dbh => $self->__sqlite_dbh, table => 'author',
109             key => 'cpanid', cb => $self;
110              
111             $self->_atree( \%at );
112             }
113              
114             ### set up the author tree
115             { my %mt;
116             tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie',
117             dbh => $self->__sqlite_dbh, table => 'module',
118             key => 'module', cb => $self;
119              
120             $self->_mtree( \%mt );
121             }
122              
123             ### start a transaction
124             $self->__sqlite_dbh->query('BEGIN');
125              
126             return 1;
127              
128             }
129              
130             sub _standard_trees_completed { return $used_old_copy }
131             sub _custom_trees_completed { return }
132             ### finish transaction
133             sub _finalize_trees { $_[0]->__sqlite_dbh->commit; return 1 }
134              
135             ### saves current memory state, but not implemented in sqlite
136             sub _save_state {
137             error(loc("%1 has not implemented writing state to disk", __PACKAGE__));
138             return;
139             }
140             }
141              
142             { my $txn_count = 0;
143              
144             ### XXX move this outside the sub, so we only compute it once
145             my $class;
146             my @keys = qw[ author cpanid email ];
147             my $tmpl = {
148             class => { default => 'CPANPLUS::Module::Author', store => \$class },
149             map { $_ => { required => 1 } } @keys
150             };
151              
152             ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually
153             my $ph = join ',', map { '?' } @keys;
154              
155              
156             sub _add_author_object {
157             my $self = shift;
158             my %hash = @_;
159             my $dbh = $self->__sqlite_dbh;
160              
161             my $href = do {
162             local $Params::Check::NO_DUPLICATES = 1;
163             local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
164             check( $tmpl, \%hash ) or return;
165             };
166              
167             ### keep counting how many we inserted
168             unless( ++$txn_count % TXN_COMMIT ) {
169             #warn "Committing transaction $txn_count";
170             $dbh->commit or error( $dbh->error ); # commit previous transaction
171             $dbh->begin_work or error( $dbh->error ); # and start a new one
172             }
173              
174             $dbh->query(
175             "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)",
176             values %$href
177             ) or do {
178             error( $dbh->error );
179             return;
180             };
181              
182             return 1;
183             }
184             }
185              
186             { my $txn_count = 0;
187              
188             ### XXX move this outside the sub, so we only compute it once
189             my $class;
190             my @keys = qw[ module version path comment author package description dslip mtime ];
191             my $tmpl = {
192             class => { default => 'CPANPLUS::Module', store => \$class },
193             map { $_ => { required => 1 } } @keys
194             };
195              
196             ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually
197             my $ph = join ',', map { '?' } @keys;
198              
199             sub _add_module_object {
200             my $self = shift;
201             my %hash = @_;
202             my $dbh = $self->__sqlite_dbh;
203              
204             my $href = do {
205             local $Params::Check::NO_DUPLICATES = 1;
206             local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
207             check( $tmpl, \%hash ) or return;
208             };
209              
210             ### fix up author to be 'plain' string
211             $href->{'author'} = $href->{'author'}->cpanid;
212              
213             ### keep counting how many we inserted
214             unless( ++$txn_count % TXN_COMMIT ) {
215             #warn "Committing transaction $txn_count";
216             $dbh->commit or error( $dbh->error ); # commit previous transaction
217             $dbh->begin_work or error( $dbh->error ); # and start a new one
218             }
219              
220             $dbh->query(
221             "INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)",
222             values %$href
223             ) or do {
224             error( $dbh->error );
225             return;
226             };
227              
228             return 1;
229             }
230             }
231              
232             { my %map = (
233             _source_search_module_tree
234             => [ module => module => 'CPANPLUS::Module' ],
235             _source_search_author_tree
236             => [ author => cpanid => 'CPANPLUS::Module::Author' ],
237             );
238              
239             while( my($sub, $aref) = each %map ) {
240             no strict 'refs';
241              
242             my($table, $key, $class) = @$aref;
243             *$sub = sub {
244             my $self = shift;
245             my %hash = @_;
246              
247             my($list,$type);
248             my $tmpl = {
249             allow => { required => 1, default => [ ], strict_type => 1,
250             store => \$list },
251             type => { required => 1, allow => [$class->accessors()],
252             store => \$type },
253             };
254              
255             check( $tmpl, \%hash ) or return;
256              
257              
258             ### we aliased 'module' to 'name', so change that here too
259             $type = 'module' if $type eq 'name';
260              
261             my $meth = $table .'_tree';
262              
263             {
264             my $throw = $self->$meth;
265             }
266              
267             my $dbh = $self->__sqlite_dbh;
268             my $res = $dbh->query( "SELECT * from $table" );
269              
270             my @rv = map { $self->$meth( $_->{$key} ) }
271             grep { allow( $_->{$type} => $list ) } $res->hashes;
272              
273             return @rv;
274             }
275             }
276             }
277              
278              
279              
280             sub __sqlite_create_db {
281             my $self = shift;
282             my $dbh = $self->__sqlite_dbh;
283              
284             ### we can ignore the result/error; not all sqlite implementations
285             ### support this
286             $dbh->query( qq[
287             DROP TABLE IF EXISTS author;
288             \n]
289             ) or do {
290             msg( $dbh->error );
291             };
292             $dbh->query( qq[
293             DROP TABLE IF EXISTS module;
294             \n]
295             ) or do {
296             msg( $dbh->error );
297             };
298              
299              
300              
301             $dbh->query( qq[
302             /* the author information */
303             CREATE TABLE author (
304             id INTEGER PRIMARY KEY AUTOINCREMENT,
305              
306             author varchar(255),
307             email varchar(255),
308             cpanid varchar(255)
309             );
310             \n]
311              
312             ) or do {
313             error( $dbh->error );
314             return;
315             };
316              
317             $dbh->query( qq[
318             /* the module information */
319             CREATE TABLE module (
320             id INTEGER PRIMARY KEY AUTOINCREMENT,
321              
322             module varchar(255),
323             version varchar(255),
324             path varchar(255),
325             comment varchar(255),
326             author varchar(255),
327             package varchar(255),
328             description varchar(255),
329             dslip varchar(255),
330             mtime varchar(255)
331             );
332              
333             \n]
334              
335             ) or do {
336             error( $dbh->error );
337             return;
338             };
339              
340             $dbh->query( qq[
341             /* the module index */
342             CREATE INDEX IX_module_module ON module (
343             module
344             );
345              
346             \n]
347              
348             ) or do {
349             error( $dbh->error );
350             return;
351             };
352              
353             $dbh->query( qq[
354             /* the version index */
355             CREATE INDEX IX_module_version ON module (
356             version
357             );
358              
359             \n]
360              
361             ) or do {
362             error( $dbh->error );
363             return;
364             };
365              
366             $dbh->query( qq[
367             /* the module-version index */
368             CREATE INDEX IX_module_module_version ON module (
369             module, version
370             );
371              
372             \n]
373              
374             ) or do {
375             error( $dbh->error );
376             return;
377             };
378              
379             return 1;
380             }
381              
382             1;