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

=cut

our $VERSION = '0.05';

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

=cut

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

        $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, database => 'name' );

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

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 isn't number") unless ($id =~ /^\d+$/);

        my $database = $args->{database} || $self->{database};

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

        my $cache_file = "$cache_path/$database#$id";
        $cache_file =~ s#//#/#g;

        $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],
        database => '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 = $arg->{database} ||  $self->{database};
        $log->logconfess("can't find database name") unless ($database);

        my $cache_file = $self->{path} . '/' . $database . '#' . $arg->{id};

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