File Coverage

blib/lib/HTML/TrackerLink.pm

Criterion	Covered	Total	%
statement	94	113	83.1
branch	37	64	57.8
condition	4	6	66.6
subroutine	16	18	88.8
pod	7	7	100.0
total	158	208	75.9

package HTML::TrackerLink;

# HTML::TrackerLink is a package for automatically finding tracker references
# in the form of 'Keyword 12345' or '#12345', and converting them into links into
# the external tracking system.

# See POD below for more details

use 5.006;
use strict;

use vars qw{$VERSION $errstr};
BEGIN {
	$VERSION = '1.03';
	$errstr  = '';
}





#####################################################################
# Constructor and Accessors

sub new {
	my $class = shift;

	# Create our object
	my $self = bless {
		keywords => {},
	}, $class;
	return $self unless @_;

	# Handle arguments
	if ( @_ == 1 ) {
		# Should be a tracker URL for the default search
		my $url = shift;
		return undef unless $self->_check_url( $url );

		# Set the default search
		$self->{default} = $url;

	} elsif ( @_ == 2 ) {
		# Should be a single keyword/url pair
		my ($keyword, $url) = @_;
		return undef unless $self->_check_keyword( $keyword );
		return undef unless $self->_check_url( $url );

		# Set the keyword
		$self->{keywords}->{lc $keyword} = $url;

		# Set the default search to be the same
		$self->{default_keyword} = $keyword;

	} elsif ( scalar(@_) % 2 == 0 ) {
		# Multiple keyword/url pairs
		my %keywords = @_;
		foreach my $keyword ( sort keys %keywords ) {
			my $url = $keywords{$keyword};
			unless ( $self->_check_keyword( $keyword ) ) {
				return $self->_error( "Invalid keyword '$keyword': "
					. $self->errstr );
			}
			unless ( $self->_check_url( $url ) ) {
				return $self->_error( "Bad URL for keyword '$keyword': "
					. $self->errstr );
			}

			# Set the keyword
			$self->{keywords}->{$keyword} = $url;
		}

	} else {
		return $self->_error( 'Arguments must be in keyword/url pairs' );
	}

	$self;
}

# Return the currently defined keywords
sub keywords {
	if ( wantarray ) {
		return sort keys %{ $_[0]->{keywords} };
	} else {
		return scalar keys %{ $_[0]->{keywords} };
	}
}





#####################################################################
# Main Methods

# Get or set a keyword search
sub keyword {
	my $self = shift;
	my $keyword = $self->_check_keyword($_[0]) ? lc shift : return undef;
	return $self->{keywords}->{$keyword} unless @_;

	# Set the tracker URL
	my $url = $self->_check_url($_[0]) ? shift : return undef;
	$self->{keywords}->{$keyword} = $url;
}

# Get the current default search
sub default {
	my $self = shift;
	return $self->{default_keyword}
		? $self->{keywords}->{ $self->{default_keyword} }
		: $self->{default} unless @_;

	# Try to set the default search
	my $url = $self->_check_url($_[0]) ? shift : return undef;

	# In case they are using a keyword, remove it
	delete $self->{default_keyword};
	$self->{default} = $url;
}

# Make the default search the same as a particular keyword
sub default_keyword {
	my $self = shift;
	my $keyword = $self->_check_keyword($_[0]) ? lc shift : return undef;

	# Does the keyword exist?
	unless ( exists $self->{keywords}->{$keyword} ) {
		return $self->_error( "The keyword '$keyword' does not exist" );
	}

	# In case they are using an explicit default search, remove it
	delete $self->{default};

	$self->{default_keyword} = $keyword;
}

# Process and return a string
sub process {
	my $self = shift;
	my $text = (@_ and defined $_[0]) ? shift
		: return $self->_error( 'You did not provide a string to process' );

	# Prepare the transforms
	my @replace = ();
	if ( $self->keywords ) {
		my $any_keyword = '(?:' . join('|', $self->keywords) .')';
		push @replace, [
			qr/\b($any_keyword)\s+\#?(\d+)/is,
			sub { $self->_replace(
				$self->{keywords}->{lc $_[3]}, $_[2], $_[4],
			) },
		];
	}
	if ( $self->default ) {
		push @replace, [
			qr/\#(\d+)/s,
			sub { $self->_replace(
				$self->default, $_[2], $_[3],
			) },
		];
	}

	# Hand off to the main substitution method
	return $self->_subst( $text, @replace );
}

# Implement the parallel substitution
sub _subst {
	my $self  = shift;
	my $input = shift;

	# Map the match regex to capture everything BEFORE the match,
	# and the entire pattern provided.
	# (We'll provide them as the first params)
	my @try = map { [ qr/\G(.*?)($_->[0])/s => $_->[1] ] } @_;
	unless ( @try ) {
		# Handle the pathological no-replace case
		return $input;
	}

	# Start the main loop
	my $position = 0;
	my $len      = length $input;
	my $output   = '';
	while ( $position < $len ) {
		my $found = undef;
		my @start = ();
		my @end   = ();
		foreach my $r ( @try ) {
			# Skip if it is not in the string
			pos $input = $position;
			next unless $input =~ $r->[0];

			# Skip if it DOESN'T match earlier
			if ( $found and $start[2] <= $-[2] ) {
				next;
			}

			# This is the best option.
			# Save the matching regex
			$found = $r->[1];
			@start = @-;
			@end   = @+;
		}

		# Break out if no more matches
		last unless $found;

		# Append the pre-match string to the output
		$output .= substr( $input, $start[1], $end[1] - $start[1] );

		# Pass the rest to the transform function
		my $rv = $found->(
			map {
				substr( $input, $start[$_], $end[$_] - $start[$_] )
			} 0 .. $#end
		);
		unless ( defined $rv ) {
			# Transform is signaling an error
			return undef;
		}

		# Transform completed ok
		$output .= $rv;

		# Move the match position for the next iteration
		$position = $end[2];
	}

	# Append the remainder of the string
	return $output . substr( $input, $position );
}

# Return any error message
sub errstr { $errstr }





#####################################################################
# Support Methods

sub _check_keyword {
	my $self = shift;
	my $kw = shift or return $self->_error( 'You did not provide a keyword' );
	return $self->_error( 'Keyword contains non-word characters' ) if $kw =~ /\W/;
	return $self->_error( 'Keyword cannot start with a number' )   if $kw =~ /^\d/;
	return 1;
}

sub _check_url {
	my $self = shift;
	my $url = shift or return $self->_error( 'You did not provide a tracker URL' );
	unless ( $url =~ m!^https?://[\w.]+/! ) {
		return $self->_error( 'The tracker URL format appears to be invalid' );
	}
	unless ( $url =~ /\%n/ ) {
		return $self->_error( 'The tracker URL does not contain a %n placeholder' );
	}
	return 1;
}

# Generates the link in the replacer
sub _replace {
	my ($self, $url, $text, $id) = @_;

	# Create the link
	$url =~ s/\%n/$id/g;
	return "$text";
}

sub _error { $errstr = $_[1]; undef }

1;

__END__