| 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 | |
|---|
| 42 | EmailJP �⥸�塼���������ޤ�����Ŭ��ʷ�������ޤ��� |
|---|
| 43 | |
|---|
| 44 | =head2 OPTIONS |
|---|
| 45 | |
|---|
| 46 | sendmail() �ؿ�ϰʲ��Υ��ץ���������ޤ��� |
|---|
| 47 | |
|---|
| 48 | server => SMTP�����Хۥ���P���ɥ쥹 |
|---|
| 49 | |
|---|
| 50 | EmailJP ��������������ǥե�����127.0.0.1�ʼ��ۥ��ȡˤ� SMTP �³���ƥ��������ޤ��� |
|---|
| 51 | SMTP �³�����Υ�륵����P���ɥ쥹����������� |
|---|
| 52 | server ���ץ����ǻ�ꤷ�Ƥ�������� |
|---|
| 53 | ���ؤΥ�������������륵���Ф�����ϡ� |
|---|
| 54 | 1��ܤΥ�륵���Ф���ߤ��Ƥ����� |
|---|
| 55 | 2��ܰʹߤΥ�륵���Фؽ��³���ޤ��� |
|---|
| 56 | ������ǽ�ʥ�륵���Ф�Ƥ������Ȥ��ᤷ�ޤ��� |
|---|
| 57 | |
|---|
| 58 | hello => HELLOʸ�� SMTP �³����HELO ���ޥ�ΰ���ꤷ�ޤ��� |
|---|
| 59 | �ǥե����Ǥ�localhost �Ȥʤ����� |
|---|
| 60 | ���ΤޤޤǤ������������� |
|---|
| 61 | timeout => �����ॢ����ÿ� SMTP �³���Υ����ॢ����ÿ��ꤷ�ޤ��� |
|---|
| 62 | |
|---|
| 63 | return => ���顼�������ɥ쥹 |
|---|
| 64 | |
|---|
| 65 | �������λ�����顼��ȯ��������ˡ� |
|---|
| 66 | SMTP �����Ф�����������ɥ쥹��ꤷ�ޤ��� |
|---|
| 67 | ��ꤷ�ʤ����ϡ�����å��Return-Path: �Ԥ����Ȥ������� |
|---|
| 68 | ����������顼��뤬�������Τ�EmailJP ������������� |
|---|
| 69 | EmailJP ����������������ϡ�ñ�˵���������� |
|---|
| 70 | |
|---|
| 71 | to => ��밸����ɥ쥹 |
|---|
| 72 | |
|---|
| 73 | ���������ɥ쥹��ꤷ�ޤ��� |
|---|
| 74 | ��ꤷ�ʤ����ϡ�����å��To: Cc: Bcc: �Ԥ����Ȥ������� |
|---|
| 75 | |
|---|
| 76 | |
|---|
| 77 | internal => ��ʸ���� |
|---|
| 78 | sendmail() �ؿ�ƤӽФ�¦������ɤϡ� |
|---|
| 79 | �ǥե�����EUC-JP �Ȥߤʤ��ޤ��� |
|---|
| 80 | EUC-JP �ʳ��������UTF-8�ʤ���Ѥ��Ƥ������� |
|---|
| 81 | internal ���ץ����ǻ�ꤷ�Ƥ�������� |
|---|
| 82 | Shift_JIS��UTF-8 �ʤɤ���ѤǤ��ޤ��� |
|---|
| 83 | |
|---|
| 84 | charset => ���ʸ���� |
|---|
| 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 | |
|---|
| 93 | head => ����å�body => ���ʸ |
|---|
| 94 | |
|---|
| 95 | ������������إå������ꤷ�ޤ��� |
|---|
| 96 | ����å������ͽ������Ƥ������� |
|---|
| 97 | ������mail ���ץ�����ꤷ�Ƥ�������� |
|---|
| 98 | |
|---|
| 99 | mail => ������� |
|---|
| 100 | |
|---|
| 101 | ������������إå������ꤷ�ޤ��� |
|---|
| 102 | �إå�����δ֤ˤ϶�ߣ���ɬ��Ǥ��� |
|---|
| 103 | ����å������ͽ��Υ���Ƥ������� |
|---|
| 104 | �嵭��head��body ���ץ�����ꤷ�Ƥ�������� |
|---|
| 105 | |
|---|
| 106 | =head2 DEFAULT MAIL HEADER |
|---|
| 107 | |
|---|
| 108 | mail ���ץ����ޤ���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 | |
|---|
| 123 | PC�����Υ���ˡ��ϥ�������Ω�κ��ʤɤ�IBM ���������� |
|---|
| 124 | EscapeJIS.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 �η�ӥ��ɥ쥹��ޤʤ����ϡ� |
|---|
| 138 | NTT �ɥ�����ʸ�����ʤ�������뤿��hift_JIS �Ȥʤ����� |
|---|
| 139 | |
|---|
| 140 | ���ʸ���&#xHHHH; ����γ�ʸ���ɤ����ꡢ |
|---|
| 141 | ��������au��TU-KA �η�ӥ��ɥ쥹���� |
|---|
| 142 | ����NTT �ɥ��⡦Vodafone �η�ӥ��ɥ쥹��ޤʤ����ϡ� |
|---|
| 143 | EmojiTrans.pm �⥸�塼�������ơ� |
|---|
| 144 | NTT �ɥ����γ�ʸ���ɤ���TU-KA ��λ��ʸ���ɤ�Ѵ����ޤ��� |
|---|
| 145 | |
|---|
| 146 | ���ʸ���&#xHHHH; ����γ�ʸ���ɤ����ꡢ |
|---|
| 147 | ��������Vodafone �η�ӥ��ɥ쥹���� |
|---|
| 148 | ����NTT �ɥ��⡦au��TU-KA �η�ӥ��ɥ쥹��ޤʤ����ϡ� |
|---|
| 149 | EmojiTrans.pm �⥸�塼�������ơ� |
|---|
| 150 | NTT �ɥ����γ�ʸ���ɤ�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 | # ---------------------------------------------------------------- |
|---|
| 202 | sub 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 | # ---------------------------------------------------------------- |
|---|
| 383 | sub 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 | # ---------------------------------------------------------------- |
|---|
| 396 | sub 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: �إå�Ѥ���������� ---------------------------------------------------------------- |
|---|
| 424 | sub 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: �إå�Ѥ���������� ---------------------------------------------------------------- |
|---|
| 437 | sub 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 ��ꤹ�� ---------------------------------------------------------------- |
|---|
| 451 | sub 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 �⥸�塼����ä�ɤ߹��� ---------------------------------------------------------------- |
|---|
| 467 | sub auto_require { |
|---|
| 468 | my $pm = shift or return; |
|---|
| 469 | $DEBUG and print "[require=$pm]\n"; |
|---|
| 470 | eval "require '$pm';"; |
|---|
| 471 | } |
|---|
| 472 | # ---------------------------------------------------------------- |
|---|
| 473 | # Perl �⥸�塼����ä�ɤ߹��� ---------------------------------------------------------------- |
|---|
| 474 | sub require_or_die { |
|---|
| 475 | &auto_require( @_ ); |
|---|
| 476 | die "$_[0] - $@\n" if $@; |
|---|
| 477 | } |
|---|
| 478 | # ---------------------------------------------------------------- |
|---|
| 479 | ;1; |
|---|
| 480 | # ---------------------------------------------------------------- |
|---|