File Coverage

File:lib/OpenAPI/Handler/Captcha.pm
Coverage:84.5%

linestmtbrancondsubpodtimecode
1package OpenAPI;
2
3#use Smart::Comments;
4
22
22
22
22
190
69
228
use strict;
5
22
22
22
22
274
78
198
use warnings;
6
7
22
22
22
22
270
71
222
use vars qw( $UUID $Cache );
8
22
22
22
22
306
96
282
use GD::SecurityImage;
9
22
22
22
22
9476
88
254
use utf8;
10
22
22
22
22
255
70
379
use Encode 'encode';
11
12my @CnWordList = qw(
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
89my @WordList = qw(
90    about afraid after again against
91    agree almost along angry another
92    answers arms around away back
93    ball basket become begin better
94    boat boating books booth born
95    both boxes boys bread brush
96    burn buses busy cake call
97    camping capital care careful carry
98    cars catch centre cheaper chess
99    china cinema city class clean
100    clever coat cold college comb
101    come country course cups dark
102    days decide declare deed deliver
103    develop dinner dirty doctor doing
104    door down dress drive each
105    early east eight eleven enjoy
106    evening every exam excited excuse
107    fall family famous fast faster
108    father feel fever fifty film
109    fine finish first fish fishing
110    five floor food foot forty
111    four friend friends from front
112    full funny future games give
113    glad goal good goodbye grade
114    ground grow hair half hand
115    hands happen hard have head
116    healthy hear heavily help here
117    high hill history hold hole
118    home hour hours house hundred
119    hungry hurry hurt idea instead
120    into invite jump just keep
121    kind kinds knock know ladder
122    lake largest last late learn
123    leave left lesson lessons letter
124    letters life lights like listen
125    little live long longer look
126    lunch machine make many market
127    match matter meals medical meeting
128    message middle million minute model
129    modern moment money month more
130    morning most move much music
131    name near nearly need news
132    next nice night nine north
133    number office once oneself only
134    open other over pair papers
135    parents parking party pass past
136    people piano pick piece place
137    plane plant play player plenty
138    points post prepare primary promise
139    pulling quarter quick quietly race
140    rain read ready rest result
141    return right road room roses
142    round rules rush school scoot
143    send seven several ship shirt
144    shoes shoot short show shower
145    side sides signs singing sixty
146    skate skating slim slow slowly
147    smile snowman some soon sorry
148    south spare speak sports square
149    squares stamps stand start station
150    stay stop store story street
151    student studies study such summer
152    supper table take talk tall
153    teach teacher team teeth tell
154    test thank that them then
155    there these thin thing things
156    think thirty this three through
157    ticket time times today traffic
158    train tree trees trip trouble
159    turn twenty twice under until
160    very view visit voice wait
161    wake walk wall want wash
162    washing watch ways wear week
163    weeks welcome well west what
164    when window winter wish with
165    word work world worried write
166    wrong year your hello moon
167);
168
169# Create a normal image
170sub GET_captcha_column {
171
9
9
0
53
    my ($self, $bits) = @_;
172
9
52
    my $col = $bits->[1];
173
9
50
68
    if ($col eq 'id') {
174
9
59
        my $captcha_from_cookie = $self->{_captcha_from_cookie};
175
9
100
58
        if ($captcha_from_cookie) {
176
8
87
            $OpenAPI::Cache->remove($captcha_from_cookie);
177        }
178
179
9
1331
        my $id = $UUID->create_str;
180
9
85
        $Cache->set($id => 1);
181
182
9
2019
        $self->{_cookie} = { captcha => $id };
183
9
90
        return $id;
184    } else {
185
0
0
        die "Unknown captcha column: $col\n";
186    }
187}
188
189sub GET_captcha_value {
190
15
15
0
98
    my ($self, $bits) = @_;
191
15
87
    my $col = $bits->[1];
192
15
82
    my $value = $bits->[2];
193
194
15
62
    my $ext = 'gif';
195
15
100
142
    if ($value =~ s/\.(gif|jpg|png|jpeg)$//g) {
196
6
40
        $ext = $1;
197
6
0
50
49
0
        if ($ext eq 'jpg') { $ext = 'jpeg' }
198    }
199
15
50
98
    if ($col eq 'id') {
200
15
1150
        my $id = $value;
201
15
152
        my $solution = $Cache->get($id);
202
15
100
568
        if (defined $solution) {
203
12
100
124
            my $lang = lc($self->{_cgi}->url_param('lang')) || 'en';
204
12
100
100
117
            if ($lang eq 'cn') {
205            #if ($solution eq '1') { # new ID, no solution yet
206
4
31
                $solution = $self->gen_cn_solution;
207
4
32
                $self->gen_cn_image($solution);
208            } elsif ($lang eq 'en') {
209
7
46
                $solution = $self->gen_en_solution;
210
7
61
                $self->gen_en_image($solution);
211            } else {
212
1
4
                die "Unsupported lang (only cn and en allowed): $lang\n";
213            }
214
11
523
            $Cache->set($id => $solution);
215
11
2561
            return;
216        } else {
217
3
11
            die "Invalid captcha ID: $id\n";
218        }
219    } else {
220
0
0
        die "Unknown captcha column: $col\n";
221    }
222}
223
224sub gen_en_solution {
225
7
7
0
42
    my ($self) = @_;
226
7
28
    my $str = '';
227
7
38
    my $list = \@WordList;
228
7
40
    my ($i, $j) = (0, 0);
229
7
50
    while ($i < 2) {
230
14
50
81
        last if $j > 100;
231
14
125
        my $rand = int rand scalar(@$list);
232
14
55
        my $saved_str = $str;
233
14
101
        $str .= $list->[$rand] . " ";
234
14
55
        my $len = length($str);
235
14
50
80
        if ($len >= 15) {
236
0
0
            $str = $saved_str;
237
0
0
            $j++;
238
0
0
            next;
239        }
240
14
106
        $i++;
241    }
242
7
47
    $str;
243    # XXX debug only
244}
245
246sub gen_cn_solution {
247
4
4
0
28
    my ($self) = @_;
248
4
19
    my $str = '';
249
4
23
    my $list = \@CnWordList;
250
4
29
    my ($i, $j) = (0, 0);
251
4
36
    while ($i < 2) {
252
7
50
48
        last if $j > 100;
253
7
54
        my $rand = int rand scalar(@$list);
254
7
33
        my $saved_str = $str;
255
7
50
        $str .= $list->[$rand];
256
7
44
        my $len = length($str);
257
7
100
50
        last if $len == 3;
258
6
50
42
        if ($len >= 5) {
259
0
0
            $str = $saved_str;
260
0
0
            $j++;
261
0
0
            next;
262        }
263
6
58
        $i++;
264    }
265
4
33
    $str;
266    # XXX debug only
267}
268
269sub gen_cn_image {
270
4
4
0
28
    my ($self, $str) = @_;
271
4
26
    my $angle = int rand 4;
272
4
92
    my $captcha = GD::SecurityImage->new(
273        width => 100,
274        height => 37,
275        lines => 2 + int rand 2,
276        font => "$FindBin::Bin/../font/wqy-zenhei.ttf",
277        #thickness => 0.5,
278        rndmax => 3,
279        angle => $angle,
280        ptsize => 15,
281        #send_ctobg => 1,
282        #scramble => 1,
283    );
284
285    #warn $str;
286
4
4226
    $captcha->random($str);
287
4
221
    $captcha->create(ttf => 'default');
288
4
50
3411
    die "Failed to load ttf font for GD: $@\n" if $captcha->gdbox_empty;
289
4
90
    $captcha->particle(300); # : 1732);
290
4
133700
    my ($image_data, $mime_type) = $captcha->out(compress => 1);
291
4
2769
    $self->{_bin_data} = $image_data;
292
4
12
    $self->{_type} = "image/$mime_type";
293    ### $mime_type
294}
295
296sub gen_en_image {
297
7
7
0
48
    my ($self, $str) = @_;
298
7
46
    my $angle = 2 + int rand 4;
299
7
133
    my $captcha = GD::SecurityImage->new(
300        width => 120,
301        height => 30,
302        lines => 1,
303        font => "$FindBin::Bin/../font/wqy-zenhei.ttf",
304        #thickness => 0.5,
305        rndmax => 3,
306        angle => $angle,
307        ptsize => 14,
308        #ptsize => 80,
309        #send_ctobg => 1,
310        #scramble => 1,
311    );
312
313    #warn $str;
314
7
7495
    $captcha->random($str);
315
7
368
    $captcha->create(ttf => 'default');
316
7
50
5971
    die "Failed to load ttf font for GD: $@\n" if $captcha->gdbox_empty;
317
7
176
    $captcha->particle(100); # : 1732);
318
7
91825
    my ($image_data, $mime_type) = $captcha->out(compress => 1);
319
7
5083
    $self->{_bin_data} = $image_data;
320
7
27
    $self->{_type} = "image/$mime_type";
321    ### $mime_type
322}
323
3241;
325