Perl

Perl で書かれた有名なシステム・ソフト

Perl は実際どんなところで使われているのだろう? という疑問から調べてみたら、そう多くはなかった。sourceforge.net での言語ごとのプロジェクト登録数を調べてみても、Java が C++ を抜き 1位であり、Perl は極端に少ない印象を受ける。システムとして動作する Perl でのシステム構築の例は、もっと探せばあるのかも知れないので、知っている人がいたら教えて欲しい。

ネットで調べていて気づいたのは Perl が使われてる大規模システムと思われるものはそのサイトがベンチャーからスタートしていること。ベンチャーなので最初は社長や CEO 自らがコードを書いてる。このパターンがもちろんすべてではないと思うが、「そのサイトで最初に使われていた言語が Perl で、結果的に大規模になった」例が多いのではないだろうか。ウェブサイトを開発するときのプロトタイプには Java よりも Perl の方が作りやすい場合もあるだろう。だから最初は Perl でそのままずっと Perl というのは Web 2.0 的なシステムであろう。自分たちでプロジェクトをコントロールできる場合は、言語は何でもアリなので Perl でもよいということだ。

続きを読む

Perl で、添付ファイル付きのメールを送る方法

Perl で、

open(SEND, '/usr/sbin/sendmail') || die;

などとせずにモジュールを使ってメールを送信するには、以下のようにする。

使用するモジュール


use Net::SMTP;
use MIME::Entity;
#!/usr/bin/perl use Net::SMTP; use MIME::Entity; # Settings our $SENDER = '送信元のメールアドレス'; our $RECIPIENT = '送信先のメールアドレス'; our $SUBJECT = 'タイトル'; our $ATTACHED_FILE_1 = '/home/youraccount/添付ファイル名その1.jpg'; our $ATTACHED_FILE_2 = '/home/youraccount/添付ファイル名その2.jpg'; # Create object my $smtp=Net::SMTP->new('localhost',
                    HELLO=>'yourmailsever.yourdomain.com');
# Built headers $smtp->mail($SENDER); # Sender $smtp->to ($RECIPIENT); # Receiver # Built Data (Create data by MIME::Entity) $smtp->data(); my $mime = MIME::Entity->build(
        From    =>    $SENDER   , # Sender   (data)
        To      =>    $RECIPIENT, # Receiver (data)
        Subject =>    $SUBJECT  , # Subject
        Data    => ['']);         # body
# Attached file $mime->attach(
    Path     => $ATTACHED_FILE_1,
    Type     => 'image/jpeg',
    Encoding => 'Base64'
); # Attached file $mime->attach(
    Path     => $ATTACHED_FILE_2,
    Type     => 'image/jpeg',
    Encoding => 'Base64'
); # Attached file (Text) # $mime->attach( # Path => $ATTACHED_FILE, # Type => 'text/plain', # Encoding => '-SUGGEST' #); $smtp->datasend($mime->stringify); # transfer strings # Data termination and send mail $smtp->dataend(); #Quit SMTP connection $smtp->quit; # for debug print "Sender : $SENDER\n"; print "Recipient : $RECIPIENT\n"; print "Attached : $ATTACHED_FILE\n"; 1;
続きを読む

Perl での、文字列の扱い:<br />シングルクォートとダブルクォーテーションの違い

まずはこのエントリのタイトルにある「シングルクォート ('…') とダブルクォーテーション ("…")」、なぜ 「クォート」 と 「クォーテーション」 なのか? という細かい^^;質問は置いておいて、Perl で文字列を表現する方法は実はいくつかあるのだということに注意したい。基本的にはシングルクォートとダブルクォーテーションの違いがある。シングルクォートの場合は、その中に書いた文字列はそのまま文字列として Perl に解釈される。特にダブルクォーテーションの場合は、文字列の中に変数を埋め込める。これは便利な反面、やっかいなことになることがある。例えばメールアドレスをダブルクォーテーションで囲んだ場合には、メールアドレスには必ずアットマーク 「@」 があり、この文字に Perl が出くわしたときに 「配列 」と解釈してしまうため、多くの場合は自分の予期しない結果か、エラーとなる。

