バグだらけのPerlサンプルコード

2012-04-04

Perl

(

)

最近ハマったバグを無理矢理詰め込んだスクリプトを書いてみました。

バグだらけのスクリプト

例えば次のようなオブジェクトを与えられた上で

my $cfgs = [
    {
        date => '2012-03-26',
        cmd  => "bash -c 'echo error >&2; exit 255'",
    },
    {
        date => '2012-03-27',
        msg  => 'message from msg',
    },
    {
        date => '2012-03-28',
        cmd  => 'echo message from cmd',
    },
   ];

2012/3/29 に実行すると次のような結果が得られるスクリプトを作成することを考えます。

$ perl script.pl 2012-03-28; echo "exit code: $?"  # date が '2012-03-28' は invalid で die (exit code 1)
date: 2012-03-28
Error: invalid!
exit code: 1
$ perl script.pl; echo "exit code: $?"  # オプションがなければ date は実行日の前日（2012-03-28）
date: 2012-03-28
Error: invalid!
exit code: 1
$ perl script.pl 2012-03-27; echo "exit code: $?"  # 指定した日付に msg が定義されていれば表示 ＆ cmd が定義されていなければ invalid (exit code 1)
date: 2012-03-27
msg: message from msg
Error: invalid!
exit code: 1
$ perl script.pl 2012-03-26; echo "exit code: $?"  # 指定した日付の cmd を実行して失敗した場合はその exit code で終了
date: 2012-03-26
error
Error: command failed: bash -c 'echo error >&2; exit 255'
exit code: 255
$ perl script.pl 2012-03-25; echo "exit code: $?"  # 範囲外の日付をが指定されると die (exit code 1)
date: 2012-03-25
Error: cfg object on 2012-03-25 not found!
exit code: 1

無理矢理バグを詰め込んでるんで、気持ち悪い書き方になっていますが、次のようなスクリプトを作成しました。
しかしこれには4つのバグが含まれているため、意図した挙動にはなりません。どこがバグかわかりますか？

#!/usr/bin/env perl
# buggy.pl
use strict;
use warnings;
use Time::Piece;
use Time::Seconds;

my $cfgs = [
    {
        date => '2012-03-26',
        cmd  => "bash -c 'echo error >&2; exit 255'",
    },
    {
        date => '2012-03-27',
        msg  => 'message from msg',
    },
    {
        date => '2012-03-28',
        cmd  => 'echo message from cmd',
    },
   ];

sub get_cfg {
    my ($cfgs, $date) = @_;
    my $cfg;
    foreach my $tmp_cfg (@$cfgs) {
        if ($tmp_cfg->{date} eq $date) {
            $cfg = $tmp_cfg;
            last;
        }
    }
    print "msg: $cfg->{msg}\n" if $cfg->{msg};

    return $cfg;
}

sub main {
    my $date = shift || (localtime - ONE_DAY)->date;
    print "date: $date\n";
    my $cfg = get_cfg($cfgs, $date) or die "cfg object on $date not found!\n";
    die "invalid!\n" if not defined $cfg->{cmd} || $date eq '2012-03-28';
    system($cfg->{cmd}) && die "command failed: $cfg->{cmd}\n";

    print "done\n";
}

eval {
    main(@ARGV);
};
if ($@) {
    print "Error: $@";
    exit $? >> 8 || 1;
}

意図した仕様は次のような感じです。

コマンドラインオプションとして yyyy-mm-dd 形式の日付を指定できる（指定がなければ昨日の日付が使われる）
$cfgs は date, cmd, msg などをキーに持つハッシュのリファレンスを要素とする配列のリファレンス
指定した日付に対応する date を持つ $cfgs の要素に対して msg を表示したり、cmd を実行したりする
get_cfg 関数は $cfgs, $date を引数に持ち、$cfgs から date が $date と一致する要素（$cfg）を返す（一致するものがなければ undef を返す）。その際、msg が定義されていれば出力する
get_cfg の結果（$cfg）が undef の場合は die (exit code 1)
get_cfg により得たオブジェクトが cmd を持たない、または $date が 2012-03-28 であれば die（exit code 1）
system の返り値が 0 でなければ die（exit code はコマンドの exit code）

ところが、実際は次のような結果になります。

