「先読み」と「後読み」の正規表現（lookahead assertion と lookbehind assertion）

「詳説 正規表現」で「先読み」、「後読み」と呼んでいる正規表現は英語でそれぞれ lookahead assertion, lookbehind assertion、まとめて lookaround assertion と呼ぶ。

$ echo 'Regex example:1234567890.' | perl -p -i -e 's/(?<=\d)(?=(\d{3})+(?!\d))/,/g'
Regex example:1,234,567,890.

参考

• regexp - (?=lookahead) and (?<=lookbehind) assertions

perl -0777 による slurping

Perlでファイルの内容を読み込む場合、普通は1行ずつ処理する。

もし1行ずつ処理する方法が適当でない思ったら、undef $/ することによってファイルの内容をスカラ変数に一気に代入することができる。tこれを"slurping"と呼ぶ。

undef $/;
$whole_file = ;               # 'slurp' mode

Slurping は Perlコマンド実行時のオプション '-0777' でも有効にできる。今日まで知らなかったけど、ワンライナーの場合にすごく便利。

$ cat foo.txt
foo
foo
foo
$ perl -0777 -pe 's/o\nf//g' foo.txt
foooo

'-0'に続く数値は400以上であれば何でもよいのだが、777と書くのが慣例になっているらしい。詳しいことは参考ページに書いてある。

参考

• Perl Slurp Ease
• [Chapter 8] File Contents
• perlrun - perldoc.perl.org

Perlの 'x' オペレータ（repetition operator）

たとえば Ruby や Python で "4444" という文字列を出力したいときは、'*'演算子を使って次のように書く。

$ ruby -e 'p "4" * 4'
"4444"

$ python -c 'print "4" * 4'
4444

一方、Perlの場合は'x'演算子（アルファベットのx）を使う。

$ perl -e 'print "4" x 4, "\n"'
4444

さらに、リストコンテキストで使った場合はリスト内の要素を複製できる。

perl -e '@a = (1, 2) x 4; print join (":", @a), "\n"'
1:2:1:2:1:2:1:2

ちなみに、この演算子は"perldoc perlop"によると"repetition operator"と呼ばれている。

参考

• python - How can I repeat a string in Perl? - Stack Overflow
• perlop - perldoc.perl.org

GCC最適化オプション（-O0, -O1, -O2, -O3, -funroll-loops）

「An Introduction to GCC」に載っていた例を実際に試してみた。

環境は CentOS-6.0 で、

• 2.6.32-71.29.1.el6.x86_64 GNU/Linux
• gcc (GCC) 4.4.4 20100726 (Red Hat 4.4.4-13)

やったこと

本に載っていた"test.c"をそのまま使い、-O0, -O1, -O2, -O3, -O3 -funroll-loops の5種類について実行ファイルのサイズとtimeコマンドの結果を求めた。

コンパイルと実行に使ったPerlスクリプトは以下のとおり。

#!/usr/bin/perl
#
# test.pl
#
@a = ('-Wall -O0', '-Wall -O1', '-Wall -O2', '-Wall -O3', '-Wall -O3 -funroll-loops');
for($i=0; $i <= $#a; $i++){
  print("\[$a[$i]\]\n");
  system("gcc $a[$i] test.c && size -B ./a.out && time ./a.out");
  print("\n\n");
}

ここで、実行ファイルのサイズを求めるにあたっては、ls -lではなくGNU Binutilsのsizeコマンドを使うようにした。sizeコマンドはELFファイルの中のセクションごとにサイズを調べてくれるので、.textセクションのサイズも分かる。すなわち最適化による命令の量の変化がより明らかになる。

結果

# ./test.pl > test.log 2>&1
# cat test.log
[-Wall -O0]
   text    data     bss     dec     hex filename
   1387     492      16    1895     767 ./a.out
sum = 4e+38

real 0m1.677s
user 0m1.263s
sys 0m0.002s


[-Wall -O1]
   text    data     bss     dec     hex filename
   1329     492      16    1837     72d ./a.out
sum = 4e+38

real 0m0.793s
user 0m0.735s
sys 0m0.003s


[-Wall -O2]
   text    data     bss     dec     hex filename
   1369     492      16    1877     755 ./a.out
sum = 4e+38

real 0m0.457s
user 0m0.442s
sys 0m0.005s


[-Wall -O3]
   text    data     bss     dec     hex filename
   1369     492      16    1877     755 ./a.out
sum = 4e+38

real 0m0.456s
user 0m0.444s
sys 0m0.003s


[-Wall -O3 -funroll-loops]
   text    data     bss     dec     hex filename
   1665     492      16    2173     87d ./a.out
sum = 4e+38

real 0m0.503s
user 0m0.493s
sys 0m0.002s

性能がよいのは-O2と-O3で、たぶん同じコード。funroll-loopsの最適化は今回の例では逆効果だった。

サイズを最も小さくできたのは-O1。

