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'};
                                }
                        }
                }
        }

        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			}
164			}
165
166			return undef;
167			}
168
169	dpavlin	22	=head2 save_ds
170	dpavlin	18
171			Store data_structure on disk.
172
173	dpavlin	22	$db->save_ds(
174	dpavlin	18	ds => \@ds,
175			current_filename => $self->{'current_filename'},
176			headline => $self->{'headline'},
177			);
178
179			B<Totally broken, but fast.>
180
181	dpavlin	22	Depends on filename generated by C<load_ds>.
182	dpavlin	18
183			=cut
184
185	dpavlin	22	sub save_ds {
186	dpavlin	18	my $self = shift;
187
188	dpavlin	44	die "can't write to database in read_only mode!" if ($self->{'read_only'});
189
190	dpavlin	18	return unless($self->{'path'});
191			return unless (@_);
192
193			my $arg = {@_};
194
195			my $log = $self->_get_logger;
196
197	dpavlin	22	$log->logdie("save_ds without cache_file -- did you called gs_get before?") unless ($self->{'cache_file'});
198	dpavlin	18
199			foreach my $e (qw/ds current_filename headline/) {
200	dpavlin	40	$log->logconfess("missing $e") unless $arg->{$e};
201	dpavlin	18	}
202
203			$log->debug("creating storable cache file ",$self->{'cache_file'});
204
205			store {
206			ds => $arg->{'ds'},
207			current_filename => $arg->{'current_filename'},
208			headline => $arg->{'headline'},
209			}, $self->{'cache_file'};
210
211			}
212
213	dpavlin	1	=head1 AUTHOR
214
215			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
216
217			=head1 COPYRIGHT & LICENSE
218
219			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
220
221			This program is free software; you can redistribute it and/or modify it
222			under the same terms as Perl itself.
223
224			=cut
225
226			1; # End of WebPAC::DB