Perlの最近のブログ記事

子プロセスに処理を渡して、親プロセスで標準出力を切るとき、

my $pid;
if($pid = fork){
　#親の処理
　close (STDOUT);
　wait;
}
elsif(defined $pid){
　close (STDOUT);
　#子の処理
}
　・
　・
　・


みたいな感じで今までOKだったのだが、ロリポップ系サーバなどではこれがうまく行かない。ブラウザの出力自体は切れるのだが、子プロセスの処理を行ってくれない。

WEBサーバによって変わると聞いたことがあるので、ググってみたところ、標準出力を切る部分を、

close (STDOUT);
close (STDERR);
close (STDIN);

とやったら上手く行った。

apache2.0系（うちの環境）とapache1.3系（ロリポップ系？）でどうやら違うらしい。

ちなみに、上記3つの順番が違っても1つ足りなくてもダメだった。

close (STDIN);
close (STDOUT);
close (STDERR);

↑これだとなぜか子プロセスが終了するまでブラウザが開放されない


close (STDOUT);
close (STDERR);
close (STDIN);

↑この順番じゃないとダメみたい。

STDOUTだけだと、新しいapacheのときダメだよって聞いていたので、それとは逆の現象だが、解決したからまあいいか。

私はDocomoの携帯しか持ってないので、事前にauとsoftbankを持ってる友人に頼んで、メールヘッダなどを調査したらこんな感じ↓

■　Docomo
----------------------------------------------------------------------------------
From ****@docomo.ne.jp Wed May 26 17:54:11 2010
Return-Path: <****@docomo.ne.jp>
X-Original-To: ***@igreks.jp
Delivered-To: ***@igreks.jp
Received: from localhost (localhost.localdomain [127.0.0.1])
by ***.igreks.jp (Postfix) with ESMTP id 5DE338B41B2
for <***@igreks.jp>; Wed, 26 May 2010 17:54:11 +0900 (JST)
X-Virus-Scanned: amavisd-new at igreks.jp
Received: from ***.igreks.jp ([127.0.0.1])
by localhost (igreks.jp [127.0.0.1]) (amavisd-new, port ****)
with ESMTP id kkpANBxiUasa for <****@igreks.jp>;
Wed, 26 May 2010 17:54:11 +0900 (JST)
Received: from docomo.ne.jp (mail108.docomo.ne.jp [203.138.203.8])
by ***.igreks.jp (Postfix) with ESMTP id 3E6618B40B0
for <***@igreks.jp>; Wed, 26 May 2010 17:54:11 +0900 (JST)
Date: Wed, 26 May 2010 17:54:09 +0900 (JST)
From: ****@docomo.ne.jp
To: ***@igreks.jp
Subject: =?iso-2022-jp?B?GyRCMSsbKEI=?=
Message-ID:
MIME-Version: 1.0
Content-Type: text/plain; charset="iso-2022-jp"
Content-Transfer-Encoding: 7bit