補足：-Osオプション

-Osオプションを使うとサイズの最適化を行うことができる。これも試した結果、確かにサイズが最も小さくなった。

[-Wall -Os]
   text    data     bss     dec     hex filename
   1289     492      16    1797     705 ./a.out
sum = 4e+38

real 0m0.575s
user 0m0.544s
sys 0m0.003s

-Wall -O1の場合と比較すると、.textセクションのサイズは40バイト減り、実行時間も0.2sくらい減っている。

参考

• An Introduction to GCC - Optimization examples
• GNU Binutils

コマンドを手軽にマルチプロセス実行 GNU Parallel

GNU Parallelというプログラムを今さら知ったのでメモしておく。これは、複数のプログラムを並行して実行したいときに便利。

インストール

GNU Parallelのダウンロードページから最新版の parallel-20110722.tar.bz2 をダウンロードし、configure, make, make install する。

$ wget ftp://ftp.gnu.org/gnu/parallel/parallel-20110722.tar.bz2
$ tar xvjf parallel-20110722.tar.bz2
$ cd parallel-20110722
$ ./configure
$ make
$ sudo make install

ちなみに環境は Darwin 10.8.0 x86_64。

試してみる

とりあえずPerlで簡単なプログラムを作って試す。

print_argv0.pl

#!/usr/bin/perl
sleep(1);
print "$ARGV[0]\n";
exit;

1秒間スリープして引数を表示するだけのもの。これにlsの結果を入力する処理を、prallelコマンド経由で実行してみる。

同時に実行するジョブ数 = 20 で実行した場合（-jオプション）

$ time ls|parallel -j 20 ./print_argv0.pl {}
COPYING
Makefile
Makefile.am
Makefile.in
NEWS
README
aclocal.m4
config.h
config.h.in
config.log
config.status
configure
configure.ac
install-sh
missing
print_argv0.pl
src
stamp-h1

real 0m1.396s
user 0m0.229s
sys 0m0.259s

1.396s で終了したので、確かに同時に実行されている様子。lsの結果が18行なので順番に実行すれば18秒はかかってしまうはず。

ジョブ数 = 1 で実行した場合

$ time ls|parallel -j 1 ./print_argv0.pl {}
COPYING
Makefile
Makefile.am
Makefile.in
NEWS
README
aclocal.m4
config.h
config.h.in
config.log
config.status
configure
configure.ac
install-sh
missing
print_argv0.pl
src
stamp-h1

real 0m18.517s
user 0m0.231s
sys 0m0.243s

19.517s かかった。

プロセス

ついでにプロセスの状態を調べるため、ジョブの数を3にして parallel をバックグラウンド実行した後、psコマンドを打ってみた。

$ time ls|parallel -j 3 ./print_argv0.pl {} &
[1] 5140
$ ps axl
  UID   PID  PPID CPU PRI NI      VSZ    RSS WCHAN  STAT   TT       TIME COMMAND
（略）
  501  5142  5140   0  29  0  2443672   8584 -      S      p0    0:00.18 /usr/bin/perl -w /usr/local/bin/parallel -j 3 ./print_argv0.pl {}
  501  5172  5142   0  30  0  2437344   1048 -      S      p0    0:00.01 /usr/bin/perl ./print_argv0.pl Makefile.in
  501  5173  5142   0  30  0  2437344   1048 -      S      p0    0:00.01 /usr/bin/perl ./print_argv0.pl NEWS
  501  5174  5142   0  31  0  2437344   1048 -      S      p0    0:00.01 /usr/bin/perl ./print_argv0.pl README
（略）

parallel自体もperlで書かれており、/usr/bin/perl -w により実行されている（プロセスID 5142）。中ではforkしているらしく、子プロセスが3つ生成されている（5172, 5173, 5174）。

参考

• GNU Parallel - build and execute command lines from standard input in parallel - 概要 [Savannah]
• いまさら findと xargsと parallelの便利さを主張してみる - ダイミテイ

文字列の1文字目だけ大文字にする関数

最近、Perlにucfirstという関数があると知ったので、記録しておく。

Perlの場合

ucfirst

$ perl -le 'print ucfirst("hello")'
Hello

PHPの場合

Perlと同じく、ucfirst

$ php -r 'echo ucfirst("hello");'
Hello

Emacs Lispの場合

upcase-initials

※Perl, PHPとは仕様が少し異なる。1文字目が空白だと読み飛ばし、最初のアルファベットを大文字にする。

(upcase-initials "hello")
"Hello"
(upcase-initials " hello")
" Hello"

Common Lispの場合

string-upcase

(string-upcase "hello" :start 0 :end 1)
"Hello"

参考

• CLHS: Function STRING-UPCASE, STRING-DOWNCASE...

順列を求めるプログラム（Perl、Elisp）

