perl

2010年2月23日 (火)

auとdocomoのIPアドレス帯域のチェックツール

キャリアのIPを登録し忘れたせいで、最近立て続けにサイトにアクセスできない問
い合わせをいただいた。キャリアごとにWebで使用しているIPを公開しているのだ
が、ついチェックをサボるとこういうことになってしまう。
正直atomで公開してくれていると更新がわかって便利なのだが、auもdocomoも
Webページでしか公開していない。そこでezweb(au)PCサイトビューア(au)
brew(au)iモード(docomo) のWebページを解析して、変更があればメールで
通知するスクリプトを書いた。
チェックごとに前回チェックした時とのIPの差分をとって差分があった場合に通知
します。初回は必ずメールが来ます。cronに登録して毎日実行するといいと思いま
す。

#!/usr/bin/perl -w
use strict;
use warnings;
use LWP::Simple;
use HTML::TreeBuilder;
use Data::Dumper;
use Mail::Mailer;
use YAML ();
my $file_name  = "/var/tmp/mobile_app_ip.yml";

my %provider = (
    "ezweb"=>"http://www.au.kddi.com/ezfactory/tec/spec/ezsava_ip.html",
    "brew"=>"http://www.kddi.com/business/customer/tec/index.html",
    "ezpcsv"=>"http://www.au.kddi.com/ezfactory/tec/spec/pcsv.html",
    "imode" => "http://www.nttdocomo.co.jp/service/imode/make/content/ip/index.html",
    );
my %ydoc;
if( -f $file_name){
    %ydoc = YAML::LoadFile($file_name);
}
my %notices;
my %new_doc;
for my $prov_name (keys(%provider)){
    my $html = get($provider{$prov_name});
    my $tree = new HTML::TreeBuilder;
    $tree->parse($html);
    $tree->eof();
    my $num = 1;
    my %ip_set;
    my @ip_order;
    my $state;
    if($prov_name =~ /^ez/){
        for my $tag ( $tree->look_down("class", "TableText")){
            if($tag->as_text eq $num){
                $state = "ip";
                $num++;
                next;
            }
            unless($state){
                next;
            }
            if($state eq "ip"){
                $state = "mask";
                push @ip_order,$tag->as_text;
                $ip_set{$tag->as_text} = {provider=>$prov_name};
                next;
            }
            if($state eq "mask"){
                $ip_set{$ip_order[-1]}->{"mask"} = $tag->as_text;
                $state = undef;
                next;
            }
        }
    }
    elsif($prov_name =~ /brew/){
        for my $tag ( $tree->look_down("class", "center")){
            if($tag->as_text eq $num){
                $state = "ip";
                $num++;
                next;
            }
            unless($state){
                next;
            }
            if($state eq "ip"){
                $state = undef;
                my @nodes = split "/",$tag->as_text;
                $nodes[0] =~ s/\s+//g;
                $nodes[1] =~ s/\s+.*$//;
                push @ip_order,$nodes[0];
                $ip_set{$nodes[0]} = {provider=>$prov_name,"mask"=>"/".$nodes[1]};
            }
        }

    }
    else {
        my $cnt=0;
        for my $tag ( $tree->look_down("class", "normal txt")){
            my $li_html = $tag->as_HTML;
            my $li_tree = new HTML::TreeBuilder;
            $li_tree->parse($li_html);
            $li_tree->eof();
            for my $li ( $li_tree->find("li")){
                my @nodes = split "/",$li->as_text;
                $nodes[1] =~ s/\s+.*$//;
                push @ip_order,$nodes[0];
                $ip_set{$nodes[0]} = {provider=>$prov_name,"mask"=>"/".$nodes[1]};
            }
            $li_tree = $li_tree->delete;

            $cnt++;
            if($cnt > 1){
                last;
            }
        }
    }
    $tree = $tree->delete;
    for my $ip (@ip_order){
        if(!$ydoc{$prov_name} or !$ydoc{$prov_name}->{$ip}){
            $notices{$prov_name} = [] unless $notices{$prov_name};
            push @{$notices{$prov_name}},"ip:$ip" .$ip_set{$ip}->{"mask"} . " added.\n";
        }elsif($ydoc{$prov_name}->{$ip}->{"mask"} ne $ip_set{$ip}->{"mask"}){
            $notices{$prov_name} = [] unless $notices{$prov_name};
            push @{$notices{$prov_name}}," ip:$ip".$ip_set{$ip}->{"mask"} . " mask modified.\n";
        }
    }
    for my $ip (keys(%{$ydoc{$prov_name}})){
        unless($ip_set{$ip}){
            $notices{$prov_name} = [] unless $notices{$prov_name};
            push @{$notices{$prov_name}},"ip:$ip".$ydoc{$prov_name}->{$ip}->{"mask"} . " deleted.\n";
        }
    }
    $new_doc{$prov_name} = \%ip_set;
}
if(%notices){
    my $mailer = Mail::Mailer->new("smtp",Server=>"SMTPサーバ");
    $mailer->open({
        From => '送信元メールアドレス',
        To => '送信先メールアドレス',
        Subject => 'Provider IP Modified',
        }) or die "Can't open $! \n";

    for my $prov_name (keys(%notices)){
        print $mailer "\nPROVIDER:". $prov_name ." URL:" . $provider{$prov_name} ."\n";
        for my $message (@{$notices{$prov_name}}){
            print $mailer $message;
        }
    }
    $mailer->close();
}
open my $new_file ,">",$file_name;
print $new_file YAML::Dump(%new_doc);
close $new_file

