messaging/bunshin/Bunshin.pm


=head1 NAME

Bunshin --- A shimbun implemrntion written in Perl

=cut

package Bunshin;
use strict;
use vars qw($DEBUG $MYNAME $VERSION);
$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
$MYNAME = 'Bunshin';
$DEBUG = 0;
use FileHandle;
require Message::Entity;
require Message::Util;
require Message::Field::Date;

sub new ($;%) {
  my $class = shift;
  my $self = bless {}, $class;
  $self->{fmt2str} = Message::Util::make_clone
    (\%Message::Field::Date::FMT2STR);
  $self;
}

=item $b->msg_regex ($regex)

Set regex used to cut a message.

=cut

sub set_regex ($$$) {
  my $self = shift;
  my $name = shift;
  my $regex = shift;
  $regex =~ s/\x20/\\x20/g;
  $regex =~ s/\x09/\\x09/g;
  $regex =~ s/\x0D(?!\x0A)/\x0D\x0A/g;
  $regex =~ s/(?<!\x0D)\x0A/\x0D\x0A/g;
  $regex =~ s/\x0D/\\x0D/g;
  $regex =~ s/\x0A/\\x0A/g;
  $regex =~ s/\x23/\\x23/g;
  $self->{'regex_'.$name} = $regex;
}

sub set_hook_function ($$\&) {
  my $self = shift;
  my $name = shift;
  my $function = shift;
  $self->{'hook_'.$name} = $function;
}

sub set_element_decoders ($%) {
  my $self = shift;
  my %list = @_;
  for (keys %list) {
    if ($list{$_} eq 'enentity_html') {
      $list{$_} = \&Message::Util::enentity_html;
    } elsif ($list{$_} eq 'deentity_html') {
      $list{$_} = \&Message::Util::deentity_html;
    ## TODO: escape_uri, unescape_uri
    }
  }
  $self->{element_decoder} = %list;
}

sub set_format ($$\&) {
  my $self = shift;
  my $name = shift;
  my $function = shift;
  $self->{fmt2str}->{$name} = $function;
}

sub set_elements ($$@) {
  my $self = shift;
  my $name = shift;
  $self->{'elements_'.$name} = \@_;
}

sub set_source ($%) {
  my $self = shift;
  my %option = @_;
  ($self->{source}, $self->{meta_info}) = $self->_get_resource (%option);
  $self->default_parameter (base_uri => $option{uri}) if $option{uri};
        ## BUG: Doesn't support redirection
  if ($option{uri} || $option{file}) {
    my $c = $self->{hook_code_conversion} || \&_code_conversion;
    $self->{source} = &$c ($self, $self->{source}, \%option, $self->{meta_info});
  }
  $self->{source} =~ s/\x0D(?!\x0A)/\x0D\x0A/g;
  $self->{source} =~ s/(?<!\x0D)\x0A/\x0D\x0A/g;
  $self;
}

sub _get_resource ($%) {
  my $self = shift;
  my %option = @_;
  my ($resource, $meta);
  if (defined $option{value}) {
    $resource = $option{value};
  } elsif ($option{uri}) {
    require Message::Field::UA;
    require LWP::UserAgent;
    my $ua = Message::Field::UA->new;
    $ua->add_our_name;
    $ua->add ('libwww-perl' => $LWP::VERSION);
    my $lwp = LWP::UserAgent->new;
    $lwp->agent ($ua->stringify);
    my $req = HTTP::Request->new (GET => $option{uri});
    my $res = $lwp->request ($req);
    $resource = $res->content;
    $meta = parse Message::Header $res->headers_as_string,
      -parse_all => 0, -format => 'http-response',
    ;
  } elsif ($option{file}) {
    my $f = new FileHandle $option{file} => 'r';
    Carp::croak "set_source: $option{file}: $!" unless defined $f;
    my $c = $self->{hook_code_conversion} || \&_code_conversion;
    local $/ = undef;
    $resource = $f->getline;
  } else {
    Carp::croak "_get_resource: $_[0]: Unsupported data source type";
  }
  ($resource, $meta);
}

