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

   1 package WebPAC::Store;
   2
   3 use warnings;
   4 use strict;
   5
   6 use WebPAC::Common;
   7 use base qw/WebPAC::Common Class::Accessor/;
   8 __PACKAGE__->mk_accessors(qw/database/);
   9
  10 use Storable;
  11 use File::Path;
  12 use Data::Dump qw/dump/;
  13
  14 =head1 NAME
  15
  16 WebPAC::Store - Store WebPAC data on disk
  17
  18 =head1 VERSION
  19
  20 Version 0.15
  21
  22 =cut
  23
  24 our $VERSION = '0.15';
  25
  26 =head1 SYNOPSIS
  27
  28 This module provides disk storage for normalised data and lookups.
  29
  30 It is one of newer components of WebPAC, so it will change from time to
  31 time.
  32
  33 I will try to keep backward compatiblity by providing multiple back-ends,
  34 but this can't be garanteed. In other words, don't delete your input
  35 databases just yet :-)
  36
  37 This has additional advantage. I can create single place to plugin other
  38 file formats which provide better performance for particular type of data.
  39
  40 =head1 FUNCTIONS
  41
  42 =head2 new
  43
  44 Create new normalised database object
  45
  46   my $store = new WebPAC::Store({
  47         database => 'name',
  48   });
  49
  50 Optional parameter C<path> defines path to directory
  51 in which cache file for C<data_structure> call will be created.
  52
  53 Optional parametar C<database> will be used used as subdirectory in path if no
  54 database in specified when calling other functions.
  55
  56 =cut
  57
  58 =head2 load_ds
  59
  60 Retrive from disk one data_structure records usually using field 000 as key
  61
  62   my $ds = $store->load_ds(
  63                 database => 'ps',
  64                 input => 'name',
  65                 id => 42,
  66   );
  67
  68 This function will also perform basic sanity checking on returned
  69 data and disable caching if data is corrupted (or changed since last
  70 update).
  71
  72 C<input> is used to differenciate different source input databases
  73 which are indexed in same database.
  74
  75 C<database> if B<optional> argument which will override database name used when creating
  76 C<WebPAC::Store> object (for simple retrival from multiple databases).
  77
  78 Returns hash or undef if cacheing is disabled or unavailable.
  79
  80 =cut
  81
  82 sub load_ds {
  83         my $self = shift;
  84
  85         my $log = $self->_get_logger;
  86
  87         $log->logconfess("arguments for load_ds must be HASH") unless (ref(\@_) eq 'ARRAY' && ($#_ % 2 == 1));
  88
  89         my $args = {@_};
  90         my $id = $args->{id};
  91
  92         $log->logconfess("got hash, but without id") unless (defined($id));
  93         $log->logconfess("got hash, but id [$id] isn't number") unless ($id =~ /^\d+$/);
  94
  95         my $database = $args->{database} || $self->database || $log->logconfess("no database?");
  96
  97         my $input = $args->{input} || '';
  98
  99         my $cache_file = $self->var_path( 'ds', $database, $input, $id );
 100
 101         $log->debug("using cache_file $cache_file");
 102
 103         if (-r $cache_file) {
 104                 my $ds_ref = retrieve($cache_file);
 105                 if ($ds_ref) {
 106                         $log->debug("cache hit: $cache_file");
 107                         if ($ds_ref->{'ds'}) {
 108                                 return $ds_ref->{'ds'};
 109                         } else {
 110                                 $log->warn("cache entry $cache_file corrupt. Use rm $cache_file to re-create it on next run!");
 111                         }
 112                 }
 113         } else {
 114                 #$log->warn("cache entry $cache_file doesn't exist");
 115                 return undef;
 116         }
 117
 118         return undef;
 119 }
 120
 121 =head2 save_ds
 122
 123 Store data_structure on disk.
 124
 125   $store->save_ds(
 126         database => 'name',
 127         input => 'name',
 128         id => $ds->{000}->[0],
 129         ds => $ds,
 130   );
 131
 132 C<database> and C<input> are optional.
 133
 134 =cut
 135
 136 sub save_ds {
 137         my $self = shift;
 138
 139         my $args = {@_};
 140
 141         my $log = $self->_get_logger;
 142         $log->debug("save_ds arguments:", sub { dump( \@_ ) });
 143
 144         foreach my $f (qw/id ds/) {
 145                 $log->logconfess("need $f") unless (defined($args->{$f}));
 146         }
 147
 148         my $database = $args->{database} || $self->{database};
 149         $log->logconfess("can't find database name") unless (defined($database));
 150
 151         my $input = $args->{input} || '';
 152
 153         my $cache_file = $self->var_path( 'ds', $database, $input );
 154
 155         mkpath($cache_file) unless (-d $cache_file);
 156
 157         $cache_file = $self->var_path( 'ds', $database, $input, $args->{id} );
 158
 159         $log->debug("creating storable cache file $cache_file");
 160
 161         return store {
 162                 ds => $args->{ds},
 163                 id => $args->{id},
 164         }, $cache_file;
 165
 166 }
 167
 168 =head2 load_lookup
 169
 170 Loads lookup hash from file
 171
 172   $data = $store->load_lookup(
 173         database => $database,
 174         input => $input,
 175         key => $key,
 176   );
 177
 178 C<database> is optional.
 179
 180 =cut
 181
 182 sub load_lookup {
 183         my $self = shift;
 184         my $args = {@_};
 185
 186         my $log = $self->_get_logger;
 187
 188         foreach my $r (qw/input key/) {
 189                 $log->logconfess("need '$r'") unless defined($args->{$r});
 190         }
 191
 192         my $database = $args->{database} || $self->{database} || $log->logconfess("no database?");
 193
 194         my $path = $self->var_path( 'lookup', $database, $args->{input}, $args->{key} );
 195
 196         if (! -e $path) {
 197                 $log->error("lookup $path doesn't exist, lookups will be disabled. Try re-indexing $database/", $args->{input});
 198                 return;
 199         }
 200
 201         if (my $data = retrieve($path)) {
 202                 $log->info("loaded lookup $path ", -s $path, " bytes");
 203                 return $data;
 204         } else {
 205                 $log->logwarn("can't load lookup $database/", $args->{input}, "/", $args->{key}, " from $path: $!");
 206                 return undef;
 207         }
 208 }
 209
 210 =head2 save_lookup
 211
 212 Save lookup data to file.
 213
 214   $store->save_lookup(
 215         database => $database,
 216         input => $input,
 217         key => $key,
 218         data => $lookup,
 219   );
 220
 221 C<database> is optional.
 222
 223 =cut
 224
 225 sub save_lookup {
 226         my $self = shift;
 227         my $args = {@_};
 228
 229         my $log = $self->_get_logger;
 230
 231         foreach my $r (qw/input key data/) {
 232                 $log->logconfess("need '$r'") unless defined($args->{$r});
 233         }
 234
 235         my $database = $args->{database} || $self->{database} || $log->logconfess("no database?");
 236
 237         my $path = $self->var_path( 'lookup', $database, $args->{input} );
 238
 239         mkpath($path) unless (-d $path);
 240
 241         $path .= "/" . $args->{key};
 242
 243         my $t = time();
 244
 245         if (store $args->{data}, $path) {
 246                 $log->info(sprintf("saved lookup %s %d bytes in %.2fs", $path, -s $path, time() - $t));
 247                 return 1;
 248         } else {
 249                 $log->logwarn("can't save lookup to $path: $!");
 250                 return undef;
 251         }
 252 }
 253
 254 =head2 load_row
 255
 256 Loads row from input database cache (used for lookups)
 257
 258   $row = $store->load_row(
 259         database => $database,
 260         input => $input,
 261         id => 42,
 262   );
 263
 264 C<database> is optional.
 265
 266 =cut
 267
 268 sub load_row {
 269         my $self = shift;
 270         my $args = {@_};
 271
 272         my $log = $self->_get_logger;
 273
 274         foreach my $r (qw/input id/) {
 275                 $log->logconfess("need '$r'") unless defined($args->{$r});
 276         }
 277
 278         my $database = $args->{database} || $self->{database} || $log->logconfess("no database?");
 279
 280         my $path = $self->var_path( 'row', $database, $args->{input}, $args->{id} );
 281
 282         if (! -e $path) {
 283                 $log->warn("input row $path doesn't exist, skipping");
 284                 return;
 285         }
 286
 287         if (my $data = retrieve($path)) {
 288                 $log->debug("loaded row $path");
 289                 return $data;
 290         } else {
 291                 $log->logwarn("can't load row from $path: $!");
 292                 return undef;
 293         }
 294 }
 295
 296 =head2 save_row
 297
 298 Save row data to file.
 299
 300   $store->save_row(
 301         database => $database,
 302         input => $input,
 303         id => $mfn,
 304         row => $lookup,
 305   );
 306
 307 C<database> is optional.
 308
 309 =cut
 310
 311 sub save_row {
 312         my $self = shift;
 313         my $args = {@_};
 314
 315         my $log = $self->_get_logger;
 316
 317         foreach my $r (qw/input id row/) {
 318                 $log->logconfess("need '$r'") unless defined($args->{$r});
 319         }
 320
 321         my $database = $args->{database} || $self->{database} || $log->logconfess("no database?");
 322
 323         my $path = $self->var_path( 'row', $database, $args->{input} );
 324
 325         mkpath($path) unless (-d $path);
 326
 327         $path .= "/" . $args->{id};
 328
 329         if (store $args->{row}, $path) {
 330                 $log->debug("saved row $path");
 331                 return 1;
 332         } else {
 333                 $log->logwarn("can't save row to $path: $!");
 334                 return undef;
 335         }
 336 }
 337
 338
 339 =head1 AUTHOR
 340
 341 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 342
 343 =head1 COPYRIGHT & LICENSE
 344
 345 Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
 346
 347 This program is free software; you can redistribute it and/or modify it
 348 under the same terms as Perl itself.
 349
 350 =cut
 351
 352 1; # End of WebPAC::Store