"Higher-Order Perl" という本を読む。順列を求めるプログラムが載っている。何かの役にたつかもしれないから覚えとこう、と思い実際に書いてみる。ついでにEmacs Lispでも書いてみる。

Perlで順列（permutation）を求める

Higher-Order Perl: - Google ブックス より、そのまま引用。

sub permute{
  my @items = @{ $_[0] };
  my @perms = @{ $_[1] };
  unless(@items){
    print "@perms\n";
  } else {
    my(@newitems, @newperms, $i);
    foreach $i (0 .. $#items) {
      @newitems = @items;
      @newperms = @perms;
      unshift(@newperms, splice(@newitems, $i, 1));
      permute([@newitems], [@newperms]);
    }
  }
}
# sample call:
permute([qw(red yellow blue green)], []);

"permute.pl"というファイルに保存し、実行してみる。

$ perl ./permute.pl
green blue yellow red
blue green yellow red
green yellow blue red
yellow green blue red
blue yellow green red
yellow blue green red
green blue red yellow
blue green red yellow
green red blue yellow
red green blue yellow
blue red green yellow
red blue green yellow
green yellow red blue
yellow green red blue
green red yellow blue
red green yellow blue
yellow red green blue
red yellow green blue
blue yellow red green
yellow blue red green
blue red yellow green
red blue yellow green
yellow red blue green
red yellow blue green

順序が反対になって出力されるのが気になるが（red yellow blue green が最初に出力されて欲しい）、これはunshiftをpushに変えれば済む話なのでよしとする。

Emacs Lispの場合

loopは使わずに、マップ関数で実現。

