# ------------------------------------------------------------------------
# EmailHTML.pm -- HTMLファイルをMIMEマルチパートに変換する
# ------------------------------------------------------------------------
# 2004/11/03 最初のバージョン
# 2004/11/07 POD を少し整備しました
# ------------------------------------------------------------------------
package EmailHTML;
use strict;
use vars qw( $VERSION $DEBUG );
# ------------------------------------------------------------------------
$VERSION = "0.01";
# ------------------------------------------------------------------------
=head1 NAME
EmailHTML.pm -- html file into mime multipart message
=head1 SYNOPSIS
# HTMLメール送信サンプルプログラム
use strict;
use EmailHTML;
use Net::SMTP;
# 初期設定
my $SMTP_HOST = "127.0.0.1";
my $MAIL_FROM = 'from@domain.name';
my $MAIL_RCPT = 'to@domain.name';
my $URL = "http://www.domain.name/i/";
# 指定 URL の内容から HTML メールを作成する
my $eh = new EmailHTML( URL => $URL );
$eh->set_header( From => $MAIL_FROM );
$eh->set_header( To => $MAIL_RCPT );
my $data = $eh->out_text();
# Net::SMTP を使ってメール送信する
my $smtp = new Net::SMTP( $SMTP_HOST ) or die "SMTP Failed - $SMTP_HOST\n";
$smtp->mail( $MAIL_FROM ) or die "Invalid sender - $MAIL_FROM\n";
$smtp->to( $MAIL_RCPT ) or die "Invalid receipts - $MAIL_RCPT\n";
$smtp->data();
$smtp->datasend( $data );
$smtp->dataend();
$smtp->quit();
=head1 DESCRIPTION
指定したURLからHTMLをダウンロードし、画像ファイルを含む
MIME マルチパート形式による HTML メールに変換します。
ページ内の画像も自動的にダウンロードされ、Base64エンコードされます。
HTML 中の IMG タグは 
と書き換えられます。
（NTTドコモ宛のデコメールに利用できます）
Outlook Express、Becky! 2 で表示できることはもちろん、
NTT DoCoMo 900i シリーズのデコメールとしても受信できます。
ただし、デコメールの制限により、画像ファイルを含めた容量が
10KB 以下となっている必要があります。
10KB を超える場合は、900i 実機で受信した場合に
単なる画像ファイル添付メールとなっているため、ご注意ください。
HTML の文字コードはダウンロードしたまま変更されません。
サーバ上で Shift_JIS のコンテンツは、メール中でも Shift_JIS になります。
ISO-2022-JP、EUC-JP、UTF-8、ISO-8859-1、US-ASCII なども利用可能です。
UCS-2 などの 16bit 文字は利用できません。
のように META タグで文字コードが指定された場合は、そのコードとみなします。
META タグで文字コードが指定されない場合は、Shift_JIS⇒EUC-JP⇒UTF-8の順で
自動判別されます。（オプションで自動判別を OFF にすることも可能です）
文字コードの自動判別に失敗する場合は、文字コードは不明(無指定)となります。
EmailHTML.pm 自体は変換処理のみを行い、メール送信処理は行いません。
メールを送信する場合は、Net::SMTP モジュールを併用するか、
out_file() メソッドで sendmail を起動してメールを送信してください。
=head1 METHODS
new() コンストラクタ
my $eh = new EmailHTML(
URL => "http://www.yahoo.co.jp/", # URL指定
HTML => undef, # 読み込みさせない場合
HTML_BASE64 => undef, # HTML部分をBase64化する
HTML_QP => undef, # HTML部分をQP化する
USER_AGENT => "DoCoMo/0.0/SH900i/c100", # HTTP_USER_AGENTを指定
TZ => "+0900", # Date:ヘッダ用TIMEZONE
DETECT_SJIS => 1, # Shift_JIS を自動検出する
DETECT_EUCJP => 1, # EUC-JP を自動検出する
DETECT_UTF8 => 1, # UTF-8 を自動検出する
);
HTML では、指定 URL の内容を予めダウンロード済みの際に指定できます。
HTML のダウンロードは行われません。
HTML 中の画像ファイルはダウンロードされます。
HTML_BASE64 を真にした場合、画像ファイルだけでなくマルチパート中の
HTML 部分についても Base64 エンコードされます。
デフォルトでは、ダウンロード時の文字コードのまま生データで出力されます。
HTML_QP を真にした場合は、HTML 部分を Quoted-Pritable 形式にします。
メール経路が 7bit の場合などに有効です。
USER_AGENT は、HTML や画像ファイルを HTTP 経由でダウンロードする際に
利用するブラウザ名を指定します。
サーバ側でブラウザや携帯電話を自動判別している際にも利用できます。
TZ は、メールヘッダの Date: 行で指定するタイムゾーンを指定します。
デフォルトでは +0900（日本標準時）となります。
DETECT_SJIS、DETECT_EUCJP、DETECT_UTF8 は、
META タグによって HTML の文字コードが特定されなかった場合に、
HTML 中の内容から文字コードを自動判別するか否かを指定します。
真の場合は、自動判別します。偽の場合は自動判別しません。
DETECT_SJIS が真の場合は、Shift_JIS（≒CP932、IBM拡張漢字・
携帯電話絵文字を含む）としてありえないバイト列が１バイトも
含まれない場合に、Shift_JIS として判別します。
DETECT_EUCJP が真の場合は、EUC-JP としてありえないバイト列が
１バイトも含まれない場合に、EUC-JP として判別します。
DETECT_UTF8 が真の場合は、UTF-8 としてありえないバイト列が
１バイトも含まれない場合に、UTF-8 として判別します。
Shift_JIS⇒EUC-JP⇒UTF-8 の優先順位で判別されます。
日本語ページに本モジュールを利用する場合は、全て真をお勧めします。
日本語以外のページにも利用する場合は、全て偽をお勧めします。
META タグもなく自動判別もしなかった場合は、文字コードは無指定となり
メールソフト側（の HTML 表示モジュール）の HTML 文字コード自動判別
処理に依存します。
set_header() メソッド
$eh->set_header( From => 'from@domain.name' );
$eh->set_header( To => 'to@domain.name' );
$eh->set_header( "X-Mailer" => "Microsoft Outlook Express" );
メールヘッダを指定します。
デフォルトでは、以下のヘッダが自動生成されます。
Date: out_text メソッドを呼び出した時刻
Subject: HTMLの〜タグ指定内容
Content-Type: multipart/related
MIME-Version: 1.0（固定）
Content-Transfer-Encoding: 7bit または 8bit（自動）
X-Mailer: USER_AGENT
set_header メソッドで指定されている場合は、自動生成よりも
set_header メソッドで指定された内容が優先されます。
my $head = {
"From" => 'from@domain.name',
"To" => 'to@domain.name',
"X-Mailer" => "Microsoft Outlook Express",
};
$eh->set_header( %$head );
のように複数のメールヘッダを一括指定することも可能です。
out_text() メソッド
print $eh->out_text();
HTML 内容とページ内の画像ファイルをダウンロードして、
MIME マルチパート形式のテキスト(文字列)として取り出します。
out_file() メソッド
$eh->out_file( "/tmp/sample.eml" );
out_file は、MIME マルチパート形式のテキストとして取り出す代わりに
指定したファイル（例えば sample.eml）にメール内容を書き込みます。
$eh->out_file( "| /usr/sbin/sendmail -t -oi" );
第１引数を“|”で始めることで外部コマンドも指定できます。
sendmail を利用してそのままメール送信する例です。
-t オプションによりメール中の To: Cc: Bcc: 行が参照されます。
get_html() メソッド
set_html() メソッド
my $content = $eh->get_html();
$content =~ s#(set_html( $content );
HTML 中のタグを
⇒
のように大文字化する例です。
get_html メソッドでは、（MIME マルチパート化して出力する前に）
HTML の内容を先行取得できます。
例えば大文字化などの処理を行った上で set_html メソッドに渡すことで、
HTML の内容を書き換えることも可能です。
get_html メソッドを呼び出さずに set_html メソッドを呼ぶことも可能です。
HTML 内容が決まっている場合などに HTTP ダウンロードを省くことができます。
get_encoding() メソッド
set_encoding() メソッド
get_encoding は、HTML の文字コード(charset=)を取得します。
META タグの指定内容の参照または、バイト列による自動判別となります。
get_html 処理時の確認に利用できます。（EmailHTML.pm では文字コードの
自動変換は行いません。Jcode.pm や Encode.pm などを併用してください）
set_encoding は、HTML の文字コード(charset=)を指定します。
META タグの指定内容や、バイト列の自動判別よりも優先されます。
set_html した内容で文字コードが既知の場合に有効でしょう。
=head1 COPYRIGHT
Copyright 2004 Kawasaki Yusuke
http://www.kawa.net/
=cut
# ------------------------------------------------------------------------
use MIME::Base64; # MIMEヘッダ、画像ファイルの符号化
use LWP::UserAgent; # HTTP ダウンロード
# ------------------------------------------------------------------------
# コンストラクタ new() のデフォルトオプション
# ------------------------------------------------------------------------
my $DEFAULT_ARG = {
# デフォルト値のない変数
URL => undef, # URL
HTML => undef, #
HTML_BASE64 => undef, #
HTML_QP => undef, #
# HTTP ダウンロード時に利用する User-Agent:（ブラウザ名）
USER_AGENT => "EmailHTML/".$VERSION,
# メールヘッダ生成時に利用する Date: 用タイムゾーン指定
TZ => "+0900",
# HTML 本文の文字コード自動判別を行うか否か
DETECT_SJIS => 1, # Shift_JIS を自動検出する
DETECT_EUCJP => 1, # EUC-JP を自動検出する
DETECT_UTF8 => 1, # UTF-8 を自動検出する
};
# ------------------------------------------------------------------------
# メール中の固定値
# ------------------------------------------------------------------------
my $BOUNDREL = "EN-REL-1";
my $BOUNDALT = "EN-ALT-1";
my $MULTIPART_MESS = "This is a multi-part message in MIME format.";
# ------------------------------------------------------------------------
# URL指定でHTMLファイルをMIMEマルチパートに変換する
# ------------------------------------------------------------------------
sub new {
my $package = shift;
my $obj = {};
bless $obj, $package;
$obj->{arg} = { @_ }; # ハッシュにする
# デフォルト値から設定を持ち込む
foreach my $key ( keys %$DEFAULT_ARG ) {
next if defined $obj->{arg}->{$key};
$obj->{arg}->{$key} = $ENV{$key} || $DEFAULT_ARG->{$key};
}
$obj;
}
# ------------------------------------------------------------------------
# ヘッダを設定する
# ------------------------------------------------------------------------
sub set_header {
my $obj = shift or return;
$obj->{header} ||= {}; # 初回は初期化
while ( $#_ > 0 ) {
my $key = shift;
my $val = shift;
$key =~ s/[^\w\-]/-/sg; # 英数字・ハイフンのみ許可
$key =~ s/^([a-z])/uc($1)/se; # 先頭は必ず大文字にする
$obj->{header}->{$key} = $val;
$DEBUG and print STDERR "[$key=$val]\n";
}
$obj->{header};
}
# ------------------------------------------------------------------------
# テキストパートを設定する
# ------------------------------------------------------------------------
sub set_text {
my $obj = shift or return;
$obj->{text} = shift;
$obj->{text_charset} = shift;
}
# ------------------------------------------------------------------------
# テキストパートを取り出す
# ------------------------------------------------------------------------
sub get_text {
my $obj = shift or return;
return unless defined $obj->{text};
wantarray ? ( $obj->{text}, $obj->{text_charset} ) : $obj->{text};
}
# ------------------------------------------------------------------------
# HTML 本体を設定する
# ------------------------------------------------------------------------
sub set_html {
my $obj = shift or return;
$obj->{html} = shift;
}
# ------------------------------------------------------------------------
# HTML 本体を取り出す（スカラーで返す）
# ------------------------------------------------------------------------
sub get_html {
my $obj = shift or return;
my $ref = $obj->get_html_ref();
return unless ref $ref;
$$ref;
}
# ------------------------------------------------------------------------
# HTML 本体を取り出す（リファレンスで返す）
# ------------------------------------------------------------------------
sub get_html_ref {
my $obj = shift or return;
return \$obj->{html} if defined $obj->{html}; # キャッシュ
return \$obj->{arg}->{HTML} if defined $obj->{arg}->{HTML};
my $argurl = $obj->{arg}->{URL} or return; # URLを確認
$obj->{html} = $obj->http_download( $argurl ); # HTTP受信
\$obj->{html};
}
# ------------------------------------------------------------------------
# エンコーディングを設定する
# ------------------------------------------------------------------------
sub set_encoding {
my $obj = shift or return;
$obj->{html_charset} = shift or return;
}
# ------------------------------------------------------------------------
# エンコーディングを返す
# ------------------------------------------------------------------------
sub get_encoding {
my $obj = shift or return;
return $obj->{html_charset} if defined $obj->{html_charset}; # キャッシュ
$obj->{html_charset} = $obj->detect_charset(); # 自動判別
}
# ------------------------------------------------------------------------
# HTML から RFC822 形式（.eml）で取り出す（ファイル書き込み）
# ------------------------------------------------------------------------
sub out_file {
my $obj = shift or return;
my $eml = shift or return;
my $open = ( $eml =~ /^[\|\&\>]/ ) ? $eml : "> $eml";
open( EML, $open ) or die "$! - $eml\n";
print EML $obj->out_text();
close( EML );
$eml;
}
# ------------------------------------------------------------------------
# HTML から RFC822 形式（.eml）で取り出す（テキスト）
# ------------------------------------------------------------------------
sub out_text {
my $obj = shift or return;
# HTML を取り出す
my $argurl = $obj->{arg}->{URL};
my $content = $obj->get_html();
my $encode = $obj->get_encoding();
$DEBUG and print STDERR "[encode=$encode]\n";
# 改行コードを統一する
$content =~ s#\r\n#\n#sg;
$content =~ s#\r#\n#sg;
# ページタイトルを取得する（さらに MIME エンコードしたい）
my $title = ( $content =~ m#]*>(.*?)]*>#is )[0];
$title =~ s/\s+/ /g;
$DEBUG and print STDERR "[title=$title]\n";
# 文字コードが既知なら、エスケープシーケンスまたは2バイトコード以降〜
# 次の空白の手前(ないし文末)までの全ての文字をBASE64 してしまう。
# 2バイト文字後の ASCII も BASE64 されてしまうが、実害はないかなと。
if ( $encode ) {
$title =~ s{
([\e\x80-\xFF]\S*)
}{
"=?$encode?B?".MIME::Base64::encode_base64($1, "")."?=";
}egx;
$DEBUG and print STDERR "[title=$title]\n";
}
# A HREF リンクタグを変換する（絶対パスにする）
$content =~ s#(< (?:A|LINK) \s[^>]*? HREF=)
('[^'>]+'|"[^">]+"|[^">\s]+)
((?:\s[^>]*)? >)
#&conv_a_href_tag( $1, $2, $3, $argurl )#gexi;
$content =~ s#(< (?:SCRIPT|IFRAME|EMBED) \s[^>]*? SRC=)
('[^'>]+'|"[^">]+"|[^">\s]+)
((?:\s[^>]*)? >)
#&conv_a_href_tag( $1, $2, $3, $argurl )#gexi;
$content =~ s#(< (?:FORM) \s[^>]*? ACTION=)
('[^'>]+'|"[^">]+"|[^">\s]+)
((?:\s[^>]*)? >)
#&conv_a_href_tag( $1, $2, $3, $argurl )#gexi;
# IMG タグを変換する（cid方式にまとめる）
my $filelist = {};
$content =~ s#(< (?:IMG|INPUT) \s[^>]*? SRC=)
('[^'>]+'|"[^">]+"|[^">\s]+)
((?:\s+[^>]*)? >)
#&conv_img_tag( $1, $2, $3, $filelist )#gexi;
$content =~ s#(< (?:BODY|TABLE|TR|TD) \s[^>]*? BACKGROUND=)
('[^'>]+'|"[^">]+"|[^">\s]+)
((?:\s+[^>]*)? >)
#&conv_img_tag( $1, $2, $3, $filelist )#gexi;
$DEBUG and print STDERR "[img=",scalar(keys %$filelist)," tags]\n";
# 画像ファイルをダウンロードする
my $imgname = {};
my $filedata = {};
foreach my $cid ( sort keys %$filelist ) {
# 画像URLの決定
my $imglink = &relative_url( $argurl, $filelist->{$cid} );
# ファイル名の取得
my $imgfile = ( $imglink =~ m#([^/]+)$# )[0];
$imgname->{$cid} = $imgfile;
$DEBUG and print STDERR "[$cid=$imgfile]\n";
# 画像データ(バイナリ)の取得
my( $imgraw, $err ) = $obj->http_download( $imglink );
next if ( $imgraw eq "" );
$filedata->{$cid} = $imgraw;
}
# メールヘッダを生成する
my $head_ctype = sprintf( 'multipart/related; boundary="%s"', $BOUNDREL );
my $head_date = &get_date_string( time(), $obj->{arg}->{TZ} );
my $head_bits = "8bit";
$head_bits = "7bit" if ( $encode =~ /^(ISO-2022-JP|US-ASCII)/i );
$head_bits = "7bit" if $obj->{arg}->{"HTML_BASE64"};
$head_bits = "7bit" if $obj->{arg}->{"HTML_QP"};
my $outhead = {
"Date" => $head_date,
"Subject" => $title,
"Content-Type" => $head_ctype,
"MIME-Version" => "1.0",
"Content-Transfer-Encoding" => $head_bits,
"X-Mailer" => $obj->{arg}->{"USER_AGENT"},
};
# set_header で予め指定されたヘッダで上書きする
if ( ref $obj->{header} ) {
foreach my $key ( keys %{$obj->{header}} ) {
$outhead->{$key} = $obj->{header}->{$key};
}
}
my $outdata = [];
# メールヘッダ
foreach my $key ( sort keys %$outhead ) {
my $val = $outhead->{$key};
$val =~ s/\s+/ /sg; # 連続する空白は1つに
$val =~ s/^\s+//s; # 値の先頭の空白は削除
$val =~ s/\s+$//s; # 値の末尾の空白も削除
my $line = sprintf( "%s: %s\n", $key, $val );
push( @$outdata, $line ); # メールヘッダ
$DEBUG and print STDERR "[$key=$val]\n";
}
push( @$outdata, "\n" ); # メールヘッダ終了
# メール本文
push( @$outdata, "$MULTIPART_MESS\n" );
push( @$outdata, "\n" );
push( @$outdata, "--$BOUNDREL\n" );
push( @$outdata, "Content-Type: multipart/alternative; ".
"boundary=\"$BOUNDALT\"\n" );
push( @$outdata, "\n" );
# テキストパート
my( $text_body, $text_code ) = $obj->get_text();
$text_code ||= $encode;
my $text_cset = "; charset=\"$text_code\"" if $text_code;
if ( $text_body ne "" ) {
push( @$outdata, "--$BOUNDALT\n" );
push( @$outdata, "Content-Type: text/plain$text_cset\n" );
push( @$outdata, "Content-Transfer-Encoding: $head_bits\n" );
push( @$outdata, "\n" );
push( @$outdata, $text_body ); # テキストパート本体
push( @$outdata, "\n" );
}
# ＨＴＭＬパート
my $html_body;
my $html_bits;
my $html_cset = "; charset=\"$encode\"" if $encode;
if ( $obj->{arg}->{"HTML_BASE64"} ) {
$html_body = MIME::Base64::encode( $content );
$html_bits = "Base64";
} elsif ( $obj->{arg}->{"HTML_QP"} ) {
$html_body =~ s/([\=\x7F-\xFF])/sprintf("=%02X",ord($1))/ge;
$html_bits = "Quoted-Printable";
} else {
$html_body = $content;
$html_bits = ( $content =~ /[\x80-\xFF]/ ) ? "8bit" : "7bit";
}
$DEBUG and print STDERR "[Content-Transfer-Encoding=$html_bits]\n";
push( @$outdata, "--$BOUNDALT\n" );
push( @$outdata, "Content-Type: text/html$html_cset\n" );
push( @$outdata, "Content-Transfer-Encoding: $html_bits\n" );
push( @$outdata, "\n" );
push( @$outdata, $html_body ); # ＨＴＭＬパート本体
push( @$outdata, "\n" );
push( @$outdata, "--$BOUNDALT--\n" ); # alternative 終了
# 添付ファイルパート（画像）
foreach my $cid ( sort keys %$filedata ) {
my $ext = ( $imgname->{$cid} =~ /\.(\w+)$/ )[0] || "gif";
$ext =~ tr/A-Z/a-z/;
my $map = {
jpg => "image/jpeg",
jpeg => "image/jpeg",
gif => "image/gif",
png => "image/png",
bmp => "image/bmp",
html => "text/html",
htm => "text/html",
hdml => "text/x-hdml",
css => "text/css",
js => "application/x-javascript",
swf => "application/x-shockwave-flash",
};
my $ctype = $map->{$ext} || "application/octet-stream";
my $imgb64 = MIME::Base64::encode( $filedata->{$cid} );
push( @$outdata, "--$BOUNDREL\n" );
push( @$outdata, "Content-Type: $ctype; ".
"name=\"$imgname->{$cid}\"\n" );
push( @$outdata, "Content-Disposition: inline; ".
"filename=\"$imgname->{$cid}\"\n" );
push( @$outdata, "Content-Id: <$cid>\n" );
push( @$outdata, "Content-Transfer-Encoding: base64\n" );
push( @$outdata, "\n" );
push( @$outdata, $imgb64 ); # 画像データ本体
push( @$outdata, "\n" );
}
# メール本文終了
push( @$outdata, "--$BOUNDREL--\n" );
my $joindata = join( "", @$outdata ); # 全データを合体する
$joindata;
}
# ------------------------------------------------------------------------
# IMG タグを処理する（cid方式にする）
# ------------------------------------------------------------------------
sub conv_img_tag {
my( $prefix, $src, $suffix, $imghash ) = @_;
return unless ref $imghash;
# "" で囲まれていたら
$src = $1 if ( $src =~ /^["'](.*)["']$/s );
# cid は img01 からカウントアップ
my $cnt = scalar keys %$imghash;
my $cid = sprintf( "cid%02d", $cnt + 1 );
# 既に同じ画像を使っていたら同じ cid とする
foreach my $prev ( sort keys %$imghash ) {
if ( $imghash->{$prev} eq $src ) {
$cid = $prev;
last;
}
}
$imghash->{$cid} = $src;
my $ret = sprintf( '%s"cid:%s"%s', $prefix, $cid, $suffix );
$ret;
}
# ------------------------------------------------------------------------
# 相対リンクを処理する
# ------------------------------------------------------------------------
sub relative_url {
my $baseurl = shift or return;
my $linkurl = shift or return;
if ( $linkurl =~ m#^(https?|ftp|mailto|tel):# ) {
# 絶対リンクの場合はそのまま返す
return $linkurl;
} elsif ( $linkurl =~ m/^#/ ) {
#「#〜」表記（リンクの場合）
return $linkurl;
} elsif ( $linkurl =~ m#^/# ) {
# サイト内絶対パス指定
my $basehost = ( $baseurl =~ m#^(\w+://[\w\.\-]+)# )[0];
return $basehost.$linkurl;
} else {
# 相対リンクの場合は計算する
my $basedir = ( $baseurl =~ m#^(.*)(/[^/]*)$# )[0];
my $linkto = $basedir."/".$linkurl;
$linkto =~ s#/\./#/#;
return $linkto;
}
}
# ------------------------------------------------------------------------
# タグの処理
# ------------------------------------------------------------------------
sub conv_a_href_tag {
my( $prefix, $href, $suffix, $base ) = @_;
# "" で囲まれていたら
$href = $1 if ( $href =~ /^["'](.*)["']$/s );
# 相対リンク対応
my $url = &relative_url( $base, $href );
join( "", $prefix, '"', $url, '"', $suffix );
}
# ------------------------------------------------------------------------
# Date: ヘッダ用の文字列を生成する
# ------------------------------------------------------------------------
sub get_date_string {
my $utc = shift || time();
my $tz = shift;
my $WDAYNAME = [qw( Sun Mon Tue Wed Thu Fri Sat )];
my $MONTHNAME = [qw( Jan Feb Mar Apr May Jun
Jul Aug Sep Oct Nov Dec )];
my( $sec, $min, $hour, $day, $month, $year, $wday ) = localtime($utc);
my $date = sprintf( "%s, %2d %s %4d %02d:%02d:%02d %s",
$WDAYNAME->[$wday], $day, $MONTHNAME->[$month],
$year+1900, $hour, $min, $sec );
$date .= " $tz" if $tz;
$date;
}
# ------------------------------------------------------------------------
# HTML の文字コードを判定する
#
# ------------------------------------------------------------------------
sub detect_charset {
my $obj = shift or return;
my $ref = $obj->get_html_ref() or return; # 本文を取得
# META タグから自動検出する
if ( $$ref =~ m/\"\']|"[^\"]*"|'[^\']*')+)>/si ) {
my $args = $1;
$DEBUG and print STDERR "[meta=$args]\n";
my $hash = {};
while ( $args =~ m/([^\s\=\'\"]+)=
([^\>\"\'\s]+|"[^\"]*"|'[^\']*')/sgx ) {
my( $key, $val ) = ( $1, $2 );
$key =~ tr/a-z/A-Z/;
$val =~ s/^["'](.*)["']$/$1/s;
$hash->{$key} = $val;
# $DEBUG and print STDERR "[META:$key=$val]\n";
}
if ( $hash->{"HTTP-EQUIV"} =~ /^Content-Type/i ) {
$DEBUG and print STDERR "[Content-Type=",$hash->{"CONTENT"},"]\n";
if ( $hash->{"CONTENT"} =~ /;\s*charset=["']?([^\'\"\s]+)/i ) {
$DEBUG and print STDERR "[charset=$1]\n";
return $1;
}
}
}
# ISO-2022-JP エスケープシーケンスが存在する（あまりないだろうが…）
return "ISO-2022-JP" if ( $$ref =~ m/\e\$\B/ );
# 行を分割する
my $lines = [ grep {/[\x80-\xFF]/} split( /[\r\n]+/, $$ref )];
# 128〜255 がなければ、US-ASCII だろう
return "US-ASCII" unless scalar @$lines;
# Shift_JIS にマッチするか確認する
# ASCII 21-7E
# 半角片仮名 A1-DF
# JIS-X-0208-1997 81-9F|E0-EF / 40-7E|80-FC
if ( $obj->{arg}->{DETECT_SJIS} ) {
my $RE_ASC1 = '[\x00-\x7F]'; # ASCII文字
my $RE_SJIS = '[\x81-\x9F\xE0-\xEF][\x40-\x7E\x80-\xFC]'; # 全角文字
my $RE_KANA = '[\xA1-\xDF]'; # SJIS半角カナ文字
my $RE_EMOJI = '[\xF0-\xFC][\x40-\x7E\x80-\xFC]'; # 拡張漢字・絵文字
my $RE_VODA = '\x1B\x24[GEFOPQ][\x20-\x7F]+\x0F?'; # Vodafone絵文字
my $not_sjis;
foreach ( @$lines ) {
unless ( /^($RE_ASC1|$RE_SJIS|$RE_KANA|$RE_EMOJI|$RE_VODA)+$/s ) {
$not_sjis ++; # Shift_JISではない
last;
}
}
return "Shift_JIS" unless $not_sjis;
}
# EUC-JP にマッチする
# ASCII 21-7E
# JIS X 0208:1997 A1-FE / A1-FE
# 半角片仮名 8E / A1-DF
# JIS X 0212:1990 8F / A1-FE / A1-FE
if ( $obj->{arg}->{DETECT_EUCJP} ) {
my $RE_ASC2 = '[\x00-\x7F]'; # ASCII文字
my $RE_EUCJP = '[\xA1-\xFE][\xA1-\xFE]'; # EUC-JP 全角文字
my $RE_EUCSS2 = '\x8E[\xA1-\xDF]'; # SS2 半角カナ文字
my $RE_EUCSS3 = '\x8F[\xA1-\xFE]'; # SS3 JIS-X-0212
my $not_eucjp;
foreach ( @$lines ) {
unless ( /^($RE_ASC2|$RE_EUCJP|$RE_EUCSS2|$RE_EUCSS3)+$/s ) {
$not_eucjp ++; # EUC-JP ではない
last;
}
}
return "EUC-JP" unless $not_eucjp;
}
# UTF-8 にマッチする（BMP面のみ）
if ( $obj->{arg}->{DETECT_UTF8} ) {
my $RE_ASC3 = '[\x00-\x7F]'; # ASCII文字
my $RE_UTF8A = '[\xC0-\xDF][\x80-\xBF]'; # UTF-8その1
my $RE_UTF8B = '[\xE0-\xEF][\x80-\xBF]{2}'; # UTF-8その2
my $not_utf8;
foreach ( @$lines ) {
unless ( /^($RE_ASC3|$RE_UTF8A|$RE_UTF8B)+$/s ) {
$not_utf8 ++; # UTF-8 ではない
last;
}
}
return "UTF-8" unless $not_utf8;
}
# 確定しなかった
undef;
}
# ------------------------------------------------------------------------
# HTML をダウンロードしてくる
# ------------------------------------------------------------------------
sub http_download {
my $obj = shift or return;
my $httpurl= shift or return;
$DEBUG and print STDERR "[URL=$httpurl]\n";
return $obj->{cache}->{$httpurl} if defined $obj->{cache}->{$httpurl};
my $agent = new LWP::UserAgent() or return;
$agent->agent( $obj->{arg}->{"USER_AGENT"} );
# $DEBUG and print STDERR "[USER_AGENT=",$obj->{arg}->{"USER_AGENT"},"]\n";
my $request = new HTTP::Request( GET => $httpurl ) or return;
my $response = $agent->request( $request ) or return;
$response->is_success() or return;
my $data = $response->content();
$DEBUG and print STDERR "[content=",length($data)," bytes]\n";
$obj->{cache}->{$httpurl} = $data;
}
# ----------------------------------------------------------------
# Perl モジュールを追加で読み込む
# ----------------------------------------------------------------
sub auto_require {
my $pm = shift or return;
$DEBUG and print "[require=$pm]\n";
eval "require '$pm';";
die "$_[0] - $@\n" if $@;
}
# ------------------------------------------------------------------------
;1;
# ------------------------------------------------------------------------