lib/WebPAC/Store.pm

package WebPAC::Store;

use warnings;
use strict;

use WebPAC::Common;
use base qw/WebPAC::Common Class::Accessor/;
__PACKAGE__->mk_accessors(qw/database/);

use Storable;
use File::Path;
use Data::Dump qw/dump/;

=head1 NAME

WebPAC::Store - Store WebPAC data on disk

=head1 VERSION

Version 0.15

=cut

our $VERSION = '0.15';

=head1 SYNOPSIS

This module provides disk storage for normalised data and lookups.

It is one of newer components of WebPAC, so it will change from time to
time.

I will try to keep backward compatiblity by providing multiple back-ends,
but this can't be garanteed. In other words, don't delete your input
databases just yet :-)

This has additional advantage. I can create single place to plugin other
file formats which provide better performance for particular type of data.

=head1 FUNCTIONS

=head2 new

Create new normalised database object

  my $store = new WebPAC::Store({
        database => 'name',
  });

Optional parameter C<path> defines path to directory
in which cache file for C<data_structure> call will be created.

Optional parametar C<database> will be used used as subdirectory in path if no
database in specified when calling other functions.

=cut

=head2 load_ds

Retrive from disk one data_structure records usually using field 000 as key

  my $ds = $store->load_ds(
                database => 'ps',
                input => 'name',
                id => 42,
  );

This function will also perform basic sanity checking on returned
data and disable caching if data is corrupted (or changed since last
update).

C<input> is used to differenciate different source input databases
which are indexed in same database.

C<database> if B<optional> argument which will override database name used when creating
C<WebPAC::Store> object (for simple retrival from multiple databases).

Returns hash or undef if cacheing is disabled or unavailable.

=cut

