[webpac2] / 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'});

        $log->logdie("need ds") unless ($arg->{ds});

        foreach my $e (qw/current_filename headline/) {
                my $mfn = $arg->{ds}->{000}->[0] || '?';
                $log->warn("missing $e in record $mfn") 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