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/',
  );

Optional parameter C<path> defines path to directory
in which cache file for C<data_structure> call will be created.

=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";
                }

                if ($msg) {
                        undef $self->{'cache_data_structure'};
                        $log->warn("cache_data_structure $dir $msg, disabling...");
                } else {
                        $log->debug("using cache dir $dir");
                }
        } else {
                $log->debug("disabling cache");
                undef $self->{'cache_data_structure'};
        }
}

=head2 load_gs

Retrive from disk one data_structure records using field 000 as key

  my @ds = $db->load_gs($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_gs {
        my $self = shift;

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

        my $rec = shift || return;

        my $log = $self->_get_logger;

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

        my $id = $rec->{'000'};
        $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);

        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_gs

Store data_structure on disk.

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

B<Totally broken, but fast.>

Depends on filename generated by C<load_gs>.

=cut

sub save_gs {
        my $self = shift;

        return unless($self->{'path'});
        return unless (@_);

        my $arg = {@_};

        my $log = $self->_get_logger;

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

        foreach my $e (qw/ds current_filename headline/) {
                $log->logdie("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			path = '/path/to/cache/ds/',
47			);
48
49			Optional parameter C<path> defines path to directory
50			in which cache file for C<data_structure> call will be created.
51
52	dpavlin	1	=cut
53
54	dpavlin	18	sub new {
55			my $class = shift;
56			my $self = {@_};
57			bless($self, $class);
58
59			$self->path( $self->{'path'} );
60
61			$self ? return $self : return undef;
62	dpavlin	1	}
63
64	dpavlin	18	=head2 path
65
66			Check if specified cache directory exist, and if not, disable caching.
67
68			$db->path('./cache/ds/');
69
70			If you pass false or zero value to this function, it will disable
71			cacheing.
72
73			=cut
74
75			sub path {
76			my $self = shift;
77
78			my $dir = shift;
79
80			my $log = $self->_get_logger();
81
82			if ($dir) {
83			my $msg;
84			if (! -e $dir) {
85			$msg = "doesn't exist";
86			} elsif (! -d $dir) {
87			$msg = "is not directory";
88			} elsif (! -w $dir) {
89			$msg = "not writable";
90			}
91
92			if ($msg) {
93			undef $self->{'cache_data_structure'};
94			$log->warn("cache_data_structure $dir $msg, disabling...");
95			} else {
96			$log->debug("using cache dir $dir");
97			}
98			} else {
99			$log->debug("disabling cache");
100			undef $self->{'cache_data_structure'};
101			}
102			}
103
104			=head2 load_gs
105
106			Retrive from disk one data_structure records using field 000 as key
107
108			my @ds = $db->load_gs($rec);
109
110			This function will also perform basic sanity checking on returned
111			data and disable caching if data is corrupted (or changed since last
112			update).
113
114			Returns array or undef if cacheing is disabled or unavailable.
115
116			=cut
117
118			sub load_gs {
119			my $self = shift;
120
121			return unless $self->{'path'};
122
123			my $rec = shift \|\| return;
124
125			my $log = $self->_get_logger;
126
127			my $cache_path = $self->{'path'};
128
129			my $id = $rec->{'000'};
130			$id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);
131
132			unless (defined($id)) {
133			$log->warn("Can't use cacheing on records without unique identifier in field 000");
134			undef $self->{'path'};
135			} else {
136			my $cache_file = "$cache_path/$id";
137			$self->{'cache_file'} = $cache_file;
138			if (-r $cache_file) {
139			my $ds_ref = retrieve($cache_file);
140			if ($ds_ref) {
141			$log->debug("cache hit: $cache_file");
142			my $ok = 1;
143			foreach my $f (qw(current_filename headline)) {
144			if ($ds_ref->{$f}) {
145			$self->{$f} = $ds_ref->{$f};
146			} else {
147			$ok = 0;
148			}
149			};
150			if ($ok && $ds_ref->{'ds'}) {
151			return @{ $ds_ref->{'ds'} };
152			} else {
153			$log->warn("cache entry $cache_path corrupt. Use rm $cache_path/* to re-create it on next run!");
154			undef $self->{'path'};
155			}
156			}
157			}
158			}
159
160			return undef;
161			}
162
163			=head2 save_gs
164
165			Store data_structure on disk.
166
167			$db->save_gs(
168			ds => \@ds,
169			current_filename => $self->{'current_filename'},
170			headline => $self->{'headline'},
171			);
172
173			B<Totally broken, but fast.>
174
175			Depends on filename generated by C<load_gs>.
176
177			=cut
178
179			sub save_gs {
180			my $self = shift;
181
182			return unless($self->{'path'});
183			return unless (@_);
184
185			my $arg = {@_};
186
187			my $log = $self->_get_logger;
188
189			$log->logdie("save_gs without cache_file -- did you called gs_get before?") unless ($self->{'cache_file'});
190
191			foreach my $e (qw/ds current_filename headline/) {
192			$log->logdie("missing $e") unless $arg->{$e};
193			}
194
195			$log->debug("creating storable cache file ",$self->{'cache_file'});
196
197			store {
198			ds => $arg->{'ds'},
199			current_filename => $arg->{'current_filename'},
200			headline => $arg->{'headline'},
201			}, $self->{'cache_file'};
202
203			}
204
205	dpavlin	1	=head1 AUTHOR
206
207			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
208
209			=head1 COPYRIGHT & LICENSE
210
211			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
212
213			This program is free software; you can redistribute it and/or modify it
214			under the same terms as Perl itself.
215
216			=cut
217
218			1; # End of WebPAC::DB