suikawari/module/RisuukaDentatsu.sb


=head1 NAME

Suikawari::RisuukaDentatsu --- Suikawari module for Risuuka Keijiban

=cut

## This file is written in EUC-japan encoding.

package Suikawari::RisuukaDentatsu;
use strict;
use vars qw/$VERSION/;
$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use Message::MIME::Charset::Jcode 'jcode.pl';

sub msg_regex ($) {
<<'EOH',
<td[^>]*>
                <font[^>]*>
(\d+).(\d+).(\d+) [A-Za-z]+<!---->day (\d+):(\d+):(\d+) (.*?)<br>
<hr size=1>
(?:<IMG SRC="([^"]+)"[^>]*>)?<BR>
(.*?)<BR>
<BR>
                </font>
                </td>
EOH
  qw (date_year date_month date_day date_hour date_minute date_second
      subject misc_image_uri body);
}

sub meta_regex ($) {
  my $r = <<'EOH';
<title>([^<]+)</title>
EOH
  $r =~ s/\n$//s;
  $r, qw (list_name);
}

sub on_load_source ($$) {shift;
  my $b = shift;
  $b->set_hook_function (code_conversion => sub { jcode::euc ($_[1]) });
}

sub source ($) {
  if ($Bunshin::DEBUG) {
    (file => 'RisuukaDentatsu.tmp');
    (uri => 'http://yapeus.com/users/fuyudentatsu/');
  } else {
    (uri => 'http://yapeus.com/users/fuyudentatsu/');
  }
}

sub face ($) {
#  my %face;
#  (faces => \%face);
}

sub on_make ($$) {
  my $self = shift;
  my $b = shift;
  $b->default_parameter (date_zone => '+0900');
  $b->default_parameter (DEFAULT_subject => '(無題)');
  $b->default_parameter (newsgroups => 'suika.chuubu.r.55');
  $b->default_parameter (list_name => '理数科伝達事項');
  $b->default_parameter (list_id => 'dentatsu.2000e.risuu.chuubu.suika.fam.cx');
  my $http = $b->meta_information;
  if (ref $http) {
    $b->default_parameter (misc_http_server => $http->field ('server'));
  }
  $b->set_hook_function (msg_header_add => sub {
    my $self = shift;
    my ($msg, $p) = @_;
    my $hdr = $msg->header;
    ## Newsgroups
      my $group = $p->{newsgroups};
      $group = 'suika.test' if $Bunshin::DEBUG;
      $hdr->replace (newsgroups => $group);
  });
  $b->set_hook_function (msg_body => sub {
    shift;
    my ($msg, $body, $p) = @_;
    $body =~ s#<BR>#\x0D\x0A#g;
    $body =~ s#(?:\x0D\x0A)+$#\x0D\x0A#s;
    unless ($p->{misc_image_uri}) {
      $msg->body->value ($body);
    } else {
      require URI::WithBase;
      my $uri = URI::WithBase->new ($p->{misc_image_uri}, $p->{base_uri})->abs;
      my ($img, $http) = $b->_get_resource (uri => $uri);
      $msg->header->field ('content-type')->media_type ('multipart/mixed');
      my $text = $msg->body->item (0, -by => 'index');
        $text->body->value ($body);
      my $image = $msg->body->item (1, -by => 'index');
        $image->header->field ('content-type')->media_type ('image/png');
        $image->header->field ('content-location')->value ($uri);
        $http->scan (sub {shift;
          my $item = shift;
          next unless $item->{ns} eq $Message::Header::NS_phname2uri{content};
          $image->header->field ($item->{name} => $item->{body}, -ns => $item->{ns});
        });
        $image->body->value ($img);
    }
  });
}

=head1 SEE ALSO

Suikawari, Bunshin

=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/06/25 09:34:42 $

=cut

