This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
47bdbebfd7726696e1a97062457981c3c763e4ab
[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             my $dbh  = $self->__sqlite_dbh;
244
245             my($list,$type);
246             my $tmpl = {
247                 allow   => { required   => 1, default   => [ ], strict_type => 1,
248                              store      => \$list },
249                 type    => { required   => 1, allow => [$class->accessors()],
250                              store      => \$type },
251             };
252
253             check( $tmpl, \%hash ) or return;
254
255
256             ### we aliased 'module' to 'name', so change that here too
257             $type = 'module' if $type eq 'name';
258
259             my $res = $dbh->query( "SELECT * from $table" );
260
261             my $meth = $table .'_tree';
262             my @rv = map  { $self->$meth( $_->{$key} ) }
263                      grep { allow( $_->{$type} => $list ) } $res->hashes;
264
265             return @rv;
266         }
267     }
268 }
269
270
271
272 sub __sqlite_create_db {
273     my $self = shift;
274     my $dbh  = $self->__sqlite_dbh;
275
276     ### we can ignore the result/error; not all sqlite implementations
277     ### support this
278     $dbh->query( qq[
279         DROP TABLE IF EXISTS author;
280         \n]
281      ) or do {
282         msg( $dbh->error );
283     };
284     $dbh->query( qq[
285         DROP TABLE IF EXISTS module;
286         \n]
287      ) or do {
288         msg( $dbh->error );
289     };
290
291
292
293     $dbh->query( qq[
294         /* the author information */
295         CREATE TABLE author (
296             id INTEGER PRIMARY KEY AUTOINCREMENT,
297
298             author  varchar(255),
299             email   varchar(255),
300             cpanid  varchar(255)
301         );
302         \n]
303
304     ) or do {
305         error( $dbh->error );
306         return;
307     };
308
309     $dbh->query( qq[
310         /* the module information */
311         CREATE TABLE module (
312             id INTEGER PRIMARY KEY AUTOINCREMENT,
313
314             module      varchar(255),
315             version     varchar(255),
316             path        varchar(255),
317             comment     varchar(255),
318             author      varchar(255),
319             package     varchar(255),
320             description varchar(255),
321             dslip       varchar(255),
322             mtime       varchar(255)
323         );
324
325         \n]
326
327     ) or do {
328         error( $dbh->error );
329         return;
330     };
331
332     $dbh->query( qq[
333         /* the module index */
334         CREATE INDEX IX_module_module ON module (
335             module
336         );
337
338         \n]
339
340     ) or do {
341         error( $dbh->error );
342         return;
343     };
344
345     $dbh->query( qq[
346         /* the version index */
347         CREATE INDEX IX_module_version ON module (
348             version
349         );
350
351         \n]
352
353     ) or do {
354         error( $dbh->error );
355         return;
356     };
357
358     $dbh->query( qq[
359         /* the module-version index */
360         CREATE INDEX IX_module_module_version ON module (
361             module, version
362         );
363
364         \n]
365
366     ) or do {
367         error( $dbh->error );
368         return;
369     };
370
371     return 1;
372 }
373
374 1;