my $str = 'Perl では'; print $str . '文字列をシングルクォートで囲むのが基本'; print "$str このように、ダブルクォーテーションで囲むことができる";

なお、文字列の連結にはピリオド「.」を使う。

print '文字列を' . '連結する';

また、'…' と "…" はそれぞれ以下のように書くことができる。

print q|これはシングルクォートで囲ったのと同じ意味|; print qq|これはダブルクォーテーションで囲ったのと同じ意味|; print q/…qの後にくる記号はスラッシュとかも使える/; print qq/…同じく qqの後にくる記号はスラッシュとかも使える/; my $mail = 'support@twinkle.cc'; print $mail; →これはきちんと support@twinkle.cc と表示される。 $mail = "support@twinkle.cc"; print $mail; → こちらは support.cc と表示される。なぜなら、@twinkle が変数とみなされるからである。 → use strict を使ったらエラーとなる。
続きを読む

パスワードは生のままデータベースに保存してはいけない?

いわゆるログイン処理において、ユーザーがウェブページのフォームから入力してきたユーザー名とパスワードをデータベースに保存されているものと照合し、認証するという仕組みはメンバー制サイトにはもはや欠かせないものとなっている。ここで、ユーザー名とパスワードは SSL で暗号化された通信路(チャネル)を通じてサーバに送るのは当然として、データベースにユーザー名とパスワードを生のまま入れていた場合は、もしデータベースが何者かにハッキングされたらパスワードがそのまま漏洩してしまうことになる。パスワードというものはある個人であればどのサイトでも共通にしていることも多いのではないだろうか? あなたはまさにこのエントリを読んでいるくらいなのだからそんなことはないかも知れないが、一般ユーザーのセキュリティに対するリテラシーはどうだろう?そのようなことを前提にすると、仮に(あってはならないことだが)自サイトからパスワードが漏れた場合、そのパスワードを使って悪意のあるものが次々に他のサイトへの認証を試みるシナリオもあると思う。また、データベースがハッキングされないまでも、管理者がデータベースを覗けばユーザーが設定したパスワードを簡単に見ることができるシステムは、やはりセキュリティ上問題であろう。

このような事態を避けるためにも、セキュリティの基本ではあるが、データベース中のパスワードはハッシュ文字列で保存しておくべきである。たとえデータベースの管理者がデータベースに保存されているハッシュ値を覗けたとしても、そのハッシュ値からのパスワード自体の復元はほぼ不可能だからだ。このような仕組みにすると、ユーザーがパスワードを忘れた場合はパスワードで照合できなくなるので、再設定の仕組みが必要である。このポイントを頭に入れて注意深く世のサイトがどのように作られているか、普段からアンテナをはって参考にして欲しい。

この方法は特に Perl だけにできるということではなく、もちろん言語を問わず、ハッシュ関数が用意されている Java や PHP にも使える。

続きを読む

Perl で、Excel のデータ (XML) をアップロードして処理する方法

  1. まず、Excel で 以下のように category1、category2、name、address、phone、link、comment1、comment2 というカラム構成のワークシートを作成し、適当にデータを入力、XML 形式で保存しておく。
    注: 住所は米国の住所でないと正しく処理されないことに注意
  2. 次に、以下にあるように gmap_excel.html と gmap_excel.cgi の 2つのファイルを用意する (.gmap_excel.cgi 中のパスの設定などは適宜変更のこと)。
  3. gmap_excel.html から上の XML ファイルをサーバにアップロードする。
  4. サーバ側では Excel の XML データを処理して、gmap_excel.xml というファイルが出力される。
  5. このサーバ側で出力された gmap_excel.xml ファイルは Google Maps API を使った AJAX クライアントから利用できる。

gmap_excel.html のファイルの内容

<head>
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
    <link rel="stylesheet" href="styles-site.css" type="text/css" />
