/[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.3 - (hide annotations) (download)
Sat Jul 27 04:56:38 2002 UTC (22 years, 3 months ago) by wakaba
Branch: MAIN
Changes since 1.2: +8 -5 lines
File MIME type: text/plain
2002-07-27  Wakaba <w@suika.fam.cx>

	* send-msg.pl:
	- Don't remove Bcc: and Resent-Bcc: fields.
	(But its field-body is still removed.)
	- ($VERSION): Use CVS (RCS)'s value.
	- ($MYVERSION): New value.
	- Sort fields (by 'good-practice' order) unless the 
	message is to be resent.

1 wakaba 1.1 use strict;
2 wakaba 1.3 use vars qw($MYNAME $MYVERSION $VERSION);
3     $MYNAME = 'send.pl';
4     $VERSION=do{my @r=(q$Revision: 1.40 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
5     $MYVERSION = qq{2.5.$VERSION};
6 wakaba 1.1 use lib qw(/home/wakaba/temp/msg/);
7     use Message::Entity;
8     use Message::Field::Date;
9     use Message::MIME::Charset::Jcode 'Jcode.pm';
10     use Message::MIME::Charset::Jcode 'jcode.pl';
11     use Socket;
12     binmode STDOUT; $| = 1; binmode STDERR;
13     my %server;
14     $server{smtp} ||= 'suika.fam.cx';
15     $server{nntp} ||= 'suika.fam.cx';
16     my $debug_msg_log = 0;
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 wakaba 1.3 $ua->add ($MYNAME => $MYVERSION);
127 wakaba 1.1
128 wakaba 1.3 $header->delete (qw(date-received relay-version status x-envelope-from x-envelope-to xref));
129     $header->option (field_sort => 'good-practice') unless $resent;
130 wakaba 1.1
131     my %sopt = (
132     -fill_date => 0, -fill_msgid => 0,
133     -ua_field_name => $a.'user-agent',
134     );
135     my ($msg_mail, $msg_news);
136     if ($send_mail) {
137     $msg_mail = $msg->stringify (-format => 'mail-rfc2822', %sopt);
138     #$msg_mail =~ s/\x0D\x0A|\x0D|\x0A/\x0D\x0A/gs;
139     $msg_mail =~ s/\x0D\x0A\./\x0D\x0A../gs;
140     #$msg_mail =~ s/^(?:\x0D\x0A)+//;
141     #$msg_mail =~ s/(?:\x0D\x0A)*$/\x0D\x0A/;
142     $msg_mail .= "\x0D\x0A.\x0D\x0A";
143     }
144     if ($post_news) {
145     my %rename;
146     for (qw(cc complaints-to nntp-posting-date injector-info nntp-posting-host posting-version received to x-complaints-to x-trace)) {
147     $rename{$_} = 'x-'.$_;
148     }
149     $header->rename (%rename);
150     $msg_news = $msg->stringify (-format => 'news-usefor', %sopt);
151     #$msg_news =~ s/\x0D\x0A|\x0D|\x0A/\x0D\x0A/gs;
152     $msg_news =~ s/\x0D\x0A\./\x0D\x0A../gs;
153     #$msg_news =~ s/^(?:\x0D\x0A)+//;
154     #$msg_news =~ s/(?:\x0D\x0A)*$/\x0D\x0A/;
155     $msg_news .= "\x0D\x0A.\x0D\x0A";
156     }
157    
158     Send::SMTP::Connect () if $send_mail && !$Send::SMTP::connected;
159     if ($send_mail) {
160     pmsg('send a mail message...');
161     printS("MAIL FROM:<${eFrom}>\x0D\x0A");
162     my $r = <SMTP>;
163     error25($r) unless $r =~ /^250/;
164     Send::Log::Server25($r);
165     for my $rcptto (@eTo) {
166     next unless $rcptto;
167     printS("RCPT TO:<$rcptto>\x0D\x0A");
168     my $r = <SMTP>;
169     error25($r) unless $r =~ /^25/;
170     Send::Log::Server25($r);
171     }
172     printS("DATA\x0D\x0A");
173     my $r = <SMTP>;
174     error25($r) unless $r =~ /^354/;
175     Send::Log::Server25($r);
176     print SMTP $msg_mail;
177     cmsg25 ('(message)');
178     cmsg25 ($msg_mail) if $debug_msg_log;
179     my $r = <SMTP>;
180     error25($r) unless $r =~ /^250/;
181     Send::Log::Server25($r);
182     }
183     Send::NNTP::Connect() if $post_news && !$Send::NNTP::connected;
184     if ($post_news) {
185     pmsg('post a news article...');
186     printN("POST\x0D\x0A");
187     my $r = <NNTP>;
188     error119($r) unless $r =~ /^340/;
189     Send::Log::Server119($r);
190     print NNTP $msg_news;
191     cmsg119('(article)');
192     cmsg119($msg_news) if $debug_msg_log;
193     my $r = <NNTP>;
194     error119($r) unless $r =~ /^240/;
195     Send::Log::Server119($r);
196     }
197    
198     my $t = time;
199     pmsg("\$ mv \"$file\" \"sent/$t.822\"");
200     pmsg(`mv "$file" "sent/$t.822"`);
201     }
202     Send::SMTP::Close() if $Send::SMTP::connected;
203     Send::NNTP::Close() if $Send::NNTP::connected;
204     close LOG;
205    
206     sub pmsg {
207     print STDOUT "$0: ". join("\n$0: ",@_)."\n";
208     print LOG join("\n",@_)."\n";
209     }
210    
211     sub cmsg {pmsg('C: '.shift,@_)}
212     sub smsg {pmsg('S: '.shift,@_)}
213     sub cmsg25 {pmsg('C25: '.shift,@_)}
214     sub smsg25 {pmsg('S25: '.shift,@_)}
215     sub cmsg119 {pmsg('C119: '.shift,@_)}
216     sub smsg119 {pmsg('S119: '.shift,@_)}
217    
218     sub Send::SMTP::Close {
219     printS("QUIT\x0D\x0A");
220     my $r = <SMTP>;
221     smsg25($r);
222     close SMTP;
223     $Send::SMTP::connected = 0;
224     }
225     sub Send::NNTP::Close {
226     printN("QUIT\x0D\x0A");
227     my $r = <NNTP>;
228     smsg119($r);
229     close NNTP;
230     $Send::NNTP::connected = 0;
231     }
232    
233     sub printS {
234     print SMTP $_[0];
235     my $s = $_[0];
236     $s =~ s/\x0D\x0A$//s;
237     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
238     cmsg25($s);
239     }
240     sub printN {
241     print NNTP $_[0];
242     my $s = $_[0];
243     $s =~ s/\x0D\x0A$//s;
244     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
245     cmsg119($s);
246     }
247    
248    
249     sub wm::smtp::addstatus {
250     my $s = $_[0];
251     $s =~ s/\x0D\x0A$//s;
252     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
253     smsg($s);
254     }
255     sub Send::Log::Server25 {
256     my $s = $_[0];
257     $s =~ s/\x0D\x0A$//s;
258     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
259     smsg25($s);
260     }
261     sub Send::Log::Server119 {
262     my $s = $_[0];
263     $s =~ s/\x0D\x0A$//s;
264     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
265     smsg119($s);
266     }
267    
268     sub error {
269     my $s = $_[0];
270     $s =~ s/\x0D\x0A$//s;
271     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
272     pmsg($s);
273     Send::SMTP::Close() if $Send::SMTP::connected;
274     Send::NNTP::Close() if $Send::NNTP::connected;
275     close LOG;
276     use Carp;
277     croak ($s);
278     }
279     sub error25 {
280     my $s = $_[0];
281     $s =~ s/\x0D\x0A$//s;
282     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
283     smsg25($s);
284     Send::SMTP::Close() if $Send::SMTP::connected;
285     Send::NNTP::Close() if $Send::NNTP::connected;
286     close LOG;
287     die;
288     }
289     sub error119 {
290     my $s = $_[0];
291     $s =~ s/\x0D\x0A$//s;
292     $s =~ s/\x0D\x0A/\x0D\x0A /gs;
293     smsg119($s);
294     Send::SMTP::Close() if $Send::SMTP::connected;
295     Send::NNTP::Close() if $Send::NNTP::connected;
296     close LOG;
297     die;
298     }
299    
300    
301     sub Send::SMTP::Connect (;%) {
302     my %o = @_;
303 wakaba 1.2 my $myname = $o{myname} || &Message::Util::get_host_fqdn || 'send.pl.'.$server{smtp};
304 wakaba 1.1 pmsg('connecting to '.$server{smtp}.':25...');
305     socket (SMTP, PF_INET, SOCK_STREAM, (getprotobyname('tcp'))[2]);
306     my $aton = inet_aton($server{smtp});
307     pmsg ('IPv4 address: ' . sprintf '%vd', $aton);
308     connect(SMTP, sockaddr_in(25, $aton))
309     || error("Can't connect to $server{smtp}:25");
310     select(SMTP), $| =1; binmode SMTP;
311     my $r = <SMTP>;
312     error25($r) unless $r =~ /^220/;
313     Send::Log::Server25($r);
314     printS('HELO '.$myname."\x0D\x0A");
315     my $r = <SMTP>;
316     error25() unless $r =~ /^250/;
317     Send::Log::Server25($r);
318     $Send::SMTP::connected = 1;
319     }
320    
321     sub Send::NNTP::Connect {
322     pmsg('conecting to '.$server{nntp}.':119...');
323     socket (NNTP, PF_INET, SOCK_STREAM, (getprotobyname('tcp'))[2]);
324     connect(NNTP, sockaddr_in(119, inet_aton($server{nntp})))
325     || error("Can't connect to $server{nntp}:119");
326     select(NNTP), $| =1; binmode NNTP;
327     my $r = <NNTP>;
328     error119($r) unless $r =~ /^200/;
329     Send::Log::Server119($r);
330     #printN('AUTHINFO USER foo'."\x0D\x0A");
331     # $r = <NNTP>;
332     # error119($r) unless $r =~ /^381/;
333     # Send::Log::Server119($r);
334     #print NNTP ('AUTHINFO PASS bar'."\x0D\x0A");
335     # cmsg119('AUTHINFO PASS (password)');
336     # $r = <NNTP>;
337     # error119($r) unless $r =~ /^281/;
338     # Send::Log::Server119($r);
339     $Send::NNTP::connected = 1;
340     }
341    
342     sub __fw2hw ($) {
343     my $s = shift;
344     jcode::tr(\$s, "\xa3\xb0-\xa3\xb9\xa3\xc1-\xa3\xda\xa3\xe1-\xa3\xfa\xa1\xf5".
345     "\xa1\xa4\xa1\xa5\xa1\xa7\xa1\xa8\xa1\xa9\xa1\xaa\xa1\xae".
346     "\xa1\xb0\xa1\xb2\xa1\xbf\xa1\xc3\xa1\xca\xa1\xcb\xa1\xce".
347     "\xa1\xcf\xa1\xd0\xa1\xd1\xa1\xdc\xa1\xf0\xa1\xf3\xa1\xf4".
348     "\xa1\xf6\xa1\xf7\xa1\xe1\xa2\xaf\xa2\xb0\xa2\xb2\xa2\xb1".
349     "\xa1\xe4\xa1\xe3\xA1\xC0\xA1\xA1" =>
350     '0-9A-Za-z&,.:;?!`^_/|()[]{}+$%#*@=\'"~-><\\ ');
351     $s;
352     }
353    
354     END {
355     Send::SMTP::Close() if $Send::SMTP::connected;
356     Send::NNTP::Close() if $Send::NNTP::connected;
357     }
358    
359     =head1 LICENSE
360    
361     Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
362    
363     This program is free software; you can redistribute it and/or modify
364     it under the terms of the GNU General Public License as published by
365     the Free Software Foundation; either version 2 of the License, or
366     (at your option) any later version.
367    
368     This program is distributed in the hope that it will be useful,
369     but WITHOUT ANY WARRANTY; without even the implied warranty of
370     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
371     GNU General Public License for more details.
372    
373     You should have received a copy of the GNU General Public License
374     along with this program; see the file COPYING. If not, write to
375     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
376     Boston, MA 02111-1307, USA.
377    
378     =head1 CHANGE
379    
380     See F<ChangeLog>.
381 wakaba 1.3 $Date: 2002/07/26 06:38:53 $
382 wakaba 1.1
383     =cut
384    
385     ### send-msg.pl ends here

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24