File Coverage

blib/lib/WE_Frontend/Plugin/KeywordIndex.pm

Criterion	Covered	Total	%
statement	18	45	40.0
branch	0	2	0.0
condition	0	2	0.0
subroutine	6	10	60.0
pod	2	3	66.6
total	26	62	41.9

# -*- perl -*-

#
# $Id: KeywordIndex.pm,v 1.3 2004/01/28 16:49:59 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 2003 Slaven Rezic.
# This is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License, see the file COPYING.

#
# Mail: [e-mail]
# WWW:  http://we-framework.sourceforge.net
#

package WE_Frontend::Plugin::KeywordIndex;
use base qw(Template::Plugin);

use HTML::Entities;

use WE::Util::LangString qw(langstring);
use WE_Frontend::Plugin::WE_Navigation;

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

=head1 NAME

WE_Frontend::Plugin::KeywordIndex - gather site keywords

=head1 SYNOPSIS

    my $t = Template->new({PLUGIN_BASE => "WE_Frontend::Plugin"});

    [% USE KeywordIndex %]
    [% SET keywords = KeywordIndex.array() %]

=head1 DESCRIPTION

Gather keywords and return them to the templating system.

=head2 METHODS

=over

=cut

sub new {
    my($class, $context, $params) = @_;
    my $n = WE_Frontend::Plugin::WE_Navigation->new($context, $params);
    my $self = { WE_Navigation => $n,
		 Context => $context,
	       };
    bless $self, $class;
}

# XXX Possible args:
# * $lang
# * keyword-normalizer as a anonymous subroutine
# * restrictions (use is_released_object or such?)
sub gather_keywords {
    my($self, $rootid, %args) = @_;
    my $wen   = $self->{WE_Navigation};
    my $objdb = $wen->{ObjDB};
    my $lang  = $wen->{Context}->stash->get("lang") || "en";
    $rootid   = $objdb->root_object->Id;
    my %keywords;
    $objdb->walk($rootid,
		 sub {
		     my($id) = @_;
		     my $o = $objdb->get_object($id);
		     my $s = langstring($o->Keywords, $lang);
		     return if !defined $s;
		     my @keywords = split /\s*,\s*/, $s;
		     for my $kw (@keywords) {
			 push @{ $keywords{$kw} },
			     {
			      Id => $id,
			      Title => langstring($o->Title, $lang),
			      Relurl => "$id.html", # XXX do not hardcode extension, use NameDB if possible
			     };
		     }
		 });
    \%keywords;
}

=item array()

Format and output the given text definition.

=cut

# XXX Possible %args:
# * interpolate initials into the result array
# * sort function
sub array {
    my($self) = @_;
    my $keywords = $self->gather_keywords(); # XXX supply objid and %args (from params?)
    my @out;
    for my $kw (sort { uc $a cmp uc $b } keys %$keywords) {
	push @out, {Keyword    => $kw,
		    References => $keywords->{$kw},
		   };
    }
    return \@out;
}

1;

__END__