</head>
<body>
    <form enctype="multipart/form-data" action="gmap_excel.cgi" method="post">
        <input type="hidden" name="MAX_FILE_SIZE" value="2000000" />
        <table width="600">
            <tr><td>Names file:</td><td><input type="file" name="file" />
                    <input type="submit" value="Upload" /></td></tr>
        </table>
    </form>
</body>

gmap_excel.cgi のファイルの内容

#!/usr/bin/perl use lib "path_to_your_perl_lib/lib/perl5/site_perl"; use strict; use Geo::Google; use CGI; our $XML_HEADER = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"; # XML ヘッダ our $HOME_DIR = 'your_home_dir'; our $LOCK_DIR = 'path_to_lock_dir/lock'; # do chmod 777 path_to_lock_dir/lock our $LOCK_FILE = 'lock'; our $XML_FILE = 'path_to_your_output_xml/gmap_excel.xml'; # 出力用 XML ファイル名 our $col_index = 0; # Excel シートの現在の列(カラム)インデックス our $row_index = 0; # Excel シートの現在の行インデックス our @data = (); # 出力用データ our @current_data = (); # 現在のデータ # オブジェクト初期化 our $CGI = new CGI; our $GEO = new Geo::Google; # HTML 出力 print qq|Content-type: text/html\n\n|; print qq||; print qq||; print qq|

|; init(); print qq|

|; # 個々のデータのハンドラ sub dataHandler {
my ($expat, $text) = @_;

#  $row_index = 0 と 1 は、Excel で データのヘッダのため必要なし
if($text !~ /^\s+$/ && $row_index > 1) {    #  空白行でなければ
    $current_data[$col_index] = $text;
}
} # 要素の開始 sub startElement {
my ($expat, $tag, %attr) = @_;

if($tag eq 'Row') {            #  <Row>で始まるとき

    $col_index = 0;                #  カラムを初期化
    $row_index++;                #  行を進める
    @current_data = ();            #  現在の行データを初期化
}

if($tag eq 'Data') {            #  <Data>で始まるとき

    $col_index++;                #  列を進める
}
} # 要素の終了 sub endElement {
my ($expat, $tag) = @_;
my ($xml, $html);
my ($lng, $lat, $name, $link, $category1, $category2);
my ($street, $city, $state, $phone, $comment1, $comment2);

#  </Row> のとき
if($tag eq 'Row') {

    push(@data, {    # データに現在の行データを代入

        'category1' => $current_data[1],
        'category2' => $current_data[2],
        'name'      => $current_data[3],
        'address'   => $current_data[4],
        'phone'     => $current_data[5],
        'link'      => $current_data[6],
        'comment1'  => $current_data[7],
        'comment2'  => $current_data[8]
    });
}

