File Coverage

blib/lib/Authen/Captcha.pm

Criterion	Covered	Total	%
statement	6	8	75.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	9	11	81.8

package Authen::Captcha;

# $Source: /usr/local/cvs/Captcha/pm/Captcha.pm,v $
# $Revision: 1.23 $
# $Date: 2003/12/18 04:44:34 $
# $Author: jmiller $
# License: GNU General Public License Version 2 (see license.txt)

use 5.00503;
use strict;
use GD;
use String::Random qw(random_regex);
use Carp;
# these are used to find default images dir
use File::Basename;
use File::Spec;

use vars qw($VERSION);

$VERSION = sprintf "%d.%03d_001", q$Revision: 1.23 $ =~ /(\d+)/g;

# get our file name, used to find the default images
my $default_images_folder;
{
	my $this_file = __FILE__;
	my $this_dir = dirname($this_file);
	my @this_dirs = File::Spec->splitdir( $this_dir );
	$default_images_folder = File::Spec->catdir(@this_dirs,'Captcha','images');
}

my $num_of_soundfile_versions = 10;

# Preloaded methods go here.

sub new
{
	my ($this) = shift;
	my $class = ref($this) || $this;
	my $self = {};
	bless( $self, $class );

	my %opts = @_;

	# default character source images
	my $type = defined($opts{type}) ? $opts{type} : 'image';
	$self->type($type);
	my $src_images = (defined($opts{images_folder}) && (-d $opts{images_folder}))
	                 ? $opts{images_folder} : $default_images_folder;
	$self->images_folder($src_images);

	my $debug = (defined($opts{debug}) && ($opts{debug} =~ /^\d+$/))
	            ? $opts{debug} : 0;
	$self->debug($debug);
	$self->data_folder($opts{data_folder}) if($opts{data_folder});
	$self->output_folder($opts{output_folder}) if($opts{output_folder});
	my $expire = (defined($opts{expire}) && ($opts{expire} =~ /^\d+$/))
	             ? $opts{expire} : 300;
	$self->expire($expire);
	my $width = (defined($opts{width}) && ($opts{width} =~ /^\d+$/))
	             ? $opts{width} : 25;
	$self->width($width);
	my $height = (defined($opts{height}) && ($opts{height} =~ /^\d+$/))
	             ? $opts{height} : 35;
	$self->height($height);
	my $keep_failures = (defined($opts{keep_failures}) && $opts{keep_failures})
	                    ? 1 : 0;
	$self->keep_failures($keep_failures);

	# create a random seed if perl version less than 5.004
	if ($] < 5.005)
	{	# have to seed rand. using a fairly good seed
		srand( time() ^ ($$ + ($$ << 15)) );
	}	# else, we're just going to let perl do it's thing

	return $self;
}

sub type
{
	ref(my $self = shift) or croak "instance variable needed";
	if (@_)
	{
		if ($_[0] =~ /^(jpg|png|gif|image|picture)$/i)
		{
			$self->{_type} = 'image';
		} elsif ($_[0] =~ /^(sound|snd|wav|mp3)$/i) {
			$self->{_type} = 'sound';
		}
		return $self->{_type};
	} else {
		return $self->{_type};
	}
}

sub debug
{
	ref(my $self = shift) or croak "instance variable needed";
	if (@_)
	{
		$self->{_debug} = $_[0];
		return $self->{_debug};
	} else {
		return $self->{_debug};
	}
}

sub keep_failures
{
	ref(my $self = shift) or croak "instance variable needed";
	if (@_)
	{
		croak "keep_failures must be a zero or one" unless ($_[0] =~ /^[01]$/);
		$self->{_keep_failures} = $_[0];
		return $self->{_keep_failures};
	} else {
		return $self->{_keep_failures};
	}
}

sub expire
{
	ref(my $self = shift) or croak "instance variable needed";
	if (@_)
	{
		croak "expire must be a possitive integer" unless ($_[0] =~ /^\d+$/);
		$self->{_expire} = $_[0];
		return $self->{_expire};
	} else {
		return $self->{_expire};
	}
}

sub width
{
	ref(my $self = shift) or croak "instance variable needed";
	if (@_)
	{
		croak "width must be a possitive integer" unless ($_[0] =~ /^\d+$/);
		$self->{_width} = $_[0];
		return $self->{_width};
	} else {
		return $self->{_width};
	}
}

