Something went wrong. Try again.
Perl game server for TLE Community
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276package Lacuna::CaptchaFactory;
use strict;use Moose;use utf8;no warnings qw(uninitialized);use UUID::Tiny ':std';use GD::SecurityImage;use Data::Dumper;
use Lacuna;use Lacuna::Util qw(random_element);
has 'riddle' => ( is => 'rw', lazy => 1, builder => '_build_riddle',);
has 'font' => ( is => 'rw', lazy => 1, builder => '_build_font',);
has 'style' => ( is => 'rw', lazy => 1, builder => '_build_style',);has 'bg_color' => ( is => 'rw', lazy => 1, builder => '_build_bg_color',);has 'fg_color' => ( is => 'rw', lazy => 1, builder => '_build_fg_color',);has 'guid' => ( is => 'rw', lazy => 1, builder => '_build_guid',);has 'fonts' => ( is => 'rw', lazy => 1, builder => '_build_fonts',);has 'font_path' => ( is => 'rw', lazy => 1, builder => '_build_font_path',);has 'develop_mode' => ( is => 'rw', default => 0,);
my %riddles = ( "1x1x1=_" => "1", "0x0x0=_" => "0", "0+0+0=_" => "0", "0-0-0=_" => "0", "1/1=_" => "1", "2/1=_" => "2", "2/2=_" => "1", "4/2=_" => "2", "6/2=_" => "3", "6/3=_" => "2", "9/3=_" => "3", "10/2=_" => "5", "10/5=_" => "2", "12/3=_" => "4", "12/4=_" => "3",);
for my $a (1..9) { for my $b (1..9) { $riddles{$a.'+'.$b.'=_'} = $a + $b; $riddles{$a.'-'.$b.'=_'} = $a - $b; $riddles{$a.'x'.$b.'=_'} = $a * $b; }}for my $a ('a'..'c') { for (1..4) { my $string = $a++; $string .= $a++; my $answer = $a++; $answer .= $a++; $string .= '_'; $string .= $a++; $string .= $a++; $riddles{$string} = $answer; }}
for my $a ('a'..'c') { for (1..4) { my $string = $a++; $string .= uc($a++); my $answer = $a++; $answer .= uc($a++); $string .= '_'; $string .= $a++; $string .= uc($a++); $riddles{$string} = $answer; }}
for my $a ('1'..'2') { for (1..2) { my $string = $a++; $string .= ','; $string .= $a++; my $answer = $a++; $answer .= ','; $answer .= $a++; $string .= ',_,'; $string .= $a++; $string .= ','; $string .= $a++; $riddles{$string} = $answer; }}for my $a ('a'..'i') { for (1..2) { my $string = $a++; $string .= $a++; $string .= $a++; my $answer = $a++; $answer .= $a++; $answer .= $a++; $string .= '_'; $string .= $a++; $string .= $a++; $string .= $a++; $riddles{$string} = $answer; }}
# Return a random riddle from the list of riddlessub _build_riddle { my ($self) = @_;
my ($key, $value);
if ($self->develop_mode) { $key = "Answer 1"; $value = 1; } else { $key = random_element([ keys %riddles ]); $value = $riddles{$key}; } return [ $key, $value ];}
# The array of fonts from which to choosesub _build_fonts { my ($self) = @_; return [ "Ayuthaya", "Chalkduster", "HeadlineA", "Kai" ];}
# return a random font from the fontssub _build_font { my ($self) = @_;
return random_element($self->fonts);}
# return a random stylesub _build_style { my ($self) = @_;
return random_element([ qw(default rect circle ellipse ec blank) ]);}
# return a random background colorsub _build_bg_color { my ($self) = @_;
return random_element([ '666600', '660066', '006666' ]);}
# return a random foreground colorsub _build_fg_color { my ($self) = @_; return random_element([ '#ddffff', '#ffddff', '#ffffdd' ]);}
# return a random UUIDsub _build_guid { my ($self) = @_; return create_uuid_as_string(UUID_V4);}
# The folder where fonts can be foundsub _build_font_path { my ($self) = @_; return "/Library/Fonts";}
# Construct the imagesub construct { my ($self) = @_;
my $captchas = Lacuna->db->resultset('Lacuna::DB::Result::Captcha');
my $security_image; if ($self->develop_mode) { $security_image = GD::SecurityImage->new( width => 300, height => 80, lines => 1, thickness => 1, bgcolor => '#'.$self->bg_color, gt_font => 'giant', ) ->random("Answer = 1") ->create( normal => 'rect' ); } else { $security_image = GD::SecurityImage->new( width => 300, height => 80, lines => 10, thickness => 1, font => $self->font_path.'/'.$self->font.'.ttf', bgcolor => '#'.$self->bg_color, ptsize => 32, rndmax => 3, send_ctobg => 1, angle => int(rand(20) - 10), ) ->random($self->riddle->[0]) ->create( ttf => $self->style, $self->fg_color, $self->fg_color ) ->particle; die "Error loading ttf font for GD: $@" if $security_image->gdbox_empty; } my ($image, $mime, $string) = $security_image->info_text( x => 'left', y => 'up', gd => 1, strip => 1, color => '#000000', scolor => '#FFFFFF', text => 'Fill in the blank:', ) ->out( force => 'png', compress=> 1, ); my $filepath = '/home/lacuna/server/public/captcha/'.$self->guid.'.png'; open my $file, '>', $filepath or die "Can't write to $filepath: $!"; print {$file} $image; close $file; $captchas->create({ guid => $self->guid, riddle => $self->riddle->[0], solution=> $self->riddle->[1], created => DateTime->now, });}
no Moose;__PACKAGE__->meta->make_immutable;