git.rot13.org Git - webpac2/blob - lib/WebPAC/Store.pm

   1 package WebPAC::Store;
   2
   3 use warnings;
   4 use strict;
   5
   6 use base 'WebPAC::Common';
   7 use Storable;
   8 use File::Path;
   9 use Data::Dumper;
  10
  11 =head1 NAME
  12
  13 WebPAC::Store - Store normalized data on disk
  14
  15 =head1 VERSION
  16
  17 Version 0.08
  18
  19 =cut
  20
  21 our $VERSION = '0.08';
  22
  23 =head1 SYNOPSIS
  24
  25 This module provides disk storage for normalised data.
  26
  27 It is newest component of WebPAC, so it will change quite often or be in
  28 flux. However, I will try to keep backward compatiblity by providing
  29 multiple back-ends.
  30
  31 This has additional advantage. I can create single place to plugin other
  32 file formats which provide better performance for particular type of data.
  33
  34 For now, this is a prototype version.
  35
  36     use WebPAC::Store;
  37
  38     my $foo = WebPAC::Store->new();
  39     ...
  40
  41 =head1 FUNCTIONS
  42
  43 =head2 new
  44
  45 Create new normalised database object
  46
  47   my $db = new WebPAC::Store(
  48         path => '/path/to/cache/ds/',
  49         database => 'name',
  50         read_only => 1,
  51   );
  52
  53 Optional parameter C<path> defines path to directory
  54 in which cache file for C<data_structure> call will be created.
  55
  56 If called with C<read_only> it will not disable caching if
  57 called without write permission (but will die on C<save_ds>).
  58
  59 Mandatory parametar C<database> is used as subdirectory in database directory.
  60
  61 =cut
  62
  63 sub new {
  64         my $class = shift;
  65         my $self = {@_};
  66         bless($self, $class);
  67
  68         my $log = $self->_get_logger();
  69
  70         foreach my $p (qw/path database/) {
  71                 $log->logconfess("need $p") unless ($self->{$p});
  72         }
  73
  74         $self->path( $self->{'path'} );
  75
  76         $self ? return $self : return undef;
  77 }
  78
  79 =head2 path
  80
  81 Check if specified cache directory exist, and if not, disable caching.
  82
  83  $db->path('./cache/ds/');
  84
  85 If you pass false or zero value to this function, it will disable
  86 cacheing.
  87
  88 You can also example C<< $db->{path} >> to get current cache path.
  89
  90 =cut
  91
  92 sub path {
  93         my $self = shift;
  94
  95         my $dir = shift;
  96
  97         my $log = $self->_get_logger();
  98
  99         if ($dir) {
 100                 my $msg;
 101                 if (! -e $dir) {
 102                         if ($self->{'read_only'}) {
 103                                 $msg = "doesn't exist";
 104                         } else {
 105                                 $log->info("creating $dir");
 106                                 mkpath $dir;
 107                         }
 108                 } elsif (! -d $dir) {
 109                         $msg = "is not directory";
 110                 } elsif (! -w $dir) {
 111                         $msg = "not writable" unless ($self->{'read_only'});
 112                 }
 113
 114                 if ($msg) {
 115                         $log->warn("cache path $dir $msg, disabling...");
 116                         undef $self->{'path'};
 117                 } else {
 118                         $log->debug("using cache dir $dir");
 119                         $self->{'path'} = $dir;
 120                 }
 121         } else {
 122                 $log->debug("disabling cache");
 123                 undef $self->{'path'};
 124         }
 125 }
 126
 127 =head2 load_ds
 128
 129 Retrive from disk one data_structure records usually using field 000 as key
 130
 131   my $ds = $db->load_ds( id => 42, prefix => 'name', database => 'ps' );
 132
 133 This function will also perform basic sanity checking on returned
 134 data and disable caching if data is corrupted (or changed since last
 135 update).
 136
 137 C<prefix> is used to differenciate different source input databases
 138 which are indexed in same database.
 139
 140 C<database> if B<optional> argument which will override database name used when creating
 141 C<WebPAC::Store> object (for simple retrival from multiple databases).
 142
 143 Returns hash or undef if cacheing is disabled or unavailable.
 144
 145 =cut
 146
 147 sub load_ds {
 148         my $self = shift;
 149
 150         my $log = $self->_get_logger;
 151
 152         my $cache_path = $self->{'path'};
 153
 154         if (! $cache_path) {
 155                 $log->warn("path not set, ignoring load_ds");
 156                 return;
 157         }
 158
 159         $log->logconfess("arguments for load_ds must be HASH") unless (ref(\@_) eq 'ARRAY' && ($#_ % 2 == 1));
 160
 161         my $args = {@_};
 162         my $id = $args->{id};
 163
 164         $log->logconfess("got hash, but without id") unless (defined($id));
 165         $log->logconfess("got hash, but id [$id] isn't number") unless ($id =~ /^\d+$/);
 166
 167         my $database = $args->{database} || $self->{database};
 168         my $prefix = $args->{prefix} || '';
 169
 170         $log->logconfess("can't find database name") unless ($database);
 171
 172         my $cache_file = "$cache_path/$database/$prefix#$id";
 173         $cache_file =~ s#//#/#go;
 174
 175 open(my $fh, '>>', '/tmp/foo');
 176 print $fh "LOAD $cache_path / $database / $prefix # $id ==> $cache_file\n";
 177 close($fh);
 178
 179         $log->debug("using cache_file $cache_file");
 180
 181         if (-r $cache_file) {
 182                 my $ds_ref = retrieve($cache_file);
 183                 if ($ds_ref) {
 184                         $log->debug("cache hit: $cache_file");
 185                         if ($ds_ref->{'ds'}) {
 186                                 return $ds_ref->{'ds'};
 187                         } else {
 188                                 $log->warn("cache entry $cache_file corrupt. Use rm $cache_path/* to re-create it on next run!");
 189                                 undef $self->{'path'};
 190                         }
 191                 }
 192         } else {
 193                 #$log->warn("cache entry $cache_file doesn't exist");
 194                 return undef;
 195         }
 196
 197         return undef;
 198 }
 199
 200 =head2 save_ds
 201
 202 Store data_structure on disk.
 203
 204   $db->save_ds(
 205         id => $ds->{000}->[0],
 206         prefix => 'name',
 207         ds => $ds,
 208   );
 209
 210 B<Totally broken, but fast.>
 211
 212 Depends on filename generated by C<load_ds>.
 213
 214 =cut
 215
 216 sub save_ds {
 217         my $self = shift;
 218
 219         die "can't write to database in read_only mode!" if ($self->{'read_only'});
 220
 221         return unless($self->{'path'});
 222
 223         my $arg = {@_};
 224
 225         my $log = $self->_get_logger;
 226
 227         foreach my $f (qw/id ds/) {
 228                 $log->logconfess("need $f") unless ($arg->{$f});
 229         }
 230
 231         my $database = $self->{database};
 232         $log->logconfess("can't find database name") unless ($database);
 233
 234         my $prefix = $arg->{prefix} || '';
 235
 236         my $cache_file = $self->{path} . "/$prefix#" . $arg->{id};
 237         $cache_file =~ s#//#/#go;
 238
 239         $log->debug("creating storable cache file $cache_file");
 240
 241         return store {
 242                 ds => $arg->{ds},
 243                 id => $arg->{id},
 244         }, $cache_file;
 245
 246 }
 247
 248 =head1 AUTHOR
 249
 250 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 251
 252 =head1 COPYRIGHT & LICENSE
 253
 254 Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
 255
 256 This program is free software; you can redistribute it and/or modify it
 257 under the same terms as Perl itself.
 258
 259 =cut
 260
 261 1; # End of WebPAC::Store