sub height
{
	ref(my $self = shift) or croak "instance variable needed";
	if (@_)
	{
		croak "height must be a possitive integer" unless ($_[0] =~ /^\d+$/);
		$self->{_height} = $_[0];
		return $self->{_height};
	} else {
		return $self->{_height};
	}
}

sub output_folder
{

	ref(my $self = shift) or croak "instance variable needed";
	if (@_)
	{   # it's a setter
		$self->{_output_folder} = $_[0];
		return $self->{_output_folder};
	} else {
		return $self->{_output_folder};
	}
}

sub images_folder
{
   ref(my $self = shift) or croak "instance variable needed";
   if (@_)
   {   # it's a setter
       $self->{_images_folder} = $_[0];
       return $self->{_images_folder};
   } else {
       return $self->{_images_folder};
   }
}

sub data_folder
{
   ref(my $self = shift) or croak "instance variable needed";
   if (@_)
   {   # it's a setter
       $self->{_data_folder} = $_[0];
       return $self->{_data_folder};
   } else {
       return $self->{_data_folder};
   }
}


sub check_code
{
	ref(my $self = shift) or croak "instance variable needed";
	my ($code, $token) = @_;

	$code = lc($code);

	warn "$code  $token\n" if($self->debug() >= 2);

	my $current_time = time;
	# solution was not found in database (well, yet :)
	my $return_value = -2;
	my $database_file = File::Spec->catfile($self->data_folder(),"codes.txt");

	# create database file if it doesn't already exist
	$self->_touch_file($database_file);

	# zeros (0) and ones (1) are not part of the code
	# they could be confused with (o) and (l), so we swap them in
	$code =~ tr/01/ol/;

	# pull in current database
	warn "Open File: $database_file\n" if($self->debug() >= 2);
	$self->_get_exclusive_lock();
	open (DATA, "<$database_file")  or die "Can't open File: $database_file\n";
		my @data=;
	close(DATA);
	warn "Close File: $database_file\n" if($self->debug() >= 2);

	my $passed=0;
	# $new_data will hold the part of the database we want to keep and
	# write back out
	my $new_data = "";
	foreach my $line (@data)
	{
		$line =~ s/\n//;
		my ($data_time,$data_token,$data_code) = $line =~ m/(^\d+)::([a-f0-9]{32})::(.*)$/
			or next;

		my $png_file = File::Spec->catfile($self->output_folder(),$data_token . ".png");
		if ($data_token eq $token)
		{

			# the token was found in the database
			if (($current_time - $data_time) > $self->expire())
			{
				 warn "Crypt Found But Expired\n" if($self->debug() >= 2);
				# the token was found but has expired
				$return_value = -1;
			} else {
				warn "Match Crypt in File Crypt: $token\n" if($self->debug() >= 2);
			}

			if ( ($data_code eq $code) && ($return_value != -1) )
			{
				warn "Match: " . $data_token . " And " . $token . "\n" if($self->debug() >= 2);
				# solution was correct and was found in database - passed
				$return_value = 1;
			}

			if ( $return_value < ($self->keep_failures() ? -1 : -2) )
			{
				warn "No Match: " . $data_token . " And " . $token . "\n" if($self->debug() >= 2);
				# solution was wrong, not expired, and we're keeping failures
				$new_data .= $line."\n";
			} else {
				# remove the found token so it can't be used again
				warn "Unlink File: " . $png_file . "\n" if($self->debug() >= 2);
				unlink($png_file) or carp("Can't remove png file [$png_file]\n");
			}

			if ( $return_value == -2 ) {
				# incorrect solution
				$return_value = -3;
			}

		} elsif (($current_time - $data_time) > $self->expire()) {
			# removed expired token
			warn "Removing Expired Crypt File: " . $png_file ."\n" if($self->debug() >= 2);
			unlink($png_file) or carp("Can't remove png file [$png_file]\n");
		} else {
			# token not found or expired, keep it
			$new_data .= $line."\n";
		}
	}

	# update database
	open(DATA,">$database_file")  or die "Can't open File: $database_file\n";
		print DATA $new_data;
	close(DATA);
	$self->_release_lock();

	return $return_value;
}


