lib/WebPAC/DB.pm

package WebPAC::DB;

use warnings;
use strict;

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

=head1 NAME

WebPAC::DB - Store normalized data on disk

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=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::DB;

    my $foo = WebPAC::DB->new();
    ...

=head1 FUNCTIONS

=head2 new

Create new normalised database object

  my $db = new WebPAC::DB(
        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.

=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($rec);

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

Returns array or undef if cacheing is disabled or unavailable.

=cut

sub load_ds {
        my $self = shift;

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

        my $rec = shift || return;

        my $log = $self->_get_logger;

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

        my $id = $rec;
        $id = $rec->{'000'} if (ref($id) eq 'HASH');
        $id = $rec->{'000'}->[0] if (ref($id) eq 'ARRAY');

        unless (defined($id)) {
                $log->warn("Can't use cacheing on records without unique identifier in field 000");
                undef $self->{'path'};
        } else {
                my $cache_file = "$cache_path/$id";
                $self->{'cache_file'} = $cache_file;
                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_path corrupt. Use rm $cache_path/* to re-create it on next run!");
                                        undef $self->{'path'};
                                }
                        }
                } else {
                        return undef;
                }
        }

        return undef;
}

=head2 save_ds

Store data_structure on disk.

  $db->save_ds(
        ds => \@ds,
        current_filename => $self->{'current_filename'},
        headline => $self->{'headline'},
  );

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'});
        return unless (@_);

        my $arg = {@_};

        my $log = $self->_get_logger;

        $log->logdie("save_ds without cache_file -- did you called gs_get before?") unless ($self->{'cache_file'});

        foreach my $e (qw/ds current_filename headline/) {
                $log->logconfess("missing $e") unless $arg->{$e};
        }

        $log->debug("creating storable cache file ",$self->{'cache_file'});

        store {
                ds => $arg->{'ds'},
                current_filename => $arg->{'current_filename'},
                headline => $arg->{'headline'},
        }, $self->{'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::DB
1	dpavlin	1	package WebPAC::DB;
2
3			use warnings;
4			use strict;
5
6	dpavlin	18	use base 'WebPAC::Common';
7			use Storable;
8
9	dpavlin	1	=head1 NAME
10
11	dpavlin	18	WebPAC::DB - Store normalized data on disk
12	dpavlin	1
13			=head1 VERSION
14
15			Version 0.01
16
17			=cut
18
19			our $VERSION = '0.01';
20
21			=head1 SYNOPSIS
22
23	dpavlin	18	This module provides disk storage for normalised data.
24	dpavlin	1
25	dpavlin	18	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	dpavlin	1
29	dpavlin	18	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	dpavlin	1	use WebPAC::DB;
35
36			my $foo = WebPAC::DB->new();
37			...
38
39			=head1 FUNCTIONS
40
41	dpavlin	18	=head2 new
42	dpavlin	1
43	dpavlin	18	Create new normalised database object
44
45			my $db = new WebPAC::DB(
46	dpavlin	44	path => '/path/to/cache/ds/',
47			read_only => 1,
48	dpavlin	18	);
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	dpavlin	44	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	dpavlin	1	=cut
57
58	dpavlin	18	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	dpavlin	1	}
67
68	dpavlin	18	=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			=cut
78
79			sub path {
80			my $self = shift;
81
82			my $dir = shift;
83
84			my $log = $self->_get_logger();
85
86			if ($dir) {
87			my $msg;
88			if (! -e $dir) {
89			$msg = "doesn't exist";
90			} elsif (! -d $dir) {
91			$msg = "is not directory";
92			} elsif (! -w $dir) {
93	dpavlin	44	$msg = "not writable" unless ($self->{'read_only'});
94	dpavlin	18	}
95
96			if ($msg) {
97	dpavlin	19	$log->warn("cache path $dir $msg, disabling...");
98			undef $self->{'path'};
99	dpavlin	18	} else {
100			$log->debug("using cache dir $dir");
101	dpavlin	19	$self->{'path'} = $dir;
102	dpavlin	18	}
103			} else {
104			$log->debug("disabling cache");
105	dpavlin	19	undef $self->{'path'};
106	dpavlin	18	}
107			}
108
109	dpavlin	22	=head2 load_ds
110	dpavlin	18
111			Retrive from disk one data_structure records using field 000 as key
112
113	dpavlin	22	my @ds = $db->load_ds($rec);
114	dpavlin	18
115			This function will also perform basic sanity checking on returned
116			data and disable caching if data is corrupted (or changed since last
117			update).
118
119			Returns array or undef if cacheing is disabled or unavailable.
120
121			=cut
122
123	dpavlin	22	sub load_ds {
124	dpavlin	18	my $self = shift;
125
126			return unless $self->{'path'};
127
128			my $rec = shift \|\| return;
129
130			my $log = $self->_get_logger;
131
132			my $cache_path = $self->{'path'};
133
134	dpavlin	44	my $id = $rec;
135			$id = $rec->{'000'} if (ref($id) eq 'HASH');
136			$id = $rec->{'000'}->[0] if (ref($id) eq 'ARRAY');
137	dpavlin	18
138			unless (defined($id)) {
139			$log->warn("Can't use cacheing on records without unique identifier in field 000");
140			undef $self->{'path'};
141			} else {
142			my $cache_file = "$cache_path/$id";
143			$self->{'cache_file'} = $cache_file;
144			if (-r $cache_file) {
145			my $ds_ref = retrieve($cache_file);
146			if ($ds_ref) {
147			$log->debug("cache hit: $cache_file");
148			my $ok = 1;
149			foreach my $f (qw(current_filename headline)) {
150			if ($ds_ref->{$f}) {
151			$self->{$f} = $ds_ref->{$f};
152			} else {
153			$ok = 0;
154			}
155			};
156			if ($ok && $ds_ref->{'ds'}) {
157			return @{ $ds_ref->{'ds'} };
158			} else {
159			$log->warn("cache entry $cache_path corrupt. Use rm $cache_path/* to re-create it on next run!");
160			undef $self->{'path'};
161			}
162			}
163	dpavlin	50	} else {
164			return undef;
165	dpavlin	18	}
166			}
167
168			return undef;
169			}
170
171	dpavlin	22	=head2 save_ds
172	dpavlin	18
173			Store data_structure on disk.
174
175	dpavlin	22	$db->save_ds(
176	dpavlin	18	ds => \@ds,
177			current_filename => $self->{'current_filename'},
178			headline => $self->{'headline'},
179			);
180
181			B<Totally broken, but fast.>
182
183	dpavlin	22	Depends on filename generated by C<load_ds>.
184	dpavlin	18
185			=cut
186
187	dpavlin	22	sub save_ds {
188	dpavlin	18	my $self = shift;
189
190	dpavlin	44	die "can't write to database in read_only mode!" if ($self->{'read_only'});
191
192	dpavlin	18	return unless($self->{'path'});
193			return unless (@_);
194
195			my $arg = {@_};
196
197			my $log = $self->_get_logger;
198
199	dpavlin	22	$log->logdie("save_ds without cache_file -- did you called gs_get before?") unless ($self->{'cache_file'});
200	dpavlin	18
201			foreach my $e (qw/ds current_filename headline/) {
202	dpavlin	40	$log->logconfess("missing $e") unless $arg->{$e};
203	dpavlin	18	}
204
205			$log->debug("creating storable cache file ",$self->{'cache_file'});
206
207			store {
208			ds => $arg->{'ds'},
209			current_filename => $arg->{'current_filename'},
210			headline => $arg->{'headline'},
211			}, $self->{'cache_file'};
212
213			}
214
215	dpavlin	1	=head1 AUTHOR
216
217			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
218
219			=head1 COPYRIGHT & LICENSE
220
221			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
222
223			This program is free software; you can redistribute it and/or modify it
224			under the same terms as Perl itself.
225
226			=cut
227
228			1; # End of WebPAC::DB