1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
# -*- cperl -*-
# -----------------------------------------------------------------------------
# $Id: HashTools.pm 11365 2008-05-10 14:58:28Z topia $
# -----------------------------------------------------------------------------
# copyright (C) 2003 Topia <topia@clovery.jp>. all rights reserved.
# ハッシュをフォーマットする関数群。
package Tools::HashTools;
sub get_value_random {
my ($hash, $key) = @_;
my $values = get_array($hash, $key);
if ($values) {
# 発見. どれか一つ選ぶ。
my $idx = int(rand() * hex('0xffffffff')) % @$values;
return $values->[$idx];
}
return undef;
}
sub get_value {
my ($hash, $key) = @_;
my $values = get_array($hash, $key);
if ($values) {
# 発見.
return $values->[0];
}
return undef;
}
sub get_array {
my ($hash, $key) = @_;
my $value = $hash->{$key};
if (defined $value) {
# 発見
if (ref($value) eq 'ARRAY') {
return $value;
} else {
return [$value];
}
last;
}
return undef;
}
sub replace_recursive {
# ()がネスト可能な_replace.
# ていうか ad hoc 過ぎる気がするなあ。良い解析方法無いかな。
my ($str,$hashtables,$callbacks) = @_;
return '' if !defined($str) || ($str eq '');
my $start = 0;
my $end;
my $pos;
while (($pos = $start = index($str, '#(', $start)) != -1) {
# 検索開始。
my $level = 1;
do {
# こっかを探す。
$end = index($str, ')', $pos + 1);
if ($end == -1) {
# こっかが無い。困ったことになったが、終わった後にこっかがあったことにして誤魔化そう。
$str .= ')';
$end = length($str);
last;
}
# かっこを探す。
my $next = index($str, '(', $pos + 2);
if ($next == -1 || $next > $end) {
# かっこが無かったか、こっかより後。階層レベルを減らして検索位置を次のこっかに移す。
$pos = $end;
$level--;
} else {
# こっかより前にかっこがあった。階層レベルを増やして繰り返す。
$pos = $next;
$level++;
}
} while ($level > 0); # 階層レベルが0になるまで繰り返し。
# こっかの前までを抽出範囲とする。
$end--;
#proc $start to $end
my $work = substr($str, $start + 2, $end - $start - 1);
$work = _replace($work,$hashtables,$callbacks);
substr($str, $start, $end - $start + 2) = $work;
$start = $start + length($work);
}
return $str;
}
sub _replace {
my ($str,$hashtables,$callbacks) = @_;
# variables := variable ( '|' variable )*
# variable := key ( ';' format )?
foreach my $variable (split /\|/,$str) {
my ($key, $format) = split(/;/,$variable,2);
my ($ret) = undef;
if (defined($key) && $key ne '') {
foreach my $table (@$hashtables) {
$ret = get_value($table, $key);
last if (defined $ret);
}
if (!defined $ret) {
# not found.
foreach my $callback (@$callbacks) {
if (defined $callback) {
# callback function definition: func($key, [hashtables], [callbacks]);
my $value = $callback->($key, $hashtables, $callbacks);
if (defined $value) {
$ret = $value;
last;
}
}
}
}
} else {
# callback等がエラーを吐くので強制的に''を入れる。
$ret = '';
}
if (defined $ret) {
if (defined $format) {
return _format($format,$ret,$hashtables,$callbacks);
} else {
return $ret;
}
}
}
# 最終的に見付からなければ$strそのものを返す。
return $str;
}
sub _format {
# %s形式の値をフォーマットする。
# replace_recursiveを呼び出して再帰変換も行う。
my ($str,$value,$hashtables,$callbacks) = @_;
$str = replace_recursive($str,$hashtables,$callbacks);
$str =~ s/%(.)/_format_percent($1, $value)/eg;
return $str;
}
sub _format_percent {
$char = shift;
if ($char eq 's') {
return $_[0];
} else {
return $char;
}
}
1;
|
