1package CPAN::SQLite::META; 2require CPAN::SQLite; 3use strict; 4use warnings; 5use base qw(Exporter); 6our @EXPORT_OK; 7@EXPORT_OK = qw(setup update); 8our $global_id; 9our $VERSION = '0.199'; 10 11sub new { 12 my ($class, $cpan_meta) = @_; 13 my $cpan_sqlite = CPAN::SQLite->new(); 14 bless {cpan_meta => $cpan_meta, cpan_sqlite => $cpan_sqlite}, $class; 15} 16 17sub set { 18 my ($self, $class, $id) = @_; 19 my $sqlite_obj = $self->make_obj(class => $class, id => $id); 20 return $sqlite_obj->set_one(); 21} 22 23sub search { 24 my ($self, $class, $regex) = @_; 25 my $sqlite_obj = $self->make_obj(class => $class, regex => $regex); 26 $sqlite_obj->set_many(); 27} 28 29sub make_obj { 30 my ($self, %args) = @_; 31 my $class = $args{class}; 32 die qq{Must supply a CPAN::* class string} 33 unless ($class and $class =~ /^CPAN::/); 34 (my $type = $class) =~ s/^CPAN//; 35 my $package = __PACKAGE__ . $type; 36 bless {cpan_meta => $self->{cpan_meta}, 37 cpan_sqlite => $self->{cpan_sqlite}, 38 class => $class, 39 id => $args{id}, regex => $args{regex}, 40 }, $package; 41} 42 43package CPAN::SQLite::META::Author; 44use base qw(CPAN::SQLite::META); 45use CPAN::SQLite::Util qw(has_hash_data); 46 47sub set_one { 48 my $self = shift; 49 my $cpan_sqlite = $self->{cpan_sqlite}; 50 my $id = $self->{id}; 51 my $class = $self->{class}; 52 $cpan_sqlite->{results} = {}; 53 $cpan_sqlite->query(mode => 'author', name => $id, meta_obj => $self); 54 my $cpan_meta = $self->{cpan_meta}; 55 $cpan_meta->{readonly}{$class}{$id}; 56} 57 58sub set_many { 59 my $self = shift; 60 my $cpan_sqlite = $self->{cpan_sqlite}; 61 my $regex = $self->{regex}; 62 $cpan_sqlite->{results} = []; 63 $cpan_sqlite->query(mode => 'author', query => $regex, meta_obj => $self); 64} 65 66sub set_data { 67 my ($self, $results) = @_; 68 $self->set_author($results->{cpanid}, $results); 69} 70 71package CPAN::SQLite::META::Distribution; 72use base qw(CPAN::SQLite::META); 73use CPAN::SQLite::Util qw(has_hash_data download); 74use CPAN::DistnameInfo; 75my $ext = qr{\.(tar\.gz|tar\.Z|tgz|zip)$}; 76 77sub set_one { 78 my $self = shift; 79 my $cpan_sqlite = $self->{cpan_sqlite}; 80 my $id = $self->{id}; 81 my ($dist_name, $dist_id); 82 if ($id =~ /$ext/) { 83 ($dist_name, $dist_id) = $self->extract_distinfo($id); 84 } 85 return unless ($dist_name and $dist_id); 86 my $class = $self->{class}; 87 $cpan_sqlite->{results} = {}; 88 $cpan_sqlite->query(mode => 'dist', name => $dist_name, meta_obj => $self); 89 my $cpan_meta = $self->{cpan_meta}; 90 $cpan_meta->{readonly}{$class}{$dist_id}; 91} 92 93sub set_many { 94 my $self = shift; 95 my $cpan_sqlite = $self->{cpan_sqlite}; 96 my $regex = $self->{regex}; 97 $cpan_sqlite->{results} = []; 98 $cpan_sqlite->query(mode => 'dist', query => $regex, meta_obj => $self); 99} 100 101sub set_data { 102 my ($self, $results) = @_; 103 $global_id = $results->{download}; 104 $self->set_dist($results->{download}, $results); 105} 106 107sub set_list_data { 108 my ($self, $results, $download) = @_; 109 $global_id = $download; 110 $self->set_containsmods($results); 111 $global_id = undef; 112} 113 114package CPAN::SQLite::META::Module; 115use base qw(CPAN::SQLite::META); 116use CPAN::SQLite::Util qw(has_hash_data); 117 118sub set_one { 119 my $self = shift; 120 my $cpan_sqlite = $self->{cpan_sqlite}; 121 my $id = $self->{id}; 122 return if ($id =~ /^Bundle::/); 123 my $class = $self->{class}; 124 $cpan_sqlite->{results} = {}; 125 $cpan_sqlite->query(mode => 'module', name => $id, meta_obj => $self); 126 my $cpan_meta = $self->{cpan_meta}; 127 $cpan_meta->{readonly}{$class}{$id}; 128} 129 130sub set_many { 131 my $self = shift; 132 my $cpan_sqlite = $self->{cpan_sqlite}; 133 my $regex = $self->{regex}; 134 $cpan_sqlite->{results} = []; 135 $cpan_sqlite->query(mode => 'module', query => $regex, meta_obj => $self); 136} 137 138sub set_data { 139 my ($self, $results) = @_; 140 $self->set_module($results->{mod_name}, $results); 141 $global_id = $results->{download}; 142 $self->set_dist($results->{download}, $results); 143} 144 145sub set_list_data { 146 my ($self, $results, $download) = @_; 147 $global_id = $download; 148 $self->set_containsmods($results); 149 $global_id = undef; 150} 151 152package CPAN::SQLite::META::Bundle; 153use base qw(CPAN::SQLite::META); 154use CPAN::SQLite::Util qw(has_hash_data); 155 156sub set_one { 157 my $self = shift; 158 my $cpan_sqlite = $self->{cpan_sqlite}; 159 my $id = $self->{id}; 160 unless ($id =~ /^Bundle::/) { 161 $id = 'Bundle::' . $id; 162 } 163 my $class = $self->{class}; 164 $cpan_sqlite->{results} = {}; 165 $cpan_sqlite->query(mode => 'module', name => $id, meta_obj => $self); 166 my $cpan_meta = $self->{cpan_meta}; 167 $cpan_meta->{readonly}{$class}{$id}; 168} 169 170sub set_many { 171 my $self = shift; 172 my $cpan_sqlite = $self->{cpan_sqlite}; 173 my $regex = $self->{regex}; 174 unless ($regex =~ /(^Bundle::|[\^\$\*\+\?\|])/i) { 175 $regex = '^Bundle::' . $regex; 176 } 177 $regex = '^Bundle::' if $regex eq '^'; 178 $cpan_sqlite->{results} = []; 179 $cpan_sqlite->query(mode => 'module', query => $regex, meta_obj => $self); 180} 181 182sub set_data { 183 my ($self, $results) = @_; 184 $self->set_bundle($results->{mod_name}, $results); 185 $global_id = $results->{download}; 186 $self->set_dist($results->{download}, $results); 187} 188 189sub set_list_data { 190 my ($self, $results, $download) = @_; 191 $global_id = $download; 192 $self->set_containsmods($results); 193 $global_id = undef; 194} 195 196package CPAN::SQLite::META; 197use CPAN::SQLite::Util qw(download); 198 199my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); 200my @days = qw(Sun Mon Tue Wed Thu Fri Sat); 201 202sub set_author { 203 my ($self, $id, $results) = @_; 204 my $class = 'CPAN::Author'; 205 my $cpan_meta = $self->{cpan_meta}; 206 $cpan_meta->instance( 207 $class => $id 208 )->set( 209 'FULLNAME' => $results->{fullname}, 210 'EMAIL' => $results->{email}, 211 ); 212} 213 214sub set_module { 215 my ($self, $id, $results) = @_; 216 my $class = 'CPAN::Module'; 217 my $cpan_meta = $self->{cpan_meta}; 218 my %dslip; 219 if (my $dslip = $results->{dslip}) { 220 my @values = split '', $dslip; 221 for (qw(d s l i p)) { 222 $dslip{'stat' . $_} = shift @values; 223 } 224 } 225 my $d = $cpan_meta->instance( 226 $class => $id 227 ); 228 $d->set( 229 'description' => $results->{mod_abs}, 230 'userid' => $results->{cpanid}, 231 'CPAN_VERSION' => $results->{mod_vers}, 232 'CPAN_FILE' => $results->{download}, 233 'CPAN_USERID' => $results->{cpanid}, 234 'chapterid' => $results->{chapterid}, 235 %dslip, 236 ); 237} 238 239sub set_bundle { 240 my ($self, $id, $results) = @_; 241 my $class = 'CPAN::Bundle'; 242 my $cpan_meta = $self->{cpan_meta}; 243 my %dslip; 244 if (my $dslip = $results->{dslip}) { 245 my @values = split '', $dslip; 246 for (qw(d s l i p)) { 247 $dslip{'stat' . $_} = shift @values; 248 } 249 } 250 my $d = $cpan_meta->instance( 251 $class => $id 252 ); 253 $d->set( 254 'description' => $results->{mod_abs}, 255 'userid' => $results->{cpanid}, 256 'CPAN_VERSION' => $results->{mod_vers}, 257 'CPAN_FILE' => $results->{download}, 258 'CPAN_USERID' => $results->{cpanid}, 259 'chapterid' => $results->{chapterid}, 260 %dslip, 261 ); 262} 263 264sub set_dist { 265 my ($self, $id, $results) = @_; 266 my $class = 'CPAN::Distribution'; 267 my $cpan_meta = $self->{cpan_meta}; 268 my $d = $cpan_meta->instance( 269 $class => $id 270 ); 271 $d->set( 272 'DESCRIPTION' => $results->{dist_abs}, 273 'CPAN_USERID' => $results->{cpanid}, 274 'CPAN_VERSION' => $results->{dist_vers}, 275 ); 276} 277 278sub set_containsmods { 279 my ($self, $mods) = @_; 280 my $class = 'CPAN::Distribution'; 281 my $cpan_meta = $self->{cpan_meta}; 282 my %containsmods; 283 if ($mods and (ref($mods) eq 'ARRAY')) { 284 %containsmods = map {$_->{mod_name} => 1} @$mods; 285 } 286 my $d = $cpan_meta->instance( 287 $class => $global_id 288 ); 289 $d->{CONTAINSMODS} = \%containsmods; 290} 291 292sub reload { 293 my($self, %args) = @_; 294 my $time = $args{'time'} || time; 295 my $force = $args{force}; 296 my $db_name = $CPAN::SQLite::db_name; 297 my $db = File::Spec->catfile($CPAN::Config->{cpan_home}, $db_name); 298 my $journal_file = $db . '-journal'; 299 if (-e $journal_file) { 300 warn qq{Database locked - cannot update.}; 301 return; 302 } 303 my @args = ($^X, '-MCPAN::SQLite::META=setup,update', '-e'); 304 if (-e $db && -s _) { 305 my $mtime_db = (stat(_))[9]; 306 my $time_string = gmtime_string($mtime_db); 307 warn "Database was generated on $time_string\n"; 308 unless ($force) { 309 return if (($time - $mtime_db) < $CPAN::Config->{index_expire}*86400); 310 } 311 warn "Updating database file ...\n"; 312 push @args, q{update}; 313 } 314 else { 315 unlink($db) if -e _; 316 warn "Creating database file ...\n"; 317 push @args, q{setup}; 318 } 319 if ($CPAN::SQLite::DBI::dbh) { 320 $CPAN::SQLite::DBI::dbh->disconnect(); 321 $CPAN::SQLite::DBI::dbh = undef; 322 } 323 system(@args) == 0 or die qq{system @args failed: $?}; 324 warn "Done!\n"; 325} 326 327sub setup { 328 my $obj = CPAN::SQLite->new(setup => 1); 329 $obj->index() or die qq{CPAN::SQLite setup failed}; 330} 331 332sub update { 333 my $obj = CPAN::SQLite->new(); 334 $obj->index() or die qq{CPAN::SQLite update failed}; 335} 336 337sub gmtime_string { 338 my $time = shift; 339 return unless $time; 340 my @a = gmtime($time); 341 my $string = sprintf("%s, %02d %s %d %02d:%02d:%02d GMT", 342 $days[$a[6]], $a[3], $months[$a[4]], 343 $a[5] + 1900, $a[2], $a[1], $a[0]); 344 return $string; 345} 346 347sub extract_distinfo { 348 my ($self, $pathname) = @_; 349 unless ($pathname =~ m{^\w/\w\w/}) { 350 $pathname =~ s{^(\w)(\w)(.*)}{$1/$1$2/$1$2$3}; 351 } 352 my $d = CPAN::DistnameInfo->new($pathname); 353 my $dist = $d->dist; 354 my $download = download($d->cpanid, $d->filename); 355 return ($dist and $download) ? ($dist, $download) : undef; 356} 357 3581; 359 360__END__ 361 362=head1 NAME 363 364CPAN::SQLite::META - helper module for CPAN.pm integration 365 366=head1 DESCRIPTION 367 368This module has no direct public interface, but is intended 369as a helper module for use of CPAN::SQLite within the CPAN.pm 370module. A new object is created as 371 372 my $obj = CPAN::SQLite::META->new($CPAN::META); 373 374where C<$CPAN::META> comes from CPAN.pm. There are then 375two main methods available. 376 377=over 4 378 379=item C<set> 380 381This is used as 382 383 $obj->set($class, $id); 384 385where C<$class> is one of C<CPAN::Author>, C<CPAN::Module>, or 386C<CPAN::Distribution>, and C<$id> is the id CPAN.pm uses to 387identify the class. The method searches the C<CPAN::SQLite> 388database by name using the appropriate C<author>, C<dist>, 389or C<module> mode, and if a result is found, calls 390 391 $CPAN::META->instance( 392 $class => $id 393 )->set( 394 %attributes 395 ); 396 397to register an instance of this class within C<CPAN.pm>. 398 399=item C<ssearch> 400 401This is used as 402 403 $obj->search($class, $id); 404 405where C<$class> is one of C<CPAN::Author>, C<CPAN::Module>, or 406C<CPAN::Distribution>, and C<$id> is the id CPAN.pm uses to 407identify the class. The method searches the C<CPAN::SQLite> 408database by C<query> using the appropriate C<author>, C<dist>, 409or C<module> mode, and if results are found, calls 410 411 $CPAN::META->instance( 412 $class => $id 413 )->set( 414 %attributes 415 ); 416 417for each match to register an instance of this class 418within C<CPAN.pm>. 419 420=back 421 422The attributes set within C<$CPAN::META->instance> depend 423on the particular class. 424 425=over 426 427=item author 428 429The attributes are 430 431 'FULLNAME' => $results->{fullname}, 432 'EMAIL' => $results->{email}, 433 434where C<$results> are the results returned from C<CPAN::SQLite>. 435 436=item module 437 438The attributes are 439 440 'description' => $results->{mod_abs}, 441 'userid' => $results->{cpanid}, 442 'CPAN_VERSION' => $results->{mod_vers}, 443 'CPAN_FILE' => $results->{download}, 444 'CPAN_USERID' => $results->{cpanid}, 445 'chapterid' => $results->{chapterid}, 446 %dslip, 447 448where C<$results> are the results returned from C<CPAN::SQLite>. 449Here, C<%dslip> is a hash containing keys C<statd>, C<stats>, 450C<statl>, C<stati>, and C<statp>, with corresponding values 451being the registered dslip entries for the module, if present. 452 453=item dist 454 455The attributes are 456 457 'DESCRIPTION' => $results->{dist_abs}, 458 'CPAN_USERID' => $results->{cpanid}, 459 'CPAN_VERSION' => $results->{dist_vers}, 460 461As well, a C<CONTAINSMODS> key to C<$CPAN::META> is added, this 462being a hash reference whose keys are the modules contained 463within the distribution. 464 465=back 466 467There is also a method available C<reload>, which rebuilds 468the database. It can be used as 469 470 $obj->reload(force => 1, time => $time); 471 472The C<time> option (which, if not passed in, will default to the 473current time) will be used to compare the current time to 474the mtime of the database file; if they differ by more than 475one day, the database will be rebuilt. The <force> option, if 476given, will force a rebuilding of the database regardless 477of the time difference. 478 479=cut 480 481