package Yaa::LookupMap::Driver::PCRE;

# inherit everything from Yaa::LookupMap
@ISA = qw(Yaa::LookupMap);

use strict;
use IO::File;
use vars qw ($VERSION);

# set debugging constant if YAA_DEBUG environment variable is set
BEGIN {
	use constant DEBUG => ((defined $ENV{YAA_DEBUG}) ? 1 : 0);
	require File::Basename if (DEBUG);
}

=head1 NAME

Yaa::LookupMap::Driver::PCRE - pcre lookup map driver

This driver parses file, which contains regular expressions and results and performs lookups.

WARNING: Do not use this class standalone!

=cut

=head1 SYNOPSIS

my $pcre_map = Yaa::LookupMap->factory(

	driver => 'PCRE',
	file => 'pcre_file.txt',
	replacement_num => 0
);

my $result = $sql_map->lookup($key);

# prints out column some_column if sql query returned anything

print $result->getMatchValueByKey('result') if (defined $result);

B<Result keys>: This driver returns result object with only one key named B<result>

=cut

=head1 PCRE FILE FORMAT

General format:

B</regex/[flags]		result>

Examples:

# this needs replacement_num parameter set to 1!
rewrites address anything@autoreply.example.org to anything@example.org

/^([\w\.\-]+)@autoreply.example.org$/i	$1@example.org

See also:

perldoc perlre, sample_map.pcre in conf/directory

=cut

######################################################
#                GLOBAL VARIABLES                    #
######################################################
my $VERSION = "0.1";

######################################################
#               OBJECT CONSTRUCTOR                   #
######################################################

=head1 OBJECT CONSTRUCTOR

Object constructor options:

B<file> - file containing regular expressions/results

B<replacement_num> - if you're using PCRE lookup maps for address rewriting set this value to 1-9, depending how many $x (where x is integer between 1-9) variables you have in regex result.

=cut
sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	
	# call parent constructor
	my $self = Yaa::LookupMap->new();

	##################################################
	#               PUBLIC VARS                      #
	##################################################
	
	# regex file
	$self->{file} = undef;
	
	# number of $x replacements in result
	$self->{replacement_num} = 0;

	##################################################
	#              PRIVATE VARS                      #
	##################################################
	
	# hash with precompiled regexes...
	$self->{_re_hash} = undef;

	bless($self, $class);

	# clear parameters
	$self->clearParams();

	# set object properties	
	$self->setParams(@_);
	
	# parse file if necessary
	$self->parseFile() if (defined $self->{file});

	return $self;
}

####################################################
#               PUBLIC METHODS                     #
####################################################

=head1 METHODS

=cut
sub clearParams {
	my ($self) = @_;
	$self->{file} = undef;
	$self->{_re_hash} = undef;
}

=head2 parseFile ($file)

Parses plaintext file. Returns 1 on success and 0 on error.

=cut
sub parseFile {
	my ($self, $file) = @_;
	
	$self->{file} = $file if (defined $file);
	$file = $self->{file} if (! defined $file);
	
	unless (defined $file) {
		$self->{error} = "PCRE file is not defined.";
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", parseFh(), line ", __LINE__, ": Error: ", $self->{error}, "\n" if (DEBUG);
		return 0;
	}
	
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", parseFile(), line ", __LINE__, ": parsing file '$file'\n" if (DEBUG);
	
	my $fd = undef;
	
	if (! defined ($fd = IO::File->new($file, 'r'))) {
		$self->{error} = "Unable to parse file '" . $file . "': " . $!;
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", parseFile(), line ", __LINE__, ": Unable to parse file '$file': $!\n" if (DEBUG);
		return 0;
	} else {
		my $result = $self->parseFh($fd);
		$fd = undef;
		return $result;
	}
}

=head2 parseFh ($filehandle)

Parses filehandle $filehandle and returns 1 on success and 0 on error.

=cut
sub parseFh {
	my ($self, $fd) = @_;
	my $pos = undef;
	
	if (! defined $fd) {
		$self->{error} = "Filehandle not given as argument.";
		return 0;
	}
	
	# rewind to the end of file....
	if ($fd->tell > 0 && $fd->seek(0, 0) == 0) {
		$self->{error} = "Unable to read file from beginning.";
		return 0;
	}

	my $lines = 0;
	
	# read line by line && parse
	while (my $line = $fd->getline) {
		$lines++;

		# skip comments
		next if ($line =~ m/^#/);
		
		# remove whitespaces at the end
		$line =~ s/\s+$//;
		$line =~ s/^\s+//;
		
		# don't bother about blank lines :)
		next if (! length $line);
		
		# extract regex pattern and result
		my ($reg_text, $reg_result) = split(/\/[imosx]{0,5}\s/, $line);
		
		# remove starting '/'
		$reg_text =~ s/^\///;

		# get pcre file flags
		my $flags = undef;
		if ($line =~ m/.+\/([imosx]{0,5})\s+/) {
			$flags = $1;
		}

		# try to compile regex
		my $regex = undef;
		eval { $regex = qr/(?$flags:$reg_text)/; };

		if ($@) {
			$self->{error} = "Invalid regular expression in line " . $lines . ": " . $@;
			print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", parseFh(), line ", __LINE__, ": ", $self->{error}, "\n" if (DEBUG);
			$self->{_re_hash} = undef;
			return 0;
		}

		# remove leading spaces in result
		$reg_result =~ s/^\s+//;
		
		# put into hash
		$self->{_re_hash}->{$regex} = $reg_result;
		
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", parseFh(), line ", __LINE__, ": regex: '$reg_text'; flags: '$flags'; result: '$reg_result'\n" if (DEBUG);
	}

	return 1;
}

####################################################
#               PRIVATE METHODS                    #
####################################################

# performs actual lookup
sub _lookup {
	my ($self, $key) = @_;
	
	unless (defined $self->{_re_hash}) {
		$self->{error} = "PCRE file not parsed yet.";
		return undef;
	}
	
	my $result = Yaa::LookupMap::Result->new();
	
	foreach (keys %{$self->{_re_hash}}) {
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ": _lookup(), line: ", __LINE__, ": Evaluating lookup key '$key' against regex '$_'\n" if (DEBUG);
		# do we have a match?
		if ($key =~ m/$_/) {
			print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ": _lookup(), line: ", __LINE__, ": FOUND MATCH!\n" if (DEBUG);
			my $str = $self->{_re_hash}->{$_};
			
			# turn off use strict;
			no strict;

			for (my $i = 1; $i <= $self->{replacement_num}; $i++) {
				my $v = ${$i};
				$str =~ s/\$$i/$v/g if defined ($v);
			}
			
			$result->addMatch({result => $str});
			last;
		}
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ": _lookup(), line: ", __LINE__, ": NO MATCH FOUND.\n" if (DEBUG);
	}
	
	return $result;
}

1;

=head1 SEE ALSO

For general class usage, please see perldoc Yaa::LookupMap.

=cut

=head1 AUTHOR

Branko F. Gracnar <bfg@frost.ath.cx>
http://frost.ath.cx/~bfg

=cut

=head1 LICENSE

This software is released under BSD-style license. If you like this software, send me a nice postcard from somewhere to the snail mail address published on my website.

=cut