## $self->_code_conversion ($string, \%option, $meta_info)
sub _code_conversion ($$\%$) {
  $_[1];
}

sub make_msgs ($) {
  my $self = shift;
  my $s = $self->{source};
  my $f = $self->{hook_make_msg} || \&_make_a_msg;
  my @msg;
  my %param = %{$self->{default_parameter}};
  if ($self->{regex_metainfo} && ref $self->{elements_metainfo}) {
    $s =~ s{ $self->{regex_metainfo} }{
      no strict 'refs';
      for my $i (0..$#{$self->{elements_metainfo}}) {
        $param{$self->{elements_metainfo}->[$i]} = ${$i+1};
      }
      $&;
    }esx;
  }
  $s =~ s{ $self->{regex_message} }{
    no strict 'refs';
    my %p = %param;
    for my $i (0..$#{$self->{elements_message}}) {
      $p{$self->{elements_message}->[$i]} = ${$i+1};
    }
    for my $n (keys %{$self->{element_decoder}}) {
      if ($p{$n} && ref $self->{element_decoder}->{$n}) {
        $p{$n} = &{ $self->{element_decoder}->{$n} } ($p{$n});
      }
    }
    my $msg = &$f ($self, %p);
    push @msg, $msg;
  }gesx;
  @msg;
}

## Default function for "make_msg"
sub _make_a_msg ($@) {
  my $self = shift;
  my %p = @_;
  my $msg = new Message::Entity
    -fill_date  => 0,
    -fill_msgid => 0,
    -fill_ua_name       => 'x-shimbun-agent',
    -format     => 'news-usefor',
    -parse_all  => 1,
  ;
  my $hdr = $msg->header;
  ## Originator and date
    my $from = $hdr->field ('from')->add ($p{from_mail} || 'foo@bar.invalid');
    $from->display_name ($p{from_name}) if length $p{from_name};
    my $date = $hdr->field ('date');
    $p{date_year} ||= (gmtime)[5];
    $date->set_datetime (@p{qw/date_year date_month
      date_day date_hour date_minute date_second/},
      zone => $p{date_zone});
    $hdr->add (x_uri => $p{from_uri}) if $p{from_uri};
    if ($p{from_face}) {
      $msg->header->field ('x-face')->value ($p{from_face});
    } elsif ($p{faces}->{$p{from_mail}}) {
      $msg->header->field ('x-face')->value ($p{faces}->{$p{from_mail}});
    } elsif ($p{list_face}) {
      $msg->header->field ('x-face')->value ($p{list_face});
    }
  ## Message attribute
    if (length $p{msg_id}) {
      $hdr->add ('message-id' => $p{msg_id});
    } elsif ($p{msg_id_from} || $p{msg_id_right} || $p{list_id}) {
      my $c = $p{msg_count};
      $c = '.d'.(0+$date) unless defined $p{msg_count};
      my $mid;
      if ($p{msg_id_from}) {
        $mid = sprintf '<msg%s.BS%%%s%%%s>', $c, $p{list_id}, $p{msg_id_from};
      } elsif ($p{msg_id_right}) {
        $mid = sprintf '<msg%s.BS%%%s%%list@%s>', $c, $p{list_id}, $p{msg_id_right};
      } else { #if ($p{list_id}) {
        $mid = sprintf '<msg%s.BS%%list@%s>', $c, $p{list_id};
      }
      $hdr->add (($DEBUG?'x-':'').'message-id' => $mid);
    }
    if (length $p{subject}) {
      $hdr->add (subject => $p{subject});
    } elsif (length $p{DEFAULT_subject}) {
      $hdr->add (subject => $p{DEFAULT_subject});
    }
    my $a;
    for (grep {/^misc_/} keys %p) {
      $a = $hdr->field ('content-x-properties') unless ref $a;
      my $name = substr ($_, 5);
      $name =~ tr/_/-/;
      if ($p{base_uri} && /uri/ && length $p{$_}) {
        require URI::WithBase;
        $a->add ($name => URI::WithBase->new ($p{$_}, $p{base_uri})->abs);
      } elsif (/color/) {
        $p{$_} = '#'.$p{$_} if $p{$_} =~ /^[A-Za-z0-9]{6}$/;
        $a->add ($name => $p{$_}) if length $p{$_};
      } else {
        $a->add ($name => $p{$_}) if length $p{$_};
      }
    }
  ## Body and body information
    my $b = $self->{hook_msg_body} || \&_make_a_msg_body;
    &$b ($self, $msg, $p{body}, \%p);
  ## List information
    if (length $p{list_id}) {
      my $lid = $hdr->field ('list-id');
      $lid->value ($p{list_id});
      $lid->display_name ($p{list_name}) if length $p{list_name};
    }
    $hdr->add (x_mail_count => $p{msg_count}) if defined $p{msg_count};
    $hdr->add (x_ml_info => $p{list_info}) if defined $p{list_info};
    if ($p{base_uri}) {
      my $uri = $hdr->add (x_uri => '');
      $uri->value ($p{base_uri});
      $uri->display_name ($p{list_name}) if length $p{list_name};
    }
    if ($p{urn_template}) {
      my $urn = $date->stringify (
        -format_macros  => $self->{fmt2str},
        -format_template        => $p{urn_template},
        -format_parameters      => \%p,
      );
      #my $urn = $self->Message::Field::Date::_date2str ({
      #  format_template        => $p{urn_template},
      #  date_time      => $date->unix_time,
      #  zone   => $date->zone,
      #  fmt2str        => $self->{fmt2str},
      #}, \%p);
      $hdr->add ('x-uri')->value ($urn);
    }
  ## Additional information
    my $u = $self->{hook_msg_header_add};
    &$u ($self, $msg, \%p) if ref $u;
    $hdr->field ('x-shimbun-agent')->add ($MYNAME => $VERSION);
  $msg;
}

