lib/WebPAC/Store.pm

package WebPAC::Store;

use warnings;
use strict;

use base 'WebPAC::Common';
use Storable;
use File::Path;
use Data::Dump qw/dump/;

=head1 NAME

WebPAC::Store - Store WebPAC data on disk

=head1 VERSION

Version 0.13

=cut

our $VERSION = '0.13';

=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.

For now, this is a prototype version.

    use WebPAC::Store;

    my $foo = WebPAC::Store->new();
    ...

=head1 FUNCTIONS

=head2 new

Create new normalised database object

  my $db = new WebPAC::Store(
        path => '/path/to/cache/ds/',
        database => 'name',
        read_only => 1,
  );

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

If called with C<read_only> it will not disable caching if
called without write permission (but will die on C<save_ds>).

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

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        my $log = $self->_get_logger();

        foreach my $p (qw/path/) {
                $log->logconfess("need $p") unless ($self->{$p});
        }

        $self->path( $self->{'path'} );

        $self ? return $self : return undef;
}

=head2 path

Check if specified cache directory exist, and if not, disable caching.

 $db->path('./cache/ds/');

If you pass false or zero value to this function, it will disable
cacheing.

You can also call this function to get current cache path.

 my $cache_path = $db->path;

=cut

sub path {
        my $self = shift;

        my $dir = shift;
        
        return $self->{path} unless defined($dir);

        my $log = $self->_get_logger();

        if ($dir) {
                my $msg;
                if (! -e $dir) {
                        if ($self->{'read_only'}) {
                                $msg = "doesn't exist";
                        } else {
                                $log->info("creating $dir");
                                mkpath $dir;
                        }
                } elsif (! -d $dir) {
                        $msg = "is not directory";
                } elsif (! -w $dir) {
                        $msg = "not writable" unless ($self->{'read_only'});
                }

                if ($msg) {
                        $log->warn("cache path $dir $msg, disabling...");
                        undef $self->{'path'};
                } else {
                        $log->debug("using cache dir $dir");
                        $self->{'path'} = $dir;
                }
        } else {
                $log->debug("disabling cache");
                undef $self->{'path'};
        }
}

=head2 load_ds

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

  my $ds = $db->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;

        my $cache_path = $self->{'path'};

        if (! $cache_path) {
                $log->warn("path not set, ignoring load_ds");
                return;
        }

        $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 = "$cache_path/ds/$database/$input/$id";
        $cache_file =~ s#//#/#go;

        $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_path/* to re-create it on next run!");
                                undef $self->{'path'};
                        }
                }
        } else {
                #$log->warn("cache entry $cache_file doesn't exist");
                return undef;
        }

        return undef;
}

=head2 save_ds

Store data_structure on disk.

  $db->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;

        die "can't write to database in read_only mode!" if ($self->{'read_only'});

        return unless($self->{'path'});

        my $args = {@_};

        my $log = $self->_get_logger;
        $log->debug("save_ds arguments:", 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->{path} . "/ds/$database/$input/";
        $cache_file =~ s#//#/#go;

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

        $cache_file .= $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 = $db->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->{path} . "/lookup/$database/" . $args->{input} . '/' . $args->{key};

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

        if (my $data = retrieve($path)) {
                $log->info("loaded lookup $path");
                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.

  $db->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->{path} . "/lookup/$database/" . $args->{input};

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

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

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