messaging/suikawari/wari.pl


=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.1 $=~/\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 $directory = './module/';
my $posted_log = '.posted';
GetOptions (
        debug   => \$Bunshin::DEBUG,
        'module-dir=s'  => \$directory,
        'nntp-server=s' => \$NNTP_SERVER,
        'posted-log=s'  => \$posted_log,
) or die;

sub dprint (@);
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::$_";
  require "$_.sb";
  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));
  $b->set_elements (metainfo => @metareg);
  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;
    dprint 'Date: '.$t;
    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);
  dprint ${*$nntp}{'net_cmd_code'}, @{${*$nntp}{'net_cmd_resp'}};
  unless ($r) {
    close_nntp ($nntp);
    die;
  }
}

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

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

sub dprint (@) {
  print shift, ' ' if $Bunshin::DEBUG && @_ > 1;
  print map {/\n$/s? $_: $_."\n"} @_ if $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 02:50:54 $

=cut

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