$ perl buggy.pl 2012-03-28; echo "exit code: $?"  # 日付が 2012-03-28 なのにコマンドが実行され、正常終了する
date: 2012-03-28
message from cmd
done
exit code: 0
$ perl buggy.pl; echo "exit code: $?"  # 日付がおかしい（2012-03-28じゃない）
date: 1969-12-31
Error: invalid!
exit code: 0
$ perl buggy.pl 2012-03-27; echo "exit code: $?"  # exit code が 0（1じゃない）
date: 2012-03-27
msg: message from msg
Error: invalid!
exit code: 0
$ perl buggy.pl 2012-03-26; echo "exit code: $?"  # これは問題ない
date: 2012-03-26
error
Error: command failed: bash -c 'echo error >&2; exit 255'
exit code: 255
$ perl buggy.pl 2012-03-25; echo "exit code: $?"  # エラーメッセージがおかしい（"cfg object on 2012-03-25 not found!" じゃない） ＆ exit code が 0
date: 2012-03-25
Error: invalid!
exit code: 0

解説

どこが問題かわかりましたかね？
というわけで答え合わせです。

#!/usr/bin/env perl
# buggy_fixed.pl
use strict;
use warnings;
use Time::Piece;
use Time::Seconds;

my $cfgs = [
    {
        date => '2012-03-26',
        cmd  => "bash -c 'echo error >&2; exit 255'",
    },
    {
        date => '2012-03-27',
        msg  => 'message from msg',
    },
    {
        date => '2012-03-28',
        cmd  => 'echo message from cmd',
    },
   ];

sub get_cfg {
    my ($cfgs, $date) = @_;
    my $cfg;
    foreach my $tmp_cfg (@$cfgs) {
        if ($tmp_cfg->{date} eq $date) {
            $cfg = $tmp_cfg;
            last;
        }
    }
    # $cfg が undef の場合に $cfg->{msg} を評価すると $cfg が empty hash のリファレンスになる（つまり not undef）
    #print "msg: $cfg->{msg}\n" if $cfg->{msg};
    print "msg: $cfg->{msg}\n" if $cfg && $cfg->{msg};

    return $cfg;
}

sub main {
    # 組み込み関数、モジュールの関数、事前に宣言された関数は括弧が省略できるため
    # localtime - ONE_DAY は localtime( - ONE_DAY ) を意味する
    #my $date = shift || (localtime - ONE_DAY)->date;
    my $date = shift || (localtime() - ONE_DAY)->date;
    print "date: $date\n";
    my $cfg = get_cfg($cfgs, $date) or die "cfg object on $date not found!\n";
    # not は || よりも優先順位が低いので not (defined $cfg->{cmd} || $date eq '2012-03-28') になっていた
    #die "invalid!\n" if not defined $cfg->{cmd} || $date eq '2012-03-28';
    die "invalid!\n" if ! defined $cfg->{cmd} || $date eq '2012-03-28';
    system($cfg->{cmd}) && die "command failed: $cfg->{cmd}\n";

    print "done\n";
}

eval {
    main(@ARGV);
};
if ($@) {
    print "Error: $@";
    # exit ($ >> 8) || 1 になっていた
    #exit $ >> 8 || 1
    exit ($? >> 8 || 1);
}

「if not defined はこう書いた方が英語っぽくてわかりやすいかなぁと思ってこうしてます」みたいなことがとある本に書いてあったので、「たしかに！！」と思ってよく使ってたんですが常に not じゃなくて ! を使った方が良いかもしれません。
localtime - ONE_DAY の挙動については id:gfx さんに教えてもらいました。
プロトタイプを使って引数のない関数と明示すれば後続の処理は引数とみなされないらしいです。

#!/usr/bin/env perl
# sample.pl
use strict;
use warnings;
use feature qw(say);

# プロトタイプなし
sub one {
    return 1;
}

# プロトタイプを使って引数がないことを明示
sub two () {
    return 2;
}

say 'one + 1: ', one + 1;
say 'two + 1: ', two + 1;

これを実行してみると、

$ perl sample.pl
one + 1: 1
two + 1: 3

確かに one + 1 は one( + 1) 、two + 1 は two() + 1 となっていることが確認できますね！

そんなわけで、ちょっと Perl に慣れてきたかなぁと思ってきたところで痛い目に会いましたというお話でした。