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 hash 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	package WebPAC::DB;
2
3	use warnings;
4	use strict;
5
6	use base 'WebPAC::Common';
7	use Storable;
8
9	=head1 NAME
10
11	WebPAC::DB - Store normalized data on disk
12
13	=head1 VERSION
14
15	Version 0.01
16
17	=cut
18
19	our $VERSION = '0.01';
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::DB;
35
36	my $foo = WebPAC::DB->new();
37	...
38
39	=head1 FUNCTIONS
40
41	=head2 new
42
43	Create new normalised database object
44
45	my $db = new WebPAC::DB(
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	=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	$msg = "not writable" unless ($self->{'read_only'});
94	}
95
96	if ($msg) {
97	$log->warn("cache path $dir $msg, disabling...");
98	undef $self->{'path'};
99	} else {
100	$log->debug("using cache dir $dir");
101	$self->{'path'} = $dir;
102	}
103	} else {
104	$log->debug("disabling cache");
105	undef $self->{'path'};
106	}
107	}
108
109	=head2 load_ds
110
111	Retrive from disk one data_structure records using field 000 as key
112
113	my $ds = $db->load_ds($rec);
114
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 hash or undef if cacheing is disabled or unavailable.
120
121	=cut
122
123	sub load_ds {
124	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	my $id = $rec;
135	$id = $rec->{'000'} if (ref($id) eq 'HASH');
136	$id = $rec->{'000'}->[0] if (ref($id) eq 'ARRAY');
137
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	} else {
164	return undef;
165	}
166	}
167
168	return undef;
169	}
170
171	=head2 save_ds
172
173	Store data_structure on disk.
174
175	$db->save_ds(
176	ds => $ds,
177	current_filename => $self->{'current_filename'},
178	headline => $self->{'headline'},
179	);
180
181	B<Totally broken, but fast.>
182
183	Depends on filename generated by C<load_ds>.
184
185	=cut
186
187	sub save_ds {
188	my $self = shift;
189
190	die "can't write to database in read_only mode!" if ($self->{'read_only'});
191
192	return unless($self->{'path'});
193	return unless (@_);
194
195	my $arg = {@_};
196
197	my $log = $self->_get_logger;
198
199	$log->logdie("save_ds without cache_file -- did you called gs_get before?") unless ($self->{'cache_file'});
200
201	foreach my $e (qw/ds current_filename headline/) {
202	$log->logconfess("missing $e") unless $arg->{$e};
203	}
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	=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