sub load_ds {
        my $self = shift;

        my $log = $self->_get_logger;

        $log->logconfess("arguments for load_ds must be HASH") unless (ref(\@_) eq 'ARRAY' && ($#_ % 2 == 1));

        my $args = {@_};
        my $id = $args->{id};

        $log->logconfess("got hash, but without id") unless (defined($id));
        $log->logconfess("got hash, but id [$id] isn't number") unless ($id =~ /^\d+$/);

        my $database = $args->{database} || $self->database || $log->logconfess("no database?");

        my $input = $args->{input} || '';

        my $cache_file = $self->var_path( 'ds', $database, $input, $id );

        $log->debug("using cache_file $cache_file");

        if (-r $cache_file) {
                my $ds_ref = retrieve($cache_file);
                if ($ds_ref) {
                        $log->debug("cache hit: $cache_file");
                        if ($ds_ref->{'ds'}) {
                                return $ds_ref->{'ds'};
                        } else {
                                $log->warn("cache entry $cache_file corrupt. Use rm $cache_file to re-create it on next run!");
                        }
                }
        } else {
                #$log->warn("cache entry $cache_file doesn't exist");
                return undef;
        }

        return undef;
}

=head2 save_ds

Store data_structure on disk.

  $store->save_ds(
        database => 'name',
        input => 'name',
        id => $ds->{000}->[0],
        ds => $ds,
  );

C<database> and C<input> are optional.

=cut

sub save_ds {
        my $self = shift;

        my $args = {@_};

        my $log = $self->_get_logger;
        $log->debug("save_ds arguments:", sub { dump( \@_ ) });

        foreach my $f (qw/id ds/) {
                $log->logconfess("need $f") unless (defined($args->{$f}));
        }

        my $database = $args->{database} || $self->{database};
        $log->logconfess("can't find database name") unless (defined($database));

        my $input = $args->{input} || '';

        my $cache_file = $self->var_path( 'ds', $database, $input );

        mkpath($cache_file) unless (-d $cache_file);

        $cache_file = $self->var_path( 'ds', $database, $input, $args->{id} );

        $log->debug("creating storable cache file $cache_file");

        return store {
                ds => $args->{ds},
                id => $args->{id},
        }, $cache_file;

}

=head2 load_lookup

Loads lookup hash from file

  $data = $store->load_lookup(
        database => $database,
        input => $input,
        key => $key,
  );

C<database> is optional.

=cut

sub load_lookup {
        my $self = shift;
        my $args = {@_};

        my $log = $self->_get_logger;

        foreach my $r (qw/input key/) {
                $log->logconfess("need '$r'") unless defined($args->{$r});
        }

        my $database = $args->{database} || $self->{database} || $log->logconfess("no database?");

        my $path = $self->var_path( 'lookup', $database, $args->{input}, $args->{key} );

        if (! -e $path) {
                $log->error("lookup $path doesn't exist, lookups will be disabled. Try re-indexing $database/", $args->{input});
                return;
        }

        if (my $data = retrieve($path)) {
                $log->info("loaded lookup $path ", -s $path, " bytes");
                return $data;
        } else {
                $log->logwarn("can't load lookup $database/", $args->{input}, "/", $args->{key}, " from $path: $!");
                return undef;
        }
}

=head2 save_lookup

Save lookup data to file.

  $store->save_lookup(
        database => $database,
        input => $input,
        key => $key,
        data => $lookup,
  );

C<database> is optional.

=cut

sub save_lookup {
        my $self = shift;
        my $args = {@_};

        my $log = $self->_get_logger;

        foreach my $r (qw/input key data/) {
                $log->logconfess("need '$r'") unless defined($args->{$r});
        }

        my $database = $args->{database} || $self->{database} || $log->logconfess("no database?");

        my $path = $self->var_path( 'lookup', $database, $args->{input} );

        mkpath($path) unless (-d $path);

        $path .= "/" . $args->{key};

        my $t = time();

        if (store $args->{data}, $path) {
                $log->info(sprintf("saved lookup %s %d bytes in %.2fs", $path, -s $path, time() - $t));
                return 1;
        } else {
                $log->logwarn("can't save lookup to $path: $!");
                return undef;
        }
}

=head2 load_row

Loads row from input database cache (used for lookups)

  $row = $store->load_row(
        database => $database,
        input => $input,
        id => 42,
  );

C<database> is optional.

=cut

sub load_row {
        my $self = shift;
        my $args = {@_};

        my $log = $self->_get_logger;

        foreach my $r (qw/input id/) {
                $log->logconfess("need '$r'") unless defined($args->{$r});
        }

        my $database = $args->{database} || $self->{database} || $log->logconfess("no database?");

        my $path = $self->var_path( 'row', $database, $args->{input}, $args->{id} );

        if (! -e $path) {
                $log->warn("input row $path doesn't exist, skipping");
                return;
        }

        if (my $data = retrieve($path)) {
                $log->debug("loaded row $path");
                return $data;
        } else {
                $log->logwarn("can't load row from $path: $!");
                return undef;
        }
}

=head2 save_row

Save row data to file.

  $store->save_row(
        database => $database,
        input => $input,
        id => $mfn,
        row => $lookup,
  );

C<database> is optional.

=cut

sub save_row {
        my $self = shift;
        my $args = {@_};

        my $log = $self->_get_logger;

        foreach my $r (qw/input id row/) {
                $log->logconfess("need '$r'") unless defined($args->{$r});
        }

        my $database = $args->{database} || $self->{database} || $log->logconfess("no database?");

        my $path = $self->var_path( 'row', $database, $args->{input} );

        mkpath($path) unless (-d $path);

        $path .= "/" . $args->{id};

        if (store $args->{row}, $path) {
                $log->debug("saved row $path");
                return 1;
        } else {
                $log->logwarn("can't save row to $path: $!");
                return undef;
        }
}


=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of WebPAC::Store
1	dpavlin	209	package WebPAC::Store;
2
3			use warnings;
4			use strict;
5
6	dpavlin	887	use WebPAC::Common;
7			use base qw/WebPAC::Common Class::Accessor/;
8			__PACKAGE__->mk_accessors(qw/database/);
9
10	dpavlin	209	use Storable;
11	dpavlin	215	use File::Path;
12	dpavlin	713	use Data::Dump qw/dump/;
13	dpavlin	209
14			=head1 NAME
15
16	dpavlin	710	WebPAC::Store - Store WebPAC data on disk
17	dpavlin	209
18			=head1 VERSION
19
20	dpavlin	887	Version 0.15
21	dpavlin	209
22			=cut
23
24	dpavlin	887	our $VERSION = '0.15';
25	dpavlin	209
26			=head1 SYNOPSIS
27
28	dpavlin	710	This module provides disk storage for normalised data and lookups.
29	dpavlin	209
30	dpavlin	710	It is one of newer components of WebPAC, so it will change from time to
31			time.
32	dpavlin	209
33	dpavlin	710	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	dpavlin	209	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	dpavlin	887	my $store = new WebPAC::Store({
47	dpavlin	217	database => 'name',
48	dpavlin	887	});
49	dpavlin	209
50			Optional parameter C<path> defines path to directory
51			in which cache file for C<data_structure> call will be created.
52
53	dpavlin	713	Optional parametar C<database> will be used used as subdirectory in path if no
54			database in specified when calling other functions.
55	dpavlin	218
56	dpavlin	209	=cut
57
58			=head2 load_ds
59
60	dpavlin	217	Retrive from disk one data_structure records usually using field 000 as key
61	dpavlin	209
62	dpavlin	735	my $ds = $store->load_ds(
63	dpavlin	713	database => 'ps',
64			input => 'name',
65			id => 42,
66			);
67	dpavlin	209
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	dpavlin	713	C<input> is used to differenciate different source input databases
73	dpavlin	218	which are indexed in same database.
74
75	dpavlin	236	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	dpavlin	209	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	dpavlin	217	$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	dpavlin	218	$log->logconfess("got hash, but id [$id] isn't number") unless ($id =~ /^\d+$/);
94	dpavlin	217
95	dpavlin	887	my $database = $args->{database} \|\| $self->database \|\| $log->logconfess("no database?");
96	dpavlin	714
97	dpavlin	713	my $input = $args->{input} \|\| '';
98	dpavlin	217
99	dpavlin	887	my $cache_file = $self->var_path( 'ds', $database, $input, $id );
100	dpavlin	217
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	dpavlin	887	$log->warn("cache entry $cache_file corrupt. Use rm $cache_file to re-create it on next run!");
111	dpavlin	209	}
112			}
113	dpavlin	217	} else {
114			#$log->warn("cache entry $cache_file doesn't exist");
115			return undef;
116	dpavlin	209	}
117
118			return undef;
119			}
120
121			=head2 save_ds
122
123			Store data_structure on disk.
124
125	dpavlin	735	$store->save_ds(
126	dpavlin	713	database => 'name',
127			input => 'name',
128	dpavlin	209	id => $ds->{000}->[0],
129			ds => $ds,
130			);
131
132	dpavlin	716	C<database> and C<input> are optional.
133	dpavlin	209
134			=cut
135
136			sub save_ds {
137			my $self = shift;
138
139	dpavlin	713	my $args = {@_};
140	dpavlin	209
141			my $log = $self->_get_logger;
142	dpavlin	853	$log->debug("save_ds arguments:", sub { dump( \@_ ) });
143	dpavlin	209
144			foreach my $f (qw/id ds/) {
145	dpavlin	713	$log->logconfess("need $f") unless (defined($args->{$f}));
146	dpavlin	209	}
147
148	dpavlin	713	my $database = $args->{database} \|\| $self->{database};
149	dpavlin	714	$log->logconfess("can't find database name") unless (defined($database));
150	dpavlin	209
151	dpavlin	713	my $input = $args->{input} \|\| '';
152	dpavlin	217
153	dpavlin	887	my $cache_file = $self->var_path( 'ds', $database, $input );
154	dpavlin	218
155	dpavlin	299	mkpath($cache_file) unless (-d $cache_file);
156
157	dpavlin	887	$cache_file = $self->var_path( 'ds', $database, $input, $args->{id} );
158	dpavlin	299
159	dpavlin	209	$log->debug("creating storable cache file $cache_file");
160
161			return store {
162	dpavlin	713	ds => $args->{ds},
163			id => $args->{id},
164	dpavlin	209	}, $cache_file;
165
166			}
167
168	dpavlin	715	=head2 load_lookup
169
170	dpavlin	716	Loads lookup hash from file
171
172	dpavlin	735	$data = $store->load_lookup(
173	dpavlin	715	database => $database,
174			input => $input,
175			key => $key,
176			);
177
178	dpavlin	716	C<database> is optional.
179
180	dpavlin	715	=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	dpavlin	887	my $path = $self->var_path( 'lookup', $database, $args->{input}, $args->{key} );
195	dpavlin	715
196			if (! -e $path) {
197	dpavlin	749	$log->error("lookup $path doesn't exist, lookups will be disabled. Try re-indexing $database/", $args->{input});
198	dpavlin	715	return;
199			}
200
201			if (my $data = retrieve($path)) {
202	dpavlin	1083	$log->info("loaded lookup $path ", -s $path, " bytes");
203	dpavlin	715	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	dpavlin	710	=head2 save_lookup
211
212	dpavlin	716	Save lookup data to file.
213
214	dpavlin	735	$store->save_lookup(
215	dpavlin	713	database => $database,
216			input => $input,
217			key => $key,
218			data => $lookup,
219			);
220	dpavlin	710
221	dpavlin	716	C<database> is optional.
222
223	dpavlin	710	=cut
224
225			sub save_lookup {
226			my $self = shift;
227	dpavlin	713	my $args = {@_};
228	dpavlin	710
229			my $log = $self->_get_logger;
230
231	dpavlin	713	foreach my $r (qw/input key data/) {
232			$log->logconfess("need '$r'") unless defined($args->{$r});
233			}
234	dpavlin	710
235	dpavlin	713	my $database = $args->{database} \|\| $self->{database} \|\| $log->logconfess("no database?");
236
237	dpavlin	887	my $path = $self->var_path( 'lookup', $database, $args->{input} );
238	dpavlin	713
239	dpavlin	710	mkpath($path) unless (-d $path);
240
241	dpavlin	713	$path .= "/" . $args->{key};
242	dpavlin	710
243	dpavlin	764	my $t = time();
244
245	dpavlin	713	if (store $args->{data}, $path) {
246	dpavlin	1083	$log->info(sprintf("saved lookup %s %d bytes in %.2fs", $path, -s $path, time() - $t));
247	dpavlin	713	return 1;
248	dpavlin	710	} else {
249	dpavlin	735	$log->logwarn("can't save lookup to $path: $!");
250	dpavlin	713	return undef;
251	dpavlin	710	}
252			}
253
254	dpavlin	735	=head2 load_row
255	dpavlin	710
256	dpavlin	735	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	dpavlin	887	my $path = $self->var_path( 'row', $database, $args->{input}, $args->{id} );
281	dpavlin	735
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	dpavlin	887	my $path = $self->var_path( 'row', $database, $args->{input} );
324	dpavlin	735
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	dpavlin	209	=head1 AUTHOR
340
341			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
342
343			=head1 COPYRIGHT & LICENSE
344
345	dpavlin	716	Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
346	dpavlin	209
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