lib/WebPAC/Store.pm

package WebPAC::Store;

use warnings;
use strict;

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

=head1 NAME

WebPAC::Store - Store normalized data on disk

=head1 VERSION

Version 0.04

=cut

our $VERSION = '0.04';

=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/',
        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 using field 000 as key

  my $ds = $db->load_ds( 42 );

There is also a more verbose form, similar to C<save_ds>

  my $ds = $db->load_ds( 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).

Returns hash or undef if cacheing is disabled or unavailable.

=cut

sub load_ds {
        my $self = shift;

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

        my $log = $self->_get_logger;

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

        my $id = shift;
        if (lc($id) eq 'id') {
                $id = shift;
                $log->logconfess("got hash, but without key id") unless (defined($id));
                $log->logconfess("got hash, but id isn't number") unless ($id =~ /^\d+$/);
        }

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