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