lib/WebPAC/Store.pm

package WebPAC::Store;

use warnings;
use strict;

use base 'WebPAC::Common';
use Storable;
use File::Path;
use Data::Dumper;

=head1 NAME

WebPAC::Store - Store WebPAC data on disk

=head1 VERSION

Version 0.10

=cut

our $VERSION = '0.10';

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

Mandatory parametar C<database> is used as subdirectory in database directory.

=cut

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

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

        foreach my $p (qw/path database/) {
                $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 example C<< $db->{path} >> to get current cache path.

=cut

sub path {
        my $self = shift;

        my $dir = shift;

        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( id => 42, prefix => 'name', database => 'ps' );

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

C<prefix> 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};
        my $prefix = $args->{prefix} || '';

        $log->logconfess("can't find database name") unless ($database);

        my $cache_file = "$cache_path/$database/$prefix/$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(
        id => $ds->{000}->[0],
        prefix => 'name',
        ds => $ds,
  );

B<Totally broken, but fast.>

Depends on filename generated by C<load_ds>.

=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 $arg = {@_};

        my $log = $self->_get_logger;

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

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

        my $prefix = $arg->{prefix} || '';

        my $cache_file = $self->{path} . '/' . $prefix . '/';
        $cache_file =~ s#//#/#go;

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

        $cache_file .= $arg->{id};

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

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

}

=head2 save_lookup

  $db->save_lookup( $database, $input, $key, $lookup );

=cut

sub save_lookup {
        my $self = shift;
        my ($database, $input, $key, $lookup) = @_;

        my $log = $self->_get_logger;

        my $path = $self->{'path'} . "/lookup/$input";

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

        $path .= "/$key";

        if (store $lookup, $path) {
                $log->info("saved lookup $path");
        } else {
                $log->logwarn("can't store lookup $database/$input/$key in $path: $!");
        }

        
}


=head1 AUTHOR

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

=head1 COPYRIGHT & LICENSE