sub _make_a_msg_body ($$$\%) {
  my $self = shift;
  my ($msg, $body, $param) = @_;
  if (length $body) {
    $body =~ s/(?<!\x0D\x0A)\z/\x0D\x0A/s;
    $msg->body ($body);
  }
}

sub default_parameter ($@) {
  my $self = shift;
  if (@_ == 1) {
    return $self->{default_parameter}->{ $_[0] };
  }
  while (my ($name, $value) = splice (@_, 0, 2)) {
    $self->{default_parameter}->{$name} = $value;
  }
  $self;
}

=head1 $meta = $b->meta_information

Gets meta information from resource requesting protocol.
Usually returned value is Message::Header object.
When resource is getten via HTTP, its content is HTTP response
header.

=cut

sub meta_information ($) {
  my $self = shift;
  $self->{meta_info};
}

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/08/29 12:10:59 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.2	Bunshin --- A shimbun implemrntion written in Perl
5	wakaba	1.1
6			=cut
7
8			package Bunshin;
9			use strict;
10			use vars qw($DEBUG $MYNAME $VERSION);
11	wakaba	1.6	$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
12	wakaba	1.1	$MYNAME = 'Bunshin';
13			$DEBUG = 0;
14			use FileHandle;
15			require Message::Entity;
16			require Message::Util;
17			require Message::Field::Date;
18
19			sub new ($;%) {
20			my $class = shift;
21			my $self = bless {}, $class;
22			$self->{fmt2str} = Message::Util::make_clone
23	wakaba	1.5	(\%Message::Field::Date::FMT2STR);
24	wakaba	1.1	$self;
25			}
26
27			=item $b->msg_regex ($regex)
28
29			Set regex used to cut a message.
30
31			=cut
32
33			sub set_regex ($$$) {
34			my $self = shift;
35			my $name = shift;
36			my $regex = shift;
37			$regex =~ s/\x20/\\x20/g;
38			$regex =~ s/\x09/\\x09/g;
39			$regex =~ s/\x0D(?!\x0A)/\x0D\x0A/g;
40			$regex =~ s/(?<!\x0D)\x0A/\x0D\x0A/g;
41			$regex =~ s/\x0D/\\x0D/g;
42			$regex =~ s/\x0A/\\x0A/g;
43			$regex =~ s/\x23/\\x23/g;
44			$self->{'regex_'.$name} = $regex;
45			}
46
47			sub set_hook_function ($$\&) {
48			my $self = shift;
49			my $name = shift;
50			my $function = shift;
51			$self->{'hook_'.$name} = $function;
52			}
53
54	wakaba	1.6	sub set_element_decoders ($%) {
55			my $self = shift;
56			my %list = @_;
57			for (keys %list) {
58			if ($list{$_} eq 'enentity_html') {
59			$list{$_} = \&Message::Util::enentity_html;
60			} elsif ($list{$_} eq 'deentity_html') {
61			$list{$_} = \&Message::Util::deentity_html;
62			## TODO: escape_uri, unescape_uri
63			}
64			}
65			$self->{element_decoder} = %list;
66			}
67
68	wakaba	1.1	sub set_format ($$\&) {
69			my $self = shift;
70			my $name = shift;
71			my $function = shift;
72			$self->{fmt2str}->{$name} = $function;
73			}
74
75			sub set_elements ($$@) {
76			my $self = shift;
77			my $name = shift;
78			$self->{'elements_'.$name} = \@_;
79			}
80
81			sub set_source ($%) {
82			my $self = shift;
83			my %option = @_;
84	wakaba	1.4	($self->{source}, $self->{meta_info}) = $self->_get_resource (%option);
85			$self->default_parameter (base_uri => $option{uri}) if $option{uri};
86			## BUG: Doesn't support redirection
87			if ($option{uri} \|\| $option{file}) {
88			my $c = $self->{hook_code_conversion} \|\| \&_code_conversion;
89			$self->{source} = &$c ($self, $self->{source}, \%option, $self->{meta_info});
90			}
91			$self->{source} =~ s/\x0D(?!\x0A)/\x0D\x0A/g;
92			$self->{source} =~ s/(?<!\x0D)\x0A/\x0D\x0A/g;
93			$self;
94			}
95
96			sub _get_resource ($%) {
97			my $self = shift;
98			my %option = @_;
99			my ($resource, $meta);
100	wakaba	1.1	if (defined $option{value}) {
101	wakaba	1.4	$resource = $option{value};
102	wakaba	1.1	} elsif ($option{uri}) {
103			require Message::Field::UA;
104			require LWP::UserAgent;
105			my $ua = Message::Field::UA->new;
106			$ua->add_our_name;
107			$ua->add ('libwww-perl' => $LWP::VERSION);
108			my $lwp = LWP::UserAgent->new;
109			$lwp->agent ($ua->stringify);
110			my $req = HTTP::Request->new (GET => $option{uri});
111			my $res = $lwp->request ($req);
112	wakaba	1.4	$resource = $res->content;
113			$meta = parse Message::Header $res->headers_as_string,
114			-parse_all => 0, -format => 'http-response',
115			;
116	wakaba	1.1	} elsif ($option{file}) {
117			my $f = new FileHandle $option{file} => 'r';
118			Carp::croak "set_source: $option{file}: $!" unless defined $f;
119			my $c = $self->{hook_code_conversion} \|\| \&_code_conversion;
120			local $/ = undef;
121	wakaba	1.4	$resource = $f->getline;
122	wakaba	1.1	} else {
123	wakaba	1.4	Carp::croak "_get_resource: $_[0]: Unsupported data source type";
124	wakaba	1.1	}
125	wakaba	1.4	($resource, $meta);
126	wakaba	1.1	}
127
128	wakaba	1.4	## $self->_code_conversion ($string, \%option, $meta_info)
129			sub _code_conversion ($$\%$) {
130	wakaba	1.1	$_[1];
131			}
132
133			sub make_msgs ($) {
134			my $self = shift;
135			my $s = $self->{source};
136			my $f = $self->{hook_make_msg} \|\| \&_make_a_msg;
137			my @msg;
138			my %param = %{$self->{default_parameter}};
139			if ($self->{regex_metainfo} && ref $self->{elements_metainfo}) {
140			$s =~ s{ $self->{regex_metainfo} }{
141			no strict 'refs';
142			for my $i (0..$#{$self->{elements_metainfo}}) {
143			$param{$self->{elements_metainfo}->[$i]} = ${$i+1};
144			}
145			$&;
146			}esx;
147			}
148			$s =~ s{ $self->{regex_message} }{
149			no strict 'refs';
150			my %p = %param;
151			for my $i (0..$#{$self->{elements_message}}) {
152			$p{$self->{elements_message}->[$i]} = ${$i+1};
153			}
154	wakaba	1.6	for my $n (keys %{$self->{element_decoder}}) {
155			if ($p{$n} && ref $self->{element_decoder}->{$n}) {
156			$p{$n} = &{ $self->{element_decoder}->{$n} } ($p{$n});
157			}
158			}
159	wakaba	1.1	my $msg = &$f ($self, %p);
160			push @msg, $msg;
161			}gesx;
162			@msg;
163			}
164
165			## Default function for "make_msg"
166			sub _make_a_msg ($@) {
167			my $self = shift;
168			my %p = @_;
169			my $msg = new Message::Entity
170			-fill_date => 0,
171			-fill_msgid => 0,
172			-fill_ua_name => 'x-shimbun-agent',
173	wakaba	1.5	-format => 'news-usefor',
174	wakaba	1.1	-parse_all => 1,
175			;
176			my $hdr = $msg->header;
177			## Originator and date
178	wakaba	1.3	my $from = $hdr->field ('from')->add ($p{from_mail} \|\| 'foo@bar.invalid');
179	wakaba	1.1	$from->display_name ($p{from_name}) if length $p{from_name};
180			my $date = $hdr->field ('date');
181			$p{date_year} \|\|= (gmtime)[5];
182			$date->set_datetime (@p{qw/date_year date_month
183			date_day date_hour date_minute date_second/},
184			zone => $p{date_zone});
185	wakaba	1.3	$hdr->add (x_uri => $p{from_uri}) if $p{from_uri};
186	wakaba	1.1	if ($p{from_face}) {
187			$msg->header->field ('x-face')->value ($p{from_face});
188			} elsif ($p{faces}->{$p{from_mail}}) {
189			$msg->header->field ('x-face')->value ($p{faces}->{$p{from_mail}});
190			} elsif ($p{list_face}) {
191			$msg->header->field ('x-face')->value ($p{list_face});
192			}
193			## Message attribute
194			if (length $p{msg_id}) {
195			$hdr->add ('message-id' => $p{msg_id});
196	wakaba	1.3	} elsif ($p{msg_id_from} \|\| $p{msg_id_right} \|\| $p{list_id}) {
197	wakaba	1.1	my $c = $p{msg_count};
198			$c = '.d'.(0+$date) unless defined $p{msg_count};
199	wakaba	1.3	my $mid;
200			if ($p{msg_id_from}) {
201			$mid = sprintf '<msg%s.BS%%%s%%%s>', $c, $p{list_id}, $p{msg_id_from};
202			} elsif ($p{msg_id_right}) {
203			$mid = sprintf '<msg%s.BS%%%s%%list@%s>', $c, $p{list_id}, $p{msg_id_right};
204			} else { #if ($p{list_id}) {
205			$mid = sprintf '<msg%s.BS%%list@%s>', $c, $p{list_id};
206			}
207	wakaba	1.1	$hdr->add (($DEBUG?'x-':'').'message-id' => $mid);
208			}
209	wakaba	1.3	if (length $p{subject}) {
210			$hdr->add (subject => $p{subject});
211			} elsif (length $p{DEFAULT_subject}) {
212			$hdr->add (subject => $p{DEFAULT_subject});
213			}
214	wakaba	1.1	my $a;
215			for (grep {/^misc_/} keys %p) {
216			$a = $hdr->field ('content-x-properties') unless ref $a;
217			my $name = substr ($_, 5);
218			$name =~ tr/_/-/;
219			if ($p{base_uri} && /uri/ && length $p{$_}) {
220			require URI::WithBase;
221	wakaba	1.2	$a->add ($name => URI::WithBase->new ($p{$_}, $p{base_uri})->abs);
222	wakaba	1.5	} elsif (/color/) {
223			$p{$_} = '#'.$p{$_} if $p{$_} =~ /^[A-Za-z0-9]{6}$/;
224			$a->add ($name => $p{$_}) if length $p{$_};
225	wakaba	1.1	} else {
226			$a->add ($name => $p{$_}) if length $p{$_};
227			}
228			}
229			## Body and body information
230			my $b = $self->{hook_msg_body} \|\| \&_make_a_msg_body;
231			&$b ($self, $msg, $p{body}, \%p);
232			## List information
233			if (length $p{list_id}) {
234			my $lid = $hdr->field ('list-id');
235			$lid->value ($p{list_id});
236			$lid->display_name ($p{list_name}) if length $p{list_name};
237			}
238	wakaba	1.3	$hdr->add (x_mail_count => $p{msg_count}) if defined $p{msg_count};
239			$hdr->add (x_ml_info => $p{list_info}) if defined $p{list_info};
240	wakaba	1.1	if ($p{base_uri}) {
241			my $uri = $hdr->add (x_uri => '');
242			$uri->value ($p{base_uri});
243			$uri->display_name ($p{list_name}) if length $p{list_name};
244			}
245			if ($p{urn_template}) {
246	wakaba	1.5	my $urn = $date->stringify (
247			-format_macros => $self->{fmt2str},
248			-format_template => $p{urn_template},
249			-format_parameters => \%p,
250			);
251			#my $urn = $self->Message::Field::Date::_date2str ({
252			# format_template => $p{urn_template},
253			# date_time => $date->unix_time,
254			# zone => $date->zone,
255			# fmt2str => $self->{fmt2str},
256			#}, \%p);
257	wakaba	1.1	$hdr->add ('x-uri')->value ($urn);
258			}
259			## Additional information
260			my $u = $self->{hook_msg_header_add};
261			&$u ($self, $msg, \%p) if ref $u;
262			$hdr->field ('x-shimbun-agent')->add ($MYNAME => $VERSION);
263			$msg;
264			}
265
266			sub _make_a_msg_body ($$$\%) {
267			my $self = shift;
268			my ($msg, $body, $param) = @_;
269			if (length $body) {
270			$body =~ s/(?<!\x0D\x0A)\z/\x0D\x0A/s;
271			$msg->body ($body);
272			}
273			}
274
275			sub default_parameter ($@) {
276			my $self = shift;
277			if (@_ == 1) {
278			return $self->{default_parameter}->{ $_[0] };
279			}
280			while (my ($name, $value) = splice (@_, 0, 2)) {
281			$self->{default_parameter}->{$name} = $value;
282			}
283			$self;
284			}
285
286	wakaba	1.4	=head1 $meta = $b->meta_information
287
288			Gets meta information from resource requesting protocol.
289			Usually returned value is Message::Header object.
290			When resource is getten via HTTP, its content is HTTP response
291			header.
292
293			=cut
294
295			sub meta_information ($) {
296			my $self = shift;
297			$self->{meta_info};
298			}
299
300	wakaba	1.1	=head1 LICENSE
301
302			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
303
304			This program is free software; you can redistribute it and/or modify
305			it under the terms of the GNU General Public License as published by
306			the Free Software Foundation; either version 2 of the License, or
307			(at your option) any later version.
308
309			This program is distributed in the hope that it will be useful,
310			but WITHOUT ANY WARRANTY; without even the implied warranty of
311			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
312			GNU General Public License for more details.
313
314			You should have received a copy of the GNU General Public License
315			along with this program; see the file COPYING. If not, write to
316			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
317			Boston, MA 02111-1307, USA.
318
319			=head1 CHANGE
320
321			See F<ChangeLog>.
322	wakaba	1.6	$Date: 2002/08/29 12:10:59 $
323	wakaba	1.1
324			=cut
325
326			1;