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.02

=cut

our $VERSION = '0.02';

=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.

You can also example C<< $db->{path} >> to get current cache path.

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

There is also a more verbose form, similar to C<save_ds>

  my $ds = $db->load_ds( id => 42 );

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 $log = $self->_get_logger;

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

        my $id = shift;
        if (lc($id) eq 'id') {
                $id = shift;
                $log->logconfess("got hash, but without key id") unless (defined($id));
                $log->logconfess("got hash, but id isn't number") unless ($id =~ /^\d+$/);
        }

        if (! defined($id)) {
                $log->warn("called without id");
                return undef;
        } else {
                my $cache_file = "$cache_path/$id";
                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_file corrupt. Use rm $cache_path/* to re-create it on next run!");
                                        undef $self->{'path'};
                                }
                        }
                } else {
                        #$log->warn("cache entry $cache_file doesn't exist");
                        return undef;
                }
        }

        return undef;
}

=head2 save_ds

Store data_structure on disk.

  $db->save_ds(
        id => $ds->{000}->[0],
        ds => $ds,
  );

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

        my $arg = {@_};

        my $log = $self->_get_logger;

        foreach my $f (qw/id ds/) {
                $log->logconfess("need $f") unless ($arg->{$f});
        }

        my $cache_file = $self->{path} . '/' . $arg->{id};

        $log->debug("creating storable cache file $cache_file");

        return store {
                ds => $arg->{ds},
                id => $arg->{id},
        }, $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	dpavlin	124	Version 0.02
16	dpavlin	1
17			=cut
18
19	dpavlin	124	our $VERSION = '0.02';
20	dpavlin	1
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	dpavlin	124	You can also example C<< $db->{path} >> to get current cache path.
78
79	dpavlin	18	=cut
80
81			sub path {
82			my $self = shift;
83
84			my $dir = shift;
85
86			my $log = $self->_get_logger();
87
88			if ($dir) {
89			my $msg;
90			if (! -e $dir) {
91			$msg = "doesn't exist";
92			} elsif (! -d $dir) {
93			$msg = "is not directory";
94			} elsif (! -w $dir) {
95	dpavlin	44	$msg = "not writable" unless ($self->{'read_only'});
96	dpavlin	18	}
97
98			if ($msg) {
99	dpavlin	19	$log->warn("cache path $dir $msg, disabling...");
100			undef $self->{'path'};
101	dpavlin	18	} else {
102			$log->debug("using cache dir $dir");
103	dpavlin	19	$self->{'path'} = $dir;
104	dpavlin	18	}
105			} else {
106			$log->debug("disabling cache");
107	dpavlin	19	undef $self->{'path'};
108	dpavlin	18	}
109			}
110
111	dpavlin	22	=head2 load_ds
112	dpavlin	18
113			Retrive from disk one data_structure records using field 000 as key
114
115	dpavlin	124	my $ds = $db->load_ds( 42 );
116	dpavlin	18
117	dpavlin	124	There is also a more verbose form, similar to C<save_ds>
118
119			my $ds = $db->load_ds( id => 42 );
120
121	dpavlin	18	This function will also perform basic sanity checking on returned
122			data and disable caching if data is corrupted (or changed since last
123			update).
124
125	dpavlin	70	Returns hash or undef if cacheing is disabled or unavailable.
126	dpavlin	18
127			=cut
128
129	dpavlin	22	sub load_ds {
130	dpavlin	18	my $self = shift;
131
132			return unless $self->{'path'};
133
134			my $log = $self->_get_logger;
135
136			my $cache_path = $self->{'path'};
137
138	dpavlin	124	my $id = shift;
139			if (lc($id) eq 'id') {
140			$id = shift;
141			$log->logconfess("got hash, but without key id") unless (defined($id));
142			$log->logconfess("got hash, but id isn't number") unless ($id =~ /^\d+$/);
143			}
144	dpavlin	18
145	dpavlin	124	if (! defined($id)) {
146			$log->warn("called without id");
147			return undef;
148	dpavlin	18	} else {
149			my $cache_file = "$cache_path/$id";
150			if (-r $cache_file) {
151			my $ds_ref = retrieve($cache_file);
152			if ($ds_ref) {
153			$log->debug("cache hit: $cache_file");
154			my $ok = 1;
155	dpavlin	124	# foreach my $f (qw(current_filename headline)) {
156			# if ($ds_ref->{$f}) {
157			# $self->{$f} = $ds_ref->{$f};
158			# } else {
159			# $ok = 0;
160			# }
161			# };
162	dpavlin	18	if ($ok && $ds_ref->{'ds'}) {
163	dpavlin	70	return $ds_ref->{'ds'};
164	dpavlin	18	} else {
165	dpavlin	124	$log->warn("cache entry $cache_file corrupt. Use rm $cache_path/* to re-create it on next run!");
166	dpavlin	18	undef $self->{'path'};
167			}
168			}
169	dpavlin	50	} else {
170	dpavlin	127	#$log->warn("cache entry $cache_file doesn't exist");
171	dpavlin	50	return undef;
172	dpavlin	18	}
173			}
174
175			return undef;
176			}
177
178	dpavlin	22	=head2 save_ds
179	dpavlin	18
180			Store data_structure on disk.
181
182	dpavlin	22	$db->save_ds(
183	dpavlin	124	id => $ds->{000}->[0],
184	dpavlin	70	ds => $ds,
185	dpavlin	18	);
186
187			B<Totally broken, but fast.>
188
189	dpavlin	22	Depends on filename generated by C<load_ds>.
190	dpavlin	18
191			=cut
192
193	dpavlin	22	sub save_ds {
194	dpavlin	18	my $self = shift;
195
196	dpavlin	44	die "can't write to database in read_only mode!" if ($self->{'read_only'});
197
198	dpavlin	18	return unless($self->{'path'});
199
200			my $arg = {@_};
201
202			my $log = $self->_get_logger;
203
204	dpavlin	124	foreach my $f (qw/id ds/) {
205			$log->logconfess("need $f") unless ($arg->{$f});
206			}
207	dpavlin	18
208	dpavlin	124	my $cache_file = $self->{path} . '/' . $arg->{id};
209	dpavlin	113
210	dpavlin	124	$log->debug("creating storable cache file $cache_file");
211	dpavlin	18
212	dpavlin	124	return store {
213			ds => $arg->{ds},
214			id => $arg->{id},
215			}, $cache_file;
216	dpavlin	18
217			}
218
219	dpavlin	1	=head1 AUTHOR
220
221			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
222
223			=head1 COPYRIGHT & LICENSE
224
225			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
226
227			This program is free software; you can redistribute it and/or modify it
228			under the same terms as Perl itself.
229
230			=cut
231
232			1; # End of WebPAC::DB