Perl Archive

前職時代の後輩（といっても、ほとんど入れ替わりだったけど）作。がんばってますな。ワシもがんばらねば

とまあ今更ながらCGI::Applicationのプラグインを作ってみました。
というのもちょっとしたCGIなんかを作るときはやっぱりよくできてましてね、このモジュール

御意。ほんとよくできてるよね、CGI::Application

メール送信関連の実装、と言うのは簡単だが、まじめに作るとそれだけでフレームワークになってしまうので、どの程度で妥協するのか悩み中

• メール本文はテンプレートファイルで。テンプレートファイル名を指定しない場合のルールを決める
• From, To, Subject は設定ファイルに書くなりどっかから持ってくるなり、なんなりするが、テンプレートエンジンは通す
• 7bit ISO-2022-JP 決め打ちにしよかとも思ったが、イマドキの MUA なら 8bit UTF-8 で大丈夫かな？　携帯電話はまずそげ。まぁ、無難に 7bit JIS にしとくか
• 添付ファイルや HTML メールは、いらね

などと考えて「普通のメールを無難に送るだけのメソッドをおまけ的に実装」することにした

メールの実装終わったら、次は validation を考えることにした。ものすごく楽したくて、ものすごく手を抜けない部分なので、じっくり考えよう

明日以降の実装のためのメモ

YAML ファイルの runmode 名と同じ項からいろいろ取得、というところまで仕様にするとやりすぎかなとも思ったので、prerun モードで実行するから不要なら上書きしてね、というスタンスにした

あと、実行可能な runmode を指定するホワイトリスト形式は安全でいいんだが、ちょっと作ってみるって時に面倒なので、ブラックリスト形式にした

• 予約語＝C::M::App のメソッドの場合は実行しない
• アンダースコアで始まるメソッドは実行しない
• それ以外のメソッドは全部実行する

という感じで

存在しない runmode を指定した場合は 404 ページを表示したいので、not_found というオーバーライド可能なメソッドを追加した

次は、メール送信とログ出力の予定

mod_perl とか fcgi はかなり後回し。ログイン画面を簡単に作る工夫とかもあると嬉しい。。。かな？

少し間があいてしまったが、やっていないわけではなくて、Template-Toolkit 関連部分の実装を終えたので、現在試用しながら実装変更中

使っててわかったのが、

• config 関連の実装が必要
  • YAML 形式のファイル読み込みにする予定
• Mail 送信関連の実装が必要
  • トレンドは Email::* っぽいので、Email::Simple と Email::Send あたりを使ってみようかと思っている。でも、Email::* はお互い依存してそげなんで、後で考える。愛用してきた MIME::Lite でもいいんだが

。。。とか思ってたら、MIME::Lite も久しぶりにアップデートされてるじゃん！

First release from Perl Email Project. Updated packaging.

らしい。RJBS すげえ！

ファイル開く数一桁で済む方法を選択したはいいが、ファイル数百個開くラクチンパターンと速度に差がない。マシンスペックは間違いなくあがっているので、ローカルで使うプログラムでそんなこと意識してもしゃぁない時代になっているようだ

今日は DBIx::Simple 周り
DB 関連のエラー拾うために、よく

$dbh->select(...) or die $dbh->error;

とかするが、わざとエラーにしてみるために

$dbh->disconnect;
$dbh->select(...) or die $dbh->error;

してみたら、

Database object no longer usable (because of ...)

と返ってきたので、さらに実験

use DBIx::Simple;
use Data::Dumper;

my $dbh = DBIx::Simple->connect('dbi:SQLite:dbname=dum.db');
print Dumper $dbh;

$dbh->disconnect;
print Dumper $dbh;

実行結果

$VAR1 = bless( {
                 'lc_columns' => 1,
                 'dbh' => bless( {}, 'DBI::db' ),
                 'dbd' => 'SQLite'
               }, 'DBIx::Simple' );
$VAR1 = bless( {
                 'what' => 'Database object',
                 'cause' => 'DBIx::Simple=HASH(0x812c15c)->disconnect at db.pl line 7'
               }, 'DBIx::Simple::DeadObject' );

おー、なるほど

if ( ref $dbh eq 'DBIx::Simple::DeadObject' ) {
  print 'DB object has been already a-born.';
  undef $dbh;
}

とかできるのね。使うことがあるかどうかはわからないけど

みんながやっている時にやらないのがひねくれ者の真骨頂。日常よく使っている系を history から抜き出してみた

クライアントマシン

• 無差別

 86 l
 66 dream
 62 cd
 39 for
 29 ssh-agent
 28 ssh-add
 28 jobs
 21 oneroad
 21 myrsync
 18 gcp

• 除 alias や自前コマンド

 62 cd
 39 for
 29 ssh-agent
 28 ssh-add
 28 jobs
 16 clear
 11 curl
 10 open
  8 mkdir
  7 tar

サーバマシン

• 無差別

197 fg
173 perl
 44 l
 17 jobs
  9 vim
  8 w3m
  8 rm
  8 emacs
  5 clear
  4 mv

• 除 alias や自前コマンド

197 fg
173 perl
 17 jobs
  9 vim
  8 w3m
  8 rm
  8 emacs
  5 clear
  4 mv
  4 ls

クライアントマシンとサーバマシンの傾向がはっきりしていておもしろかった
あと、長めなのに手入力しているやつは、頭では覚えていないのに手が覚えているらしくておもしろかったので、書き残しておく

※長いのは読みやすいように複数行に分けた

tar zcfvp - target_dir | ssh user@host "cat > target.tar.gz"
tar zcfvp - target_dir | ssh user@host "tar zxfvp -"

zcat access.log.yyyymmdd.gz|awk '{print $1}'|sort|uniq -c|sort -nr|head -10