EZアプリはPCサイトビューア用のIPでアクセスしてくるみたいだったので、PCサ
イトビューアのIPもチェックするようにした

Rubyで書こうと思っていたけど、nokogiriがlibxml2のdevel環境に依存している
が、私のサーバ環境ではインストールに失敗(libxml2とlibxml2-devのバージョン
が一致しない)したため、PerlのHTML::TreeBuilderを使用することにした。
こちらはサクッとCPANからインストールできた。

追記 2010 02.25
brew用のアドレス一覧のサイトがありました。
プログラムに追記しました。

| | コメント (0) | トラックバック (0)

2010年1月26日 (火)

PerlのDBIでMySQLにShift JISの日本語のデータを挿入する。

DBIでプレースホルダを使用して、Shift JISの日本語でかつ文字コードが0x5cで終わるデータをinsertするとエラーになってしまう。


use DBI;

my $dbh = DBI->connect('DBI:Mysql:test', 'testuser', 'testpwd');

$dbh.do("insert into table ( name ) values(?)",undef,'')|| die $dbh->errstr;




本当はhttp://www.klab.jp/media/mysql/index6.htmlにあるようにmysql_set_character_set()が使えればいいのですが、比較的最近、追加されたAPIなので使えないパターンがあると思います。
ネットで探しても、Shift JISを使うなの一点張りですが、それ派、私にではなく、Docomoに言ってくれと思います。
そこで、MySQLはHEX文字で記述された文字コードをUNHEXという関数で文字に直すということができるため、UNHEXを使うようにしたところ、問題が起きなくなりました。 下記がそのコードです。

sub _to_hex_str{

  my( $str ) = @_;

  my @codes = unpack("C*",$str);

  my $code_format;

  my $code_str;

  foreach my $code (@codes){

    $code_format .= "%x"

  }

  $code_str = sprintf $code_format,@codes;

  return $code_str;

}

my $dbh = DBI->connect('DBI:Mysql:test', 'testuser', 'testpwd');

$dbh.do("insert into table ( name ) values(UNHEX('" . _to_hex_str($name) . "'))")|| die $dbh->errstr;



ネットで見かけなかった解決方法なので何か不都合があるかもしれません。
もし、問題がありそうだったら、教えてください。

| | コメント (3) | トラックバック (0)

2010年1月24日 (日)

Perlへの懺悔

ここ数年Rubyを使っています。
Rubyこそ最高のスクリプト言語だと思っていました。
Rubyの名前の由来もよりよいPerl (pearlは6月の誕生石、ruby は7月の誕生石 )
という意味を意識してのものです。
そのため、Rubyが盛隆になった今、Perlを使っている人は、Rubyに乗り遅れて、Perlの知識にしばられているだけ。そう思っていました。

でも、その思いは間違っていました。

PerlにはPerlのよさがあり、Rubyにけっして劣っていない。と最近そう確信するにいたりました。
そこで懺悔の意味をこめて、Rubyに比べたPerlのよさを述べたいと思います。

1.参照回数によるオブジェクト破棄のため、破棄時が明確である。
perlは対象のオブジェクトのリファレンスがなくなった時に破棄が実行されるのに対し、rubyはGC(ガベージコレクター)による破棄のため、破棄がいつ行われるかわかりません。
いつ行われるかわからないというのは、2つの点で問題があります。

   a.メモリが必要以上に消費されてしまう。
   b.リソースの開放処理を自分で記述する必要がある。

a.に対してですが、最近Rubyでバックアップツールを作って、動かしていたのですが、4Gあるメモリーがほとんどバックアップツールによって使われてしまい、他のプログラムの動作に支障がでたということがありました。
バックアップツールはファイルを読み込む処理はあるものの、一時変数に読み込んだデータを代入しているので、関数が終了した時点でそのメモリーが開放され、メモリーが使い果たされることはないと思っていたのですが、関数を抜けた瞬間にGCが動くと言うわけではないため、メモリー使用が蓄積されてしまいました。そのため、毎回GC.startというメソッドを呼び出すようにしたところ、メモリの使用量が一定になりました。

b.に関しては下記のソースを比べてみてください。
perlバージョン

 use DBI;

sub print_simple01{
  my $dbh = DBI->connect('DBI:Mysql:test', 'testuser', 'testpwd');
  my $sth = dbh.prepare('select * from simple01');
  $sth.execute
  while(my @row = $sth->fetchrow_array) {
    print "@row\n";
  }
}

rubyバージョン

 require 'dbi'