(defun permute (lat)
  (cond
   ((null lat) '(()))
   (t (mapcan
       (lambda (atm)
         (mapcar (lambda (lst) (cons atm lst))
                 (permute (remove* atm lat :count 1))))
       lat))))

Perlよりだいぶすっきり。しかし一つひとつの関数が濃い。

実行結果。

(permute '(red yellow blue green))
=> ((red yellow blue green) (red yellow green blue)
    (red blue yellow green) (red blue green yellow)
    (red green yellow blue) (red green blue yellow)
    (yellow red blue green) (yellow red green blue)
    (yellow blue red green) (yellow blue green red)
    (yellow green red blue) (yellow green blue red)
    (blue red yellow green) (blue red green yellow)
    (blue yellow red green) (blue yellow green red)
    (blue green red yellow) (blue green yellow red)
    (green red yellow blue) (green red blue yellow)
    (green yellow red blue) (green yellow blue red)
    (green blue red yellow) (green blue yellow red))

導出について

上記の関数を作るときの考え方を書いておく。

まず、具体的な計算例を想像して分析してみる。たとえば3要素のリスト (a b c) に対して期待される結果は ((a b c) (a c b) (b a c) (b c a) (c a b) (c b a)) となる。

このうち、最初の2つの部分リスト ((a b c) (a c b)) は、 a を リスト (b c) と (c b) に cons した形なので次式で表せる。

(mapcar (lambda (lst) (cons 'a lst)) '((b c) (c b)))

さらに、第二引数の((b c) (c b))は、(b c)の順列だから、(permute '(b c))と表せる。

(mapcar (lambda (lst) (cons 'a lst)) (permute '(b c)))

残り4つの部分リストも同様に(mapcar (lambda ...) (permute ...))の形で表し、これらを連結（nconc）する。

(nconc
 (mapcar (lambda (lst) (cons 'a lst)) (permute '(b c)))
 (mapcar (lambda (lst) (cons 'b lst)) (permute '(a c)))
 (mapcar (lambda (lst) (cons 'c lst)) (permute '(a b))))

同じようなコードの重複を無くすため、mapcanを使って変形する。

(mapcan
 (lambda (atm)
   (mapcar (lambda (lst) (cons atm lst))
           (permute (remove* atm '(a b c) :count 1))))
 '(a b c))

remove*は第1引数と等しい要素を第2引数からすべて削除する関数だが、キーワードパラメータとして :count 1 を指定すれば削除する個数を制限できる。

この段階で再帰的関数の主要部分ができたので、(a b c)を関数の引数 lat として defun に変換する。

(defun permute (lat)
  (cond
   ((null lat) ???)
   (t (mapcan
       (lambda (atm)
         (mapcar (lambda (lst) (cons atm lst))
                 (permute (remove* atm lat :count 1))))
       lat))))

あとは保留してある「???」の部分、すなわち再帰が終了する場合の式を考えれば完成。

そのため、要素1個のリスト (a) の順列を求める過程を具体的にトレースしてみる。

(permute '(a))
;; cond の t に対応する式
=> (mapcan
    (lambda (atm)
      (mapcar (lambda (lst) (cons atm lst))
              (permute (remove* atm '(a) :count 1))))
    '(a))
;; mapcan を評価して、atm を 'a に置換
=> (nconc
    (mapcar (lambda (lst) (cons 'a lst))
            (permute (remove* 'a '(a) :count 1))))
;; remove* と nconc を評価（引数が1個なので nconc は実質的に何もしない）
=> (mapcar (lambda (lst) (cons 'a lst))
            (permute nil))

ここまで展開すると、(a)の順列を求めた結果が ((a)) となるためには(permute nil) の結果が (()) であればよいということがきっと分かる。

(mapcar (lambda (lst) (cons 'a lst))
            '(()))
=> ((a))

よって、保留した部分も '(()) と書けばよい。これでようやく関数が完成。

(defun permute (lat)
  (cond
   ((null lat) '(()))
   (t (mapcan
       (lambda (atm)
         (mapcar (lambda (lst) (cons atm lst))
                 (permute (remove* atm lat :count 1))))
       lat))))

参考

• Higher-Order Perl: - Google ブックス

CGIの環境変数 SERVER_NAME と HTTP_HOST

ほかの誰かが作ったCGIを移行する仕事で、バグの原因になったので記録しておく。

症状

CGIで作成された、お問い合わせフォーム。このCGIが出力するHTMLは、head要素内のscript要素でJavaScriptファイルを参照し、ユーザーインターフェースを制御している。

www有りと無しの二通りのURLでアクセスが可能（http://www.example.com/form/ と http://example.com/form/）。しかし、www有りでアクセスした場合は、JavaScriptが正しく動作しない。

原因と対応

JavaScriptファイルのうち、動的に生成されるファイルにバグがあった。動的に生成される部分というのは XMLHTTPオブジェクトがアクセスするURLであり、環境変数SERVER_NAMEを使って生成されていた。次のように。

$url = "\/\/" . $ENV{'SERVER_NAME'} . $service_path . '?';
 $script =~ s/<url>/$url/g;  # $scriptの中身はJSのテンプレ。それを置換している。
 print "Pragma: no-cache\n";
 print "Cache-Control: no-cache\n";
 print "Content-type: text/plain; charset=UTF-8\n\n";
 print $script;

SERVER_NAMEの値はWebサーバーの設定に依存してしまうため、JavaScriptファイルを取得するときのリクエストが www.example.com なのに対して、XMLHTTPオブジェクトは example.com を参照してしまうという矛盾が生じた。これはクロスドメイン制限（cross-domain restrictions）に抵触、あるいは同一生成元ポリシー（same-origin policy）に反してしまう。よって、次のように修正すればOK。

$url = "\/\/" . $ENV{'HTTP_HOST'} . $service_path . '?';  # HTTP_HOST に変更
 $script =~ s/<url>/$url/g;
  （略）

SERVER_NAME と HTTP_HOST

CGIの環境変数のうち、SERVER_NAME と HTTP_HOST はよく似ていているのだが、意味が異なる。

これらの意味は、CGIに環境変数を渡しているApacheのドキュメントに書いてあるはずなのだが、いまいちみつからない。とりあえず、mod_rewriteの中に説明があったのでそこを引用しておく。

mod_rewrite - Apache HTTP Server

• HTTP headers:
  • （略）
  • HTTP_HOST
  • （略）
• server internals:
  • （略）
  • SERVER_NAME
  • （略）

These variables all correspond to the similarly named HTTP MIME-headers, C variables of the Apache server or struct tm fields of the Unix system. Most are documented elsewhere in the Manual or in the CGI specification.

SERVER_NAME and SERVER_PORT depend on the values of UseCanonicalName and UseCanonicalPhysicalPort respectively.

要するに、HTTP_HOSTのほうは"HTTP headers"、つまりブラウザからのリクエストヘッダに含まれるHOSTを表し、SERVER_NAMEのほうは"server interanals"、つまりApacheサーバー内の設定ファイル等に記述されているSERVER_NAMEを表すということ。したがって、HTTP_HOSTを扱うときはセキュリティ的に注意を要する、なんて話題も避けられない（変な文字列が送られてくる可能性があるから、内容をチェックしたりエスケープしたりする）。

このあたりの話は、Apacheから環境を引き継ぐプロセス全般に通用する話だから、PerlだけでなくPHPやRuby, Javaサーブレットなどを作るときにも頭に入っているとよいかもしれない。あと、mod_rewrite の条件を書く時にも。

参考

• HTTP access control - MDC Doc Center
• javascript - Cross domain script tag working in FF and Chrome but not IE - Stack Overflow
• mod_rewrite - Apache HTTP Server
• Apache Environmental Variables
• Chris Shiflett: SERVER_NAME Versus HTTP_HOST

setuid なスクリプト

シェルやPerlで書かれたスクリプトも、setuidプログラムのように動作して欲しいときがある。その場合にどうすればいいか、という話（セキュリティの問題があるため仕事ではほとんど役に立たない、教養レベルの話）。

いろいろと方法があるだろうけれど、ここではそのうちの2つ記録しておく。

その1. setuid(0)とsystem()を用いたラッパープログラム

setuid on shell scripts に書いてあるとおり、シェルやPerl等のスクリプトファイルの場合は、setuidビットをセットして実行しても無視される。そこで、ラッパーとしてELFの実行ファイルをC言語で作成してsetuidビットをセットするのだが、その内部でただ単にsystem(…)関数でスクリプトを実行するだけでは足りない。system(…)の前に、setuid(0)を実行しないといけない。

…
int main()
{
   setuid( 0 );
   system( "/path/to/script.sh" );

   return 0;
}
  

ここで、setuid(0)が必要となる理由は、"man 3 system", "man sh" を調べると分かる。

man 3 system:

DESCRIPTION system() executes a command specified in command by calling /bin/sh -c command, and returns after the command has been completed. During execution of the command, SIGCHLD will be blocked, and SIGINT and SIGQUIT will be ignored.

man sh:

If the shell is started with the effective user (group) id not equal to the real user (group) id, and the -p option is not supplied, no startup files are read, shell functions are not inherited from the environment, the SHELLOPTS variable, if it appears in the environment, is ignored, and the effective user id is set to the real user id. If the -p option is supplied at invocation, the startup behavior is the same, but the effective user id is not reset.

整理すると、system("/path/to/script.sh") は /bin/sh -c "/path/to/script.sh" に変換される。この/bin/shは、effective use id=root で real user id=一般ユーザーの状態で実行されるから、effective user id が一般ユーザーのidで上書きされ、結局はsetuidプログラムのクレデンシャル（credential）が失われてしまう、という流れ。

これを防ぐには、effective use id と real user id が一致した状態でsystem(…)を呼べばよいから、事前にsetuid(0)を呼ぶことになる（setuid(0)により、effective use id と real use id の両方に 0 つまりrootが設定される）。

※UNIXプロセスのクレデンシャル関係の用語は、邦訳が揺らいでいて曖昧なので英語のままがいい。ちなみに、手元にある「Amazon.co.jp： 詳解UNIXプログラミング: W.リチャード スティーヴンス, W.Richard Stevens, 大木 敦雄: 本」では"real user id"が「実ユーザID」、"effective user id"が「実効ユーザID」と訳されている。

その2. execve() を用いたラッパープログラム

ここから別解。system()とsetuid(0)の使用をやめて、exec()系のexecve()を用いる方法。

なぜexecve()を使うかと言えば、man 3 systemおよび「IPA ISEC　セキュア・プログラミング講座：C/C++言語編　第10章 著名な脆弱性対策：コマンド注入攻撃対策」で推奨されているから。要するに、スクリプトに引き継がれる環境変数を制御できるから。

man 3 system

Do not use system() from a program with set-user-ID or set-group-ID privileges, because strange values for some environment variables might be used to subvert system integrity. Use the exec(3) family of functions instead, but not execlp(3) or execvp(3).

IPA ISEC セキュア・プログラミング講座より引用:

これらのうち使用を推奨するのは、 execle execve execvP の3つである。なぜならば、環境変数 PATH が改ざんされていても影響を受けず、起動するプログラムに与える環境変数を制御できるからである。

同時に、実行される側、スクリプトのほうにも一工夫必要となる。具体的には、man shに記載のとおり、shebang行に-pオプション（ Turn on privileged mode）を加えて、子プロセスの effective user id の変更を防ぐ。

man sh:

-p Turn on privileged mode. In this mode, the $ENV and $BASH_ENV files are not processed, shell functions are not inherited from the environment, and the SHELLOPTS variable, if it appears in the environment, is ignored. If the shell is started with the effective user (group) id not equal to the real user (group) id, and the -p option is not supplied, these actions are taken and the effective user id is set to the real user id. If the -p option is supplied at startup, the effective user id is not reset. Turning this option off causes the effective user and group ids to be set to the real user and group ids.

以上をまとめると、次のようなコードになる。

execve()を使った場合のコード（C）

fork()してexecve()する流れ。コンパイル後、chmod で所有者root の 4755 に変更しておく。

/* setuid_test.c */
#include <stdio.h>
#include <stdlib.h>
#include <sys/types.h>
#include <unistd.h>
#include <signal.h>
int main(int argc, char *argv[]){
  int pid;
  if((pid=fork()) < 0){
    return 1;
  }else if(pid > 0){
    wait(NULL);
  }else{
    if(execve("/path/to/script.sh", NULL, NULL) == -1){
      return 1;
    }
    return 0;
  }
  return 0;
}
    

スクリプトのコード（shebang行の -p が必要）

スクリプトのほうは chmod で所有者が一般ユーザーの 744 にしておく。

#!/bin/bash -p
tail /var/log/maillog;  # rootだけが読み込めるログを表示してみる
    

実行例

以下のような感じ（CentOS5で確認）。

$ ./setuid_test
Jan 16 10:11:16 example postfix/smtp[9884]: D446F10C4F9B: host mx.example.com[999.999.999.999] refused to talk to me: 421 Message from (999.999.999.999) temporarily deferred - …
Jan 16 10:11:17 example postfix/smtp[9884]: D446F10C4F9B: host mx.example.com[999.999.999.999] refused to talk to me: 421 Message from (999.999.999.999) temporarily deferred - …
…
    

ちなみに、shebang行の-pを消して実行した場合、execve("/path/to/script.sh", NULL, NULL)の後にsetuid(x)とsetgid(x)が勝手に実行されて、setuidプログラムのクレデンシャルが失われることが分かる（ここで、x は一般ユーザーのID）。以下は、その現象を strace で記録したもの。

$ id
uid=505(testuser) gid=505(testuser) groups=505(testuser)
$ strace -f -o strace.txt ./setuid_test
$ cat strace.txt
…略…
25971 execve("/path/to/script.sh", [0], [/* 0 vars */]) = 0
…略…
25971 getuid()                          = 505
25971 getgid()                          = 505
25971 geteuid()                         = 0
25971 getegid()                         = 505
25971 rt_sigprocmask(SIG_BLOCK, NULL, [], 8) = 0
25971 setuid(505)                       = 0
25971 setgid(505)                       = 0
25971 open("/proc/meminfo", O_RDONLY)   = 3
…略…
    

参考

• setuid on shell scripts
• IPA ISEC　セキュア・プログラミング講座：C/C++言語編　第10章 著名な脆弱性対策：コマンド注入攻撃対策
• Amazon.co.jp： 詳解UNIXプログラミング: W.リチャード スティーヴンス, W.Richard Stevens, 大木 敦雄: 本
• The #! magic, details about the shebang/hash-bang mechanism

PerlによるプログレッシブJPEGとベースラインJPEGの判別

JPEGファイルは、プログレッシブJPEGとベースラインJPEGに分類される（参考：Baseline JPEG and Progressive JPEG?）。

Webサイトで使用する画像の場合、プログレッシブのほうを採用するのが現在は一般的だと思われるが、携帯サイトの場合は事情が異なる。というのは、携帯電話の中にプログレッシブ非対応の機種があるため。

よって、この違いに意識的でないと、携帯サイトのテスト工程で「ある機種で写真が表示されません」ということが起こる。こうした状況、つまり「サーバーにあるプログレッシブJPEGを洗い出したい」場合に、Perlの Image::Info が使える（もちろん Perl以外の選択肢もある。参考：プログレッシブJPEGやCMYKモードのJPEGをUnix環境で判別（判定） | はやとも　-hayatomo.com-）

Image::Info インストール

CentOS5の場合、CPANシェルでインストールできた。

# perl -MCPAN -e shell
insatll Image::Info

Baseline／Progressive判別スクリプト

JPEGファイルのパスを引数として、単純に「ファイルパス: Baseline」「ファイルパス: Progressive」と出力するだけのプログラム。

#!/usr/bin/perl
use strict;
use warnings;
use Image::Info "image_info";

my $info = image_info($ARGV[0]);
print "$ARGV[0]: $info->{'JPEG_Type'}\n";

実行例

findでjpgを抽出してスクリプトに渡す（スクリプトは "./info_jpeg.pl" に置いてある）。

$ find /foo/bar/images/ -name '*jpg' -exec ./info_jpeg.pl {} \;
/foo/bar/images/pic01.jpg: Baseline
/foo/bar/images/pic02.jpg: Progressive
/foo/bar/images/pic03.jpg: Baseline

参考

• Baseline JPEG and Progressive JPEG?
• Image::Info - search.cpan.org
• プログレッシブJPEGやCMYKモードのJPEGをUnix環境で判別（判定） | はやとも　-hayatomo.com-

補足

Image::Info の image_info メソッドによって得られる連想配列の中身。ここで、「JPEG_Type」がBaseline/Progressiveを表す。

 $VAR1 = {
          'width' => 240,
          'file_media_type' => 'image/jpeg',
          'file_ext' => 'jpg',
          'color_type' => 'YCbCr',
          'AdobeTransformVersion' => 100,
          'ColorComponents' => [
                                 [
                                   'Y',
                                   34,
                                   0
                                 ],
                                 [
                                   'Cb',
                                   17,
                                   1
                                 ],
                                 [
                                   'Cr',
                                   17,
                                   1
                                 ]
                               ],
          'ColorComponentsDecoded' => [
                                        {
                                          'ComponentIdentifier' => 'Y',
                                          'HorizontalSamplingFactor' => 2,
                                          'VerticalSamplingFactor' => 2,
                                          'QuantizationTableDesignator' => 0
                                        },
                                        {
                                          'ComponentIdentifier' => 'Cb',
                                          'HorizontalSamplingFactor' => 1,
                                          'VerticalSamplingFactor' => 1,
                                          'QuantizationTableDesignator' => 1
                                        },
                                        {
                                          'ComponentIdentifier' => 'Cr',
                                          'HorizontalSamplingFactor' => 1,
                                          'VerticalSamplingFactor' => 1,
                                          'QuantizationTableDesignator' => 1
                                        }
                                      ],
          'BitsPerSample' => [
                               8,
                               8,
                               8
                             ],
          'SamplesPerPixel' => 3,
          'JFIF_Version' => '1.02',
          'App12-Ducky' => '2',
          'AdobeTransformFlags' => [
                                     49152,
                                     0
                                   ],
          'AdobeTransform' => 1,
          'height' => 180,
          'resolution' => '100/100',
          'JPEG_Type' => 'Baseline'
        };

SWFのメタデータ（幅や高さ等）を調べるPerlモジュール

以前書いた Technical Memorandum: FLVのメタデータ（動画の幅や高さ等）を調べるPerlモジュール と同じような内容…

SWFの場合は、CPANにある「SWF::Header」を使う。

プログラム例

#!/usr/bin/perl
# swfinfo.pl
# 引数で指定されたSWFファイルのメタデータを出力する
# 前提：SWF::Headerがインストールしてあること（CPANにある）
use SWF::Header;
use Data::Dumper;
my $h = SWF::Header->read_file($ARGV[0]);
print Dumper($h);

実行例

$ perl ./swfinfo.pl ./foo.swf
$VAR1 = {
          'width' => 940,
          'count' => 50,
          'version' => 9,
          'background' => '#000000',
          'duration' => '4.16666666666667',
          'height' => 200,
          'xmin' => 0,
          'rate' => 12,
          'ymax' => 4000,
          'signature' => 'CWS',
          'filelen' => 124058,
          'ymin' => 0,
          'xmax' => 18800
        };

参考

• SWF::Header - search.cpan.org

FLVのメタデータ（動画の幅や高さ等）を調べるPerlモジュール

仕事では、FLVファイルをサイトに掲載してください、という類の要求がしばしばある。

大抵の場合、FLVファイルだけポンと渡されるので、実際にFLVを掲載するために必要な「幅」「高」さといった情報はもらえないことが多い。そのくらいメールに付記して欲しいと思う反面、渡す側の人間にすればそんな細かい情報が要るとは見当がつかないだろうから、この現象は仕方がないということで自ら調べることになる。

Perlを利用する場合は、「FLV::Info」というモジュールで簡単に調べられる。なお、インストールはCPANシェルから特に問題なく行うことができた（CentOS5.3での話）。

メタ情報出力プログラム例

#!/usr/bin/perl
# flvinfo.pl
# 引数で指定されたFLVファイルのメタデータを出力する
# 前提：FLV::Infoがインストールしてあること（CPANにある）
use FLV::Info;
my $reader = FLV::Info->new();
$reader->parse($ARGV[0]);
my %info = $reader->get_info();
print "$info{video_count} video frames\n";
print $reader->report();

実行例

$ perl ./flvinfo.pl foo.flv
748 video frames
File name          foo.flv
File size          1082585 bytes
Duration           about 24.925 seconds
Video              748 frames
  codec            Sorenson H.263
  height           240
  type             interframe/keyframe
  width            320
Audio              954 packets
  format           MP3
  rate             44100 Hz
  size             16 bit
  type             stereo
Meta               1 event
  audiocodecid     2
  audiosamplerate  44100
  audiosamplesize  16
  duration         24.958
  filesize         1082585
  framerate        29.97002997003
  height           240
  stereo           1
  videocodecid     2
  width            320

参考

• FLV::Info - search.cpan.org

再帰によるべき乗（累乗）の計算をいくつか

再帰によりxのn乗を求める。すごく初歩的な問題だと思うが、あらためて。

n回再帰

(defun power (x n) "X to the Nth power"
  (if (<= n 0)
      1
    (* x (power x (- n 1)))))
power
(power 2 8)
=> 256

別解その1: 2乗を利用して再帰呼び出し回数を減らす

(defun power (x n)
  (cond
   ((<= n 1) x)
   ; nが偶数の場合にnを半減させる
   ((evenp n) (funcall (lambda (x) (* x x)) (power x (/ n 2))))
   (t (* x (power x (- n 1))) )))

別解その2: さらに再帰呼び出しを減らす（Perlで書いてるけど）

sub pow3{
    my ($x, $n) = @_;
    if($n < 1){
        1;
    }elsif($n % 2 == 0){
        (sub { my $x=shift; return $x*$x; })->( pow3($x, $n / 2) );2
    }else{
        # nが奇数の場合
        $x * (sub { my $x=shift; return $x*$x; })->( pow3($x, ($n - 1) / 2) );
    }
}

たいていの人は最初の解法で満足するだろう。が、"Paradigms of Artificial Intelligence Programming" という本には2番目の解法が載っていた。すごい人は些細な問題に対してもこだわりが違うのだな、と。

Perlのプロファイラ Devel::DProf

シンプルなプロファイラ。標準モジュールなので、すぐに使える。

$ perl -d:DProf ./p.pl  ;; あるいはシェバング行に追加してもよい（#!/usr/local/bin/perl -d:DProf）

$ dprofpp
Total Elapsed Time =   0.0096 Seconds
  User+System Time =        0 Seconds
Exclusive Times
%Time ExclSec CumulS #Calls sec/call Csec/c  Name
 0.00       - -0.000      1        -      -  strict::import
 0.00       - -0.000      1        -      -  strict::bits
 0.00       - -0.000      1        -      -  warnings::BEGIN
 0.00       - -0.000      1        -      -  warnings::import
 0.00       - -0.000      2        -      -  main::BEGIN
 0.00       - -0.000     11        -      -  main::__ANON__
 0.00       - -0.000      7        -      -  main::pow3
 0.00       - -0.000     12        -      -  main::pow2
 0.00       - -0.000     64        -      -  main::pow

参考

Devel::DProf

XML::Parserが動かない問題でハマる

PerlでXMLをあつかう場合、XML::Simpleを仲介者としてXML::Parserを利用していた。しかしサーバーによってはXML::Parserがインストールされていない＆インストールできないので、エラーになってしまう。

  # xmlを読み込む
  $XML::Simple::PREFERRED_PARSER = 'XML::Parser';  # この行をコメントアウトすると動いたが、UTF8フラグ関係の動きが変わってしまって文字化け。具体的にどのモジュールがParseを行っているのか不明なのでどこをどうすればいいのやら（プロファイルをとればわかるだろう）
  my $xmlobj = XMLin($res->content);

しかたなく binmode STDOUT, ":utf8"; を取ったら日本語も化けなくなった（今のところ謎）。

perl: warning: Setting locale failed.

Perlコマンド実行で警告が出る場合、以下のように環境変数を設定する。

$ export PERL_BADLANG=0

参考

perl: warning: Setting locale failed.が出るときの対処。

Perlメールの文字化け

Encode::encode()でjis変換すると化ける文字がある。

そういうときはtrで強引にやる。

for my $key (keys %values) {
    #YEN SIGN, WAVE DASH, MINUS SIGN
    $values{$key} =~ tr/\x{00a5}\x{ff5e}\x{ff0d}/\x{005c}\x{301c}\x{2212}/;
}
...
$body = makemailbody($template, \%values);
$body = Encode::encode('jis', $body);

MTにPerlモジュールを追加したいとき

参考：mtプラグインにおける Perl モジュール の配置 について - 左脳Script

CPANを使えない環境での話。
/インストールディレクトリ/lib/ に置くと動作するらしい。
Digest::SHA::PurePerl なら、/インストールディレクトリ/lib/Digest/SHA/

今回はとりあえず、バックアップ／復元に使う、
* Archive::Tar
* Archive::Zip
* IO::Compress::Gzip
* IO::Uncompress::Gunzip
が使えればOK.

[HOP] partition problemのコード

単独のreturnが参考になった。

use strict;
use warnings;
use Data::Dumper;

sub partition{
    my ($target, $treasures) = @_;

    return [] if $target == 0;     #anon. array ref
    return () if $target < 0 || @$treasures <= 0; # empty list
    # ここはPerlの作法に詳しくないと謎。
    # 一般的に、エラーケースではempty listを返すのが普通。
    # 空リストを明示的に書かずに、単独のreturnでよいかもしれない
    # （呼び出し元がリストコンテキストなら空リストになるから）

    my ($first, @rest) = @$treasures;
    my @solutions = partition($target - $first, \@rest);
    return ((map {[$first, @$_]} @solutions), partition($target, \@rest));
    # この文も実は難しい。mapの結果は、@solutionsがarray refならリスト、
    # empty listなら空リストになる性質がある。
}

print Dumper(partition(5, [1,2,3,4]));

クローラーの邪魔をしたい場合

.htaccess

BrowserMatchNoCase Googlebot     robot
BrowserMatchNoCase Slurp         robot
BrowserMatchNoCase msnbot        robot
BrowserMatchNoCase proodleBot    robot
BrowserMatchNoCase psbot         robot
BrowserMatchNoCase ScSpider      robot
BrowserMatchNoCase TutorGigBot   robot
BrowserMatchNoCase YottaShopping robot
BrowserMatchNoCase Faxobot       robot
BrowserMatchNoCase Gigabot       robot
BrowserMatchNoCase MJ12bot       robot
BrowserMatchNoCase Baidu         robot
deny from env=robot

確認（Perlモジュールを使う）

$ lwp-request -mHEAD -H 'User-Agent: slurp' http://sample.com/img/1.jpg
$ lwp-request -mHEAD -H 'User-Agent: slurp' http://user:password@testserver.com/img/1.jpg