lib/Packaging/Tools/Plugin/Role/Cache.pm

   1 package Packaging::Tools::Plugin::Role::Cache;
   2
   3 use 5.014;
   4
   5 use strict;
   6 use warnings;
   7
   8 =head1 NAME
   9
  10 Packaging::Tools::Plugin::Role::Cache - role allows caching expensive data of Packaging::Tools::Plugin
  11
  12 =cut
  13
  14 use Carp qw/carp croak/;
  15
  16 our $VERSION = '0.001';
  17
  18 require File::Basename;
  19 require File::Spec;
  20
  21 use DBI;
  22 require DBD::SQLite;
  23 use File::ConfigDir qw(config_dirs);    # File::DataDir
  24 require File::Find::Rule;
  25 use File::Path qw(make_path);
  26
  27 use Moo::Role;
  28 use namespace::clean;
  29
  30 has '_dbh' => (
  31                 is       => 'rw',
  32                 isa      => 'DBI::db',
  33                 isa      => sub { $_[0]->isa("DBI::db") or die "$_[0] is not a DBI::db!"; },
  34                 clearer  => '_disco',
  35                 builder  => '_open_cache',
  36                 init_arg => undef
  37               );
  38 has '_last_scan' => (
  39                       is       => 'rw',
  40                       builder  => '_fetch_last_scan',
  41                       trigger  => sub { $_[0]->_persist_last_scan( $_[1] ) },
  42                       init_arg => undef
  43                     );
  44
  45 requires '_column_defs';
  46 requires '_find_packaged_modules';
  47 requires 'find_packaged_modules';
  48 requires 'find_package';
  49
  50 # not multi-process/thread safe ...
  51 sub _create_cache
  52 {
  53     my ( $self, $basedir ) = @_;
  54     my $db_name;
  55
  56     ( my $cache_basename = ref($self) ) =~ s/.*::([^:]+)$/$1/;
  57     if ($basedir)
  58     {
  59         $db_name = File::Spec->catfile( $basedir, "$cache_basename.db" );
  60     }
  61     else
  62     {
  63         my @config_dirs = config_dirs("Packaging-Tools");    # File::DataDir
  64         if ( 0 == scalar(@config_dirs) )
  65         {
  66             @config_dirs = config_dirs();                    # File::DataDir
  67             foreach my $cfg_dir (@config_dirs)
  68             {
  69                 -w $cfg_dir or next;
  70                 my $pt_cfg_dir = File::Spec->catdir( $cfg_dir, "Packaging-Tools" );
  71                 make_path( $pt_cfg_dir, { mode => 0755, } );
  72                 $db_name = File::Spec->catfile( $pt_cfg_dir, "$cache_basename.db" );
  73                 last;
  74             }
  75         }
  76
  77         if ( !$db_name )
  78         {
  79             foreach my $cfg_dir (@config_dirs)
  80             {
  81                 -w $cfg_dir or next;
  82                 $db_name = File::Spec->catfile( $cfg_dir, "$cache_basename.db" );
  83                 last;
  84             }
  85         }
  86     }
  87
  88     my $dbh = DBI->connect( "dbi:SQLite:dbname=$db_name", "", "" );
  89
  90     my $mkpkgtbl = <<EOT;
  91 CREATE TABLE IF NOT EXISTS DIST_PKGS (
  92     PKG_IDENT VARCHAR(256) PRIMARY KEY,
  93     DIST_NAME VARCHAR(32),
  94     DIST_VERSION VARCHAR(16),
  95     DIST_FILE VARCHAR(64),
  96     PKG_NAME VARCHAR(32),
  97     PKG_VERSION VARCHAR(16),
  98     PKG_MAINTAINER VARCHAR(64),
  99     PKG_INSTALLED BOOLEAN,
 100     PKG_LOCATION VARCHAR(128),
 101     PKG_HOMEPAGE VARCHAR(256),
 102     PKG_LICENSE VARCHAR(64),
 103     PKG_MASTER_SITES TEXT
 104 );
 105 EOT
 106
 107     my $sth = $dbh->prepare($mkpkgtbl);
 108     $sth->execute();
 109     $sth->finish();
 110
 111     my $mklasttbl = <<EOT;
 112 CREATE TABLE IF NOT EXISTS LAST_SCAN (
 113     LAST_SCAN BIGINT
 114 );
 115 EOT
 116
 117     $sth = $dbh->prepare($mklasttbl);
 118     $sth->execute();
 119     $sth->finish();
 120
 121     return $dbh;
 122 }
 123
 124 sub _open_cache
 125 {
 126     my ( $self, $basedir ) = @_;
 127
 128     ( my $cache_basename = ref($self) ) =~ s/.*::([^:]+)$/$1/;
 129
 130     my @search_dirs = $basedir ? ($basedir) : config_dirs("Packaging-Tools");    # File::DataDir
 131     scalar(@search_dirs) == 0 and return $self->_create_cache($basedir);
 132     my @cache_files =
 133       File::Find::Rule->name( $cache_basename . ".db" )->maxdepth(1)->in(@search_dirs);
 134     scalar(@cache_files) > 1
 135       and croak( "More than one cache file found: " . join( ", ", @cache_files ) );
 136     scalar(@cache_files) == 0 and return $self->_create_cache($basedir);
 137
 138     my $dbh = DBI->connect( "dbi:SQLite:dbname=" . $cache_files[0], "", "" );
 139
 140     return $dbh;
 141 }
 142
 143 sub _update_cache
 144 {
 145     my ( $self, %data ) = @_;
 146
 147     my @colnames = @{ $self->_column_defs() };
 148
 149     my $dbh     = $self->_dbh;
 150     my @coldata = @data{@colnames};
 151     my $sql     = sprintf( "INSERT OR IGNORE INTO DIST_PKGS (%s) VALUES (%s)",
 152                        join( ", ", @colnames ), join( ", ", map { $dbh->quote($_) } @coldata ) );
 153     my $sth;
 154
 155     $sth = $dbh->prepare($sql);
 156     if ( !$sth->execute() )    # should be 1
 157     {
 158         my $pk = shift @colnames;
 159         $sql =
 160             "UPDATE OR IGNORE DIST_PKGS SET "
 161           . join( ", ", map { "$_=" . $dbh->quote( $data{$_} ) } @colnames )
 162           . " WHERE $pk="
 163           . $dbh->quote( $data{$pk} );
 164         $sth = $dbh->prepare($sql);
 165         $sth->execute() or croak( $dbh->errstr() );
 166     }
 167
 168     return;
 169 }
 170
 171 sub _fetch_last_scan
 172 {
 173     my $self = shift;
 174
 175     $self->_dbh or $self->_open_cache();
 176
 177     my $dbh           = $self->_dbh;
 178     my $sql           = "SELECT LAST_SCAN FROM LAST_SCAN";
 179     my @last_scan_row = $dbh->selectrow_array($sql);
 180     @last_scan_row and return $last_scan_row[0];
 181
 182     return 0;    # must be epoch
 183 }
 184
 185 sub _persist_last_scan
 186 {
 187     my ( $self, $new_last_scan ) = @_;
 188     my $dbh = $self->_dbh;
 189     my $sql = "delete from LAST_SCAN";
 190     $dbh->do($sql) or warn $dbh->errstr();
 191     $sql = "insert into LAST_SCAN (LAST_SCAN) values ($new_last_scan)";
 192     $dbh->do($sql) or warn $dbh->errstr();
 193     return;
 194 }
 195
 196 around 'find_packaged_modules' => sub {
 197     my $orig = shift;
 198     my $self = shift;
 199
 200     $self->_dbh or $self->_open_cache();
 201
 202     my $dbh           = $self->_dbh;
 203     my $sql           = "SELECT LAST_SCAN FROM LAST_SCAN";
 204     my @last_scan_row = $dbh->selectrow_array($sql);
 205
 206     my $last_scan = $self->_last_scan;
 207     $self->_last_scan( time() );
 208     my %pkg_idents = %{ $self->_find_packaged_modules($last_scan) };
 209
 210     local $dbh->{FetchHashKeyName} = 'NAME_uc';
 211     $sql = "SELECT * FROM DIST_PKGS";
 212     my $sth         = $dbh->prepare($sql);
 213     my $rows        = $sth->execute() or croak( $dbh->errstr() );
 214     my $pkg_details = $sth->fetchall_hashref( $self->_column_defs()->[0] );
 215     delete @{$pkg_details}{ keys %pkg_idents };
 216
 217     # update refreshed info ...
 218     foreach my $pkg_id ( keys %pkg_idents )
 219     {
 220         $self->_update_cache( PKG_IDENT => $pkg_id,
 221                               %{ $pkg_idents{$pkg_id} } );
 222     }
 223
 224     %pkg_idents = ( %{$pkg_details}, %pkg_idents );
 225
 226     return \%pkg_idents;
 227 };
 228
 229 around 'find_package' => sub {
 230     my $orig  = shift;
 231     my $self  = shift;
 232     my %match = @_;
 233
 234     $self->_dbh or $self->_open_cache();
 235
 236     scalar( keys %match ) > 0 or croak("find_package( key => value )");
 237
 238     my $dbh = $self->_dbh;
 239     my $sql = sprintf( "SELECT DISTINCT %s FROM DIST_PKGS WHERE %s",
 240                        $self->_column_defs()->[0],
 241                        join( " AND ", map { $_ . "=" . $dbh->quote( $match{$_} ) } keys %match ) );
 242     my @found = $dbh->selectrow_array($sql);
 243     1 == scalar(@found) and return $found[0];
 244     return;
 245 };
 246
 247 around get_pkg_details => sub {
 248     my $orig = shift;
 249     my $self = shift;
 250
 251     $self->_dbh or $self->_open_cache();
 252
 253     my ( $pkg_ident, @var_names ) = @_;
 254
 255     return @{ $self->packaged_modules()->{$pkg_ident} }{@var_names};
 256 };
 257
 258 no Moo::Role;
 259
 260 1;