1;
### Suikawari::TomikouKeijiban ends here
1
2	=head1 NAME
3
4	Suikawari::RisuukaDentatsu --- Suikawari module for Risuuka Keijiban
5
6	=cut
7
8	## This file is written in EUC-japan encoding.
9
10	package Suikawari::RisuukaDentatsu;
11	use strict;
12	use vars qw/$VERSION/;
13	$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
14	use Message::MIME::Charset::Jcode 'jcode.pl';
15
16	sub msg_regex ($) {
17	<<'EOH',
18	<td[^>]*>
19	<font[^>]*>
20	(\d+).(\d+).(\d+) [A-Za-z]+<!---->day (\d+):(\d+):(\d+) (.*?)<br>
21	<hr size=1>
22	(?:<IMG SRC="([^"]+)"[^>]*>)?<BR>
23	(.*?)<BR>
24	<BR>
25	</font>
26	</td>
27	EOH
28	qw (date_year date_month date_day date_hour date_minute date_second
29	subject misc_image_uri body);
30	}
31
32	sub meta_regex ($) {
33	my $r = <<'EOH';
34	<title>([^<]+)</title>
35	EOH
36	$r =~ s/\n$//s;
37	$r, qw (list_name);
38	}
39
40	sub on_load_source ($$) {shift;
41	my $b = shift;
42	$b->set_hook_function (code_conversion => sub { jcode::euc ($_[1]) });
43	}
44
45	sub source ($) {
46	if ($Bunshin::DEBUG) {
47	(file => 'RisuukaDentatsu.tmp');
48	(uri => 'http://yapeus.com/users/fuyudentatsu/');
49	} else {
50	(uri => 'http://yapeus.com/users/fuyudentatsu/');
51	}
52	}
53
54	sub face ($) {
55	# my %face;
56	# (faces => \%face);
57	}
58
59	sub on_make ($$) {
60	my $self = shift;
61	my $b = shift;
62	$b->default_parameter (date_zone => '+0900');
63	$b->default_parameter (DEFAULT_subject => '(無題)');
64	$b->default_parameter (newsgroups => 'suika.chuubu.r.55');
65	$b->default_parameter (list_name => '理数科伝達事項');
66	$b->default_parameter (list_id => 'dentatsu.2000e.risuu.chuubu.suika.fam.cx');
67	my $http = $b->meta_information;
68	if (ref $http) {
69	$b->default_parameter (misc_http_server => $http->field ('server'));
70	}
71	$b->set_hook_function (msg_header_add => sub {
72	my $self = shift;
73	my ($msg, $p) = @_;
74	my $hdr = $msg->header;
75	## Newsgroups
76	my $group = $p->{newsgroups};
77	$group = 'suika.test' if $Bunshin::DEBUG;
78	$hdr->replace (newsgroups => $group);
79	});
80	$b->set_hook_function (msg_body => sub {
81	shift;
82	my ($msg, $body, $p) = @_;
83	$body =~ s#<BR>#\x0D\x0A#g;
84	$body =~ s#(?:\x0D\x0A)+$#\x0D\x0A#s;
85	unless ($p->{misc_image_uri}) {
86	$msg->body->value ($body);
87	} else {
88	require URI::WithBase;
89	my $uri = URI::WithBase->new ($p->{misc_image_uri}, $p->{base_uri})->abs;
90	my ($img, $http) = $b->_get_resource (uri => $uri);
91	$msg->header->field ('content-type')->media_type ('multipart/mixed');
92	my $text = $msg->body->item (0, -by => 'index');
93	$text->body->value ($body);
94	my $image = $msg->body->item (1, -by => 'index');
95	$image->header->field ('content-type')->media_type ('image/png');
96	$image->header->field ('content-location')->value ($uri);
97	$http->scan (sub {shift;
98	my $item = shift;
99	next unless $item->{ns} eq $Message::Header::NS_phname2uri{content};
100	$image->header->field ($item->{name} => $item->{body}, -ns => $item->{ns});
101	});
102	$image->body->value ($img);
103	}
104	});
105	}
106
107	=head1 SEE ALSO
108
109	Suikawari, Bunshin
110
111	=head1 LICENSE
112
113	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
114
115	This program is free software; you can redistribute it and/or modify
116	it under the terms of the GNU General Public License as published by
117	the Free Software Foundation; either version 2 of the License, or
118	(at your option) any later version.
119
120	This program is distributed in the hope that it will be useful,
121	but WITHOUT ANY WARRANTY; without even the implied warranty of
122	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
123	GNU General Public License for more details.
124
125	You should have received a copy of the GNU General Public License
126	along with this program; see the file COPYING. If not, write to
127	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
128	Boston, MA 02111-1307, USA.
129
130	=head1 CHANGE
131
132	See F<ChangeLog>.
133	$Date: 2002/06/25 09:34:42 $
134
135	=cut
136
137	1;
138	### Suikawari::TomikouKeijiban ends here