#-*- perl -*-
#
# Copyright (C) 2005,2008 Ken'ichi Fukamachi
# All rights reserved. This program is free software; you can
# redistribute it and/or modify it under the same terms as Perl itself.
#
# $FML: Outline.pm,v 1.4 2008/08/24 09:57:48 fukachan Exp $
#
package FML::Article::Outline;
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK);
use Carp;
=head1 NAME
FML::Article::Outline - article thread outline.
=head1 SYNOPSIS
=head1 DESCRIPTION
=head1 METHODS
=head2 new(curproc)
constructor.
=cut
# Descriptions: constructor.
# Arguments: OBJ($self) OBJ($curproc)
# Side Effects: none
# Return Value: OBJ(FML::Article)
sub new
{
my ($self, $curproc) = @_;
my ($type) = ref($self) || $self;
my $me = { _curproc => $curproc };
return bless $me, $type;
}
=head1 ARTICLE THREAD OUTLINE
=head2 add_outline($thread_db_args)
add thread outline information to article object.
=cut
# Descriptions: add thread outline information to article object.
# Arguments: OBJ($self) HASH_REF($tdb_args)
# Side Effects: update article.
# Return Value: none
sub add_outline
{
my ($self, $tdb_args) = @_;
my $curproc = $self->{ _curproc };
my $config = $curproc->config();
my $id = $tdb_args->{ id } || -1;
my $charset = $curproc->langinfo_get_charset("reply_message");
# e.g. "iso-2022-jp" => "ja",
use Mail::Message::Charset;
my $cobj = new Mail::Message::Charset;
my $lang = $cobj->message_charset_to_language($charset);
if ($config->yes('use_article_thread_outline')) {
# 1. get thread outline containing article $id within it.
# 2. fix charset as could as possible.
use FML::Article::Thread;
my $article_thread = new FML::Article::Thread $curproc, $tdb_args;
my $_outline = $article_thread->get_outline($id, $tdb_args);
my $outline = $self->_fix_charset($_outline, $charset);
# 3 .apply rules.
my $rules = $config->get_as_array_ref('article_thread_outline_rules');
for my $rule (@$rules) {
my $fp = sprintf("_fp_$rule", $outline, $charset, $lang);
if ($self->can($fp)) {
$self->$fp($outline, $charset, $lang);
}
else {
$curproc->logerror("outline: no such rule: $rule");
}
}
}
}
# Descriptions: fix charset.
# Arguments: OBJ($self) STR($s) STR($charset)
# Side Effects: none
# Return Value: STR
sub _fix_charset
{
my ($self, $s, $charset) = @_;
use Mail::Message::String;
my $str = new Mail::Message::String $s;
$str->charcode_convert($charset);
return $str->as_str();
}
# Descriptions: add thread outline to article header.
# Arguments: OBJ($self) STR($outline) STR($charset) STR($lang)
# Side Effects: update article header.
# Return Value: none
sub _fp_add_outline_to_header
{
my ($self, $outline, $charset, $lang) = @_;
my $curproc = $self->{ _curproc };
my $config = $curproc->config();
my $_hdr = "X-Article-Thread-Outline";
my $hdr_name = $config->{ article_thread_outline_header_field } || $_hdr;
# clean up.
my $_outline = $outline;
$_outline =~ s/^\s*//;
$_outline =~ s/\s*$//;
# add.
my $header = $curproc->article_message_header();
$header->add($hdr_name, $_outline);
}
# Descriptions: prepend thread outline to article body.
# Arguments: OBJ($self) STR($outline) STR($charset) STR($lang)
# Side Effects: update article body.
# Return Value: none
sub _fp_prepend_outline_to_body
{
my ($self, $outline, $charset, $lang) = @_;
$self->_fp_body("prepend", $outline, $charset, $lang);
}
# Descriptions: append thread outline to article body.
# Arguments: OBJ($self) STR($outline) STR($charset) STR($lang)
# Side Effects: update article body.
# Return Value: none
sub _fp_append_outline_to_body
{
my ($self, $outline, $charset, $lang) = @_;
$self->_fp_body("append", $outline, $charset, $lang);
}
# Descriptions: add thread outline to article body.
# Arguments: OBJ($self) STR($fp) STR($outline) STR($charset) STR($lang)
# Side Effects: update article body.
# Return Value: none
sub _fp_body
{
my ($self, $fp, $outline, $charset, $lang) = @_;
my $curproc = $self->{ _curproc };
my $config = $curproc->config();
my $sp = "=" x 60;
my $separator = $config->{ article_thread_outline_body_separator } || $sp;
my $title_key = sprintf("article_thread_outline_greeting_%s" ,$lang);
my $_title = $config->{ $title_key } || '';
my $title = $self->_fix_charset($_title, $charset);
# prepare buffer.
my $_outline = sprintf("%s\n%s\n%s\n%s",
$separator,
$title,
$outline,
$separator);
# append.
if ($fp eq 'prepend' || $fp eq 'append') {
my $body = $curproc->article_message_body();
$body->$fp({
type => "text/plain",
charset => $charset,
data => $_outline,
});
}
}
=head1 CODING STYLE
See C on fml coding style guide.
=head1 AUTHOR
Ken'ichi Fukamachi
=head1 COPYRIGHT
Copyright (C) 2001,2002,2003,2004,2005,2008 Ken'ichi Fukamachi
All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl itself.
=head1 HISTORY
FML::Article first appeared in fml8 mailing list driver package.
See C for more details.
=cut
1;