File Coverage

lib/DB/Object/Cache/Tables.pm
Criterion Covered Total %
statement 31 123 25.2
branch 0 46 0.0
condition 0 35 0.0
subroutine 11 21 52.3
pod 10 10 100.0
total 52 235 22.1


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             ##----------------------------------------------------------------------------
3             ## Database Object Interface - ~/lib/DB/Object/Cache/Tables.pm
4             ## Version v0.100.3
5             ## Copyright(c) 2020 DEGUEST Pte. Ltd.
6             ## Author: Jacques Deguest <jack@deguest.jp>
7             ## Created 2017/07/19
8             ## Modified 2021/09/04
9             ## All rights reserved
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             package DB::Object::Cache::Tables;
15             BEGIN
16             {
17 3     3   27 use strict;
  3         17  
  3         183  
18 3     3   35 use warnings;
  3         7  
  3         109  
19 3     3   18 use parent qw( Module::Generic );
  3         7  
  3         36  
20 3     3   245 use vars qw( $VERSION );
  3         5  
  3         155  
21 3     3   2139 use JSON;
  3         29429  
  3         15  
22 3     3   487 use Fcntl qw( :flock );
  3         9  
  3         404  
23 3     3   4030 use Module::Generic::File qw( sys_tmpdir );
  3         33579163  
  3         52  
24 3     3   2659 use Devel::Confess;
  3         15152  
  3         28  
25 3     3   330 our $VERSION = 'v0.100.3';
26             };
27              
28 3     3   34 use strict;
  3         19  
  3         97  
29 3     3   13 use warnings;
  3         7  
  3         3624  