#  </Workbook> のとき
if($tag eq 'Workbook') {

    $row_index = -1; #  行数を初期化 ($row_index = 0 はヘッダのため -1 からスタート)
    foreach my $row (@data) {

        $row_index++;

        if($row->{address}) {
            $lng = '';  $lat = '';
            my ($degree) = getDegrees($row->{address});
            if($degree) {
                $lng    = $degree->longitude;
                $lat    = $degree->latitude;
            }
        }

        $name      = $row->{name};
        $link      = $row->{link}
                   =~ /http:\/\/[!#-9A-~]+\.+[a-z0-9]/ ? $row->{link} : '';
        $category1 = $row->{category1};
        $category2 = $row->{category2};
        ($street, $city, $state) = split(',', $row->{address});
        $street    = $street;
        $city      = $city;
        $state     = $state;
        $phone     = $row->{phone};
        $comment1  = $row->{comment1} eq '-' ? '' : $row->{comment1};
        $comment2  = $row->{comment2};

        #  lng と lat が検索できたら (データが入っているということだから)
        if($lng && $lat) {

            $xml    .= "\t<marker\n"
                    .  "\t\tlng       = \"$lng\" lat = \"$lat\"\n"
                    .  "\t\tname      = \"" . $name      . "\"\n"
                    .  "\t\tlink      = \"" . $link      . "\"\n"
                    .  "\t\tcategory1 = \"" . $category1 . "\"\n"
                    .  "\t\tcategory2 = \"" . $category2 . "\"\n"
                    .  "\t\taddress1  = \"$street\"\n"
                    .  "\t\taddress2  = \"$city, $state\"\n"
                    .  "\t\tphone     = \"$phone\"\n"
                    .  "\t\tcomment1  = \"$comment1\"\n"
                    .  "\t\tcomment2  = \"$comment2\"\n"
                    .  "\t/>\n\n";

        } elsif($row_index) {

            $html   .= '<tr><td>'
                    .  "$row_index / $name / $street, $city, $state"
                    .  '</td></tr>';
        }
    }

    $xml    =  $XML_HEADER
            .  "<markers>\n"
            .  $xml
            .  "</markers>\n";

    if($html) {    #  エラーがあれば
        $html    = '<table>'
                 . '<tr><td>***** 以下、緯度経度が検索不能でした。</td></tr>'
                 . $html
                 . '</table>';
    } else {    #  エラーがなければ
        print '<br />done.';
    }

    #  ファイルのオープン
    &file_lock;        #  ファイルロック
    open(XML, ">$HOME_DIR$XML_FILE")
    or die('Cannot open an XML file: ' . "$HOME_DIR$XML_FILE");
    print XML $xml;    #  書き込み
    close(XML);        #  ファイルを閉じる
    &file_unlock;      #  ロック解除

    print $html;
}
} sub getDegrees { # 住所から緯度経度を検索
return $GEO->location( address => shift); # shift = address / リファレンスを返す
} sub init() {
# XMLパーサー作成 ('UTF-8')
my $xml_parser = new XML::Parser(   ProtocolEncoding => 'UTF-8',
                                    Handlers=>{ Start=>\&startElement,
                                                End  =>\&endElement,
                                                Char =>\&dataHandler });
# ファイルのオープンはいらない。input タグで指定した name 属性がそのままファイルハンドルになる
my $xml = $CGI->param('file');

# XMLパース処理
$xml_parser->parse($xml) or    die "XML error: $xml_parser";

# ファイルクローズ
close($xml);
} sub file_lock {
my $wait = 5;
while (!symlink('.',"$HOME_DIR$LOCK_DIR/.$LOCK_FILE")) {
    if (--$wait <= 0) {
# &error( '現在他の方が使用中です。', # 'しばらくしてから再度ご利用ください。');
    }
    sleep (1);
}
} sub file_unlock {
unlink ("$HOME_DIR$LOCK_DIR/.$LOCK_FILE");
} 1;

gmap_excel.xml 出力例

<?xml version="1.0" encoding="UTF-8"?>
<marker
    lng       = "-122.125690" lat = "37.413570"
    name      = "Tofu House"
    link      = ""
    category1 = "Restaurant"
    category2 = "Korean"
    address1  = "4127 El Camino Real"
    address2  = " Palo Alto,  CA 94306"
    phone     = "650-424-8805"
    comment1  = ""
    comment2  = "Santa Clara の Tofu House と同じ店。"
/>
...
続きを読む

Perl で、データベースを使う

Perl で、データベース (ここでは MySQL を使うときの基本) をおさらいしよう。Perl でのデータベースへのアクセスは、DBI モジュールを使う。このモジュールは XS で書かれているため、Linux などにインストールするには gcc のコンパイル環境が必要である。レンタルサーバは予め DBI がインストールされているところを選んでおけば間違いないが、そうでない場合は自力でインストールする必要があるため注意しよう。
さて、以下はデータベース中のテーブルのフィールドが id、name、value となっていてそれらを扱う場合の例である。最初のデータベースの定義のところで、mysql のところを Pg とするだけで PostgreSQL に対応できる (ようである)。
スクリプト中ではデータベースのテーブルを変数でマッピング (定義) している (ハッシュを使う方法もあると思うのでもっといい方法があったら教えて欲しい)。こうしておくと後でテーブルの定義を変更したときなど柔軟に対応できるだろう。
foreach の中の「$_」は、Perl では「現在処理中のデータ」であり、