def print_simple01
  dbh = DBI.connect('DBI:Mysql:test', 'testuser', 'testpwd')
  sth = dbh.prepare('select * from simple01')
  sth.execute
  while row=sth.fetch do
      p row
  end
  sth.finish
  dbh.disconnect
end

ほとんど変わらないのですが、rubyバージョンには、sth.finishやdbh.disconnectの文があるのに対し、perlにはありません。
なぜかというとperlにはオブジェクトが廃棄される際にDESTROYというメソッドが呼び出されることになっているので、その中でリソースの開放処理を行っているため、必要ないのです。
rubyの場合にもオブジェクト削除時に処理を走らせることができるにはできるのですが、いつ実行されるかわからないため、リソースの開放処理には使えません。そのため、自分でリソース開放処理を行う必要があります。
もちろん、rubyの開発者はそのことを承知していて、その問題をブロックにより解決しています。例えば次のようになります。
ruby ブロックバージョン

 require 'dbi'

def print_simple01
  DBI.connect("dbi:Mysql:test:localhost", "testuser", "testpass") do |dbh|
    dbh.prepare('select * from simple01') do |sth|
      while row=sth.fetch do
          p row
      end
    end
  end
end

確かにリソースの開放処理がいらなくなったため、スマートになったと言えます。その代わりネストが深くなっています。
リソースを複数同時に使いたい場合等に複雑になってしまうため、perlの参照回数方式のほうがこの場合はいいように思えます。
rubyが参照回数方式ではなく、GC方式にしているのは、rubyの拡張ライブラリを書きやすくするためだそうです。
このあたりは開発者をいかに楽にするかというrubyの思想だから、それでいいと思います。

2. 高機能のオブジェクト指向機能が使える。
ここは、えっと思うところかもしれません。
確かにPerl5に組み込まれているオブジェクト指向の機能は無理やり感があって、使いづらい思いをした人も多いと思います。でも、言語にオブジェクト機能が組み込まれていないからこその柔軟性がPerlにはあります。
Mooseというモジュールです。
Mooseは、各メンバ変数ごとに型を指定したり、書き込み、読み込みの許可を指定できたり、デフォルト値のセットに関数を指定できたり、遅延評価できたり、フックをかけたり、強制的に型変換をできたり、またロールを使ってインターフェースプログラミングを支援したりと高機能なオブジェクト指向機能を提供してくれます。
高機能な代わりMooseは重いです。でも互換・軽量版のMouseというモジュールもあります。Mouseは10年前のバージョンであるperl 5.6でも動作します。
要件に応じて取捨選択ができるのです。処理速度が重要な場面なら、それらのモジュールを使わなければいいのです。

以上他にもあると思いますが、私にはすぐに思いつきません。

ここで何でいまさらPerlのよさに気づいたのかを説明します。

業務上の都合でこの数ヶ月perlを使わざるを得ませんでした。
;抜けや$つけ忘れ、宣言忘れのエラーが出まくる、モジュールの最後に1;を書き忘れて、動作がおかしい、mockやfixture等の仕組みがないからテストがしにくい、irbがない、@a[1]で動作がおかしいのにエラーにならない、ハッシュスライスの文法が直感的でない、inspectがないから、printで出してもHash,Arrayなどのあまり意味のない情報が出力される等散々最初は愚痴りました。

初めに立てたスケジュールも大幅に狂いだし、どうしようかと思ったそんな時、iPhoneのアプリでlearning perlが600円とういう安さで提供されていたため、通勤中にでも読もうと買ってみたところ、これが本当にいい本でした。

$はsclarのsで@はarrayのaからだよのところから、なぜモジュールの最後に1;をつける必要があるのか(もし条件にあわなかったら、そのモジュールを読まないという機能を提供するため)等、なぜが書かれていました。

perlを知ることはLarry Wallを知ることと言われるように確かに文法はrubyに比べて複雑で、時々トリッキーです。でもそれぞれには、理由があり、納得できれば気にならなくなります。

また、Perlのコードは可読性が低いとよく言われます。実際自分でPerlで書いた2ヶ月前のコードを読んでさっぱり意味が解からなかった経験があり、私もずっとそう思っていました。
でも最近、他人が書いたRubyやPerl、自分の書いたRubyやPerlのプログラムを読んで、決してPerlのほうがRubyより読みにくいと言えないと確信しました。

例えばCでプログラムを書くときは、まず設計をしてからプログラムを書きます。でもスクリプト言語を覚えたての時は、いちいちコンパイルする必要も無いため、Try&Errorでガリガリとコードを書いてしまい、後々なぜそういう処理をしたのかが思い出せないのが、自分の書いたコードでも読みにくい原因だと思います。

Rubyでそこそこの規模のツールの開発やRailsによるWebアプリの開発を経験してきた今は、保守を考えたモジュールやメソッドの分割に慣れ親しみ、Perlで書いてもRubyで書いても可読性は全然変わりません。

Perlなんてと思っている方は、是非「初めてのPerl」,「続・初めてのPerl」,「モダンPerl入門」を読んでみてください。
きっと、Perl、悪くないよね。って日が来ます。

| | コメント (3) | トラックバック (0)