Copyright 2005 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	217	use Data::Dumper;
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	710	Version 0.10
18	dpavlin	209
19			=cut
20
21	dpavlin	710	our $VERSION = '0.10';
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	218	Mandatory parametar C<database> is used as subdirectory in database directory.
63
64	dpavlin	209	=cut
65
66			sub new {
67			my $class = shift;
68	dpavlin	710	my $self = {@_};
69			bless($self, $class);
70	dpavlin	209
71	dpavlin	218	my $log = $self->_get_logger();
72
73			foreach my $p (qw/path database/) {
74			$log->logconfess("need $p") unless ($self->{$p});
75			}
76
77	dpavlin	209	$self->path( $self->{'path'} );
78
79			$self ? return $self : return undef;
80			}
81
82			=head2 path
83
84			Check if specified cache directory exist, and if not, disable caching.
85
86			$db->path('./cache/ds/');
87
88			If you pass false or zero value to this function, it will disable
89			cacheing.
90
91			You can also example C<< $db->{path} >> to get current cache path.
92
93			=cut
94
95			sub path {
96			my $self = shift;
97
98			my $dir = shift;
99
100			my $log = $self->_get_logger();
101
102			if ($dir) {
103			my $msg;
104			if (! -e $dir) {
105	dpavlin	215	if ($self->{'read_only'}) {
106			$msg = "doesn't exist";
107			} else {
108			$log->info("creating $dir");
109			mkpath $dir;
110			}
111	dpavlin	209	} elsif (! -d $dir) {
112			$msg = "is not directory";
113			} elsif (! -w $dir) {
114			$msg = "not writable" unless ($self->{'read_only'});
115			}
116
117			if ($msg) {
118			$log->warn("cache path $dir $msg, disabling...");
119			undef $self->{'path'};
120			} else {
121			$log->debug("using cache dir $dir");
122			$self->{'path'} = $dir;
123			}
124			} else {
125			$log->debug("disabling cache");
126			undef $self->{'path'};
127			}
128			}
129
130			=head2 load_ds
131
132	dpavlin	217	Retrive from disk one data_structure records usually using field 000 as key
133	dpavlin	209
134	dpavlin	236	my $ds = $db->load_ds( id => 42, prefix => 'name', database => 'ps' );
135	dpavlin	209
136			This function will also perform basic sanity checking on returned
137			data and disable caching if data is corrupted (or changed since last
138			update).
139
140	dpavlin	218	C<prefix> is used to differenciate different source input databases
141			which are indexed in same database.
142
143	dpavlin	236	C<database> if B<optional> argument which will override database name used when creating
144			C<WebPAC::Store> object (for simple retrival from multiple databases).
145
146	dpavlin	209	Returns hash or undef if cacheing is disabled or unavailable.
147
148			=cut
149
150			sub load_ds {
151			my $self = shift;
152
153			my $log = $self->_get_logger;
154
155			my $cache_path = $self->{'path'};
156
157	dpavlin	217	if (! $cache_path) {
158			$log->warn("path not set, ignoring load_ds");
159			return;
160	dpavlin	209	}
161
162	dpavlin	217	$log->logconfess("arguments for load_ds must be HASH") unless (ref(\@_) eq 'ARRAY' && ($#_ % 2 == 1));
163
164			my $args = {@_};
165			my $id = $args->{id};
166
167			$log->logconfess("got hash, but without id") unless (defined($id));
168	dpavlin	218	$log->logconfess("got hash, but id [$id] isn't number") unless ($id =~ /^\d+$/);
169	dpavlin	217
170	dpavlin	236	my $database = $args->{database} \|\| $self->{database};
171	dpavlin	218	my $prefix = $args->{prefix} \|\| '';
172	dpavlin	217
173			$log->logconfess("can't find database name") unless ($database);
174
175	dpavlin	299	my $cache_file = "$cache_path/$database/$prefix/$id";
176	dpavlin	218	$cache_file =~ s#//#/#go;
177	dpavlin	217
178			$log->debug("using cache_file $cache_file");
179
180			if (-r $cache_file) {
181			my $ds_ref = retrieve($cache_file);
182			if ($ds_ref) {
183			$log->debug("cache hit: $cache_file");
184			if ($ds_ref->{'ds'}) {
185			return $ds_ref->{'ds'};
186			} else {
187			$log->warn("cache entry $cache_file corrupt. Use rm $cache_path/* to re-create it on next run!");
188			undef $self->{'path'};
189	dpavlin	209	}
190			}
191	dpavlin	217	} else {
192			#$log->warn("cache entry $cache_file doesn't exist");
193			return undef;
194	dpavlin	209	}
195
196			return undef;
197			}
198
199			=head2 save_ds
200
201			Store data_structure on disk.
202
203			$db->save_ds(
204			id => $ds->{000}->[0],
205	dpavlin	218	prefix => 'name',
206	dpavlin	209	ds => $ds,
207			);
208
209			B<Totally broken, but fast.>
210
211			Depends on filename generated by C<load_ds>.
212
213			=cut
214
215			sub save_ds {
216			my $self = shift;
217
218			die "can't write to database in read_only mode!" if ($self->{'read_only'});
219
220			return unless($self->{'path'});
221
222			my $arg = {@_};
223
224			my $log = $self->_get_logger;
225
226			foreach my $f (qw/id ds/) {
227			$log->logconfess("need $f") unless ($arg->{$f});
228			}
229
230	dpavlin	218	my $database = $self->{database};
231	dpavlin	217	$log->logconfess("can't find database name") unless ($database);
232	dpavlin	209
233	dpavlin	218	my $prefix = $arg->{prefix} \|\| '';
234	dpavlin	217
235	dpavlin	299	my $cache_file = $self->{path} . '/' . $prefix . '/';
236	dpavlin	218	$cache_file =~ s#//#/#go;
237
238	dpavlin	299	mkpath($cache_file) unless (-d $cache_file);
239
240			$cache_file .= $arg->{id};
241
242	dpavlin	209	$log->debug("creating storable cache file $cache_file");
243
244			return store {
245			ds => $arg->{ds},
246			id => $arg->{id},
247			}, $cache_file;
248
249			}
250
251	dpavlin	710	=head2 save_lookup
252
253			$db->save_lookup( $database, $input, $key, $lookup );
254
255			=cut
256
257			sub save_lookup {
258			my $self = shift;
259			my ($database, $input, $key, $lookup) = @_;
260
261			my $log = $self->_get_logger;
262
263			my $path = $self->{'path'} . "/lookup/$input";
264
265			mkpath($path) unless (-d $path);
266
267			$path .= "/$key";
268
269			if (store $lookup, $path) {
270			$log->info("saved lookup $path");
271			} else {
272			$log->logwarn("can't store lookup $database/$input/$key in $path: $!");
273			}
274
275
276			}
277
278
279	dpavlin	209	=head1 AUTHOR
280
281			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
282
283			=head1 COPYRIGHT & LICENSE
284
285			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
286
287			This program is free software; you can redistribute it and/or modify it
288			under the same terms as Perl itself.
289
290			=cut
291
292			1; # End of WebPAC::Store