/[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 - (show 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 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