sub _open_lock_file {
	my $self = shift;
	my $file_name = shift;
	open(LOCK, ">>$file_name") or die "Error opening lockfile $file_name: $!\n";
}

sub _get_shared_lock {
	my $self = shift;
	my $lock_file_name = File::Spec->catfile($self->data_folder(),"codes.lock");
	$self->_open_lock_file($lock_file_name);

	# shared lock
	flock(LOCK, 1) or die "Error locking lockfile in shared mode: $!\n";
}

sub _get_exclusive_lock {
	my $self = shift;
	my $lock_file_name = File::Spec->catfile($self->data_folder(),"codes.lock");
	$self->_open_lock_file($lock_file_name);

	# exclusive lock
	flock(LOCK, 2) or die "Error locking lockfile exclusively: $!\n";
}

sub _release_lock {
	my $self = shift;
	flock(LOCK, 8) or die "Error unlocking lockfile: $!\n";
	close(LOCK);
}

sub _touch_file
{
	ref(my $self = shift) or croak "instance variable needed";
	my $file = shift;
	# create database file if it doesn't already exist
	if (! -e $file)
	{
		open (DATA, ">>$file") or die "Can't create File: $file\n";
		close(DATA);
	}
}

sub generate_random_string
{
	ref(my $self = shift) or croak "instance variable needed";
	my $length = shift;

	# generate a new code
	my $code = "";
	for(my $i=0; $i < $length; $i++)
	{
		my $char;
		my $list = int(rand 4) +1;
		if ($list == 1)
		{ # choose a number 1/4 of the time
			$char = int(rand 7)+50;
		} else { # choose a letter 3/4 of the time
			$char = int(rand 25)+97;
		}
		$char = chr($char);
		$code .= $char;
	}
	return $code;
}

sub _save_code
{
	ref(my $self = shift) or croak "instance variable needed";
	my $code = shift;
	my $token = shift;

	my $database_file = File::Spec->catfile($self->data_folder(),'codes.txt');

	# set a variable with the current time
	my $current_time = time;

	# create database file if it doesn't already exist
	$self->_touch_file($database_file);

	# clean expired codes and images
	$self->_get_exclusive_lock();

	open (DATA, "<$database_file")  or die "Can't open File: $database_file\n";
		my @data=;
	close(DATA);

	my $new_data = "";
	foreach my $line (@data)
	{
		$line =~ s/\n//;
		my ($data_time,$data_token,$data_code) = $line =~ m/(^\d+)::([a-f0-9]{32})::(.*)$/
			or next;
		if ( (($current_time - $data_time) > ($self->expire())) ||
		     ($data_token  eq $token) )
		{	# remove expired captcha, or a dup
			my $png_file = File::Spec->catfile($self->output_folder(),$data_token . ".png");
			unlink($png_file) or carp("Can't remove png file [$png_file]\n");
		} else {
			$new_data .= $line."\n";
		}
	}

	# save the code to database
	warn "open File: $database_file\n" if($self->debug() >= 2);
	open(DATA,">$database_file")  or die "Can't open File: $database_file\n";
		warn "-->>" . $new_data . "\n" if($self->debug() >= 2);
		warn "-->>" . $current_time . "::" . $token."::".$code."\n" if($self->debug() >= 2);
		print DATA $new_data;
		print DATA $current_time."::".$token."::".$code."\n";
	close(DATA);
	$self->_release_lock();
	warn "Close File: $database_file\n" if($self->debug() >= 2);
}

