File Coverage

blib/lib/Commons/Link.pm

Criterion	Covered	Total	%
statement	79	79	100.0
branch	8	8	100.0
condition			n/a
subroutine	17	17	100.0
pod	6	6	100.0
total	110	110	100.0

package Commons::Link;

use strict;
use warnings;

use Class::Utils qw(set_params);
use Digest::MD5 qw(md5_hex);
use File::Basename;
use Readonly;
use Unicode::UTF8 qw(decode_utf8 encode_utf8);
use URI;

Readonly::Scalar our $UPLOAD_URI => q{http://upload.wikimedia.org};
Readonly::Scalar our $COMMONS_URI => q{https://commons.wikimedia.org};
Readonly::Array our @UPLOAD_SEGS => qw(wikipedia commons);
Readonly::Array our @COMMONS_SEGS => qw(wiki);

our $VERSION = 0.06;

sub new {
	my ($class, @params) = @_;

	# Create object.
	my $self = bless {}, $class;

	# UTF-8 mode.
	$self->{'utf-8'} = 1;

	# Process parameters.
	set_params($self, @params);

	return $self;
}

sub link {
	my ($self, $file) = @_;

	$self->_cleanup(\$file);

	# Digest characters.
	my ($a, $b) = $self->_compute_ab($file);

	my $u = URI->new($UPLOAD_URI);
	$u->path_segments(@UPLOAD_SEGS, $a, $b, $file);

	return $u->as_string;
}

sub mw_file_link {
	my ($self, $file) = @_;

	if ($file !~ m/^(File|Image):/ms) {
		$file = 'File:'.$file;
	}

	return $self->mw_link($file);
}

sub mw_link {
	my ($self, $file) = @_;

	my $u = URI->new($COMMONS_URI);
	$u->path_segments(@COMMONS_SEGS, $file);

	return $u->as_string;
}

sub mw_user_link {
	my ($self, $user) = @_;

	if ($user !~ m/^User:/ms) {
		$user = 'User:'.$user;
	}

	return $self->mw_link($user);
}

sub thumb_link {
	my ($self, $file, $width) = @_;

	$self->_cleanup(\$file);

	# Digest characters.
	my ($a, $b) = $self->_compute_ab($file);

	my $thumb_file = $file;
	my ($name, undef, $suffix) = fileparse($file, qr/\.[^.]*/ms);
	if ($suffix eq '.svg') {
		$suffix = '.png';
		$thumb_file = $name.$suffix;
	}

	my $u = URI->new($UPLOAD_URI);
	$u->path_segments(@UPLOAD_SEGS, 'thumb', $a, $b, $file,
		$width.'px-'.$thumb_file);

	return $u->as_string;
}

sub _cleanup {
	my ($self, $file_sr) = @_;

	# Rewrite all spaces to '_'.
	${$file_sr} =~ s/ /_/g;

	# Remove 'File:' or 'Image:' prefixes.
	${$file_sr} =~ s/^(File|Image)://ig;

	# Upper case
	${$file_sr} =~ s/^(\w)/uc($1)/e;

	return;
}

sub _compute_ab {
	my ($self, $file) = @_;

	# MD5 only on bytes not utf8 chars.
	my $digest;
	if ($self->{'utf-8'}) {
		my $tmp = encode_utf8($file);
		$digest = lc(md5_hex($tmp));
	} else {
		$digest = lc(md5_hex($file));
	}

	my $a = substr $digest, 0, 1;
	my $b = substr $digest, 0, 2;

	return ($a, $b);
}

1;

__END__