foreach my $data (@$DATA) {
$id    $data->$T_FIELD[$T_ID];
$name  $data->$T_FIELD[$T_NAME];
$value $data->$T_FIELD[$T_VALUE];
}

などするのと同義である。
DBI->selectrow_arrayref は、selectrow_array と似ているが、結果をリファレンスで複数行返すところが異なる。リファレンスなのでその後の処理も高速である (と思われる)。

使用するモジュール


use DBI;
#!/usr/bin/perl use DBI; # データベースの設定 our $DB_NAME = 'DBI:mysql:your_database_name'; our $DB_USERNAME = 'your_username'; our $DB_PASSWORD = 'your_password'; our $DB_TABLE = 'your_table_name'; # テーブルの定義 our $T_ID = 0; our $T_NAME = 1; our $T_VALUE = 2; our @T_FIELD = (
'`id`',
'`name`',
'`value`'
); # データベースに接続 my $DB = DBI->connect($DB_NAME, $DB_USERNAME, $DB_PASSWORD)
   || die "Connection error";
# データを検索 my $DATA = $DB->selectall_arrayref(
                        qq|SELECT * FROM `$DB_TABLE` |
                      . qq|WHERE $T_FIELD[$T_ID]='ここに検索したい ID を書く'|
                    );
# データがあれば if(@$DATA) {
my $id, $name;

# データを出力
foreach (@$DATA)    {

    $id    = $_->[$T_ID   ];    # $T_ID    = 0
    $name  = $_->[$T_NAME ];    # $T_NAME  = 1
    $value = $_->[$T_VALUE];    # $T_VALUE = 2

    print "$id / $name / $value\n";      # データを表示
}
} # データベースの接続を切断 $DB->disconnect(); 1;
続きを読む

Perl で、サイトにアクセスして HTML を取得する方法

LWP (libwww-perl という形で配布されている) を使う。LWP::Agent モジュールは、ウェブクライアント、ウェブオートメーション (ソフトウェアやプログラムが自動的にサイトにアクセスして情報を取ってくること) といったものの基本である。もうはるか彼方、何年も前からある技術なのに基本は変わっていないのがポイント。以下のスクリプトは、$URL で指定されているサイトにアクセスして、成功すればその HTML のコードをコンソールに表示、失敗したときはエラーコードを出力する例。CGI として機能させたときは、ブラウザには HTML コードでなく $URL でアクセスしたページを表示する。つまりプロキシとして動作するということ。

シンプルなバージョン

#!/usr/bin/perl use LWP::UserAgent; use HTTP::Request; use HTTP::Response; our $URL = 'https://perltips.twinkle.cc/'; # アクセスする URL my $proxy = new LWP::UserAgent; my $req = HTTP::Request->new('GET' => $URL); # HTTP リクエストを作成 my $res = $proxy->request($req); # $res に HTTP レスポンスが返ってくる print $res->content; # HTML を表示 1;

ちょっと長いバージョン

#!/usr/bin/perl use LWP::UserAgent; use HTTP::Request; use HTTP::Response; our $URL = 'https://perltips.twinkle.cc/'; # アクセスする URL my $proxy = new LWP::UserAgent; $proxy->agent('your own created browser name here'); # 任意 $proxy->timeout(60); # 任意 my $req = HTTP::Request->new('GET' => $URL); my $res = $proxy->request($req); my $content = $res->content; print "Content-Type: text/html\n\n"; # HTML ヘッダ (CGI として動作できる) if($res->is_success) {
print $content;
} else {
print 'HTTP エラーコード: ' . $res->code;
} 1;
続きを読む

Perl で、Shift JIS でスクリプトを保存するには?

Perl でケータイ向けのサイトを書いているとき、シフトJIS でスクリプトを保存しないければならない場合がある (文字列テーブルなど)。このとき、


Unrecognized character \x81 at ./your.cgi line XX.

といったエラーに悩まされているなら、

my $group = 'グル&#x30fc;プ';