sub create_image_file
{
	ref(my $self = shift) or croak "instance variable needed";
	my $code = shift;

	my $length = length($code);
	my $im_width = $self->width();
	# create a new image and color
	my $im = new GD::Image(($im_width * $length),$self->height());
	my $black = $im->colorAllocate(0,0,0);

	# copy the character images into the code graphic
	for(my $i=0; $i < $length; $i++)
	{
		my $letter = substr($code,$i,1);
		my $letter_png = File::Spec->catfile($self->images_folder(),$letter . ".png");
		my $source = new GD::Image($letter_png);
		$im->copy($source,($i*($self->width()),0,0,0,$self->width(),$self->height()));
		my $a = int(rand (int(($self->width())/14)))+0;
		my $b = int(rand (int(($self->height())/12)))+0;
		my $c = int(rand (int(($self->width())/3)))-(int(($self->width())/5));
		my $d = int(rand (int(($self->height())/3)))-(int(($self->height())/5));
		$im->copyResized($source,($i*($self->width()))+$a,$b,0,0,($self->width())+$c,($self->height())+$d,$self->width(),$self->height());
	}

	# distort the code graphic
	for(my $i=0; $i<($length*($self->width())*($self->height())/14+200); $i++)
	{
		my $a = (int(rand ($length*($self->width())))+0);
		my $b = (int(rand $self->height())+0);
		my $c = (int(rand ($length*($self->width())))+0);
		my $d = (int(rand $self->height())+0);
		my $index = $im->getPixel($a,$b);
		if ($i < (($length*($self->width())*($self->height())/14+200)/100))
		{
			$im->line($a,$b,$c,$d,$index);
		} elsif ($i < (($length*($self->width())*($self->height())/14+200)/2)) {
			$im->setPixel($c,$d,$index);
		} else {
			$im->setPixel($c,$d,$black);
		}
	}

	# generate a background
	my $a = int(rand 5)+1;
	my $background_img = File::Spec->catfile($self->images_folder(),"background" . $a . ".png");
	my $source = new GD::Image($background_img);
	my ($background_width,$background_height) = $source->getBounds();
	my $b = int(rand (int($background_width/13)))+0;
	my $c = int(rand (int($background_height/7)))+0;
	my $d = int(rand (int($background_width/13)))+0;
	my $e = int(rand (int($background_height/7)))+0;
	my $source2 = new GD::Image(($length*($self->width())),$self->height());
	$source2->copyResized($source,0,0,$b,$c,($length*($self->width())),$self->height(),$background_width-$b-$d,$background_height-$c-$e);

	# merge the background onto the image
	$im->copyMerge($source2,0,0,0,0,($length*($self->width())),$self->height(),40);

	# add a border
	$im->rectangle(0,0,((($length)*($self->width()))-1),(($self->height())-1),$black);

	# save the image to file
	my $png_data = $im->png;

	return \$png_data;
}

sub create_sound_file
{
	ref(my $self = shift) or croak "instance variable needed";
	my $code = shift;
	my $length = length($code);

	my @chars = split('',$code);
	my $snd_file;
	local $/; # input record separator. So we can slurp the data.
	# get a random voice speaking the code
	foreach my $char (@chars)
	{
		my $voice = int(rand $num_of_soundfile_versions) + 1;
		my $src_name = File::Spec->catfile($self->images_folder(),$voice, $char . ".wav");
		warn "Open File: $src_name\n" if($self->debug() >= 2);
		open (FILE,"< $src_name") or die "Can't open File: $src_name\n";
			flock FILE, 1; # read lock
			binmode FILE;
			$snd_file .= ;
		close FILE;
		warn "Close File: $src_name\n" if($self->debug() >= 2);
	}
	return \$snd_file;
}

sub _save_file
{
	ref(my $self = shift) or croak "instance variable needed";
	my $file_ref = shift;
	my $file_name = shift;

	warn "Open File: $file_name\n" if($self->debug() >= 2);
	open (FILE,">$file_name") or die "Can't open File: $file_name \n";
		flock FILE, 2; # write lock
		binmode FILE;
		print FILE $$file_ref;
	close FILE;
	warn "Close File: $file_name\n" if($self->debug() >= 2);
}

sub generate_code
{
	ref(my $self = shift) or croak "instance variable needed";
	my $length = shift;

	my $code = $self->generate_random_string($length);
	my $token = random_regex('[a-f0-9]{32}');

	my ($captcha_data_ref,$output_filename);
	if ($self->type() eq 'image')
	{
		$captcha_data_ref = $self->create_image_file($code);
		$output_filename = File::Spec->catfile($self->output_folder(),$token . ".png");
	} elsif ($self->type() eq 'sound') {
		$captcha_data_ref = $self->create_sound_file($code);
		$output_filename = File::Spec->catfile($self->output_folder(),$token . ".wav");
	} else {
		croak "invalid captcha type [" . $self->type() . "]";
	}

	$self->_save_file($captcha_data_ref,$output_filename);
	$self->_save_code($code,$token);

	# return token (token)... or, if they want it, the code as well.
	return wantarray ? ($token,$code) : $token;
}

sub version
{
   return $VERSION;
}

1;
__END__