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.6 $=~/\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';
my $module_pattern = q([A-Za-z0-9_]+);
GetOptions (
        debug   => \$Bunshin::DEBUG,
        'module-dir=s'  => \$directory,
        'module-name=s' => \$module_pattern,
        'nntp-server=s' => \$NNTP_SERVER,
        'posted-log=s'  => \$posted_log,
        verbose => \$VERBOSE,
) or die;

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

opendir DIR, $directory;
  my @module = sort map {s/\.sb$//; $_} grep /^$module_pattern\.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;
}

my $nntp;
for (@module) {
  vprint $_;
  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;
  eval q{$b->set_element_decoders ($module->element_decoders)} or vprint $@;
  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 ($time);
  my $latest_time = $plog->field ($_, -new_item_unless_exist => 0);
  dprint 'Latest-Posted-Date: '.$latest_time;
  for ($b->make_msgs) {
    my $t = $_->header->field ('date');
    if (0+$latest_time >= 0+$t) {
      vprint 'Already posted: Date: '.$t;
      next;
    }
    $time = $t if $t > $time || !$time;
    vprint 'Date: '.$t;
    
    $_->header->field ('x-shimbun-agent')->add ($MYNAME => $VERSION);
    
    $_->option (format => 'news-usefor', -recursive => 1);
    send_msg_nntp ($_ => $nntp);
  }
  $plog->replace ($_ => $time) if $time > $latest_time;
}
close_nntp ($nntp);

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

sub send_msg_nntp ($$) {
  my $msg = shift;
  $_[0] = open_nntp () unless ref $_[0];
  my $nntp = shift;
  dprint "Posting Message...";
  my @m = map {$_."\n"} split /\x0D\x0A/, $msg;
  my $r = $nntp->post (@m);
  if ($r) {
    vprint ${*$nntp}{'net_cmd_code'}, @{${*$nntp}{'net_cmd_resp'}};
  } else {
    eprint ${*$nntp}{'net_cmd_code'}, @{${*$nntp}{'net_cmd_resp'}};
    #close_nntp ($nntp);
    #die;
    eprint "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;
  vprint "Disconnect to $NNTP_SERVER";
  $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 eprint (@) {
  print shift, ' ' if @_ > 1;
  print map {/\n$/s? $_: $_."\n"} @_;
}

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/08/29 12:12:04 $

=cut

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