root/lang/perl/misc/i18n-emoji/EmailJP.pm

Revision 3817, 20.1 kB (checked in by kawa0117, 11 months ago)

see http://www.kawa.net/works/perl/i18n-emoji/i18n-emoji.html (2005/09/13)

Line 
1# ----------------------------------------------------------------
2#   EmailJP.pl - Send mail with Net::SMTP (add Date: header)
3#   Copyright 2001-2004 Kappe Inc. All rights reserved.
4# ----------------------------------------------------------------
5#   2001/05/14  ������ɥ쥹�μ��Ф�������Ȥ����С�����
6#   2002/12/25  RCPT ���ޥ���顼�����debug ���ץ������
7#   2003/06/13  ���ʸ���ɻ������­�����إå������#   2003/06/26  �إå�ɲä����ˤ���   2003/07/01  ʣ���SMTP�����Ф��ǽ
8#   2004/07/05  �Х��������ư����������Message-Id: �����#   2004/10/28  Encode561��EmojiTrans��EscapeSJIS��EscapeJIS ���
9#   2004/11/07  POD �򾯤������ޤ���
10# ----------------------------------------------------------------
11    use strict;
12    package EmailJP;
13    use vars qw( $VERSION $DEBUG );
14# ----------------------------------------------------------------
15    $VERSION = "0.01";
16# ----------------------------------------------------------------
17=head1 NAME
18
19    EmailJP.pm -- Send mail with Net::SMTP (add Date: header)
20
21=head1 SYNOPSIS
22
23    # ����ʻȤ���ʥإå�򻲾Ȥ��ư�����ɥ쥹���
24    use EmailJP;
25    my $count = &EmailJP::sendmail( mail => $text );
26
27    # ����λȤ���ʰ�����ɥ쥹���Ū�˻�ꤹ��
28    use EmailJP;
29    my $server;
30    $server = "127.0.0.1";                      # SMTP������    $server = [qw( 192.168.0.1 127.0.0.1 )];    # ʣ���ǽ
31    my $count = &EmailJP::sendmail(
32        server   =>  $server,        # SMTP������        hello    =>  "localhost",    # HELLO
33        timeout  =>  5,              # �����ॢ����        return   =>  $return_path,   # ���顼���
34        to       =>  $rcpt_to,       # �᡼�밸�
35        head     =>  $mail_head,     # �᡼���å�        body     =>  $mail_body,     # �᡼��ʸ
36        charset  =>  "iso-2022-jp",  # ���ʸ���ɤ�JIS
37        internal =>  "EUC-JP"        # ��ʸ���ɤ�EUC
38    );
39
40=head1 DESCRIPTION
41
42EmailJP �⥸�塼���������ޤ�����Ŭ��ʷ�������ޤ���
43
44=head2 OPTIONS
45
46sendmail() �ؿ�ϰʲ��Υ��ץ���������ޤ���
47
48server => SMTP�����Хۥ���P���ɥ쥹
49
50    EmailJP ���᡼�����������ǥե�����127.0.0.1�ʼ��ۥ��ȡˤ�    SMTP �³���ƥ᡼��������ޤ���
51    SMTP �³�����Υ᡼�륵����P���ɥ쥹�����������
52    server ���ץ����ǻ�ꤷ�Ƥ��������
53    ���ؤΥ������������᡼�륵���Ф�󤷤����ϡ�
54    1��ܤΥ᡼�륵���Ф���ߤ��Ƥ�����
55    2��ܰʹߤΥ᡼�륵���Фؽ��³���ޤ���
56    ������ǽ�ʥ᡼�륵���Ф�󤷤Ƥ������Ȥ򤪴��ᤷ�ޤ���
57
58hello => HELLOʸ��    SMTP �³����HELO ���ޥ�ΰ���ꤷ�ޤ���
59    �ǥե����Ǥ�localhost �Ȥʤ�����
60    ���ΤޤޤǤ�������������
61timeout => �����ॢ����ÿ�   SMTP �³���Υ����ॢ����ÿ��ꤷ�ޤ���
62
63return => ���顼�������ɥ쥹
64
65    �᡼������λ�����顼��ȯ��������ˡ�
66    SMTP �����Ф�����������ɥ쥹��ꤷ�ޤ���
67    ��ꤷ�ʤ����ϡ��᡼���å��Return-Path: �Ԥ����Ȥ�������
68    ����������顼�᡼�뤬�������Τ�EmailJP �������������
69    EmailJP ����������������ϡ�ñ�˵����������
70
71to => �᡼�밸����ɥ쥹
72
73    �᡼��������ɥ쥹��ꤷ�ޤ���
74    ��ꤷ�ʤ����ϡ��᡼���å��To: Cc: Bcc: �Ԥ����Ȥ�������
75
76
77internal => ��ʸ����
78    sendmail() �ؿ�ƤӽФ�¦������ɤϡ�
79    �ǥե�����EUC-JP �Ȥߤʤ��ޤ���
80    EUC-JP �ʳ��������UTF-8�ʤ���Ѥ��Ƥ�������
81    internal ���ץ����ǻ�ꤷ�Ƥ��������
82    Shift_JIS��UTF-8 �ʤɤ���ѤǤ��ޤ���
83
84charset => ���ʸ����
85    �᡼������������ɤϡ��ǥե�����iso-2022-jp �Ȥʤ�����
86    ��������᡼��ʸ���&#xHHHH; ����γ�ʸ���ɤ����ꡢ
87    �᡼�������NTT �ɥ�������ɥ쥹����
88    ����au��TU-KA��Vodafone �η�ӥ��ɥ쥹��ޤʤ����ϡ�
89    NTT �ɥ�����ʸ�����ʤ�������뤿��hift_JIS �Ȥʤ�����
90    ������������ɤ����������ϡ�charset ���ץ�����    ��ꤷ�Ƥ��������
91    Shift_JIS��UTF-8 �ʤɤ���ѤǤ��ޤ���
92
93head => �᡼���å�body => �᡼��ʸ
94
95    ������������إå������ꤷ�ޤ���
96    �᡼���å������ͽ������Ƥ�������
97    ������mail ���ץ�����ꤷ�Ƥ��������
98
99mail => �᡼���å����
100
101    ������������إå������ꤷ�ޤ���
102    �إå�����δ֤ˤ϶�ߣ���ɬ��Ǥ���
103    �᡼���å������ͽ��Υ���Ƥ�������
104    �嵭��head��body ���ץ�����ꤷ�Ƥ��������
105
106=head2 DEFAULT MAIL HEADER
107
108mail ���ץ����ޤ���head ���ץ����ǻ�ꤵ�줿�إå��
109ɬ�ܤΥإå��̵�����ϡ������Τ褦�ʥإå����ư��ä�������
110
111    ����ࡧJIS�ξ���    Date: Fri, 13 Jun 2003 03:17:01 +0900
112    MIME-Version: 1.0
113    Content-Type: text/plain; charset="ISO-2022-JP"
114    Content-Transfer-Encoding: 7bit
115
116    ��hift_JIS�ξ���    Date: Fri, 13 Jun 2003 03:17:01 +0900
117    MIME-Version: 1.0
118    Content-Type: text/plain; charset="Shift_JIS"
119    Content-Transfer-Encoding: 8bit
120
121=head2 E-MAIL FOR PC
122
123PC�����Υ᡼���ˡ��ϥ�������Ω�κ��ʤɤ�IBM ����������
124EscapeJIS.pm �⥸�塼����ʸ���������Ǥ��ޤ���
125
126    CP932   UCS2    �­
127    ------  ------  ----------
128    FBFC    9AD9    �ϥ�����    FAB1    FA11    ������ܲ�
129    FBB9    9127    �Ȥ���ʿ
130
131�����������Σϣӡ��᡼�륽�եȤˤ��Ƥ������ɽ���Ǥ��ʤ��������������utlook Express��Becky! 2 �Ǥ�����Ǥ��ޤ���
132=head2 E-MAIL FOR PHONE
133
134�᡼��ʸ������ɤ�̾ISO-2022-JP (JIS) �Ȥʤ�������
135�᡼��ʸ���&#xHHHH; ����γ�ʸ���ɤ����ꡢ
136�᡼�������NTT �ɥ�������ɥ쥹����
137����au��TU-KA��Vodafone �η�ӥ��ɥ쥹��ޤʤ����ϡ�
138NTT �ɥ�����ʸ�����ʤ�������뤿��hift_JIS �Ȥʤ�����
139
140�᡼��ʸ���&#xHHHH; ����γ�ʸ���ɤ����ꡢ
141�᡼�������au��TU-KA �η�ӥ��ɥ쥹����
142����NTT �ɥ��⡦Vodafone �η�ӥ��ɥ쥹��ޤʤ����ϡ�
143EmojiTrans.pm �⥸�塼�������ơ�
144NTT �ɥ����γ�ʸ���ɤ���TU-KA ��λ��ʸ���ɤ�Ѵ����ޤ���
145
146�᡼��ʸ���&#xHHHH; ����γ�ʸ���ɤ����ꡢ
147�᡼�������Vodafone �η�ӥ��ɥ쥹����
148����NTT �ɥ��⡦au��TU-KA �η�ӥ��ɥ쥹��ޤʤ����ϡ�
149EmojiTrans.pm �⥸�塼�������ơ�
150NTT �ɥ����γ�ʸ���ɤ�dafone ��λ��ʸ���ɤ�Ѵ����ޤ���
151
152��������NTT �ɥ����γ�ʸ���ɤ������ʸ��դ�������NTT �ɥ��⡦au��TU-KA��Vodafone ��ƤΥ�������Ф��Ƴ�ʸ��������
153���������뤳�Ȥ��Ǥ��ޤ���
154
155=head1 COPYRIGHT
156
157    Copyright 2004 Kawasaki Yusuke <u-suke@kawa.net>
158    http://www.kawa.net/
159
160=cut
161# ----------------------------------------------------------------
162#   �ƥ⥸�塼����ɤ߹��ߤ����� �����ʥ⥸�塼����ưŪ��ɤ߹��ޤ�����# ----------------------------------------------------------------
163    use Net::SMTP;
164    use Encode561;
165    use EmojiTrans;
166#   use EscapeSJIS;
167#   use EscapeJIS;
168#   use EscapeUTF8;
169#   use MIME::Base64;
170#   use Jcode;
171# ----------------------------------------------------------------
172#   �ǥХå��⡼��# ----------------------------------------------------------------
173#   $DEBUG ++;
174# ----------------------------------------------------------------
175#   ����
176# ----------------------------------------------------------------
177    my $WORK_CHARSET = "EUC-JP";        # or "UTF-8"
178    my $OUT_CHARSET  = "ISO-2022-JP";   # or "UTF-8", "Shift_JIS"
179    my $DOCOMO_CHARSET = "Shift_JIS";   # �ɥ����
180    my $SMTP_SERVER  = "127.0.0.1";
181    my $SMTP_HELLO   = "localhost";
182    my $TIMEZONE     = "+0900";
183    my $MIME_VERSION = "1.0";
184    my $SMTP_TIMEOUT = 3;
185    my $MAIL_COMMAND = "/usr/sbin/sendmail -oi";
186# ----------------------------------------------------------------
187#   Content-Transfer-Encoding: �Ǥʤ����󥳡��ǥ��󥰤�� ----------------------------------------------------------------
188    my $NOT_8BIT_CODE = {
189        "iso-2022-jp"   =>  "7bit",
190    };
191# ----------------------------------------------------------------
192#   ����ǡ�Jcode.pm ��Υ��������ꤵ�줿����Ѵ��ޥå�# ----------------------------------------------------------------
193    my $JCODE2CHARSET = {
194        jis     =>  "ISO-2022-JP",
195        euc     =>  "EUC-JP",
196        sjis    =>  "Shift_JIS",
197        utf8    =>  "UTF-8",
198    };
199# ----------------------------------------------------------------
200#       �᡼����
201# ----------------------------------------------------------------
202sub sendmail {
203    my $hash = { @_ };
204    my $head = $hash->{head};
205    my $body = $hash->{body};
206    my $wait = $hash->{timeout} || $SMTP_TIMEOUT;   # SMTP�����ॢ����    my $from = $hash->{return};
207    my $rcpt = $hash->{to};
208    my $server = $hash->{server} || $SMTP_SERVER;
209    my $hello  = $hash->{hello}  || $SMTP_HELLO;
210    my $outcode = $hash->{charset};                     # charset= ���   $outcode ||= $JCODE2CHARSET->{$hash->{jcode}};      # ���������Ȥθߴ�
211    my $workcode = $hash->{internal} || $WORK_CHARSET;
212    my $command = $hash->{command} || undef;            # ������ޥ���
213    $DEBUG ++ if $hash->{debug};        # �ǥХå���002/12/25��
214    # �إå������ڤ����γ��    if ( $head eq "" && $body eq "" && defined $hash->{mail} ) {
215        my $mail = $hash->{mail};
216        $mail = join( "", @$mail ) if ref $mail;
217        $mail =~ s/\r?\n/\n/sg;
218        $mail =~ s/\r/\n/sg;
219        ( $head, $body ) = split( /(?:\n\r?\n|\r\n?\r)/, $mail, 2 );
220    } else {
221        $head =~ s/\r?\n/\n/sg;
222        $head =~ s/\r/\n/sg;
223        $body =~ s/\r?\n/\n/sg;
224        $body =~ s/\r/\n/sg;
225    }
226
227    # &#xHHHH; ����γ�ʸ���äƤ�����    my $use_emoji;
228    $use_emoji ++ if ( $head =~ /\&\#/ );
229    $use_emoji ++ if ( $body =~ /\&\#/ );
230    $DEBUG and print "[USE_EMOJI=$use_emoji]\n";
231
232    # �إå��̵��ʶ��� $head =~ s/[\r\n]+/\n/sg;
233    $head =~ s/^\s+//s;
234    $head =~ s/\s+$//s;
235
236    # ���пͥ��ɥ쥹�μ��Ф�
237
238    $from ||= ( $head =~ /^Return-Path:(?:[^\n]|\n[\040\t])*?
239        ([^\000-\040\"\'\<\>\(\)\@\,]+\@(?:[\w\-]+\.)+\w+)/mx )[0];
240    $from ||= ( $head =~ /^From:       (?:[^\n]|\n[\040\t])*?
241        ([^\000-\040\"\'\<\>\(\)\@\,]+\@(?:[\w\-]+\.)+\w+)/mx )[0];
242    $DEBUG and print "[FROM=$from]\n";
243    die "Sender address is not defined.\n" if ( $from eq "" );
244
245    # ����襢�ɥ쥹�μ��Ф�
246
247    if ( ! ref $rcpt ) {
248        if ( $rcpt eq "" ) {
249            $rcpt = [];
250            foreach my $line ( $head =~ /^(?:To|Cc|Bcc):
251                                         ((?:[^\n]+|\n[\040\t])+)/mxg ) {
252                foreach my $addr ( $line =~ /([^\000-\040\"\'\<\>\(\)\@\,]+
253                                             \@(?:[\w\-]+\.)+\w+)/xg ) {
254                    push( @$rcpt, $addr );
255                }
256            }
257        } else {
258            $rcpt = [ $rcpt ];
259        }
260    }
261    $DEBUG and print "[RCPT=",($#$rcpt+1),"]\n";
262    die "Receipt address is not defined.\n" if ( $#$rcpt < 0 );
263
264    # ����ð��Υ��ɥ쥹�������    my $user_agent = &mobile_user_agent( $rcpt );
265    $DEBUG and print "[USER_ANGET=$user_agent]\n";
266
267    # Date: �Ԥ��ʤ����Ƭ��ɲä���    my $date = ( $head =~ /(?:^|[\r\n])Date:
268                           (?:[^\n]|\n[\040\t])*?(\S.*)/is )[0];
269    if ( $date eq "" ) {
270        $date = &get_date_string();
271        $head = "Date: ".$date."\n".$head if $date;
272    }
273    $DEBUG and print "[Date=$date]\n";
274
275    # Content-Type: �Ԥ�����ɤ���ꤵ��������������
276
277    my $ctline = ( $head =~ /(?:^|[\r\n])Content-Type:
278                            (?:[^\n]|\n[\040\t])*?(\S.*)/isx )[0];
279    if ( $ctline =~ m#^text/.*;\s*charset="?([^"]+)#isx ) {
280        $outcode = $1;
281    }
282    # ��ϥ����ɤ�̤�����������ɥ����ߤǡ�
283    # ��ʸ��������������ʾ��ϡ�Shift_JIS �Ȥ���    unless ( $outcode ) {
284        if ( $use_emoji && $user_agent eq "DoCoMo/" ) {
285            $outcode ||= $DOCOMO_CHARSET;
286        }
287        $outcode ||= $OUT_CHARSET;
288    }
289
290    # Content-Type: �Ԥ��ʤ����Ƭ��ɲä���    if ( $ctline eq "" && $outcode ) {
291        $ctline = "text/plain; charset=".$outcode;
292        $head = "Content-Type: ".$ctline."\n".$head;
293    }
294    $DEBUG and print "[Content-Type=$ctline]\n";
295    $DEBUG and print "[charset=$outcode]\n";
296
297    # Content-Transfer-Encoding: �Ԥ��ʤ����Ƭ��ɲä���    my $ctenc = ( $head =~ /(?:^|[\r\n])Content-Transfer-Encoding:
298                            (?:[^\n]|\n[\040\t])*?(\S.*)/isx )[0];
299    if ( $ctenc eq "" ) {
300        $ctenc = "8bit";
301        $ctenc = $NOT_8BIT_CODE->{$outcode} if $NOT_8BIT_CODE->{$outcode};
302        $head = "Content-Transfer-Encoding: ".$ctenc."\n".$head;
303    }
304    $DEBUG and print "[Content-Transfer-Encoding=$ctenc]\n";
305
306    # MIME-Version: �Ԥ��ʤ����Ƭ��ɲä���    my $mimever = ( $head =~ /(?:^|[\r\n])MIME-Version:
307                              (?:[^\n]|\n[\040\t])*?(\S.*)/isx )[0];
308    if ( $mimever eq "" ) {
309        $mimever = $MIME_VERSION;
310        $head = "MIME-Version: ".$mimever."\n".$head;
311    }
312    $DEBUG and print "[MIME-Version=$mimever]\n";
313
314    # Message-Id: �Ԥ��ʤ����Ƭ��ɲä���    my $messid = ( $head =~ /(?:^|[\r\n])Message-Id:
315                             (?:[^\n]|\n[\040\t])*?(\S.*)/isx )[0];
316    if ( $messid eq "" ) {
317        $messid = &gen_message_id( $from );
318        $head = "Message-Id: ".$messid."\n".$head if $messid;
319        $DEBUG and print "[Message-Id=$messid]\n";
320    }
321
322    # ʸ����Ѵ���
323
324    if ( $workcode ne $outcode ) {
325        &require_or_die( "Encode561.pm" ) unless defined $Encode561::VERSION;
326        $DEBUG and print "[Encode561=$workcode to $outcode]\n";
327        Encode561::from_to( \$head, $workcode, $outcode );
328        Encode561::from_to( \$body, $workcode, $outcode );
329    }
330
331    # ��ʸ�����Ƥ��ơ���Ӱ�����������ʸ������    if ( $use_emoji && $user_agent ) {
332        &require_or_die( "EmojiTrans.pm" ) unless defined $EmojiTrans::VERSION;
333        $DEBUG and print "[EmojiTrans=$user_agent]\n";
334        EmojiTrans::translate( \$head, $user_agent );
335        EmojiTrans::translate( \$body, $user_agent );
336    }
337
338    # ��ʸ����&#xHHHH; ����Υ��������ײ����MIME�إå��
339
340    if ( $outcode =~ /^ISO-2022-JP/i ) {
341        $DEBUG and print "[EscapeJIS=$outcode]\n";
342        &require_or_die( "EscapeJIS.pm" ) unless defined $EscapeJIS::VERSION;
343        EscapeJIS::unescape( \$head, $user_agent ) if $use_emoji;
344        EscapeJIS::mime_encode( \$head );
345        EscapeJIS::unescape( \$body, $user_agent ) if $use_emoji;
346    } elsif ( $outcode =~ /^(Shift[\-\_]?JIS|CP932)$/i ) {
347        $DEBUG and print "[EscapeSJIS=$outcode]\n";
348        &require_or_die( "EscapeSJIS.pm" ) unless defined $EscapeSJIS::VERSION;
349        EscapeSJIS::unescape( \$head, $user_agent ) if $use_emoji;
350        EscapeSJIS::mime_encode( \$head );
351        EscapeSJIS::unescape( \$body, $user_agent ) if $use_emoji;
352    } elsif ( $outcode =~ /^UTF-?8$/i ) {
353        $DEBUG and print "[EscapeUTF8=$outcode]\n";
354        &require_or_die( "EscapeUTF8.pm" ) unless defined $EscapeUTF8::VERSION;
355        EscapeUTF8::unescape( \$head, $user_agent ) if $use_emoji;
356        EscapeUTF8::mime_encode( \$head );
357        # EscapeUTF8::unescape( \$body, $user_agent ) if $use_emoji; # �ʸ��Ѵ����ʤ�
358    } else {
359        # ������������ɤξ��⥹�롼����   }
360
361    # Net::SMTP �ǥ᡼��������뤫��������ޥ��Ѥ��뤫���    my $use_smtp = 1 unless $command;
362    if ( $use_smtp ) {
363        &auto_require( "Net/SMTP.pm" ) unless defined $Net::SMTP::VERSION;
364        $DEBUG and print "[Net::SMTP=$Net::SMTP::VERSION]\n";
365    }
366    $use_smtp = undef unless defined $Net::SMTP::VERSION;
367    $command ||= $MAIL_COMMAND unless $use_smtp;
368    if ( ! $use_smtp && ! $command ) {
369        die "Net::SMTP is required for sending e-mail.\n"
370    }
371
372    # Net::SMTP �ޤ��ϳ�����ޥ�ǥ᡼���������    if ( $use_smtp ) {
373        $DEBUG and print "[send_by_smtp]\n";
374        &send_by_smtp( $server, $from, $rcpt, $head, $body, $hello, $wait );
375    } else {
376        $DEBUG and print "[send_by_command=$command]\n";
377        &send_by_command( $command, $from, $rcpt, $head, $body );
378    }
379}
380# ----------------------------------------------------------------
381#   ������ޥ��Ѥ����᡼����
382# ----------------------------------------------------------------
383sub send_by_command {
384    my( $command, $from, $rcpt, $head, $body ) = @_;
385
386    my $line = join( " ", $command, "-f", $from, @$rcpt );
387    open( CMD, "| $line" ) or die "$line - $!\n";
388    print CMD $head, "\n\n", $body;
389    close( CMD );
390
391    scalar @$rcpt;
392}
393# ----------------------------------------------------------------
394#   Net::SMTP ��Ѥ����᡼����
395# ----------------------------------------------------------------
396sub send_by_smtp {
397    my( $server, $from, $rcpt, $head, $body, $hello, $wait ) = @_;
398
399    my $smtp;
400    foreach my $host ( ref $server ? @$server : $server ) {
401        $DEBUG and print "[SERVER=$host]\n";
402        $smtp = Net::SMTP->new( $host,
403                                Hello   =>  $hello,     # HELLO
404                                Timeout =>  $wait );    # �����ॢ����        $DEBUG and print "[SMTP=$smtp]\n";
405        last if defined $smtp;
406    }
407    return undef unless $smtp;
408
409    $DEBUG and print "[FROM=$from]\n";
410    $smtp->mail( $from ) or return undef;               # ������λ��    my $sent = 0;
411    foreach my $to ( @$rcpt ) {
412        my $recv = $smtp->to( $to ) or return undef;    # ����λ��       $DEBUG and print "[TO=$to]\n";
413        $sent ++;
414    }
415
416    $smtp->data() or return undef;      # �᡼������    $smtp->datasend( $head );           # �᡼���å�    $smtp->datasend( "\n\n" );          # ��    $smtp->datasend( $body );           # �᡼��ʸ
417    $smtp->dataend();                   # �᡼����λ
418    $smtp->quit;                        # SMTP �³�ν�λ
419    $DEBUG and print "[DONE=$sent]\n";
420    $sent;
421}
422# ----------------------------------------------------------------
423#   Date: �إå�Ѥ���������� ----------------------------------------------------------------
424sub get_date_string {
425    my $utc = shift || time();
426    my $WDAYNAME  = [qw( Sun Mon Tue Wed Thu Fri Sat )];
427    my $MONTHNAME = [qw( Jan Feb Mar Apr May Jun
428                         Jul Aug Sep Oct Nov Dec )];
429    my( $sec, $min, $hour, $day, $month, $year, $wday ) = localtime($utc);
430    my $date = sprintf( "%s, %2d %s %4d %02d:%02d:%02d %s",
431        $WDAYNAME->[$wday], $day, $MONTHNAME->[$month],
432        $year+1900, $hour, $min, $sec, $TIMEZONE );
433    $date;
434}
435# ----------------------------------------------------------------
436#   Message-Id: �إå�Ѥ���������� ----------------------------------------------------------------
437sub gen_message_id {
438    my $from = shift;
439    my $user = ( $from =~ /([\w\-\.]*)\@/ )[0] || $$;
440    my $domain = ( $from =~ /\@([\w\-\.]+)/ )[0] || "localhost";
441    $user =~ tr/a-z/A-Z/;       # �桼��̾�������   my( $sec, $min, $hour, $day, $month, $year, $wday ) = localtime();
442    $year += 1900;
443    $month ++;
444    my $messid = sprintf( "<%04d%02d%02d%02d%02d%02d.%04X.%s\@%s>",
445                          $year, $month, $day, $hour, $min, $sec,
446                          rand(65536), $user, $domain );
447    $messid;
448}
449# ----------------------------------------------------------------
450#   ����äΥ��ɥ쥹�����Ҥ˳�������� User-Agent ��ꤹ�� ----------------------------------------------------------------
451sub mobile_user_agent {
452    my $rcpt = shift or return;
453
454    my $docomo = scalar grep {/\@docomo.ne.jp$/i} @$rcpt;
455    my $voda = scalar grep {/\@([a-z]\.vodafone|jp-t[a-z]).ne.jp$/i} @$rcpt;
456    my $ezweb = scalar grep {/\@(\w+\.)?(ezweb|tu-ka|ido|tk\w).ne.jp$/i} @$rcpt;
457
458    my $user_agent;
459    $user_agent = "DoCoMo/"  if (   $docomo && ! $voda && ! $ezweb );
460    $user_agent = "J-PHONE/" if ( ! $docomo &&   $voda && ! $ezweb );
461    $user_agent = "KDDI-"    if ( ! $docomo && ! $voda &&   $ezweb );
462
463    $user_agent;
464}
465# ----------------------------------------------------------------
466#   Perl �⥸�塼����ä�ɤ߹��� ----------------------------------------------------------------
467sub auto_require {
468    my $pm = shift or return;
469    $DEBUG and print "[require=$pm]\n";
470    eval "require '$pm';";
471}
472# ----------------------------------------------------------------
473#   Perl �⥸�塼����ä�ɤ߹��� ----------------------------------------------------------------
474sub require_or_die {
475    &auto_require( @_ );
476    die "$_[0] - $@\n" if $@;
477}
478# ----------------------------------------------------------------
479;1;
480# ----------------------------------------------------------------
Note: See TracBrowser for help on using the browser.