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 require 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                 clearer  => '_disco',
  34                 builder  => '_open_cache',
  35                 init_arg => undef
  36               );
  37 has '_last_scan' => (
  38                 is       => 'rw',
  39                 isa      => 'Int',
  40                 init_arg => undef
  41 );
  42
  43 requires '_column_defs';
  44 requires '_find_packaged_modules';
  45 requires 'find_packaged_modules';
  46 requires 'find_package';
  47
  48 # not multi-process/thread safe ...
  49 sub _create_cache
  50 {
  51     my ( $self, $basedir ) = @_;
  52     my $db_name;
  53
  54     ( my $cache_basename = ref($self) ) =~ s/.*::([^:]+)$/$1/;
  55     if ($basedir)
  56     {
  57         $db_name = File::Spec->catfile( $basedir, "$cache_basename.db" );
  58     }
  59     else
  60     {
  61         my @config_dirs = config_dirs("Packaging-Tools");    # File::DataDir
  62         if ( 0 == scalar(@config_dirs) )
  63         {
  64             @config_dirs = config_dirs();                    # File::DataDir
  65             foreach my $cfg_dir (@config_dirs)
  66             {
  67                 -w $cfg_dir or next;
  68                 my $pt_cfg_dir = File::Spec->catdir( $cfg_dir, "Packaging-Tools" );
  69                 make_path( $pt_cfg_dir, { mode => 0755, } );
  70                 $db_name = File::Spec->catfile( $pt_cfg_dir, "$cache_basename.db" );
  71                 last;
  72             }
  73         }
  74
  75         if ( !$db_name )
  76         {
  77             foreach my $cfg_dir (@config_dirs)
  78             {
  79                 -w $cfg_dir or next;
  80                 $db_name = File::Spec->catfile( $cfg_dir, "$cache_basename.db" );
  81                 last;
  82             }
  83         }
  84     }
  85
  86     my $dbh = DBI->connect( "dbi:SQLite:dbname=$db_name", "", "" );
  87
  88     my $mkpkgtbl = <<EOT;
  89 CREATE TABLE IF NOT EXISTS DIST_PKGS (
  90     PKG_IDENT VARCHAR(256) PRIMARY KEY,
  91     DIST_NAME VARCHAR(32),
  92     DIST_VERSION VARCHAR(16),
  93     DIST_FILE VARCHAR(64),
  94     PKG_NAME VARCHAR(32),
  95     PKG_VERSION VARCHAR(16),
  96     PKG_MAINTAINER VARCHAR(64),
  97     PKG_INSTALLED BOOLEAN,
  98     PKG_LOCATION VARCHAR(128),
  99     PKG_HOMEPAGE VARCHAR(256),
 100     PKG_LICENSE VARCHAR(64),
 101     PKG_MASTER_SITES TEXT
 102 );
 103 EOT
 104
 105     my $sth = $dbh->prepare($mkpkgtbl);
 106     $sth->execute();
 107     $sth->finish();
 108
 109     my $mklasttbl = <<EOT;
 110 CREATE TABLE IF NOT EXISTS LAST_SCAN (
 111     LAST_SCAN BIGINT
 112 );
 113 EOT
 114
 115     $sth = $dbh->prepare($mklasttbl);
 116     $sth->execute();
 117     $sth->finish();
 118
 119     return $dbh;
 120 }
 121
 122 sub _open_cache
 123 {
 124     my ( $self, $basedir ) = @_;
 125
 126     ( my $cache_basename = ref($self) ) =~ s/.*::([^:]+)$/$1/;
 127
 128     my @search_dirs = $basedir ? ($basedir) : config_dirs("Packaging-Tools");    # File::DataDir
 129     scalar(@search_dirs) == 0 and return $self->_create_cache($basedir);
 130     my @cache_files =
 131       File::Find::Rule->name( $cache_basename . ".db" )->maxdepth(1)->in(@search_dirs);
 132     scalar(@cache_files) > 1
 133       and croak( "More than one cache file found: " . join( ", ", @cache_files ) );
 134     scalar(@cache_files) == 0 and return $self->_create_cache($basedir);
 135
 136     my $dbh = DBI->connect( "dbi:SQLite:dbname=" . $cache_files[0], "", "" );
 137
 138     return $dbh;
 139 }
 140
 141 sub _update_cache
 142 {
 143     my ( $self, %data ) = @_;
 144
 145     my @colnames = @{ $self->_column_defs() };
 146
 147     my $dbh     = $self->_dbh;
 148     my @coldata = @data{@colnames};
 149     my $sql     = sprintf( "INSERT OR IGNORE INTO DIST_PKGS (%s) VALUES (%s)",
 150                        join( ", ", @colnames ), join( ", ", map { $dbh->quote($_) } @coldata ) );
 151     my $sth;
 152
 153     $sth = $dbh->prepare($sql);
 154     if ( !$sth->execute() )    # should be 1
 155     {
 156         my $pk = shift @colnames;
 157         $sql =
 158             "UPDATE OR IGNORE DIST_PKGS SET "
 159           . join( ", ", map { "$_=" . $dbh->quote( $data{$_} ) } @colnames )
 160           . " WHERE $pk="
 161           . $dbh->quote( $data{$pk} );
 162         $sth = $dbh->prepare($sql);
 163         $sth->execute() or croak( $dbh->errstr() );
 164     }
 165
 166     return;
 167 }
 168
 169 around 'find_packaged_modules' => sub {
 170     my $orig = shift;
 171     my $self = shift;
 172
 173     $self->_dbh or $self->_open_cache();
 174
 175     my $dbh           = $self->_dbh;
 176     my $sql           = "SELECT LAST_SCAN FROM LAST_SCAN";
 177     my @last_scan_row = $dbh->selectrow_array($sql);
 178
 179     my $last_scan;
 180     @last_scan_row and $last_scan = $last_scan_row[0];
 181     $self->_last_scan( time() );
 182     %pkg_idents = $self->_find_packaged_modules($last_scan);
 183
 184     local $dbh->{FetchHashKeyName} = 'NAME_uc';
 185     $sql = "SELECT * FROM DIST_PKGS";
 186     my $sth         = $dbh->prepare($sql);
 187     my $rows        = $sth->execute() or croak( $dbh->errstr() );
 188     my $pkg_details = $sth->fetchall_hashref( $self->_column_defs()->[0] );
 189     delete @{$pkg_details}{ keys %pkg_idents };
 190
 191     $self->_cache->{stale_pkg_idents} = {%pkg_idents};
 192     %pkg_idents = ( %{$pkg_details}, %pkg_idents );
 193
 194     return %pkg_idents;
 195 };
 196
 197 around 'find_package' => sub {
 198 };
 199
 200 no Moo::Role;
 201
 202 1;