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

   1 package WebPAC::DB;
   2
   3 use warnings;
   4 use strict;
   5
   6 use base 'WebPAC::Common';
   7 use Storable;
   8
   9 =head1 NAME
  10
  11 WebPAC::DB - Store normalized data on disk
  12
  13 =head1 VERSION
  14
  15 Version 0.01
  16
  17 =cut
  18
  19 our $VERSION = '0.01';
  20
  21 =head1 SYNOPSIS
  22
  23 This module provides disk storage for normalised data.
  24
  25 It is newest component of WebPAC, so it will change quite often or be in
  26 flux. However, I will try to keep backward compatiblity by providing
  27 multiple back-ends.
  28
  29 This has additional advantage. I can create single place to plugin other
  30 file formats which provide better performance for particular type of data.
  31
  32 For now, this is a prototype version.
  33
  34     use WebPAC::DB;
  35
  36     my $foo = WebPAC::DB->new();
  37     ...
  38
  39 =head1 FUNCTIONS
  40
  41 =head2 new
  42
  43 Create new normalised database object
  44
  45   my $db = new WebPAC::DB(
  46         path = '/path/to/cache/ds/',
  47   );
  48
  49 Optional parameter C<path> defines path to directory
  50 in which cache file for C<data_structure> call will be created.
  51
  52 =cut
  53
  54 sub new {
  55         my $class = shift;
  56         my $self = {@_};
  57         bless($self, $class);
  58
  59         $self->path( $self->{'path'} );
  60
  61         $self ? return $self : return undef;
  62 }
  63
  64 =head2 path
  65
  66 Check if specified cache directory exist, and if not, disable caching.
  67
  68  $db->path('./cache/ds/');
  69
  70 If you pass false or zero value to this function, it will disable
  71 cacheing.
  72
  73 =cut
  74
  75 sub path {
  76         my $self = shift;
  77
  78         my $dir = shift;
  79
  80         my $log = $self->_get_logger();
  81
  82         if ($dir) {
  83                 my $msg;
  84                 if (! -e $dir) {
  85                         $msg = "doesn't exist";
  86                 } elsif (! -d $dir) {
  87                         $msg = "is not directory";
  88                 } elsif (! -w $dir) {
  89                         $msg = "not writable";
  90                 }
  91
  92                 if ($msg) {
  93                         $log->warn("cache path $dir $msg, disabling...");
  94                         undef $self->{'path'};
  95                 } else {
  96                         $log->debug("using cache dir $dir");
  97                         $self->{'path'} = $dir;
  98                 }
  99         } else {
 100                 $log->debug("disabling cache");
 101                 undef $self->{'path'};
 102         }
 103 }
 104
 105 =head2 load_ds
 106
 107 Retrive from disk one data_structure records using field 000 as key
 108
 109   my @ds = $db->load_ds($rec);
 110
 111 This function will also perform basic sanity checking on returned
 112 data and disable caching if data is corrupted (or changed since last
 113 update).
 114
 115 Returns array or undef if cacheing is disabled or unavailable.
 116
 117 =cut
 118
 119 sub load_ds {
 120         my $self = shift;
 121
 122         return unless $self->{'path'};
 123
 124         my $rec = shift || return;
 125
 126         my $log = $self->_get_logger;
 127
 128         my $cache_path = $self->{'path'};
 129
 130         my $id = $rec->{'000'};
 131         $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);
 132
 133         unless (defined($id)) {
 134                 $log->warn("Can't use cacheing on records without unique identifier in field 000");
 135                 undef $self->{'path'};
 136         } else {
 137                 my $cache_file = "$cache_path/$id";
 138                 $self->{'cache_file'} = $cache_file;
 139                 if (-r $cache_file) {
 140                         my $ds_ref = retrieve($cache_file);
 141                         if ($ds_ref) {
 142                                 $log->debug("cache hit: $cache_file");
 143                                 my $ok = 1;
 144                                 foreach my $f (qw(current_filename headline)) {
 145                                         if ($ds_ref->{$f}) {
 146                                                 $self->{$f} = $ds_ref->{$f};
 147                                         } else {
 148                                                 $ok = 0;
 149                                         }
 150                                 };
 151                                 if ($ok && $ds_ref->{'ds'}) {
 152                                         return @{ $ds_ref->{'ds'} };
 153                                 } else {
 154                                         $log->warn("cache entry $cache_path corrupt. Use rm $cache_path/* to re-create it on next run!");
 155                                         undef $self->{'path'};
 156                                 }
 157                         }
 158                 }
 159         }
 160
 161         return undef;
 162 }
 163
 164 =head2 save_ds
 165
 166 Store data_structure on disk.
 167
 168   $db->save_ds(
 169         ds => \@ds,
 170         current_filename => $self->{'current_filename'},
 171         headline => $self->{'headline'},
 172   );
 173
 174 B<Totally broken, but fast.>
 175
 176 Depends on filename generated by C<load_ds>.
 177
 178 =cut
 179
 180 sub save_ds {
 181         my $self = shift;
 182
 183         return unless($self->{'path'});
 184         return unless (@_);
 185
 186         my $arg = {@_};
 187
 188         my $log = $self->_get_logger;
 189
 190         $log->logdie("save_ds without cache_file -- did you called gs_get before?") unless ($self->{'cache_file'});
 191
 192         foreach my $e (qw/ds current_filename headline/) {
 193                 $log->logconfess("missing $e") unless $arg->{$e};
 194         }
 195
 196         $log->debug("creating storable cache file ",$self->{'cache_file'});
 197
 198         store {
 199                 ds => $arg->{'ds'},
 200                 current_filename => $arg->{'current_filename'},
 201                 headline => $arg->{'headline'},
 202         }, $self->{'cache_file'};
 203
 204 }
 205
 206 =head1 AUTHOR
 207
 208 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 209
 210 =head1 COPYRIGHT & LICENSE
 211
 212 Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
 213
 214 This program is free software; you can redistribute it and/or modify it
 215 under the same terms as Perl itself.
 216
 217 =cut
 218
 219 1; # End of WebPAC::DB