/[suikacvs]/messaging/manakai/doc/example/sendmsg/send-msg.pl
Suika

Contents of /messaging/manakai/doc/example/sendmsg/send-msg.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations) (download)
Fri Jul 26 06:25:30 2002 UTC (22 years, 11 months ago) by wakaba
Branch: MAIN
File MIME type: text/plain
2002-07-25  Wakaba <w@suika.fam.cx>

	* ChangeLog: New file.
	* send-msg.pl:
	- (pod:CHANGES): Removed.
	- (pod:LICENSE): New section.

1 wakaba 1.1 use strict;
2     use vars qw($MYNAME $VERSION);
3     $MYNAME = 'send.pl'; $VERSION = '2.4';
4     use lib qw(/home/wakaba/temp/msg/);
5     use Message::Entity;
6     use Message::Field::Date;
7     use Message::MIME::Charset::Jcode 'Jcode.pm';
8     use Message::MIME::Charset::Jcode 'jcode.pl';
9     use Socket;
10     binmode STDOUT; $| = 1; binmode STDERR;
11     my %server;
12     $server{smtp} ||= 'suika.fam.cx';
13     $server{nntp} ||= 'suika.fam.cx';
14     my $debug_msg_log = 0;
15    
16     my $myhostname = 'send-msg';
17    
18     open LOG, '>> send.slog'; binmode LOG;
19     my $date = Message::Field::Date->new (zone => [+1, 9, 0]);
20     $date->unix_time (time);
21     pmsg ("\x0C",
22     'User-Agent: '.$MYNAME.'/'.$VERSION,
23     'Date: '.$date);
24    
25     opendir DIR, '.';
26     my @files = sort(grep(/^[^_][\x00-\xFF]*?\.822$/, readdir(DIR)));
27     close DIR;
28     if ($#files < 0) {
29     pmsg("These are no files to send!"); close LOG; die;
30     }
31     $Send::SMTP::connected = 0;
32     $Send::NNTP::connected = 0;
33    
34     my $crlf = "\x0D\x0A";
35    
36    
37     for my $file (@files) {
38     pmsg('Open message file for sending: '.$file);
39     my $m;
40     {
41     open M, $file or &error ($!);
42     local $/ = undef;
43     $m = <M>;
44     close M;
45     }
46     $m =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
47     $m =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
48     my $msg = Message::Entity->parse ($m , -parse_all => 1,
49     -fill_date => 0, -fill_msgid => 0,
50     );
51    
52     ## mail/post to...
53     my $header = $msg->header;
54    
55     ## Envelope From, To
56     my $eFrom = $header->field ('x-envelope-from')->addr_spec;
57     my $resent = $header->field ('resent-from')->addr_spec;
58     if ($resent) {
59     $eFrom ||= $resent;
60     } else {
61     $eFrom ||= $header->field ('from')->addr_spec;
62     }
63     my @eTo = $header->field ('x-envelope-to')->addr_spec;
64     my ($send_mail,$post_news) = (0, 0);
65     if ($resent) {
66     @eTo =($header->field ('resent-to')->addr_spec,
67     $header->field ('resent-cc')->addr_spec,
68     $header->field ('resent-bcc')->addr_spec) if $#eTo < 0;
69     } else {
70     @eTo =($header->field ('to')->addr_spec,
71     $header->field ('cc')->addr_spec,
72     $header->field ('bcc')->addr_spec) if $#eTo < 0;
73     $post_news = 1 if $header->field_exist ('newsgroups');
74     }
75     $send_mail = 1 if @eTo > 0;
76     &error ('No envelope from') if $send_mail && !$eFrom;
77     if ($eFrom && $header->field ('from')->item (0, -by => 'index')->display_name =~ /</) {
78     my $buggy = 0;
79     for (@eTo) {
80     $buggy = 1 if /\@jp-[a-z]\.ne\.jp$/i;
81     }
82     $header->field ('from')->item (0, -by => 'index')->option (output_display_name => 0) if $buggy;
83     }
84    
85     if ($send_mail && $post_news) {
86     $header->replace ('Posted-And-Mailed' => 'yes');
87     } elsif (!$send_mail && !$post_news) {
88     &error('Not for mail nor news!');
89     }
90    
91     my $a = '';
92     $a = 'resent-' if ($resent);
93     unless ($header->field_exist ($a.'message-id')) {
94     my $msgid;
95     if ($resent) {
96     $msgid = $header->field ('resent-message-id', -prepend => 1);
97     } else {
98     $msgid = $header->field ('message-id');
99     }
100     $msgid->generate (addr_spec => $eFrom);
101     pmsg ($a.'Message-id: '.$msgid);
102     }
103    
104     unless ($header->field_exist ($a.'date')) {
105     my $date;
106     if ($resent) {
107     $date = $header->field ('resent-date', -prepend => 1);
108     } else {
109     $date = $header->field ('date');
110     }
111     $date->unix_time ((stat ($file))[9]);
112     pmsg($a.'Date: '.$date);
113     }
114     my $ua;
115     if ($resent) {
116     $ua = $header->add ('resent-user-agent' => '', -prepend => 1);
117     $msg->option (fill_ua_name => 'resent-user-agent');
118     } else {
119     $ua = $header->field ('user-agent');
120     }
121     if ($Jcode::VERSION) {
122     $ua->add ('Jcode.pm' => $Jcode::VERSION);
123     }
124     #my $jv=do{my @r=($jcode::rcsid=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
125     $ua->add ('jcode.pl' => ['',$jcode::rcsid]);
126     $ua->add ($MYNAME => $VERSION);
127    
128     $header->delete (qw(bcc date-received relay-version resent-bcc status x-envelope-from x-envelope-to xref));
129    
130     my %sopt = (
131     -fill_date => 0, -fill_msgid => 0,
132     -ua_field_name => $a.'user-agent',
133     );
134     my ($msg_mail, $msg_news);
135     if ($send_mail) {
136     $msg_mail = $msg->stringify (-format => 'mail-rfc2822', %sopt);
137     #$msg_mail =~ s/\x0D\x0A|\x0D|\x0A/\x0D\x0A/gs;
138     $msg_mail =~ s/\x0D\x0A\./\x0D\x0A../gs;
139     #$msg_mail =~ s/^(?:\x0D\x0A)+//;
140     #$msg_mail =~ s/(?:\x0D\x0A)*$/\x0D\x0A/;
141     $msg_mail .= "\x0D\x0A.\x0D\x0A";
142     }
143     if ($post_news) {
144     my %rename;
145     for (qw(cc complaints-to nntp-posting-date injector-info nntp-posting-host posting-version received to x-complaints-to x-trace)) {
146     $rename{$_} = 'x-'.$_;
147     }
148     $header->rename (%rename);
149     $msg_news = $msg->stringify (-format => 'news-usefor', %sopt);
150     #$msg_news =~ s/\x0D\x0A|\x0D|\x0A/\x0D\x0A/gs;
151     $msg_news =~ s/\x0D\x0A\./\x0D\x0A../gs;
152     #$msg_news =~ s/^(?:\x0D\x0A)+//;
153     #$msg_news =~ s/(?:\x0D\x0A)*$/\x0D\x0A/;
154     $msg_news .= "\x0D\x0A.\x0D\x0A";
155     }
156    
157     Send::SMTP::Connect () if $send_mail && !$Send::SMTP::connected;
158     if ($send_mail) {
159     pmsg('send a mail message...');
160     printS("MAIL FROM:<${eFrom}>\x0D\x0A");
161     my $r = <SMTP>;
162     error25($r) unless $r =~ /^250/;
163     Send::Log::Server25($r);
164     for my $rcptto (@eTo) {
165     next unless $rcptto;
166     printS("RCPT TO:<$rcptto>\x0D\x0A");
167     my $r = <SMTP>;
168     error25($r) unless $r =~ /^25/;
169     Send::Log::Server25($r);
170     }
171     printS("DATA\x0D\x0A");
172     my $r = <SMTP>;
173     error25($r) unless $r =~ /^354/;
174     Send::Log::Server25($r);
175     print SMTP $msg_mail;
176     cmsg25 ('(message)');
177     cmsg25 ($msg_mail) if $debug_msg_log;
178     my $r = <SMTP>;
179     error25($r) unless $r =~ /^250/;
180     Send::Log::Server25($r);
181     }
182     Send::NNTP::Connect() if $post_news && !$Send::NNTP::connected;
183     if ($post_news) {
184     pmsg('post a news article...');
185     printN("POST\x0D\x0A");
186     my $r = <NNTP>;
187     error119($r) unless $r =~ /^340/;
188     Send::Log::Server119($r);
189     print NNTP $msg_news;
190     cmsg119('(article)');
191     cmsg119($msg_news) if $debug_msg_log;
192     my $r = <NNTP>;
193     error119($r) unless $r =~ /^240/;
194     Send::Log::Server119($r);
195     }
196    
197     my $t = time;
198     pmsg("\$ mv \"$file\" \"sent/$t.822\"");
199     pmsg(`mv "$file" "sent/$t.822"`);
200     }
201     Send::SMTP::Close() if $Send::SMTP::connected;
202     Send::NNTP::Close() if $Send::NNTP::connected;
203     close LOG;
204    
205     sub pmsg {
206     print STDOUT "$0: ". join("\n$0: ",@_)."\n";
207     print LOG join("\n",@_)."\n";
208     }
209    
210     sub cmsg {pmsg('C: '.shift,@_)}
211     sub smsg {pmsg('S: '.shift,@_)}
212     sub cmsg25 {pmsg('C25: '.shift,@_)}
213     sub smsg25 {pmsg('S25: '.shift,@_)}
214     sub cmsg119 {pmsg('C119: '.shift,@_)}
215     sub smsg119 {pmsg('S119: '.shift,@_)}
216    
217     sub Send::SMTP::Close {
218     printS("QUIT\x0D\x0A");
219     my $r = <SMTP>;
220     smsg25($r);
221     close SMTP;
222     $Send::SMTP::connected = 0;
223     }
224     sub Send::NNTP::Close {
225     printN("QUIT\x0D\x0A");
226     my $r = <NNTP>;
227     smsg119($r);
228     close NNTP;
229     $Send::NNTP::connected = 0;
230     }
231    
232     sub printS {
233     print SMTP $_[0];
234     my $s = $_[0];
235     $s =~ s/\x0D\x0A$//s;
236     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
237     cmsg25($s);
238     }
239     sub printN {
240     print NNTP $_[0];
241     my $s = $_[0];
242     $s =~ s/\x0D\x0A$//s;
243     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
244     cmsg119($s);
245     }
246    
247    
248     sub wm::smtp::addstatus {
249     my $s = $_[0];
250     $s =~ s/\x0D\x0A$//s;
251     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
252     smsg($s);
253     }
254     sub Send::Log::Server25 {
255     my $s = $_[0];
256     $s =~ s/\x0D\x0A$//s;
257     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
258     smsg25($s);
259     }
260     sub Send::Log::Server119 {
261     my $s = $_[0];
262     $s =~ s/\x0D\x0A$//s;
263     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
264     smsg119($s);
265     }
266    
267     sub error {
268     my $s = $_[0];
269     $s =~ s/\x0D\x0A$//s;
270     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
271     pmsg($s);
272     Send::SMTP::Close() if $Send::SMTP::connected;
273     Send::NNTP::Close() if $Send::NNTP::connected;
274     close LOG;
275     use Carp;
276     croak ($s);
277     }
278     sub error25 {
279     my $s = $_[0];
280     $s =~ s/\x0D\x0A$//s;
281     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
282     smsg25($s);
283     Send::SMTP::Close() if $Send::SMTP::connected;
284     Send::NNTP::Close() if $Send::NNTP::connected;
285     close LOG;
286     die;
287     }
288     sub error119 {
289     my $s = $_[0];
290     $s =~ s/\x0D\x0A$//s;
291     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
292     smsg119($s);
293     Send::SMTP::Close() if $Send::SMTP::connected;
294     Send::NNTP::Close() if $Send::NNTP::connected;
295     close LOG;
296     die;
297     }
298    
299    
300     sub Send::SMTP::Connect (;%) {
301     my %o = @_;
302     my $myname = $o{myname} || 'send.pl.'.$server{smtp};
303     pmsg('connecting to '.$server{smtp}.':25...');
304     socket (SMTP, PF_INET, SOCK_STREAM, (getprotobyname('tcp'))[2]);
305     my $aton = inet_aton($server{smtp});
306     pmsg ('IPv4 address: ' . sprintf '%vd', $aton);
307     connect(SMTP, sockaddr_in(25, $aton))
308     || error("Can't connect to $server{smtp}:25");
309     select(SMTP), $| =1; binmode SMTP;
310     my $r = <SMTP>;
311     error25($r) unless $r =~ /^220/;
312     Send::Log::Server25($r);
313     printS('HELO '.$myname."\x0D\x0A");
314     my $r = <SMTP>;
315     error25() unless $r =~ /^250/;
316     Send::Log::Server25($r);
317     $Send::SMTP::connected = 1;
318     }
319    
320     sub Send::NNTP::Connect {
321     pmsg('conecting to '.$server{nntp}.':119...');
322     socket (NNTP, PF_INET, SOCK_STREAM, (getprotobyname('tcp'))[2]);
323     connect(NNTP, sockaddr_in(119, inet_aton($server{nntp})))
324     || error("Can't connect to $server{nntp}:119");
325     select(NNTP), $| =1; binmode NNTP;
326     my $r = <NNTP>;
327     error119($r) unless $r =~ /^200/;
328     Send::Log::Server119($r);
329     #printN('AUTHINFO USER foo'."\x0D\x0A");
330     # $r = <NNTP>;
331     # error119($r) unless $r =~ /^381/;
332     # Send::Log::Server119($r);
333     #print NNTP ('AUTHINFO PASS bar'."\x0D\x0A");
334     # cmsg119('AUTHINFO PASS (password)');
335     # $r = <NNTP>;
336     # error119($r) unless $r =~ /^281/;
337     # Send::Log::Server119($r);
338     $Send::NNTP::connected = 1;
339     }
340    
341     sub __fw2hw ($) {
342     my $s = shift;
343     jcode::tr(\$s, "\xa3\xb0-\xa3\xb9\xa3\xc1-\xa3\xda\xa3\xe1-\xa3\xfa\xa1\xf5".
344     "\xa1\xa4\xa1\xa5\xa1\xa7\xa1\xa8\xa1\xa9\xa1\xaa\xa1\xae".
345     "\xa1\xb0\xa1\xb2\xa1\xbf\xa1\xc3\xa1\xca\xa1\xcb\xa1\xce".
346     "\xa1\xcf\xa1\xd0\xa1\xd1\xa1\xdc\xa1\xf0\xa1\xf3\xa1\xf4".
347     "\xa1\xf6\xa1\xf7\xa1\xe1\xa2\xaf\xa2\xb0\xa2\xb2\xa2\xb1".
348     "\xa1\xe4\xa1\xe3\xA1\xC0\xA1\xA1" =>
349     '0-9A-Za-z&,.:;?!`^_/|()[]{}+$%#*@=\'"~-><\\ ');
350     $s;
351     }
352    
353     END {
354     Send::SMTP::Close() if $Send::SMTP::connected;
355     Send::NNTP::Close() if $Send::NNTP::connected;
356     }
357    
358     =head1 LICENSE
359    
360     Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
361    
362     This program is free software; you can redistribute it and/or modify
363     it under the terms of the GNU General Public License as published by
364     the Free Software Foundation; either version 2 of the License, or
365     (at your option) any later version.
366    
367     This program is distributed in the hope that it will be useful,
368     but WITHOUT ANY WARRANTY; without even the implied warranty of
369     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
370     GNU General Public License for more details.
371    
372     You should have received a copy of the GNU General Public License
373     along with this program; see the file COPYING. If not, write to
374     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
375     Boston, MA 02111-1307, USA.
376    
377     =head1 CHANGE
378    
379     See F<ChangeLog>.
380     $Date: 2002/07/20 08:42:56 $
381    
382     =cut
383    
384     ### send-msg.pl ends here

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24