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 => 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;