File Coverage

blib/lib/WE/DB/Glossary.pm

Criterion	Covered	Total	%
statement	34	91	37.3
branch	9	44	20.4
condition	0	3	0.0
subroutine	8	15	53.3
pod	6	6	100.0
total	57	159	35.8

# -*- perl -*-

#
# $Id: Glossary.pm,v 1.5 2004/02/23 07:27:49 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 2002 Slaven Rezic. All rights reserved.
#
# Mail: [e-mail]
# WWW:  http://rezic.de/eserte
#

package WE::DB::Glossary;

use base qw(Class::Accessor);
__PACKAGE__->mk_accessors(qw(DB Root));

use strict;
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);

use MLDBM;
use Fcntl;

{
    package WE::GlossaryObj;
    use base qw(Class::Accessor);
    __PACKAGE__->mk_accessors
	(qw(Keyword Description));
    sub new { bless {}, $_[0] }
}

{
    # this will be written to the database and should not be used otherwise
    package WE::DB::Glossary::DBInfo;
    use base qw(Class::Accessor);
    __PACKAGE__->mk_accessors(qw());
    sub new { bless {}, $_[0] }
}

sub new {
    my($class, $root, $file, %args) = @_;
    my $self = {};

    $args{-db}         = "DB_File" unless defined $args{-db};
    $args{-serializer} = "Data::Dumper" unless defined $args{-serializer};
    $args{-locking}    = 0 unless defined $args{-locking};
    $args{-readonly}   = 0 unless defined $args{-readonly};
    $args{-writeonly}  = 0 unless defined $args{-writeonly};

    my @tie_args;
    if ($args{-readonly}) {
	push @tie_args, O_RDONLY;
    } elsif ($args{-writeonly}) {
	push @tie_args, O_RDWR;
    } else {
	push @tie_args, O_RDWR|O_CREAT;
    }

    push @tie_args, $args{-db} eq 'Tie::TextDir' ? 0770 : 0660;

    if ($args{-db} eq 'DB_File') {
	require DB_File;
	push @tie_args, $DB_File::DB_BTREE;
	if ($args{-locking}) {
	    $MLDBM::UseDB = 'DB_File::Lock';
	    push @tie_args, $args{-readonly} ? "read" : "write";
	} else {
	    $MLDBM::UseDB = 'DB_File';
	}
    } else {
	$MLDBM::UseDB = $args{-db};
    }

    $MLDBM::Serializer = $args{-serializer};

    tie %{ $self->{DB} }, 'MLDBM', $file, @tie_args
	or require Carp, Carp::confess("Can't tie MLDBM database $file with args <@tie_args>, db <$MLDBM::UseDB> and serializer <$MLDBM::Serializer>: $!");

    bless $self, $class;
    $self->Root($root);

    # read database information
    my $db_info = $self->DB->{__DBINFO__};
    if (!defined $db_info) {
	$db_info = $self->DB->{__DBINFO__} = new WE::DB::Glossary::DBInfo;
    }
    # sync members with DBINFO
    if ($db_info) {
      # none yet
    }
    # set %args
    # none yet
    # write back database information
    if (!$args{-readonly}) {
	$self->DB->{__DBINFO__} = $db_info;
    }

    $self;
}

sub add_entry {
    my($self, @args) = @_;
    my %args;
    for(my $i=0; $i<=$#args; $i++) {
	if ($args[$i] =~ /^-/) {
	    $args{$args[$i]} = $args[$i+1];
	    splice @args, $i, 2;
	    $i--;
	}
    }

    my $obj;
    if (UNIVERSAL::isa($args[0], "WE::GlossaryObj")) {
	$obj = $args[0];
    } else {
	my %obj_args = @args;
	$obj = WE::GlossaryObj->new;
	$obj->$_($obj_args{$_}) for (qw(Keyword Description));
    }

    if (exists $self->{DB}->{$obj->Keyword}) {
	if (!$args{-force}) {
	    require Carp, Carp::confess("There is already a glossary entry for keyword " . $obj->Keyword);
	}
    }

    $self->{DB}->{$obj->Keyword} = $obj;
    $obj;
}

sub delete_entry {
    my($self, $keyword) = @_;
    delete $self->{DB}->{$keyword};
}

sub get_entry {
    my($self, $keyword) = @_;
    $self->{DB}->{$keyword};
}

sub get_descr {
    my($self, $keyword) = @_;
    my $obj = $self->get_entry($keyword);
    return undef if !$obj;
    $obj->Description;
}

sub all_keywords_regex {
    my($self, $filter) = @_;
    my @keywords;
    while(my($k,$v) = each %{ $self->{DB} }) {
	next if $k =~ /^__/; # skip special keys
	next if ($filter && !$filter->($k));
	push @keywords, $k;
    }
    "(" . join("|", map { "\\b" . quotemeta($_) . "\\b" } @keywords) . ")";
}

1;

__END__