などのように、「―」を「&#x30fc;」で表すようにするとよい (Mac の場合は、「ー」が「―」になるようで、この現象が起こる)。または、文字化けする文字の後ろに「\」を付ける。

以下は、Shift JIS で文字化けする文字の一覧。文字化けを起こしやすいよく使う文字は強調しておいた。

文字 - Shift-JIS - Unicode での記述方法


<strong>―</strong>  81 5C   &#x2015;<br />
<strong>ソ</strong>  83 5C   &#x30BD;<br />
Ы  84 5C   &#x042B;<br />
Ⅸ  87 5C   &#x2168;<br />
噂  89 5C   &#x5642;<br />
浬  8A 5C   &#x6D6C;<br />
欺  8B 5C   &#x6B3A;<br />
圭  8C 5C   &#x572D;<br />
<strong>構</strong>  8D 5C   &#x69CB;<br />
蚕  8E 5C   &#x8695;<br />
<strong>十</strong>  8F 5C   &#x5341;<br />
<strong>申</strong>  90 5C   &#x7533;<br />
曾  91 5C   &#x66FE;<br />
箪  92 5C   &#x7BAA;<br />
<strong>貼</strong>  93 5C   &#x8CBC;<br />
<strong>能</strong>  94 5C   &#x80FD;<br />
<strong>表</strong>  95 5C   &#x8868;<br />
暴  96 5C   &#x66B4;<br />
<strong>予</strong>  97 5C   &#x4E88;<br />
禄  98 5C   &#x7984;<br />
兔  99 5C   &#x5154;<br />
喀  9A 5C   &#x5580;<br />
媾  9B 5C   &#x5ABE;<br />
彌  9C 5C   &#x5F4C;<br />
拿  9D 5C   &#x62FF;<br />
杤  9E 5C   &#x6764;<br />
歃  9F 5C   &#x6B43;<br />
濬  E0 5C   &#x6FEC;<br />
畚  E1 5C   &#x755A;<br />
秉  E2 5C   &#x79C9;<br />
綵  E3 5C   &#x7DB5;<br />
臀  E4 5C   &#x81C0;<br />
藹  E5 5C   &#x85F9;<br />
觸  E6 5C   &#x89F8;<br />
軆  E7 5C   &#x8EC6;<br />
鐔  E8 5C   &#x9414;<br />
饅  E9 5C   &#x9945;<br />
鷭  EA 5C   &#x9DED;<br />
偆  ED 5C   &#x5046;<br />
砡  EE 5C   &#x7821;<br />
続きを読む

Perl で、ハッシュ値 (ハッシュダイジェスト) を扱う:<br />コンテンツの内容が変更されたかどうかをチェックする方法

たとえば、あるウェブサイトのコンテンツ (ウェブページ) が変更されたかどうかをチェックする処理を考えてみる。Perl で、文字列比較を行う場合には if($a eq $b) {...} などとすればいいだろう。ただしこれは $a と $b が比較的「小さな」文字列であった場合である。それでは HTML などのデータで、以前アクセスしたときと今回アクセスしたときで内容が変更されているかどうかを効率的にチェックするにはどうしたらいいのだろう。1つの解法としては、ハッシュ関数を使うことが考えられる。Perl の変数で「ハッシュ」というものが出てくるが、こちらは「ハッシュ関数」である。ハッシュ関数としては、以前は MD5 というものが多く使われていたが、コンピュータの処理速度の向上によって相対的にセキュリティが低下したので、より安全な SHA1 を利用する。

使用するクラス


use Digest::SHA1;
use Digest::SHA1 qw(sha1_hex); # sha1_hex 関数をインポートしておく my $content = "ここに HTML などのコンテンツが入る"; my $digest = sha1_hex($content); # コンテンツのハッシュ値 (16進数) print $digest;

