File Coverage

blib/lib/WebService/CaptchasDotNet.pm

Criterion	Covered	Total	%
statement	106	110	96.3
branch	35	48	72.9
condition	14	14	100.0
subroutine	18	18	100.0
pod	5	5	100.0
total	178	195	91.2

package WebService::CaptchasDotNet;

use 5.006;

use strict;
use warnings FATAL => qw(all);

use Digest::MD5 qw(md5 md5_hex);
use File::Spec ();
use File::Path qw(mkpath);
use File::Find qw(find);
use IO::File ();
use IO::Dir ();

our $VERSION = 0.06;

our $DEBUG = 0;

#---------------------------------------------------------------------
# precompute some static variables to help persistent environments
# like mod_perl :)
#---------------------------------------------------------------------

my @letters = 'a'..'z';

my @characters;

foreach my $char (33 .. 126) {
  push @characters, chr $char;
}


#---------------------------------------------------------------------
# constructor
#---------------------------------------------------------------------
sub new {

  my $class = shift;

  my %args = @_;

  my $self = { _secret => $args{secret},
               _uid    => $args{username},
               _expire => $args{expire} || 3600,
             };

  bless $self, $class;

  $self->_init;

  return $self;
}


#---------------------------------------------------------------------
# expire accessor
#---------------------------------------------------------------------
sub expire {

  my $self = shift;

  $self->{_expire} = shift if @_;

  return $self->{_expire};
}


#---------------------------------------------------------------------
# verify routine
# make sure user input matches the captcha
#---------------------------------------------------------------------
sub verify {

  my $self = shift;

  my ($input, $random) = @_;

  my $secret = $self->{_secret};

  # basic sanity checking

  unless ($secret && $random && $input && $input =~ m/^[a-z]{6}$/ ) {
    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "insufficient data for verify()\n"
      if $DEBUG;

    return;
  }

  # make sure that the random string is sane
  my $file = $self->_verify_random_string($random);

  return unless $file;

  # now for the computation - this is what
  # the captcha image should really be
  my $decode = substr(md5(join '', $secret, $random), 0, 6);

  my $captcha = '';

  foreach my $byte (split //, $decode) {
    $captcha .= $letters[ord($byte) % 26];
  }

  if ($input eq $captcha) {

    # a random string can only be used once - cleanup
    unlink $file;

    return 1;
  }

  return;
}


#---------------------------------------------------------------------
# random string generator
#---------------------------------------------------------------------
sub random {

  my $self = shift;

  my $string = join '', @characters[rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                    rand 64, rand 64, rand 64, rand 64,
                                   ];

  # hmph, I can't seem to localize md5_hex() in my tests...
  my $random = Digest::MD5->new->add($string)->hexdigest;

  my $tempdir = $self->{_tempdir};

  my $file = File::Spec->catfile($tempdir, $random);

  if (-e $file) {
    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "collision found for '$random'\n"
      if $DEBUG;

    return;
  }

  my $fh = IO::File->new(">$file");

  unless ($fh) {
    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "could not create '$file': $!\n"
      if $DEBUG;

    return;
  }

  undef $fh;

  return $random;
}


#---------------------------------------------------------------------
# present a suitable url for html pages
#---------------------------------------------------------------------
sub url {

  my $self = shift;

  my $random = shift;

  my $user = $self->{_uid};

  return "http://image.captchas.net/?client=$user&random=$random";
}


#---------------------------------------------------------------------
# private initialization routine
#---------------------------------------------------------------------
sub _init {

  my $self = shift;

  # create a temporary filesystem to store used random strings

  my $tmp = File::Spec->catfile(File::Spec->tmpdir,
                                'CaptchasDotNet');

  mkpath $tmp unless -d $tmp;

  $self->{_tempdir} = $tmp;

  $self->_cleanup;
}


#---------------------------------------------------------------------
# check to make sure the random string passed to verify()
# is one we recently generated
#---------------------------------------------------------------------
sub _verify_random_string {

  my $self = shift;

  my $random = shift;

  # untaint
  ($random) = $random =~ m!^([0-9a-z-A-Z]{32})$!
    if $random;

  unless ($random) {

    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "unable to verify invalid random string\n"
      if $DEBUG;

    return;
  }

  my $file = File::Spec->catfile($self->{_tempdir}, $random);

  unless (-e $file) {

    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "sanity file $file not found\n"
      if $DEBUG;

    return;
  }

  if ($self->_time_to_cleanup($file)) {

    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "sanity file $file too old\n"
      if $DEBUG;

    unlink $file;

    return;
  }

  return $file;
}

sub _cleanup {

  my $self = shift;

  my $dir = $self->{_tempdir};

  my $dh = IO::Dir->new($dir);

  if ($dh) {
    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "cleaning up stale entries in $dir\n"
      if $DEBUG;

    foreach my $entry ($dh->read) {

      # untaint
      ($entry) = $entry =~ m!^([0-9a-z-A-Z]{32})$!;

      next unless $entry;

      my $file = File::Spec->catfile($dir, $entry);

      unlink $file if $self->_time_to_cleanup($file);
    }

    return 1;
  }

  print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                         "cannot open cache directory $dir - $!\n"
    if $DEBUG;

  return;
}

sub _time_to_cleanup {

  my $self = shift;

  my $file = shift;

  my $mtime = (stat $file)[9];

  if ($mtime && $mtime + $self->{_expire} < time) {

    print STDERR join ' ', 'WebService::CaptchasDotNet - ',
                           "$file created at $mtime ready for cleanup\n"
      if $DEBUG;

    return 1;
  }

  return;
}

1;

__END__