Commit | Line | Data |
4443dd53 |
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 => 0 } |
52 | ); |
53 | #$Dbh->dbh->trace(1); |
54 | |
55 | return $Dbh; |
56 | }; |
57 | } |
58 | |
59 | { my $used_old_copy = 0; |
60 | |
61 | sub _init_trees { |
62 | my $self = shift; |
63 | my $conf = $self->configure_object; |
64 | my %hash = @_; |
65 | |
66 | my($path,$uptodate,$verbose,$use_stored); |
67 | my $tmpl = { |
68 | path => { default => $conf->get_conf('base'), store => \$path }, |
69 | verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, |
70 | uptodate => { required => 1, store => \$uptodate }, |
71 | use_stored => { default => 1, store => \$use_stored }, |
72 | }; |
73 | |
74 | check( $tmpl, \%hash ) or return; |
75 | |
76 | ### if it's not uptodate, or the file doesn't exist, we need to create |
77 | ### a new sqlite db |
78 | if( not $uptodate or not -e $self->__sqlite_file ) { |
79 | $used_old_copy = 0; |
80 | |
81 | ### chuck the file |
82 | 1 while unlink $self->__sqlite_file; |
83 | |
84 | ### and create a new one |
85 | $self->__sqlite_create_db or do { |
86 | error(loc("Could not create new SQLite DB")); |
87 | return; |
88 | } |
89 | } else { |
90 | $used_old_copy = 1; |
91 | } |
92 | |
93 | ### set up the author tree |
94 | { my %at; |
95 | tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie', |
96 | dbh => $self->__sqlite_dbh, table => 'author', |
97 | key => 'cpanid', cb => $self; |
98 | |
99 | $self->_atree( \%at ); |
100 | } |
101 | |
102 | ### set up the author tree |
103 | { my %mt; |
104 | tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie', |
105 | dbh => $self->__sqlite_dbh, table => 'module', |
106 | key => 'module', cb => $self; |
107 | |
108 | $self->_mtree( \%mt ); |
109 | } |
110 | |
111 | ### start a transaction |
112 | $self->__sqlite_dbh->query('BEGIN'); |
113 | |
114 | return 1; |
115 | |
116 | } |
117 | |
118 | sub _standard_trees_completed { return $used_old_copy } |
119 | sub _custom_trees_completed { return } |
120 | ### finish transaction |
121 | sub _finalize_trees { $_[0]->__sqlite_dbh->query('COMMIT'); return 1 } |
122 | |
123 | ### saves current memory state, but not implemented in sqlite |
124 | sub _save_state { |
125 | error(loc("%1 has not implemented writing state to disk", __PACKAGE__)); |
126 | return; |
127 | } |
128 | } |
129 | |
130 | { my $txn_count = 0; |
131 | |
132 | ### XXX move this outside the sub, so we only compute it once |
133 | my $class; |
134 | my @keys = qw[ author cpanid email ]; |
135 | my $tmpl = { |
136 | class => { default => 'CPANPLUS::Module::Author', store => \$class }, |
137 | map { $_ => { required => 1 } } @keys |
138 | }; |
139 | |
140 | ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually |
141 | my $ph = join ',', map { '?' } @keys; |
142 | |
143 | |
144 | sub _add_author_object { |
145 | my $self = shift; |
146 | my %hash = @_; |
147 | my $dbh = $self->__sqlite_dbh; |
148 | |
149 | my $href = do { |
150 | local $Params::Check::NO_DUPLICATES = 1; |
151 | local $Params::Check::SANITY_CHECK_TEMPLATE = 0; |
152 | check( $tmpl, \%hash ) or return; |
153 | }; |
154 | |
155 | ### keep counting how many we inserted |
156 | unless( ++$txn_count % TXN_COMMIT ) { |
157 | #warn "Committing transaction $txn_count"; |
158 | $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction |
159 | $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one |
160 | } |
161 | |
162 | $dbh->query( |
163 | "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)", |
164 | values %$href |
165 | ) or do { |
166 | error( $dbh->error ); |
167 | return; |
168 | }; |
169 | |
170 | return 1; |
171 | } |
172 | } |
173 | |
174 | { my $txn_count = 0; |
175 | |
176 | ### XXX move this outside the sub, so we only compute it once |
177 | my $class; |
178 | my @keys = qw[ module version path comment author package description dslip mtime ]; |
179 | my $tmpl = { |
180 | class => { default => 'CPANPLUS::Module', store => \$class }, |
181 | map { $_ => { required => 1 } } @keys |
182 | }; |
183 | |
184 | ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually |
185 | my $ph = join ',', map { '?' } @keys; |
186 | |
187 | sub _add_module_object { |
188 | my $self = shift; |
189 | my %hash = @_; |
190 | my $dbh = $self->__sqlite_dbh; |
191 | |
192 | my $href = do { |
193 | local $Params::Check::NO_DUPLICATES = 1; |
194 | local $Params::Check::SANITY_CHECK_TEMPLATE = 0; |
195 | check( $tmpl, \%hash ) or return; |
196 | }; |
197 | |
198 | ### fix up author to be 'plain' string |
199 | $href->{'author'} = $href->{'author'}->cpanid; |
200 | |
201 | ### keep counting how many we inserted |
202 | unless( ++$txn_count % TXN_COMMIT ) { |
203 | #warn "Committing transaction $txn_count"; |
204 | $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction |
205 | $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one |
206 | } |
207 | |
208 | $dbh->query( |
209 | "INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)", |
210 | values %$href |
211 | ) or do { |
212 | error( $dbh->error ); |
213 | return; |
214 | }; |
215 | |
216 | return 1; |
217 | } |
218 | } |
219 | |
220 | { my %map = ( |
221 | _source_search_module_tree |
222 | => [ module => module => 'CPANPLUS::Module' ], |
223 | _source_search_author_tree |
224 | => [ author => cpanid => 'CPANPLUS::Module::Author' ], |
225 | ); |
226 | |
227 | while( my($sub, $aref) = each %map ) { |
228 | no strict 'refs'; |
229 | |
230 | my($table, $key, $class) = @$aref; |
231 | *$sub = sub { |
232 | my $self = shift; |
233 | my %hash = @_; |
234 | my $dbh = $self->__sqlite_dbh; |
235 | |
236 | my($list,$type); |
237 | my $tmpl = { |
238 | allow => { required => 1, default => [ ], strict_type => 1, |
239 | store => \$list }, |
240 | type => { required => 1, allow => [$class->accessors()], |
241 | store => \$type }, |
242 | }; |
243 | |
244 | check( $tmpl, \%hash ) or return; |
245 | |
246 | |
247 | ### we aliased 'module' to 'name', so change that here too |
248 | $type = 'module' if $type eq 'name'; |
249 | |
250 | my $res = $dbh->query( "SELECT * from $table" ); |
251 | |
252 | my $meth = $table .'_tree'; |
253 | my @rv = map { $self->$meth( $_->{$key} ) } |
254 | grep { allow( $_->{$type} => $list ) } $res->hashes; |
255 | |
256 | return @rv; |
257 | } |
258 | } |
259 | } |
260 | |
261 | |
262 | |
263 | sub __sqlite_create_db { |
264 | my $self = shift; |
265 | my $dbh = $self->__sqlite_dbh; |
266 | |
267 | ### we can ignore the result/error; not all sqlite implemantation |
268 | ### support this |
269 | $dbh->query( qq[ |
270 | DROP TABLE IF EXISTS author; |
271 | \n] |
272 | ) or do { |
273 | msg( $dbh->error ); |
274 | }; |
275 | $dbh->query( qq[ |
276 | DROP TABLE IF EXISTS module; |
277 | \n] |
278 | ) or do { |
279 | msg( $dbh->error ); |
280 | }; |
281 | |
282 | |
283 | |
284 | $dbh->query( qq[ |
285 | /* the author information */ |
286 | CREATE TABLE author ( |
287 | id INTEGER PRIMARY KEY AUTOINCREMENT, |
288 | |
289 | author varchar(255), |
290 | email varchar(255), |
291 | cpanid varchar(255) |
292 | ); |
293 | \n] |
294 | |
295 | ) or do { |
296 | error( $dbh->error ); |
297 | return; |
298 | }; |
299 | |
300 | $dbh->query( qq[ |
301 | /* the module information */ |
302 | CREATE TABLE module ( |
303 | id INTEGER PRIMARY KEY AUTOINCREMENT, |
304 | |
305 | module varchar(255), |
306 | version varchar(255), |
307 | path varchar(255), |
308 | comment varchar(255), |
309 | author varchar(255), |
310 | package varchar(255), |
311 | description varchar(255), |
312 | dslip varchar(255), |
313 | mtime varchar(255) |
314 | ); |
315 | |
316 | \n] |
317 | |
318 | ) or do { |
319 | error( $dbh->error ); |
320 | return; |
321 | }; |
322 | |
323 | return 1; |
324 | } |
325 | |
326 | 1; |