30              
31             sub init
32             {
33 0     0 1   my $self = shift( @_ );
34 0           $self->{cache} = {};
35 0           $self->{cache_dir} = sys_tmpdir();
36 0           $self->{cache_file} = "$self->{cache_dir}/sql_tables.json";
37 0           $self->{timeout} = 86400;
38 0           $self->SUPER::init( @_ );
39 0           $self->{updated} = '';
40 0 0         $self->cache_dir( $self->{cache_dir} ) if( $self->{cache_dir} );
41 0 0         $self->cache_file( $self->{cache_file} ) if( $self->{cache_file} );
42 0           return( $self );
43             }
44              
45 0     0 1   sub cache { return( shift->_set_get_hash( 'cache', @_ ) ); }
46              
47             sub cache_dir
48             {
49 0     0 1   my $self = shift( @_ );
50 0 0         if( @_ )
51             {
52 0           my $v = shift( @_ );
53 0           $self->{cache_dir} = $v;
54 0           $self->cache_file( "$v/sql_tables.json" );
55             }
56 0           return( $self->{cache_dir} );
57             }
58              
59             sub cache_file
60             {
61 0     0 1   my $self = shift( @_ );
62 0 0         if( @_ )
63             {
64 0   0       my $f = shift( @_ ) || return( $self->error( "No tables cache file path was provided." ) );
65             ## No change
66 0 0         return( $f ) if( $f eq $self->{cache_file} );
67 0 0         if( -e( $f ) )
68             {
69 0           my $mtime = ( stat( $f ) )[9];
70 0           $self->updated( $mtime );
71 0   0       my $hash = $self->read( $f ) || return;
72 0           $self->cache( $hash );
73             }
74 0           $self->{cache_file} = $f;
75             }
76 0           return( $self->{cache_file} );
77             }
78              
79             sub get
80             {
81 0     0 1   my $self = shift( @_ );
82 0           my $opts = {};
83 0 0 0       $opts = shift( @_ ) if( @_ && $self->_is_hash( $_[0] ) );
84 0           foreach my $k ( qw( host port driver ) )
85             {
86 0 0         return( $self->error( "Parameter \"$k\" is missing." ) ) if( !length( $opts->{ $k } ) );
87             }
88 0           my $cache = $self->cache;
89 0           my $timeout = $self->timeout;
90 0           my $part = {};
91 0 0         return( [] ) if( !exists( $cache->{ $opts->{host} }->{ $opts->{driver} }->{ $opts->{port} }->{ $opts->{database} }->{tables} ) );
92 0           $part = $cache->{ $opts->{host} }->{ $opts->{driver} }->{ $opts->{port} }->{ $opts->{database} };
93 0           my $ts = $part->{timestamp};
94 0 0 0       return( $part->{tables} ) if( $opts->{ignore_ttl} || ( $ts && ( time() - $ts < $timeout ) ) );
      0        
95 0           return( [] );
96             }
97              
98             sub read
99             {
100 0     0 1   my $self = shift( @_ );
101 0   0       my $tables_cache_file = shift( @_ ) || $self->cache_file || return( {} );
102 0           $tables_cache_file = $self->new_file( $tables_cache_file );
103 0           my $hash = {};
104 0           my $j = JSON->new->relaxed;
105 0 0 0       if( $tables_cache_file->exists && !$tables_cache_file->is_empty )
106             {
107 0 0         if( my $fh = $tables_cache_file->open_utf8 )
108             {
109 0           $fh->autoflush(1);
110             # my $data = join( '', $fh->getlines );
111             # $fh->close;
112 0           my $data = $tables_cache_file->load;
113             eval
114 0           {
115 0           $hash = $j->decode( $data );
116             };
117 0 0         if( $@ )
118             {
119 0           warn( "An error occured while decoding json data from the table cache file: $@\n" );
120             }
121             }
122             else
123             {
124 0           warn( "Warning only: cannot read the tables cache file \"$tables_cache_file\".\n" );
125             }
126             }
127 0           return( $hash );
128             }
129              
130             sub set
131             {
132 0     0 1   my $self = shift( @_ );
133 0   0       my $hash = shift( @_ ) || return( $self->error( "No hash reference was provided to add to tables cache." ) );
134 0 0         return( $self->error( "Hash reference provided for tables cache ($hash) is not a hash reference." ) ) if( !$self->_is_hash( $hash ) );
135 0           foreach my $k ( qw( host port driver tables ) )
136             {
137 0 0         return( $self->error( "Tables cache provided is missing the \"$k\" key." ) ) if( !length( $hash->{ $k } ) );
138             }
139 0 0         return( $self->error( "\"tables\" property in cache data is not an array reference." ) ) if( !$self->_is_array( $hash->{tables} ) );
140             ## Possibly reload the cache if the modification date changed
141 0           my $cache = $self->cache;
142 0           my $f = $self->cache_file;
143 0           my $last_update = $self->updated;
144 0 0 0       if( -s( $f ) && $last_update && ( stat( $f ) )[9] != $last_update )
      0        
145             {
146 0   0       $cache = $self->read( $f ) || return;
147             }
148 0 0         $cache->{ $hash->{host} }->{ $hash->{driver} }->{ $hash->{port} }->{ $hash->{database} } = {} if( ref( $cache->{ $hash->{host} }->{ $hash->{driver} }->{ $hash->{port} }->{ $hash->{database} } ) ne 'HASH' );
149 0           $cache->{ $hash->{host} }->{ $hash->{driver} }->{ $hash->{port} }->{ $hash->{database} }->{tables} = $hash->{tables};
150 0           $cache->{ $hash->{host} }->{ $hash->{driver} }->{ $hash->{port} }->{ $hash->{database} }->{timestamp} = time();
151 0 0         if( !defined( $self->write( $cache ) ) )
152             {
153 0           return;
154             }
155 0           return( $self );
156             }
157              
158 0     0 1   sub timeout { return( shift->_set_get_number( 'timeout', @_ ) ); }
159              
160 0     0 1   sub updated { return( shift->_set_get_number( 'updated', @_ ) ); }
161              
162             sub write
163             {
164 0     0 1   my $self = shift( @_ );
165 0   0       my $hash = shift( @_ ) || return( $self->error( "No table cache data was provided to write to cache file \"", $self->cache_file, "\"." ) );
166 0   0       my $tables_cache_file = shift( @_ ) || $self->cache_file || return( $self->error( "No cache file was set to write data to it." ) );
167 0           $tables_cache_file = $self->new_file( $tables_cache_file );
168 0 0         return( $self->error( "Tables cache data provided is not an hash reference." ) ) if( ref( $hash ) ne 'HASH' );
169 0           my $j = JSON->new->allow_nonref;
170 0 0 0       if( my $fh = $tables_cache_file->open_utf8( '>' ) )
    0          
171             {
172 0           $fh->autoflush(1);
173             eval
174 0           {
175 0           $tables_cache_file->lock( LOCK_SH );
176             };
177 0 0         $fh->print( $j->encode( $hash ) ) || return( $self->error( "Unable to write data to tables cache file \"$tables_cache_file\": $!" ) );
178             eval
179 0           {
180 0           $tables_cache_file->unlock;
181             };
182 0           $self->updated( $tables_cache_file->finfo->mtime );
183 0           return( -s( $tables_cache_file ) );
184             }
185             elsif( -e( $tables_cache_file ) && !-w( $tables_cache_file ) )
186             {
187 0           return( $self->error( "Table cache file \"$tables_cache_file\" does not have write permission: $!" ) );
188             }
189             else
190             {
191 0           return( $self->error( "Although table cache file \"$tables_cache_file\" is writable, I am unable to write to it: $!" ) );
192             }
193             }
194              
195             1;
196             # NOTE: POD
197             __END__
198              
199             =encoding utf-8
200              
201             =head1 NAME
202              
203             DB::Object::Cache::Tables - Table Cache
204              
205             =head1 SYNOPSIS
206              
207             my $cache = DB::Object::Cache::Tables->new({
208             timeout => 86400,
209             # This is automatically set
210             # cache_file => '/some/dir/sql_tables.json',
211             });
212             $dbh->cache_tables( $cache_tables );
213             $tables = $dbh->tables_info;
214             my $cache =
215             {
216             host => $host,
217             driver => $driver,
218             port => $port,
219             database => $database,
220             tables => $tables,
221             };
222             if( !defined( $cache->set( $cache ) ) )
223             {
224             warn( "Unable to write to tables cache: ", $cache->error, "\n" );
225             }
226            
227             # Returning an array reference of tables hash reference definition
228             $all = $cache_tables->get({
229             host => $self->host,
230             driver => $self->driver,
231             port => $self->port,
232             database => $db,
233             }) || do
234            
235             =head1 VERSION
236              
237             v0.100.3
238              
239             =head1 DESCRIPTION
240              
241             This is a simple given to maintain a cache of database tables in a session. When a connection object is created, it will issue a query to get the list of all tables and views in the database and pass it to L<DB::Object::Cache::Tables>, and save its object. It is then used later several times such as when instantiating table objects.
242              
243             =head1 METHODS
244              
245             =head2 init
246              
247             Possible parameters:
248              
249             =over 4
250              
251             =item I<cache_dir>
252              
253             An absolute path to a directory that will contain the json cache file. Beware that if you run your script from the web, this directory must be writable by the http server user.
254              
255             =item I<cache_file>
256              
257             Alternatively to I<cache_dir>, you can provide an absolute path to the json cache file.
258              
259             =item I<timeout>
260              
261             An amount of time in second until the cache file becomes obsolete.
262              
263             =back
264              
265             =head2 cache
266              
267             Returns the hash reference structure of the cache
268              
269             =head2 cache_dir
270              
271             Set or get the cache dir.
272              
273             When set, this will also set the cache file calling L</"cache_file">
274              
275             =head2 cache_file
276              
277             Set or get the cache file.
278              
279             When set, this will store the cache file modification time to check later if it has become obsolete and load its json data into the L</"cache">
280              
281             =head2 get
282              
283             Given an hash reference of parameters, this will return an array reference of table hash reference.
284              
285             Parameters are:
286              
287             =over 4
288              
289             =item I<host>
290              
291             =item I<driver>
292              
293             =item I<port>
294              
295             =item I<database>
296              
297             =back
298              
299             =head2 read
300              
301             Given a full path to a json cache file, this will read the file and return its data as a hash reference.
302              
303             If an error occurs while reading the json cache file, it will issue a warning using B<warn> and return an empty hash reference.
304              
305             =head2 set
306              
307             Provided with an hash reference of parameters, this will add it to the cache data and write it to the file.
308              
309             Parameters are:
310              
311             =over 4
312              
313             =item I<host>
314              
315             =item I<driver>
316              
317             =item I<port>
318              
319             =item I<database>
320              
321             =item I<tables>
322              
323             An array reference of hash reference containing table definition as returned by L<DB::Object::table_info>
324              
325             =back
326              
327             =head2 timeout
328              
329             Set/get the cache file timeout.
330              
331             If the current unix timestamp minus the cache file timestamp is higher than the timeout, the cache file has expired.
332              
333             =head2 updated
334              
335             Set/get the cache file last modified unix timestamp
336              
337             =head2 write
338              
339             Provided with a cache data, which is a hash reference and optionally the full path to the cache file, and B<write> will write the hash data as a json to the cache file.
340              
341             If no cache file is provided as a second argument, it will use the default one set up when the object was instantiated.
342              
343             It returns the size of the cache file or return undef and set the B<error>
344              
345             =head1 COPYRIGHT
346              
347             Copyright (c) 2000-2019 DEGUEST Pte. Ltd.
348              
349             =head1 SEE ALSO
350              
351             L<DB::Object>
352              
353             =head1 AUTHOR
354              
355             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
356              
357             =head1 COPYRIGHT & LICENSE
358              
359             Copyright (c) 2018-2021 DEGUEST Pte. Ltd.
360              
361             You can use, copy, modify and redistribute this package and associated
362             files under the same terms as Perl itself.
363              
364             =cut