$BK\J8(B
----------------------------------------------------------------------------------


■　au
----------------------------------------------------------------------------------
From ****@ezweb.ne.jp Wed May 26 18:24:29 2010
Return-Path: <****@ezweb.ne.jp>
X-Original-To: ***@igreks.jp
Delivered-To: ***@igreks.jp
Received: from localhost (localhost.localdomain [127.0.0.1])
by ***.igreks.jp (Postfix) with ESMTP id F1F818B41B2
for <***@igreks.jp>; Wed, 26 May 2010 18:24:28 +0900 (JST)
X-Virus-Scanned: amavisd-new at igreks.jp
Received: from ***.igreks.jp ([127.0.0.1])
by localhost (igreks.jp [127.0.0.1]) (amavisd-new, port ****)
with ESMTP id CBSY6-Rv+mf6 for <***@igreks.jp>;
Wed, 26 May 2010 18:24:28 +0900 (JST)
Received: from ezweb.ne.jp (nx3oBP07-06.ezweb.ne.jp [59.135.39.240])
by ***.igreks.jp (Postfix) with ESMTP id D7FC88B40B0
for <***@igreks.jp>; Wed, 26 May 2010 18:24:28 +0900 (JST)
Received: from nxev04mp06 (localhost [127.0.0.1])
by nxev04mp06.ezweb.ne.jp (EZweb Mail) with SMTP id 955ED5BC640B4
for <***@igreks.jp>; Wed, 26 May 2010 18:24:28 +0900 (JST)
From: ****@ezweb.ne.jp
To: ***@igreks.jp
Subject: =?iso-2022-jp?B?GyRCMSsbKEI=?=
Message-ID: <2010052618242860697200007c12@nxev04mp06.ezweb.ne.jp>
Date: Wed, 26 May 2010 18:24:28 +0900
Mime-Version: 1.0
Content-Type: text/plain; charset="iso-2022-jp"
Content-Transfer-Encoding: 7bit

$B%6!<%6!<(B
----------------------------------------------------------------------------------


■　Softbank
----------------------------------------------------------------------------------
From ****@softbank.ne.jp Wed May 26 18:24:36 2010
Return-Path: <****@softbank.ne.jp>
X-Original-To: ***@igreks.jp
Delivered-To: ***@igreks.jp
Received: from localhost (localhost.localdomain [127.0.0.1])
by ***.igreks.jp (Postfix) with ESMTP id 975BD8B41B2
for <***@igreks.jp>; Wed, 26 May 2010 18:24:36 +0900 (JST)
X-Virus-Scanned: amavisd-new at igreks.jp
Received: from ***.igreks.jp ([127.0.0.1])
by localhost (igreks.jp [127.0.0.1]) (amavisd-new, port ****)
with ESMTP id HQrmiDMGcT3n for <***@igreks.jp>;
Wed, 26 May 2010 18:24:36 +0900 (JST)
Received: from mmrts049p01c.softbank.ne.jp (mmrts049p01c.softbank.ne.jp [123.108.236.27])
by ***.igreks.jp (Postfix) with SMTP id 6D9898B40B0
for <***@igreks.jp>; Wed, 26 May 2010 18:24:36 +0900 (JST)
Subject: =?ISO-2022-JP?B?GyRCJCYkcyQzGyhC?=
Mime-Version: 1.0
Content-Type:text/plain;charset=ISO-2022-JP
Content-Transfer-Encoding:7bit
Date: Wed, 26 May 2010 18:24:35 +0900
Message-ID: <20100526182435672870.2aea@0016E68F5982>
From: <****@softbank.ne.jp>
To: ***@igreks.jp
Sender:****@softbank.ne.jp
X-Priority: 3

$B%b%j%b%j(B
----------------------------------------------------------------------------------


仕様としては、

・DBはMySQL
・空メの送信先は「reg_kara_mail@igreks.jp」とする
・空メの件名に名前を指定できる。
・登録済みの場合はエラーメールを返す。
・空メ本文にメルマガIDをあらかじめ記載しておく。
・メルマガIDが認識できない場合もエラーメールを返す。
・読者データテーブル名は仮に「user_'メルマガID'」、文字コードはUTF8とする。

これを受けて、スクリプトはざっとこんな感じに。
※おおまかな流れだけで、細かい点は割愛してます


■　空メール登録処理用CGI（karame.cgi）
-----------------------------------------------------------------------------------
#!/usr/bin/perl

package main;

use strict;
use CGI;
use DBI;
use Unicode::Japanese;

require './lib/get.pl';　#各種データ取得用ライブラリ（詳細割愛）
require './lib/proc.pl';　#各種処理用ライブラリ（詳細割愛）
require './lib/db.pl';　#DB接続、各種SQL実行用ライブラリ（詳細割愛）
require './lib/start.pl';　#メール配信用ライブラリ（詳細割愛）

&db::open();　#DB接続

my $sys_msg = '';　#エラー返信用メッセージ
my ($email, $name, $id);

######　メールから標準入力をパース
my $grep = '[\d\w-.+]+\@[\d\w-]+(\.[\d\w-]+)+';　#メールアドレスの正規表現

while(<>){
　if($_ =~ /^From.*?($grep)/i || $_ =~ /^Return-Path:.*?<($grep)>/i){
　　$email = $1;　#メールアドレス
　}
　if($_ =~ /^Subject:\s*(.+)$/i){
　　$name .= $1;　#名前
　}
　if($_ =~ /^\s*(=\?ISO-2022-JP.+\?=)\s*$/i){　#件名が途中で改行されてる時のため
　　$name .= $1;
　}
　if($_ =~ /^mid:(.+)$/){
　　$id = $1;　#メルマガID
　}
}
if($email){
　if($id){
　　my $stg = &get::setting_data($id);　#メルマガ設定データ取得
　　if($stg){
　　####### 読者テーブル内重複チェック
　　&db::query("
　　　SELECT * FROM user_$id WHERE email='$email'
　　");
　　my $href = $db::sth->fetchrow_hashref();
　　if($href){
　　　#すでに登録済みの場合
　　　$sys_msg = <<EOM;
　　　　送信いただいたメールアドレス「$email」はすでに登録済みです。
　　　　このまま次回の配信をお待ちください。
EOM
　　　$sys_msg =~ s/\t//g;
　　　#メール返信処理
　　　&start::return_mail(
　　　　'空メール登録処理エラー',
　　　　$sys_msg,
　　　);
　　　exit;
　　}
　　if($name){
　　　#名前の入力があった場合
　　　$name = Unicode::Japanese->new(
　　　　&proc::base64decode($name),　#Base64デコード処理
　　　　'jis'
　　　)->utf8;　#JISからUTF8に変換
　　}
　　######## 新規登録
　　&db::query("
　　　INSERT IGNORE INTO user_$$pd{'id'} (
　　　　no,　　#オートインクリメント
　　　　email,
　　　　name,
　　　　・
　　　　・
　　　　・
　　　)
　　　VALUES(
　　　　'',
　　　　'$email',
　　　　'$name',
　　　　・
　　　　・
　　　　・
　　　)
　　");
　}
　else{
　　$sys_msg = <<EOM;
　　　登録しようとしたメールマガジンは存在しないか、すでに廃刊されています。
　　　お手数ですが、詳しくは発行者までお問い合わせください。
EOM
　}
}
else{
　$sys_msg = <<EOM;
　　送信いただいた情報に不備があり登録できませんでした。
　　空メール本文の内容は変更せずに送信してください。
　　何度もこのエラーメールが返信される場合は、お手数ですが発行者までお問い合わせください。
EOM
}

########## エラー返信処理
if($sys_msg){
　&start::return_mail(
　　'空メール登録処理エラー',
　　$sys_msg,
　);
}
&db::close();　#DB切断

exit;

-----------------------------------------------------------------------------------



■Postfixエイリアス設定ファイル（/etc/aliase）に以下を追加
-----------------------------------------------------------------------------------
reg_kara_mail:　　"|cd 'karame.cgiがあるディレクトリの絶対パス'; ./karame.cgi"
-----------------------------------------------------------------------------------

■リスタート
-----------------------------------------------------------------------------------
# newaliases

# /etc/init.d/postfix restart
-----------------------------------------------------------------------------------


■以下のようなメールを「reg_kara_mail@igreks.jp」宛に送る

　件名：自分の名前もしくは空白
　本文：mid:melmagaID

以上。


※レンタルサーバなどでエイリアスが設定できない場合は、後からcronなどでPOPアクセスして処理するなどの方法もある。（参考→http://www.igreks.jp/dev/2009/06/pop.html）
この場合は返信メールが即時配信されない。


※ディズニーモバイルとかwilcomは調べてないけど、まあだいたい同じだべってことで。

メールの件名だけのためにMIME::Base64とか使いたくないなーと思ったので。

ほぼ、こちら（http://nabe.blog.abk.nu/064）の丸写しでごめんなさい。


-----------------------------------------------------------------------

#エンコード

my $subject1 = &base64_Encode($target1);

#デコード

my $subject2 = &base64_Decode($target2);



sub base64_Encode {
my ($target) = @_;
my ($base) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
."abcdefghijklmnopqrstuvwxyz"
."0123456789+/";
my $eStr = "";
my $pStr = unpack("B*",$target);
for(my $i = 0;my $cStr = substr($pStr,$i,6); $i += 6){
$eStr .= substr($base,ord(pack("B*","00".$cStr)),1);
if(length($cStr) == 2){
$eStr .= "==";
}
elsif(length($cStr) == 4){
$eStr .= "=";
}
}
return("=?ISO-2022-JP?B?$eStr?=");
}

sub base64_Decode {
my ($str) = @_;
$str =~ s/=\?ISO-2022-JP\?B\?([A-Za-z0-9\+\/=]*)\?=/{&base64_Decode2($1)}/egi;
return $str;
}
sub base64_Decode2 {
my ($str) = @_;
my @base64ary = (
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, # 0x00〜0x1f
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, # 0x10〜0x1f
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,62, 0, 0, 0,63, # 0x20〜0x2f
52,53,54,55, 56,57,58,59, 60,61, 0, 0, 0, 0, 0, 0, # 0x30〜0x3f
0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 11,12,13,14, # 0x40〜0x4f
15,16,17,18, 19,20,21,22, 23,24,25, 0, 0, 0, 0, 0, # 0x50〜0x5f
0,26,27,28, 29,30,31,32, 33,34,35,36, 37,38,39,40, # 0x60〜0x6f
41,42,43,44, 45,46,47,48, 49,50,51, 0, 0, 0, 0, 0 # 0x70〜0x7f
);
my $ret;
my $buf;
my $f;
if (substr($str, -1) eq '=') { $f=1; }
if (substr($str, -2) eq '==') { $f=2; }
for(my $i=0; $i<length($str); $i+=4){
$buf = ($buf<<6) + $base64ary[ ord(substr($str,$i ,1)) ];
$buf = ($buf<<6) + $base64ary[ ord(substr($str,$i+1,1)) ];
$buf = ($buf<<6) + $base64ary[ ord(substr($str,$i+2,1)) ];
$buf = ($buf<<6) + $base64ary[ ord(substr($str,$i+3,1)) ];
$ret .= chr(($buf & 0xff0000)>>16) . chr(($buf & 0xff00)>>8) . chr($buf & 0xff);
}
if ($f>0) { chop($ret); }
if ($f>1) { chop($ret); }
return $ret;
}

-----------------------------------------------------------------------

結論から言うと、親プロセスの「wait;」の直後にもう一度MySQL接続処理を呼ぶ。
※2010/7/23追記：さらに各プロセスの頭でMySQL接続処理を呼ぶ。
ただそれだけ。


■MySQL接続用（db.pl）
--------------------------------------------------------------------------
package db;

use strict;

sub open{
my $dbs = "DBI:mysql:$dbname:$dbhost";
our $dbh = DBI->connect($dbs,$dbuser,$dbpass);
if(!$dbh){ die 'MySQL connection error!'; }
}

sub query{
my ($sql) = @_;
our $sth = $db::dbh->prepare($sql) || die $db::dbh->errstr();
my $exec = $sth->execute() || die $sth->errstr();
return $exec;
}

sub close{
$db::sth->finish();
$db::dbh->disconnect();
}

1;
--------------------------------------------------------------------------


■よくあるforkの処理
--------------------------------------------------------------------------
#!/usr/bin/perl

use strict;
use DBI;

require 'db.pl';　########　上のファイル読み込み
&db::open();　#########　最初のMySQL接続

（親プロセス処理）

my $pid;
FORK: {
　if($pid = fork) {
　　&db::open();　######　←【ここで単発接続】
　　（親プロセス処理）

　　close(STDOUT);
　　wait;
　　&db::open();　　######　←【ここで再接続】これはfork終了後の処理用
　}
　elsif (defined $pid) {
　　&db::open();　######　←【ここで単発接続】
　　close(STDOUT);

　　（子プロセス処理）

　　exitしなくても勝手にexitされる？
　}
　elsif($! =~ /No more process/){
　　sleep 5;
　　redo FORK;
　}
　else{
　　die 'Fork is not supported!';
　}
} # End Of Label:FORK


（親プロセス処理再開）

&db::close();　#########　正規のMySQL接続切断
exit;
--------------------------------------------------------------------------



今まで、子プロセス内処理が終われば、全体の処理も終わるような構造のスクリプトばっかりだったので、なかなか気づかなかった。
ログも「mysql server has gone away...」ってしか出ないし。
標準出力を切ってるからブラウザからのデバックだけだと気がつかず、メルマガの空メール処理実装しようとして初めて気がついた。

一般的には、子プロセス内に入ったら、改めて子プロセス専用のコネクションを作らないと、子プロセスの終了時にMySQLコネクションが切断されてしまうらしい。
（つまり、親と同じコネクションを使っていると、親のコネクションも切れる）
全然しらんかった。


でも、なぜか子プロセスの最初で「&db::open();」してもダメだった。
perlのforkは親の変数が子に全部コピーされるから（同じデータベースハンドル、またはステートメントハンドルを使っている）なのかな？


わざわざ、子プロセス専用のSQL発行サブルーチン作るのも非効率だし、どうしようかなと悩んだ挙句こうなった。


時々、MilkyStepで即時配信メールが送れなくなるのはコレのせいだったりして。


※2010/7/23追記：
子プロセスの処理中に親プロセスが終了しても、子プロセスのMySQL接続が切れる。
また、親が終了する前に子のプロセスIDを使い始めると親のMySQL接続が切れる。
原因はよくわからんが、親・子それぞれの頭で接続処理を単発で入れたら上手く行った。

メルマガを発行していて部数が増えてくるとよくあるのが、宛先からの自動返信。

「勝手に送ってくんなボケ」とか
「Re:クソスパマーへ返信します。」

とかいろいろ。

あと最近多いのが、
「いつも、メルマガ、楽しみに拝見しています。
実は、今回、メルマガ発行者さんに伝えたいことがあってメールしました。
　・
　・
　・
このシステムで毎月、収入を得ています。
何もできない私でできるのですから、こんな素晴らしいメルマガを
書かれる方なら、きっとできることでしょう。
一度、下記のホームページをご覧になって下さい。
→URL」

といった、稼げる系の情報商材を自動返信で売り込んでくるメール。

だいたい送信元はgooメールかGメールのどちらか。

もちろん私は同意を得ていないメールアドレスをメルマガに勝手に登録したりしませんから、ボケとかクソとかは完全に向こう側のおかどちがいなのですが、さすがに毎回ボケとかクソとか言われるのは腹が立つ。

過去記事（http://www.igreks.jp/dev/2009/06/pop.html）で書いたPOPアクセスを用いてメルマガなどのエラーアドレスを自動で処理できる。

しかし、このやり方だけだと自動返信メールが処理できない。
なぜなら故意に設定された自動返信メールは、本文中にFROMとかTOとかSMTPサーバの返すメッセージが書いてないから。
つまり、フツーのメールを装って送信されてくる。

なので、前回のスクリプトを改良して自動返信メールにも対応させてみる。




[動作条件]
・perl5以上（確認した環境はは5.10）かつMail::POP3Clientモジュールがインストールされていること。
・POPアクセスにSSLを用いる場合（Gmailなど）は、さらにIO::Socket::SSLモジュール（要コンパイラ）が必要。
・あらかじめエラーメール受信専用のアドレスを作っておいて、メール送信する時にエンペロープFROMをそのアドレスに指定しておく。
・CRONなどで以下のスクリプトを実行する。
-------------------------------------------------------------------
#/usr/bin/perl -w
use strict;
use Mail::POP3Client;

my $log = "POPサーバに接続中・・・\n";

#コンストラクタ　
my $pop = new Mail::POP3Client(
　　USER => 'pop_user', #popサーバのユーザ名
　　PASSWORD => 'pop_pwd', #同パスワード
　　HOST => 'pop.gmail.com', #popサーバ名
　　AUTH_MODE => 'BEST', #認証モード（たいていはBESTでOK）
　　DEBUG => 0, #デバッグ有無（正の整数を指定すると、プロンプトにサーバとのやりとりが表示される）
　　TIMEOUT => 10, #接続タイムアウト秒（デフォルトは60）
　　USESSL => 'true' #SSLを使わない場合は0（Gmailは使う）
　);


if($pop->Count < 0){ #接続に失敗すると-1が返るらしい
　$log .= "POPサーバに接続できませんでした";
}
else{
　$log .= "ID[$id]のエラーメールアドレスを調査中・・・\n";
　　if($pop->Count != 0){
　　　my $cnt = $pop->Count;
　　　my @err = ();
　　　my $suc = 0;
　　　my %diag = ();　###　エラーの原因格納用ハッシュ（任意）
　　　my @next_ck = ();
　　　$log .= "　　$cnt件のエラーメールアドレスを処理中・・・\n";
　　　for(my $i=1; $i<=$cnt; $i++){
　　　　my $pars_ok = 0;　####　パース成功フラグ
　　　　foreach($pop->Body($i)){
　　　　　###本文（SMTPサーバが返すメッセージ）からエラーになった宛先をパース
　　　　　if(
　　　　　　$_ =~ /^To:.*?\?iso-2022-jp\?B\?.+?\?=.*?<([\d\w-.+]+\@[\d\w-]+(\.[\d\w-]+)+)>/i ||
　　　　　　$_ =~ /^Delivered-To:.*?([\d\w-.+]+\@[\d\w-]+(\.[\d\w-]+)+)/i ||
　　　　　　$_ =~ /^X-Yahoo-Forwarded:.*?from.*?([\d\w-.+]+\@[\d\w-]+(\.[\d\w-]+)+).*?to/i
　　　　　){
　　　　　　$pars_ok = 1;
　　　　　　push(@err,$1);
　　　　　　$suc++;
　　　　　　$pop->Delete($i);
　　　　　　####### Diagnosis　エラーの原因チェック
　　　　　　if($_ =~ /5\.4\.4|Host.*?not found/i){
　　　　　　　$diag{'Host_not_exists'}++; #ホストまたはドメインが存在しない
　　　　　　}
　　　　　　elsif($_ =~ /550|553|554|5\.0\.0|5\.1\.1|5\.7\.1/){
　　　　　　　$diag{'Account_not_exists'}++; #受信先又は転送先のアカウントが存在しない
　　　　　　}
　　　　　　elsif($_ =~ /421|450|4\.2\.1|User disk quota/i){
　　　　　　　$diag{'Mailbox_unavailable'}++; #受信先又は転送先のメールボックスが一時的に利用不可
　　　　　　}
　　　　　　elsif($_ =~ /451|452/){
　　　　　　　$diag{'Server_error'}++; #配信時サーバエラー
　　　　　　}
　　　　　　elsif($_ =~ /432|454|534|535|538/){
　　　　　　　$diag{'Authen_error'}++; #認証エラー
　　　　　　}
　　　　　　else{
　　　　　　　$diag{'Other'}++; #その他
　　　　　　}
　　　　　　last;
　　　　　}
　　　　}#foreach
　　　　######　パースできなかったエラーメールは次のチェックへ
　　　　push(@next_ck,$i) if !$pars_ok;
　　　}#for
　　　if(@next_ck != 0){
　　　　for(my $i=0; $i<@next_ck; $i++){
　　　　　#######　今度はヘッダをチェック
　　　　　foreach($pop->Head($next_ck[$i])){
　　　　　　if(
　　　　　　　######　自動返信元をパース
　　　　　　　$_ =~ /^From:.*?([\d\w-.+]+\@[\d\w-]+(\.[\d\w-]+)+)/i ||
　　　　　　　$_ =~ /^From:.*?\?iso-2022-jp\?B\?.+?\?=.*?<([\d\w-.+]+\@[\d\w-]+(\.[\d\w-]+)+)>/i
　　　　　　){
　　　　　　　###　パースされたアドレスがデータベースにあるかチェック
　　　　　　　&db::query("SELECT email FROM usertable WHERE email='$1'");
　　　　　　　my $exists = $db::sth->fetchrow_array();
　　　　　　　if($exists){
　　　　　　　　###　あれば削除対象に
　　　　　　　　push(@err,$1);
　　　　　　　}
　　　　　　　$suc++;
　　　　　　　#####　メール削除フラグ
　　　　　　　$pop->Delete($next_ck[$i]);
　　　　　　　$diag{'Auto_return'}++; #自動返信が設定されている
　　　　　　　last;
　　　　　　}
　　　　　}#foreach
　　　　}#for
　　　}
　　　if(@err){
　　　　####エラーアドレスをDBから削除する処理など
　　　　foreach(@err){
　　　　　&db::query("DELETE FROM usertable WHERE email='$_'");
　　　　}
　　　　$log .= "$suc件のエラーメールアドレスをデータベースから削除しました\n";
　　　}
　　　###パースに失敗することもあるでしょう。
　　　if(($cnt- $suc) > 0){
　　　　$log .= "※".($cnt- $suc)."件のエラーメールアドレスを削除できませんでした\n";
　　　}
　}
　else{
　　$log .= "エラーメールアドレスはありませんでした\n";
　}
}

#接続終了（このときメールがサーバから削除される）
$pop->Close;

print $log;

------------------------------------------------------------------------




あー疲れた。

前記事（http://www.igreks.jp/dev/2010/01/mysql.html）のようにALTER TABLEを使って更新するのもいいのだが、できれば構造のテンプレートに合わせて一発でコピーしたい。

ただ単にテーブルの構造とデータをコピーする場合、普通は、

---------------------------------------------------------------------------------------
CREATE TABLE sample_new LIKE sample_original
INSERT INTO sample_new SELECT * FROM sample_original
---------------------------------------------------------------------------------------


しかし、新しい構造のテーブルにあわせて、構造を変更しながらデータをコピーするといった方法が見つからないため、スクリプトの処理を合わせて実現してみる。
あんまりスマートじゃないけど・・・

まず、最新の構造のテンプレートを作っておく。


■最新のテーブル構造のテンプレート（tbl.pl）
---------------------------------------------------------------------------------------

package tbl;

sub conf{

my %tbl = (

'table_a' => {

'column' => '

id INT AUTO_INCREMENT PRIMARY KEY,
column_1 VARCHAR(36),
column_2 VARCHAR(255),
column_3 VARCHAR(255)

',
'option' => '

ENGINE = MyISAM DEFAULT CHARSET = utf8

'

},

'table_b' => {

'column' => '

id INT NOT NULL AUTO_INCREMENT PRIMARY KEY,
column_1 INT,
column_2 VARCHAR(255),
column_3 VARCHAR(255)

',
'option' => '

ENGINE = MyISAM DEFAULT CHARSET = utf8

'

},

・
・
・

);
return \%tbl;

}
1;

---------------------------------------------------------------------------------------


テンプレートを読み込んで新しいテーブルを一時作成し、
そのテーブルに既存のテーブルのデータをインポートする。

■更新処理（tbl_update.pl）
---------------------------------------------------------------------------------------
#!/usr/bin/perl

package::main;

my $dbh;
・
・
・
# この辺でデータベースへの接続処理（詳細割愛）

print "Content-type: text/html\n\n";

print "<p>データベースの再構築を開始します</p>\n";

# 既存のテーブル名をリストで取得
my $sth = $dbh->prepare("SHOW TABLES LIKE 'hoge_%'") || die $dbh->errstr();
$sth->execute();
my @hoge_tbl = ();
while(my @tbl = $sth->fetchrow_array()){

push(@hoge_tbl,$tbl[0]);

}

# テンプレート読み込み
require "./tbl.pl";
my $tbl = &tbl::conf(); # ※リファレンスで受け取り

foreach(@hoge_tbl){

# 既存テーブルのカラム名をリストで取得
my @cols = ();
my $sth = $dbh->prepare("DESCRIBE $_") || die $dbh->errstr();
$sth->execute();
while(my $href = $sth->fetchrow_hashref()){

push(@cols,$href->{'Field'});  # unshiftしちゃだめよ

}
my $cols = join(',',@cols);

#####################################
# テーブル名の末尾に個別にIDとかが付いてなければこの処理はいらない
$_ =~ /hoge_(.+?)(_.+?)?$/;
my $name = $1;
######################################

# 新しい構造の空テーブルを「pre_***」という名前で一旦作成
my $sth = $dbh->prepare("

CREATE TABLE IF NOT EXISTS pre_$_ (

$$tbl{$name}{'column'}

) $$tbl{$name}{'option'}

") || die $dbh->errstr();
$sth->execute();

# 既存のテーブルのデータを、カラム名を明示的に指定して挿入
# これをしないとカラムの数が合いませんよ！と怒られる
my $sth = $dbh->prepare("INSERT INTO pre_$_ ($cols) SELECT * FROM $_"); # ※1
$sth->execute();

# 既存のテーブル削除
my $sth = $dbh->prepare("DROP TABLE IF EXISTS $_");
$sth->execute();

# 新しいテーブルのリネーム（"pre_"をとる）
my $sth = $dbh->prepare("ALTER TABLE pre_$_ RENAME $_");
$sth->execute();

}

print "<p>データベースの再構築が完了しました。</p>\n";

exit;
---------------------------------------------------------------------------------------


以上。

新しいテーブルにカラムが追加されてる場合は問題ないが、カラムが削除された場合は、多分※1のところでエラーになる・・・

こういうの一発でできるSQLないのかなぁ。

配列関係の重複チェックは一度ハッシュ（%check）に入れると簡単


-----------------------------------------------------------------------------------------

my %hash = (
a => 'あああ',
b => 'いいい',
c => 'ううう',
d => 'あああ',
e => 'おおお',
f => 'あああ'
);

my %check = ();

for(values %hash){
die "$_ が重複してるよ！" if $check{$_};
$check{$_} = 1; #### 1とかaとか好きなの入れる
}

-----------------------------------------------------------------------------------------

LWPを使ったhttpレスポンスの取得には、HTTP::Request(::Common)モジュールを使ってリクエストのオブジェクトを作っておくと、レスポンス情報を確認するさまざまなメソッドを使用することができる。

HTTPモジュール群にはまず「HTTP::Message」があり、このオブジェクトには幾つかのヘッダとコンテント（ボディ）取得用のクラスが入ってるが、このクラスは抽象クラスである。
つまりHTTP::RequestとHTTP::Responseのための基本クラスとしてだけ使われ、それ自身のインスタンスは生成されることはない。

「HTTP::Response」はHTTP形式のレスポンスをカプセル化するクラスである。
このクラスのインスタンスは通常、LWP::UserAgentオブジェクトのrequestメソッドによって作成され返される。

また、「HTTP::Headers」は同様にHTTP形式のメッセージヘッダをカプセル化するクラスである。
このクラスのインスタンスは通常、HTTP::RequestやHTTP::Responseクラスのメンバー変数として、ライブラリ内部用に作成される。

つまり、

my $url = 'http://yahoo.co.jp';
my $ua = LWP::UserAgent->new();
my $req = &HTTP::Request::Common::GET($url);
my $res = $ua->request($req);

のように、レスポンス用オブジェクト($res)生成しておけば、上の3つのモジュールで定義されているメソッドは全てこのオブジェクト($res)から以下のように参照することができる。

---------------------------------------------------------------------------------------------------

（HTTP::Message）

■$res->protocol([$proto])
・・・そのメッセージに使われるHTTPプロトコルを設定する。protocol()は"HTTP/1.0"または"HTTP/1.1"のような文字列が返る。

■$res->content([$content])
・・・引数が与えられていれば、コンテントを設定する。引数が無ければ、コンテントは触れられずに返される。

■$res->add_content($data)
・・・前のコンテントの末尾にさらにデータを追加する。

■$res->content_ref
・・・コンテント文字列へのリファレンスを返す。
コンテントが巨大であれば、この方法が効率的。また、直接操作が出来る。
例：${$res->content_ref} =~ s/\bfoo\b/bar/g;

■$res->headers;
・・・HTTP::Headersオブジェクトを返す。

■$res->headers_as_string([$endl])
・・・HTTP::Headers->as_stringを呼び出す。

（HTTP::Headers）

■$res->header($field [=> $value],...)
・・・ヘッダの値を取得または設定する。
ヘッダ・フィールド名は大文字／小文字を区別しない。
引数が無い場合は複数の（$field => $values)の組を受け取る。
$valueを複数設定することにより１回の呼び出しでたくさんのフィールドを更新することも可能。$valuesにはスカラまたはスカラのリストへのリファレンスを指定することができる。
$valueが未定義だったり指定されていなければヘッダは変更されない。

複数の値を持つフィールドは、スカラ・コンテキストでは","を区切り文字としてつなげられ返される。

（例）
　$header->header(MIME_Version => '1.0',
　　　　　　User_Agent => 'My-Web-Client/0.01');
　$header->header(Accept => "text/html, text/plain, image/*");
　$header->header(Accept => [qw(text/html text/plain image/*)]);
　@accepts = $header->header('Accept');

■$res->scan(\&doit)
・・・ヘッダそれぞれにサブルーチンを適用する。コールバック・ルーチンは２つのパラメータ（フィールド名と１つの値）で呼び出される。
ヘッダが1つ以上の値を持っていれば、ルーチンはそれぞれの値につき1回呼ばれる。コールバック・ルーチンに渡されるフィールド名はHTTP仕様で提案されている大文字／小文字をもち、推奨されている"Good Practice"の順でやってくる。

■$res->as_string([$endl])
・・・フォーマットされたMIMEヘッダとしてヘッダ・フィールドを返す。
文字列を組み立てるために内部でscan()メソッドを使っているので、結果はHTTP仕様で提案されている大文字小文字で、ヘッダ・フィールドの順序の推奨されている"Good Practice"に従う。
長いヘッダの値はたたまれない。

オプションのパラメータには使用する行末シーケンスを指定できる。デフォルトは"\n"。
この場合、ヘッダに埋め込まれた"\n"文字は、この行末シーケンスで置きかえられる。

■$res->push_header($field, $val)
・・・指定されたヘッダに新しいフィールドの値を追加する。
ヘッダ・フィールド名は大文字小文字を区別しない。
同じフィールド名で、値を持たずに指定した場合、前の値が残る。
引数にはスカラやスカラのリストへのリファレンスを指定することが出来る。

（例）$header->push_header(Accept => 'image/jpeg');

■$res->remove_header($field,...)
・・・指定された名前を持つヘッダを削除する

（HTTP::Response）

■$res->code([$code])
・・・レスポンスコード(301など)を返す。

■$res->message([$message])
・・・レスポンスメッセージを返す。

■$res->request([$request])
・・・このレスポンスを発生したリクエストのリファレンスを返す。
ここまでの間に、リダイレクトや認証のリトライがある場合もあるので、$ua->request()メソッドに渡されたものと同じリクエストである必要はない。

■$res->previous([$previousResponse])
・・・最初のレスポンスがリダイレトクまたは認証されていなければ、レスポンスのチェーンを返す。

■$res->status_line
・・・文字列"$res->code + $res->message"を返す。
もしmessage属性が設定されていなければ、code（HTTP::Statusを参照にした）の公的な名前に置き換えられる。

■$res->base
・・・レスポンスのベースURLを返す。
戻り値はURIオブジェクトへのリファレンス。

ベースURLは以下のいずれかの情報源から１〜３の優先順で取得される。

　1. ドキュメント内容に埋め込まれたもの：例えばHTMLドキュメント内での
　2. レスポンスでの"Content-Base:"または"Content-Locatin:"ヘッダ
　　古いHTTP実装との互換性のため、"Base:"ヘッダも探す。
　3. このレスポンスを要求したURL。
　　これはレスポンスの前に、いくつかのリダイレクトを受信しているかもしれないため、$ua->request()メソッドに渡された元のURLでない場合もある。

■$res->as_string
・・・コンテントのプレーンテキストを返す。
主にデバッグのために使われる。引数は指定できない。

■$res->is_info
■$res->is_success
■$res->is_redirect
■$res->is_error
・・・レスポンスが情報的(informational)であるか、成功したか、リダイレクトであるか、エラーであるかを返す。
（偽ならおそらくundefか0を返す）

■$res->error_as_HTML()
・・・何のエラーが発生したかを示す完全なHTMLドキュメントが入っている文字列を返す。
このメソッドは$res->is_errorがTRUEのときだけ呼ぶべき。

■$res->current_age
・・・ section 13.2.3.によって指定されたレスポンスの"現在の年齢"("current age")を計算する。
レスポンスの年齢は元のサーバサーバーによって送信されてからの時間。
返される値は累計秒。

■$res->freshness_lifetime
・・・ section 13.2.4.で指定されたそのレスポンスの"新鮮期間"("freshness lifetime")を計算する。
"新鮮期間"はレスポンスが生成されてから終了するまでの時間の長さ。
返される値は累計秒。

■$res->is_fresh
・・・freshness_lifetime()とcurrent_age()の値をベースに、レスポンスが新鮮であればTRUEを返す。
レスポンスがもはや新鮮でなければ、もう一度取り出されるか、元のサーバによって再評価されるべきである。

■$res->fresh_until
・・・このエンティティがもはや新鮮ではない時刻を返す。


------------------------------------------------------------------------------------------------------

参考URL：
http://homepage3.nifty.com/hippo2000/perltips/HTTP/Headers.html
http://homepage3.nifty.com/hippo2000/perltips/HTTP/Message.html
http://homepage3.nifty.com/hippo2000/perltips/HTTP/Response.html

----------------------------------------------------------------------------------------------

#!/usr/bin/perl -w

use strict;
use LWP::UserAgent;
use HTTP::Request::Common;

# オブジェクト作成
my $ua = LWP::UserAgent->new();
my $url = 'http://yahoo.co.jp';
my $req = &HTTP::Request::Common::GET($url);

# レスポンスを得る
my $res = $ua->request($req);

# フィールド名を指定してヘッダを取得
my $con_type = $res->header('Content-Type');

#処理
if($con_type =~ /shift_jis/i){
　　# (sjis用エンコーディング処理)
}
elsif($con_type =~ /euc-jp/i){
　　# (ujis用エンコーディング処理)
}
elsif($con_type =~ /utf-8/i){
　　# (utf8用エンコーディング処理)
}
　　・
　　・
　　・

----------------------------------------------------------------------------------------------


※charsetをダイレクトに返してくれるメソッドはどうやら無いらしい・・・
あったら教えてください。

多くの参考サイトや本では、LWPモジュール群を利用してのSSLアクセスには「Crypt::SSLeay」モジュールが必要と説明されているが、どうやら「Net::SSLaey」モジュールがあれば可能なようだ。

もちろんサーバにSSL環境（OpenSSLとかmodSSLとか）があるっていうのが前提ではあるが。

OpenSSLとLWPのつなぎ役をしてくれるのがCrypt::SSLeayだが、もともと、OpenSSLとSSLeayとの高度な機能インタフェースを提供するモジュールが「Net::SSLaey」モジュールである。


以下確認作業

■まず適当なスクリプトでPerlの@INCの中身を確認----------------------------------------------------------------------------------------------
#!/usr/bin/perl

print "Content-type: text/plain\n\n";

foreach(@INC){
print $_.'\n';
}

exit;
----------------------------------------------------------------------------------------------

■結果↓

----------------------------------------------------------------------------------------------
/usr/local/lib/perl5/site_perl/5.10.0/i386-linux-thread-multi
/usr/local/lib/perl5/site_perl/5.10.0
/usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi
/usr/lib/perl5/vendor_perl/5.10.0
/usr/lib/perl5/vendor_perl
/usr/lib/perl5/5.10.0/i386-linux-thread-multi
/usr/lib/perl5/5.10.0
/usr/lib/perl5/site_perl
.
----------------------------------------------------------------------------------------------

■次に、Crypt::SSLeayとNet::SSLeayが入っているか確認↓

----------------------------------------------------------------------------------------------
（コマンド）
$ su
# cd /

# find -path *Crypt/SSL*

#
（↑Crypt::SSLeayは入っていない）

# find -path *Net/SSL*

./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/Net/SSLeay
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/Net/SSLeay/Handle.pm
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/Net/SSLeay.pm
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/auto/Net/SSLeay
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/auto/Net/SSLeay/https_cat.al
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/auto/Net/SSLeay/do_https4.al
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/auto/Net/SSLeay/get_httpx3.al
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/auto/Net/SSLeay/get_http.al
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/auto/Net/SSLeay/put_http.al
./usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/auto/Net/SSLeay/want_read.al
　　　・
　　　・
　　　・
（以下省略）

（↑@INCでは「/usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi」にNet::SSLeayが入っている）
----------------------------------------------------------------------------------------------

■試しに名前を変えてみる↓

----------------------------------------------------------------------------------------------
# cd /usr/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi/Net
# mv SSLeay.pm SSLeay.pm2
----------------------------------------------------------------------------------------------

■スクリプト↓でhttpsにリクエストしてみる

----------------------------------------------------------------------------------------------
#!/usr/bin/perl

use strict;
use LWP::UserAgent;
use HTTP::Request::Common;

my $ua = LWP::UserAgent->new();

my $url = "https://www.hogehoge.jp"; # 実在するセキュアサイト

$request = &HTTP::Request::Common::GET($url);
$response = $ua->request($request);

print "Content-type: text/plain\n\n";
print $response->status_line;

exit;
----------------------------------------------------------------------------------------------

■実行結果↓

----------------------------------------------------------------------------------------------

501 Protocol scheme 'https' is not supported

（httpsプロトコルはサポートしていません）
----------------------------------------------------------------------------------------------

■SSLeay.pmを元に戻す↓

----------------------------------------------------------------------------------------------
# mv SSLeay.pm2 SSLeay.pm
----------------------------------------------------------------------------------------------

■さっきのスクリプトをもう一度実行↓

----------------------------------------------------------------------------------------------

302 Found

（ファイルが存在します＝接続成功）
----------------------------------------------------------------------------------------------


めでたしめでたし。