SHA1 は、もともとあるデータから 160ビット (20 バイト) の固定長の一意のデータを生成する。このデータを「ハッシュ値」と言っているが、ハッシュ値は元のデータが 1文字でも違えば、値自体もまったく違うものとなることが約束されている。また、ハッシュ値から元のデータは復元できないようになっている (これを一方向関数という)。Digest::SHA1 モジュールには単に my $data = sha1($content); とすればハッシュ値をバイナリで出力してくれるが、視覚的に見たい場合、文字列として処理する場合 (たとえばファイル名にこのハッシュ値を使うこともできる) は sha1_hex を使う。sha1_hex を使った場合はハッシュ値が 16進数の文字列として出力されるため、固定長 40バイトのデータとなる。 この方法は特にPerl だけにできるということではなく、言語を問わず、ハッシュ関数が用意されている Java や PHP にも使える。

続きを読む

Perl で、メールサーバに送られてきたメールを処理する

Procmail を利用すればサーバに送られてきたメールが標準入力から Perl スクリプトに渡すことができる。ここでは Procmail の詳細は割愛するが、以下は標準入力に入っているメールを処理する関数。

使用するクラス


use MIME::Parser;
use MIME::Base64;
use Mail::Address;
use MIME::Parser; use MIME::Base64; use Mail::Address; use Unicode::Japanese; my ($mail) = &parse; print "From: " . $mail->{sender} . "\n"; print "To: " . $mail->{recipient} . "\n"; print "Subject: " . $mail->{subject} . "\n"; sub parse {
my ($mail);

# Parser Setting
my $parser = new MIME::Parser;
$parser->output_to_core(1);    # Keeps body analyzed internally
$parser->tmp_recycling (1);    # Recycles the temporary stuff

my $entity = $parser->parse(\*STDIN) or die "Parse Error in __FILE__\n";

# Headers
$mail->{sender   } =  $entity->head->get('from'   );
$mail->{subject  } =  $entity->head->get('subject');
$mail->{recipient} =  $entity->head->get('to'     );
$mail->{recipient} =~ s/\n//g;

# From
@addrs = Mail::Address->parse($mail->{sender});
foreach $addr (@addrs) {
    $mail->{sender} = $addr->address if $addr->address; # USE CAUTION, for the multiple address
}

# Subject
my $subject = $mail->{subject};
$lws      = '(?:(?:\x0D\x0A|\x0D|\x0A)?[ \t])+';
$ew_regex = '=\?ISO-2022-JP\?B\?([A-Za-z0-9+/]+=*)\?=';
$subject  =~ s/\n//g;
$subject  =~ s/($ew_regex)$lws(?=$ew_regex)/$1/gio;
$subject  =~ s/$lws/ /go;
$subject  =~ s/$ew_regex/decode_base64($1)/egio;
$subject  = Unicode::Japanese->new($subject, 'auto')->sjis_imode;
$mail->{subject} = $subject;

# Get MIME
($mail->{body}, $mail->{filename}, $mail->{mimetype}, $mail->{object}) = &getEntities($entity);
$mail->{body   } =  Unicode::Japanese->new($mail->{body}, 'auto')->sjis_imode;
$mail->{body   } =~ s/[  \n\r]+$//g;    # Delete the white spaces in the end of the line
$mail->{subject} =~ s/[  \n\r]+$//g;    # Delete the white spaces in the end of the line

return $mail;
} sub getEntities {
my $entity = shift;
my $body, $filename, $mimetype, $object;

# BODY
my @parts = $entity->parts;
if (@parts) {                   # multipart...

    my $i;
    foreach $i (0 .. $#parts) { # dump each part...

        &getEntities($parts[$i]);
    }
} else {                        # single part...

    # Get MIME type, and display accordingly...
    my ($type, $subtype) = split('/', $entity->head->mime_type);
    my $bodyhandle = $entity->bodyhandle;

    if ($type =~ /^(text|message)$/) {      # text

        $body .= $bodyhandle->as_string;

    } else {                                # binary

        $filename= $entity->head->recommended_filename;
        $mimetype = $entity->head->mime_type;
        $object = $bodyhandle->as_string;
        binmode($object);
        # if we want to store it as BASE64, you can continue the processs here
    }
}

return ($body, $filename, $mimetype, $object);
} 1;
続きを読む
Perl を購読