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 normalized data on disk

=head1 VERSION

Version 0.08

=cut

our $VERSION = '0.08';

=head1 SYNOPSIS

This module provides disk storage for normalised data.

It is newest component of WebPAC, so it will change quite often or be in
flux. However, I will try to keep backward compatiblity by providing
multiple back-ends.

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;

open(my $fh, '>>', '/tmp/foo');
print $fh "LOAD $cache_path / $database / $prefix # $id ==> $cache_file\n";
close($fh);

        $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#" . $arg->{id};
        $cache_file =~ s#//#/#go;

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

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

}

=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			WebPAC::Store - Store normalized data on disk
14
15			=head1 VERSION
16
17	dpavlin	236	Version 0.08
18	dpavlin	209
19			=cut
20
21	dpavlin	236	our $VERSION = '0.08';
22	dpavlin	209
23			=head1 SYNOPSIS
24
25			This module provides disk storage for normalised data.
26
27			It is newest component of WebPAC, so it will change quite often or be in
28			flux. However, I will try to keep backward compatiblity by providing
29			multiple back-ends.
30
31			This has additional advantage. I can create single place to plugin other
32			file formats which provide better performance for particular type of data.
33
34			For now, this is a prototype version.
35
36			use WebPAC::Store;
37
38			my $foo = WebPAC::Store->new();
39			...
40
41			=head1 FUNCTIONS
42
43			=head2 new
44
45			Create new normalised database object
46
47			my $db = new WebPAC::Store(
48			path => '/path/to/cache/ds/',
49	dpavlin	217	database => 'name',
50	dpavlin	209	read_only => 1,
51			);
52
53			Optional parameter C<path> defines path to directory
54			in which cache file for C<data_structure> call will be created.
55
56			If called with C<read_only> it will not disable caching if
57			called without write permission (but will die on C<save_ds>).
58
59	dpavlin	218	Mandatory parametar C<database> is used as subdirectory in database directory.
60
61	dpavlin	209	=cut
62
63			sub new {
64			my $class = shift;
65			my $self = {@_};
66			bless($self, $class);
67
68	dpavlin	218	my $log = $self->_get_logger();
69
70			foreach my $p (qw/path database/) {
71			$log->logconfess("need $p") unless ($self->{$p});
72			}
73
74	dpavlin	209	$self->path( $self->{'path'} );
75
76			$self ? return $self : return undef;
77			}
78
79			=head2 path
80
81			Check if specified cache directory exist, and if not, disable caching.
82
83			$db->path('./cache/ds/');
84
85			If you pass false or zero value to this function, it will disable
86			cacheing.
87
88			You can also example C<< $db->{path} >> to get current cache path.
89
90			=cut
91
92			sub path {
93			my $self = shift;
94
95			my $dir = shift;
96
97			my $log = $self->_get_logger();
98
99			if ($dir) {
100			my $msg;
101			if (! -e $dir) {
102	dpavlin	215	if ($self->{'read_only'}) {
103			$msg = "doesn't exist";
104			} else {
105			$log->info("creating $dir");
106			mkpath $dir;
107			}
108	dpavlin	209	} elsif (! -d $dir) {
109			$msg = "is not directory";
110			} elsif (! -w $dir) {
111			$msg = "not writable" unless ($self->{'read_only'});
112			}
113
114			if ($msg) {
115			$log->warn("cache path $dir $msg, disabling...");
116			undef $self->{'path'};
117			} else {
118			$log->debug("using cache dir $dir");
119			$self->{'path'} = $dir;
120			}
121			} else {
122			$log->debug("disabling cache");
123			undef $self->{'path'};
124			}
125			}
126
127			=head2 load_ds
128
129	dpavlin	217	Retrive from disk one data_structure records usually using field 000 as key
130	dpavlin	209
131	dpavlin	236	my $ds = $db->load_ds( id => 42, prefix => 'name', database => 'ps' );
132	dpavlin	209
133			This function will also perform basic sanity checking on returned
134			data and disable caching if data is corrupted (or changed since last
135			update).
136
137	dpavlin	218	C<prefix> is used to differenciate different source input databases
138			which are indexed in same database.
139
140	dpavlin	236	C<database> if B<optional> argument which will override database name used when creating
141			C<WebPAC::Store> object (for simple retrival from multiple databases).
142
143	dpavlin	209	Returns hash or undef if cacheing is disabled or unavailable.
144
145			=cut
146
147			sub load_ds {
148			my $self = shift;
149
150			my $log = $self->_get_logger;
151
152			my $cache_path = $self->{'path'};
153
154	dpavlin	217	if (! $cache_path) {
155			$log->warn("path not set, ignoring load_ds");
156			return;
157	dpavlin	209	}
158
159	dpavlin	217	$log->logconfess("arguments for load_ds must be HASH") unless (ref(\@_) eq 'ARRAY' && ($#_ % 2 == 1));
160
161			my $args = {@_};
162			my $id = $args->{id};
163
164			$log->logconfess("got hash, but without id") unless (defined($id));
165	dpavlin	218	$log->logconfess("got hash, but id [$id] isn't number") unless ($id =~ /^\d+$/);
166	dpavlin	217
167	dpavlin	236	my $database = $args->{database} \|\| $self->{database};
168	dpavlin	218	my $prefix = $args->{prefix} \|\| '';
169	dpavlin	217
170			$log->logconfess("can't find database name") unless ($database);
171
172	dpavlin	233	my $cache_file = "$cache_path/$database/$prefix#$id";
173	dpavlin	218	$cache_file =~ s#//#/#go;
174	dpavlin	217
175	dpavlin	218	open(my $fh, '>>', '/tmp/foo');
176	dpavlin	233	print $fh "LOAD $cache_path / $database / $prefix # $id ==> $cache_file\n";
177	dpavlin	218	close($fh);
178
179	dpavlin	217	$log->debug("using cache_file $cache_file");
180
181			if (-r $cache_file) {
182			my $ds_ref = retrieve($cache_file);
183			if ($ds_ref) {
184			$log->debug("cache hit: $cache_file");
185			if ($ds_ref->{'ds'}) {
186			return $ds_ref->{'ds'};
187			} else {
188			$log->warn("cache entry $cache_file corrupt. Use rm $cache_path/* to re-create it on next run!");
189			undef $self->{'path'};
190	dpavlin	209	}
191			}
192	dpavlin	217	} else {
193			#$log->warn("cache entry $cache_file doesn't exist");
194			return undef;
195	dpavlin	209	}
196
197			return undef;
198			}
199
200			=head2 save_ds
201
202			Store data_structure on disk.
203
204			$db->save_ds(
205			id => $ds->{000}->[0],
206	dpavlin	218	prefix => 'name',
207	dpavlin	209	ds => $ds,
208			);
209
210			B<Totally broken, but fast.>
211
212			Depends on filename generated by C<load_ds>.
213
214			=cut
215
216			sub save_ds {
217			my $self = shift;
218
219			die "can't write to database in read_only mode!" if ($self->{'read_only'});
220
221			return unless($self->{'path'});
222
223			my $arg = {@_};
224
225			my $log = $self->_get_logger;
226
227			foreach my $f (qw/id ds/) {
228			$log->logconfess("need $f") unless ($arg->{$f});
229			}
230
231	dpavlin	218	my $database = $self->{database};
232	dpavlin	217	$log->logconfess("can't find database name") unless ($database);
233	dpavlin	209
234	dpavlin	218	my $prefix = $arg->{prefix} \|\| '';
235	dpavlin	217
236	dpavlin	220	my $cache_file = $self->{path} . "/$prefix#" . $arg->{id};
237	dpavlin	218	$cache_file =~ s#//#/#go;
238
239	dpavlin	209	$log->debug("creating storable cache file $cache_file");
240
241			return store {
242			ds => $arg->{ds},
243			id => $arg->{id},
244			}, $cache_file;
245
246			}
247
248			=head1 AUTHOR
249
250			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
251
252			=head1 COPYRIGHT & LICENSE
253
254			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
255
256			This program is free software; you can redistribute it and/or modify it
257			under the same terms as Perl itself.
258
259			=cut
260
261			1; # End of WebPAC::Store