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