for i in `ls`;do cp $i $i.org;done

for i in dir1 dir2 dir3
do rsync -avvz --delete -e ssh user@host:~/data/$i ~/data
done

実際は、手が覚えてるんじゃなくて、常に History から使ってるんだけどね

C::M::App は、CGI::Application と同様、自分のクラスから継承されることを想定している

package MyClass;
use basee 'CGI::Minimal::App';

1;

んだが、一部メソッドは子クラスでのオーバーライド前提だし、一部メソッドはオーバーライドされたくないし、ということで、思案。他の言語みたいに attribute :final とか用意されてると

sub cannot_override :final {
}

とかするだけだし、そういうことを行うモジュール Attribute::Final もあるんだが、外部モジュール使うほどでもないし、attribute で実装しなくてもよかろう

# 子クラスの時だけ実行
unless ( ref $self eq __PACKAGE__ ) {
  for my $method (@all_methods) {
    next if .... ; # 親クラスのメソッドだったら何もしない

    die 'You can NOT OVERRIDE method'
      if ( grep {$_ eq $method} @not_override_methods );
  }
}

まずは基本ということで、Class::Inspector 使ってみる

# Check methods that cannot override in Sub-Class
unless ( ref $self eq __PACKAGE__ ) {
  my @not_override_methods = qw(
                                new run
                                _tt_obj _setup_http_headers _lvalue_method
                               );
  for my $method ( @{Class::Inspector->methods(ref $self, 'expanded') || [[]]} ) {
    next if $method->[1] eq __PACKAGE__;
    die 'You can NOT OVERRIDE method ',__PACKAGE__,'::',$method->[2],' in ',$method->[1]
      if ( grep {$_ eq $method->[2]} @not_override_methods );
  }
}

続いて、Class::Inspector はコアモジュールではないので、使わない版

# Check methods that cannot override in Sub-Class
unless ( ref $self eq __PACKAGE__ ) {
  my @not_override_methods = qw(
                                new run
                                _tt_obj _setup_http_headers _lvalue_method
                               );
  {
     no strict 'refs';
     for my $method ( keys %{ref($self).'::'} ) {
       next unless defined &{ref($self).'::'.$method};
       die 'You can NOT OVERRIDE method ',__PACKAGE__,'::',$method,' in ',ref($self)
         if ( grep {$_ eq $method} @not_override_methods );
     }
  }
}

タイムリーなことに、「どう書く？org」で「メソッド名一覧の表示」がお題になっているので、良さげな回答がでてきたらマネさせてもらおう

で、この実装だとコンストラクタ生成後にチェックするので、use した時点でチェクする方法考えた方がいいのかなぁ、とちょっと思った。new のしょっぱなにやっとけば同じかな

もっとスマートな実装方法はないものか

って、絶対あるはず。Class::Accessor::Lvalue とかあるんじゃね？　と思ったら、やっぱりあった。速度比較とかしているこんなサイトも見つけた

• アクセサモジュールベンチ - Lvalue速っviaElementary,...

楽々アクセサ生成だけならどれでもできそうだが、今回の要件を満たすかどうかはわからないので、後日勉強するということで。つうか、lvalue やめればシンプルになりますな

header_type というメソッドを実装していた時のこと。

package CGI::Minimal::App;
sub header_type :lvalue {
  my $self = shift;
  $self->{__HEADER_TYPE};
}

これで

• $self->header_type('redirect');
• $self->header_type = 'redirect';

どちらの書き方でも setter として動作し、$self->header_type は getter にもなる。が、header_type に set できる値は制限したいので、

package CGI::Minimal::App;
sub header_type :lvalue {
  my $self = shift;
  my $type = shift;

  die 'Invalid header type: '.$type
    unless ( $type eq 'header' or $type eq 'redirect' );

  $self->{__HEADER_TYPE} = $type;

  $self->{__HEADER_TYPE};
}

というようなコードを書くと、

$self->header_type('dummy');

はエラーになるが

$self->header_type = 'dummy';

はエラーにならない

lvalue の時も validation のロジックを通したいので、しばし思案。結果、tie を使うことにした。動いてるけど。。。もっとスマートな実装方法はないものか

package CGI::Minimal::App;
sub header_type :lvalue {
  my $self = shift;
  my $header_type = shift;

  # First use? Create new __HEADER_TYPE!
  $self->{__HEADER_TYPE} = 'header' unless exists $self->{__HEADER_TYPE};

  # tie getter and setter to CGI::Minima::App::Magic (to validate)
  tie $self->{__HEADER_TYPE}, 'CGI::Minimal::App::Magic', $self,
    sub {
      my $self = shift;
      $self->{__HEADER_TYPE};
    },
    sub {
      my $self = shift;
      my $value = shift;

      # check allowed header
      die 'Invalid header type: '.$value
        unless ( grep {$_ eq lc($value)} ('header', 'redirect', 'not_found', 'not_modified', 'none') );
      $self->{__HEADER_TYPE} = lc($value);
    };

  $self->{__HEADER_TYPE} = $header_type if defined $header_type;
  $self->{__HEADER_TYPE};
}
1;

package CGI::Minimal::App::Magic;
sub TIESCALAR {
  my $class = shift;
  my $self = shift;
  my $getter = shift;
  my $setter = shift;

  $class = ref $class || $class || __PACKAGE__;
  bless({obj => $self, getter => $getter, setter => $setter}, $class);
}

sub FETCH {
  my $self = shift;
  $self->{getter}->($self->{obj});
}

sub STORE {
  my $self = shift;
  my $value = shift;

  $self->{setter}->($self->{obj}, $value);
}
1;

• 参考
  • Tie::Scalar
  • perltie