lib/WebPAC/Store.pm

package WebPAC::Store;

use warnings;
use strict;

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

=head1 NAME

WebPAC::Store - Store normalized data on disk

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';

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