messaging/suikawari/wari.pl

#!/usr/bin/perl

=head1 NAME

wari.pl --- A shimbun implemention to post messages to NNTP server

=cut

use strict;
use lib qw#./lib/#;
use vars qw/$MYNAME $NNTP_SERVER $VERSION/;
$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
$MYNAME = 'Suikawari';
use Bunshin;
use Message::Header;

use Getopt::Long;
$NNTP_SERVER = 'localhost';
$Bunshin::DEBUG = 0;
my $VERBOSE;
my $directory = './module/';
my $posted_log = '.posted';
GetOptions (
        debug   => \$Bunshin::DEBUG,
        'module-dir=s'  => \$directory,
        'nntp-server=s' => \$NNTP_SERVER,
        'posted-log=s'  => \$posted_log,
        verbose => \$VERBOSE,
) or die;

sub dprint (@);
sub vprint (@);
binmode STDOUT;

opendir DIR, $directory;
  my @module = sort map {s/\.sb$//; $_} grep /^[A-Za-z0-9_]+\.sb$/, readdir DIR;
close DIR;
die "$0: $directory: No suikawari definition" if @module == 0;
push @main::INC, $directory;

my $plog;
{
&posted_log_ns::import;
open LOG, $posted_log;
  binmode LOG;
  local $/ = undef;
  $plog = parse Message::Header scalar <LOG>,
    -format     => 'x-internal-logfile',
    -ns_default_phuri   => $posted_log_ns::OPTION{namespace_uri},
  ;
close LOG;
}

for (@module) {
  dprint $_;
  my $module = "Suikawari::$_";
  load_module ($_);
  my $b = new Bunshin;
  my @msgreg = $module->msg_regex;
  my @metareg = $module->meta_regex;
  $b->set_regex (message => shift (@msgreg));
  $b->set_elements (message => @msgreg);
  $b->set_regex (metainfo => shift (@metareg)) if @metareg > 0;
  $b->set_elements (metainfo => @metareg) if @metareg > 0;
  my %face = $module->face;
  for (keys %face) {
    $b->default_parameter ($_ => $face{$_});
  }
  $module->on_load_source ($b);
  $b->set_source ($module->source);
  $module->on_make ($b);
  my ($nntp, $time);
  my $latest_time = $plog->field ($_, -new_item_unless_exist => 0);
  dprint 'Latest-Posted-Date: '.$latest_time;
  for ($b->make_msgs) {
    $_->option (format => 'news-usefor', -recursive => 1);
    $_->header->field ('x-shimbun-agent')->add ($MYNAME => $VERSION);
    my $t = $_->header->field ('date');
    next if $latest_time >= $t;
    $nntp = open_nntp () unless ref $nntp;
    vprint 'Date: '.$t;
    #dprint 'Subject: '.$_->header->field ('subject');
    send_msg ($_ => $nntp);
    $time = $t if $t > $time || !$time;
  }
  close_nntp ($nntp);
  $plog->replace ($_ => $time) if $time > $latest_time;
}

open LOG, '> '.$posted_log or die "$0: $posted_log: $!";
  binmode LOG;
  print LOG $plog;
close LOG;

sub send_msg ($$) {
  my $msg = shift;
  my $nntp = shift;
  dprint "Posting Message...";
  my @m = map {$_."\n"} split /\x0D\x0A/, $msg;
  my $r = $nntp->post (@m);
  vprint ${*$nntp}{'net_cmd_code'}, @{${*$nntp}{'net_cmd_resp'}};
  unless ($r) {
    #close_nntp ($nntp);
    #die;
    vprint "send_msg: Can't post the message.  Skiped";
  }
}

sub open_nntp () {
  require Net::NNTP;
  vprint "Connecting to $NNTP_SERVER...";
  my $nntp = Net::NNTP->new ($NNTP_SERVER) or die "$0: open_nntp: $!";
  vprint ${*$nntp}{'net_cmd_code'}, @{${*$nntp}{'net_cmd_resp'}};
  $nntp;
}

sub close_nntp ($) {
  my $nntp = shift;
  return unless ref $nntp;
  $nntp->quit;
  vprint ${*$nntp}{'net_cmd_code'}, @{${*$nntp}{'net_cmd_resp'}};
}

sub load_module ($) {
  no strict 'refs';
  my $m = shift;
  dprint qq{require "$m.sb"};
  require "$m.sb";
    if (defined &{ "Suikawari::${m}::require" }) {
      for (&{ "Suikawari::${m}::require" }) {
        load_module ($_) unless ${ "Suikawari::${_}::VERSION" };
        push @{ "Suikawari::${m}::ISA" }, "Suikawari::${_}";
      }
    }
}

sub dprint (@) {
  print shift, ' ' if $Bunshin::DEBUG && @_ > 1;
  print map {/\n$/s? $_: $_."\n"} @_ if $Bunshin::DEBUG;
}

sub vprint (@) {
  print shift, ' ' if ($VERBOSE || $Bunshin::DEBUG) && @_ > 1;
  print map {/\n$/s? $_: $_."\n"} @_ if $VERBOSE || $Bunshin::DEBUG;
}

package posted_log_ns;
use vars qw/%OPTION/;

sub import () {
  require Message::Header::Default;
  %OPTION = %Message::Header::Default::OPTION;
  $OPTION{namespace_uri} = 'urn:x-temp:x-posted-log';
  $OPTION{namespace_phname} = 'posted';
  $OPTION{namespace_phname_goodcase} = 'Posted';
  $OPTION{case_sensible} = 1;
  $OPTION{value_type} = {
    ':default'  => ['Message::Field::Date'],
  };
  
  $Message::Header::NS_phname2uri{$OPTION{namespace_phname}} = $OPTION{namespace_uri};
  $Message::Header::NS_uri2phpackage{$OPTION{namespace_uri}} = __PACKAGE__;
}

=head1 SEE ALSO

Bunshin L<Shimbun>

=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/16 11:06:45 $

=cut

1;
### wari.pl ends here
1	#!/usr/bin/perl
2
3	=head1 NAME
4
5	wari.pl --- A shimbun implemention to post messages to NNTP server
6
7	=cut
8
9	use strict;
10	use lib qw#./lib/#;
11	use vars qw/$MYNAME $NNTP_SERVER $VERSION/;
12	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	$MYNAME = 'Suikawari';
14	use Bunshin;
15	use Message::Header;
16
17	use Getopt::Long;
18	$NNTP_SERVER = 'localhost';
19	$Bunshin::DEBUG = 0;
20	my $VERBOSE;
21	my $directory = './module/';
22	my $posted_log = '.posted';
23	GetOptions (
24	debug => \$Bunshin::DEBUG,
25	'module-dir=s' => \$directory,
26	'nntp-server=s' => \$NNTP_SERVER,
27	'posted-log=s' => \$posted_log,
28	verbose => \$VERBOSE,
29	) or die;
30
31	sub dprint (@);
32	sub vprint (@);
33	binmode STDOUT;
34
35	opendir DIR, $directory;
36	my @module = sort map {s/\.sb$//; $_} grep /^[A-Za-z0-9_]+\.sb$/, readdir DIR;
37	close DIR;
38	die "$0: $directory: No suikawari definition" if @module == 0;
39	push @main::INC, $directory;
40
41	my $plog;
42	{
43	&posted_log_ns::import;
44	open LOG, $posted_log;
45	binmode LOG;
46	local $/ = undef;
47	$plog = parse Message::Header scalar <LOG>,
48	-format => 'x-internal-logfile',
49	-ns_default_phuri => $posted_log_ns::OPTION{namespace_uri},
50	;
51	close LOG;
52	}
53
54	for (@module) {
55	dprint $_;
56	my $module = "Suikawari::$_";
57	load_module ($_);
58	my $b = new Bunshin;
59	my @msgreg = $module->msg_regex;
60	my @metareg = $module->meta_regex;
61	$b->set_regex (message => shift (@msgreg));
62	$b->set_elements (message => @msgreg);
63	$b->set_regex (metainfo => shift (@metareg)) if @metareg > 0;
64	$b->set_elements (metainfo => @metareg) if @metareg > 0;
65	my %face = $module->face;
66	for (keys %face) {
67	$b->default_parameter ($_ => $face{$_});
68	}
69	$module->on_load_source ($b);
70	$b->set_source ($module->source);
71	$module->on_make ($b);
72	my ($nntp, $time);
73	my $latest_time = $plog->field ($_, -new_item_unless_exist => 0);
74	dprint 'Latest-Posted-Date: '.$latest_time;
75	for ($b->make_msgs) {
76	$_->option (format => 'news-usefor', -recursive => 1);
77	$_->header->field ('x-shimbun-agent')->add ($MYNAME => $VERSION);
78	my $t = $_->header->field ('date');
79	next if $latest_time >= $t;
80	$nntp = open_nntp () unless ref $nntp;
81	vprint 'Date: '.$t;
82	#dprint 'Subject: '.$_->header->field ('subject');
83	send_msg ($_ => $nntp);
84	$time = $t if $t > $time \|\| !$time;
85	}
86	close_nntp ($nntp);
87	$plog->replace ($_ => $time) if $time > $latest_time;
88	}
89
90	open LOG, '> '.$posted_log or die "$0: $posted_log: $!";
91	binmode LOG;
92	print LOG $plog;
93	close LOG;
94
95	sub send_msg ($$) {
96	my $msg = shift;
97	my $nntp = shift;
98	dprint "Posting Message...";
99	my @m = map {$_."\n"} split /\x0D\x0A/, $msg;
100	my $r = $nntp->post (@m);
101	vprint ${$nntp}{'net_cmd_code'}, @{${$nntp}{'net_cmd_resp'}};
102	unless ($r) {
103	#close_nntp ($nntp);
104	#die;
105	vprint "send_msg: Can't post the message. Skiped";
106	}
107	}
108
109	sub open_nntp () {
110	require Net::NNTP;
111	vprint "Connecting to $NNTP_SERVER...";
112	my $nntp = Net::NNTP->new ($NNTP_SERVER) or die "$0: open_nntp: $!";
113	vprint ${$nntp}{'net_cmd_code'}, @{${$nntp}{'net_cmd_resp'}};
114	$nntp;
115	}
116
117	sub close_nntp ($) {
118	my $nntp = shift;
119	return unless ref $nntp;
120	$nntp->quit;
121	vprint ${$nntp}{'net_cmd_code'}, @{${$nntp}{'net_cmd_resp'}};
122	}
123
124	sub load_module ($) {
125	no strict 'refs';
126	my $m = shift;
127	dprint qq{require "$m.sb"};
128	require "$m.sb";
129	if (defined &{ "Suikawari::${m}::require" }) {
130	for (&{ "Suikawari::${m}::require" }) {
131	load_module ($_) unless ${ "Suikawari::${_}::VERSION" };
132	push @{ "Suikawari::${m}::ISA" }, "Suikawari::${_}";
133	}
134	}
135	}
136
137	sub dprint (@) {
138	print shift, ' ' if $Bunshin::DEBUG && @_ > 1;
139	print map {/\n$/s? $_: $_."\n"} @_ if $Bunshin::DEBUG;
140	}
141
142	sub vprint (@) {
143	print shift, ' ' if ($VERBOSE \|\| $Bunshin::DEBUG) && @_ > 1;
144	print map {/\n$/s? $_: $_."\n"} @_ if $VERBOSE \|\| $Bunshin::DEBUG;
145	}
146
147	package posted_log_ns;
148	use vars qw/%OPTION/;
149
150	sub import () {
151	require Message::Header::Default;
152	%OPTION = %Message::Header::Default::OPTION;
153	$OPTION{namespace_uri} = 'urn:x-temp:x-posted-log';
154	$OPTION{namespace_phname} = 'posted';
155	$OPTION{namespace_phname_goodcase} = 'Posted';
156	$OPTION{case_sensible} = 1;
157	$OPTION{value_type} = {
158	':default' => ['Message::Field::Date'],
159	};
160
161	$Message::Header::NS_phname2uri{$OPTION{namespace_phname}} = $OPTION{namespace_uri};
162	$Message::Header::NS_uri2phpackage{$OPTION{namespace_uri}} = __PACKAGE__;
163	}
164
165	=head1 SEE ALSO
166
167	Bunshin L<Shimbun>
168
169	=head1 LICENSE
170
171	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
172
173	This program is free software; you can redistribute it and/or modify
174	it under the terms of the GNU General Public License as published by
175	the Free Software Foundation; either version 2 of the License, or
176	(at your option) any later version.
177
178	This program is distributed in the hope that it will be useful,
179	but WITHOUT ANY WARRANTY; without even the implied warranty of
180	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
181	GNU General Public License for more details.
182
183	You should have received a copy of the GNU General Public License
184	along with this program; see the file COPYING. If not, write to
185	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
186	Boston, MA 02111-1307, USA.
187
188	=head1 CHANGE
189
190	See F<ChangeLog>.
191	$Date: 2002/06/16 11:06:45 $
192
193	=cut
194
195	1;
196	### wari.pl ends here