cmtd/lib/CMTD/Captcha.pm

package CMTD::Captcha;

use strict;
use warnings;
use utf8;

use Imager;

our $VERSION = 0.01;

sub new {
  my ($class, %config) = @_;
  my $self = {
    width     => 120,
    height    => 40,
    bg_color  => '#444444',
    fg_color  => '#999999',
    expire    => 300,
    debug     => 0,
    length    => 6,
    ft_file   => undef,
    ft_size   => 32,
    ft_family => 'SansSerif',
    wv_size   => 5,
    wv_length => 60,
    %config
  };

  die("Captcha : ft_file not set\n") unless ($self->{ft_file});

  return bless $self, $class;
}

sub _gen_code {
  my ($self) = @_;
  my ($code, $pos);

  my @chars = ('a' .. 'f', '0' .. '9');
  my $length = $self->{length};

  $code = "";
  while ($length --> 0) {
    $pos = int rand scalar(@chars);
    $code .= $chars[$pos];
  }

  return $code;
}

sub create {
  my ($self) = @_;
  my ($code, $data, $err);

  eval {
    warn "Generating code\n" if $self->{debug};
    $code = $self->_gen_code();
    warn "Code is: $code\n" if $self->{debug};

    my $image = Imager->new(
      xsize => $self->{width},
      ysize => $self->{height},
    );

    warn "Creating image (1/3)\n" if $self->{debug};
    $image->box(filled => 1, color => $self->{bg_color});

    # calculate position of bottom left corner of text box
    warn "Creating font\n" if $self->{debug};
    my $font = Imager::Font->new(
      file  => $self->{ft_file},
      size  => $self->{ft_size},
      color => $self->{fg_color},
    ) or die("can't create font: ", Imager->errstr, "\n");

    warn "Creating image (2/3)\n" if $self->{debug};
    $font->align(
      string => $code,
      halign => 'center',
      valign => 'center',
      image  => $image,
      x => $image->getwidth  / 2,
      y => $image->getheight / 2,
    ) or die("can't place code on image\n");

    $image->filter(
      type    => 'noise',
      amount  => 120,
      subtype => 0,
    ) or die("can't distort image\n");

    $image = $image->convert(preset => 'grey');

    warn "Saving image\n" if ($self->{debug});
    $image->write(data => \$data, type => 'jpeg')
      or die("can't write image: " . Imager->errstr . "\n");

    $self->{error} = ''; 1;
  } or do {
    warn "Error: $@" if ($self->{debug});
    $self->{error} = $@;
    return;
  };

  return ($code, $data);
}

sub error {
  my ($self) = @_;
  return $self->{error} || '';
}

1;

=pod

=head1 NAME

CMTD::Captcha -- generate captcha with Imager

=head1 DESCRIPTION

Based on Mojolicious::Plugin::CaptchaRenderer, but uses Imager instead.

=head1 Methods / Private

=head2 C<_gen_code>

Generate captcha code for placing to image.

=head1 Methods / Public

=head2 C<new>

  my $captcha = CMTD::Captcha->new(%config);

Constructor. Takes plain hash of options. Mandatory settings:

  * ft_file   -- default: undef, file with font to use

Optional settings:

  * width     -- 120, image width
  * height    -- 30,  image height
  * bg_color  -- '#444444', base background color for image
  * fg_color  -- '#999999', color of text
  * debug     -- 0, display diagnostic messages to stderr
  * ft_size   -- 32, font size, points
  * ft_family -- 'SansSerif', font family
  * wv_size   --  5, distortion settings, vertical amplitude
  * wv_length -- 60, distortion settings, wave length

=head2 C<create>

  my $captcha = CMTD::Captcha->new(%config);
  my ($code, $data) = $captcha->create();

Generates captcha image, returns hash of filename.

=head2 C<error>

  my $captcha = CMTD::Captcha->new(%config);
  ...do something wrong...
  my $error = $captcha->error;

Returns last occured error for method C<create>
Error will be cleared on next successfull call to these methods.

=cut