File Coverage

blib/lib/Web/Sitemap.pm

Criterion	Covered	Total	%
statement	115	121	95.0
branch	25	42	59.5
condition	10	18	55.5
subroutine	23	23	100.0
pod	3	3	100.0
total	176	207	85.0

package Web::Sitemap;

our $VERSION = '0.903';

use strict;
use warnings;
use bytes;

use File::Temp;
use File::Copy;
use IO::Compress::Gzip qw/gzip $GzipError/;
use Encode;
use Carp;

use Web::Sitemap::Url;

use constant {
	URL_LIMIT => 50000,
	FILE_SIZE_LIMIT => 50 * 1024 * 1024,
	FILE_SIZE_LIMIT_MIN => 1024 * 1024,

	DEFAULT_FILE_PREFIX => 'sitemap.',
	DEFAULT_TAG => 'pages',
	DEFAULT_INDEX_NAME => 'sitemap',

	XML_HEAD => '',
	XML_MAIN_NAMESPACE => 'xmlns="http://www.sitemaps.org/schemas/sitemap/0.9"',
	XML_MOBILE_NAMESPACE => 'xmlns:mobile="http://www.google.com/schemas/sitemap-mobile/1.0"',
	XML_IMAGES_NAMESPACE => 'xmlns:image="http://www.google.com/schemas/sitemap-image/1.1"'

};

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

	my %allowed_keys = map { $_ => 1 } qw(
		output_dir      temp_dir              loc_prefix
		url_limit       file_size_limit       file_prefix
		file_loc_prefix default_tag           index_name
		mobile          images                namespace
		charset         move_from_temp_action
	);

	my @bad_keys = grep { !exists $allowed_keys{$_} } keys %p;
	croak "Unknown parameters: @bad_keys" if @bad_keys;

	my $self = {
		loc_prefix => '',
		tags => {},

		url_limit => URL_LIMIT,
		file_size_limit => FILE_SIZE_LIMIT,
		file_prefix => DEFAULT_FILE_PREFIX,
		file_loc_prefix => '',
		default_tag => DEFAULT_TAG,
		index_name => DEFAULT_INDEX_NAME,
		mobile => 0,
		images => 0,
		charset => 'utf8',

		%p,    # actual input values
	};

	$self->{file_loc_prefix} ||= $self->{loc_prefix};

	if ($self->{file_size_limit} < FILE_SIZE_LIMIT_MIN) {
		$self->{file_size_limit} = FILE_SIZE_LIMIT_MIN;
	}

	if ($self->{namespace}) {

		$self->{namespace} = [$self->{namespace}]
			if !ref $self->{namespace};

		croak 'namespace must be scalar or array ref!'
			if ref $self->{namespace} ne 'ARRAY';
	}

	unless ($self->{output_dir}) {
		croak 'output_dir expected!';
	}

	if ($self->{temp_dir} and not -w $self->{temp_dir}) {
		croak sprintf "Can't write to temp_dir '%s' (error: %s)", $self->{temp_dir}, $!;
	}

	if ($self->{move_from_temp_action} and ref $self->{move_from_temp_action} ne 'CODE') {
		croak 'move_from_temp_action must be code ref!';
	}

	return bless $self, $class;
}

sub add
{
	my ($self, $url_list, %p) = @_;

	my $tag = $p{tag} || $self->{default_tag};

	if (ref $url_list ne 'ARRAY') {
		croak 'The list of sitemap URLs must be array ref';
	}

	for my $url (@$url_list) {
		my $data = Web::Sitemap::Url->new(
			$url,
			mobile => $self->{mobile},
			loc_prefix => $self->{loc_prefix},
		)->to_xml_string;

		if ($self->_file_limit_near($tag, bytes::length $data)) {
			$self->_next_file($tag);
		}

		$self->_append_url($tag, $data);
	}
}

sub finish
{
	my ($self, %p) = @_;

	return unless keys %{$self->{tags}};

	my $index_temp_file_name = $self->_temp_file->filename;
	open my $index_file, '>' . $index_temp_file_name or croak "Can't open file '$index_temp_file_name'! $!\n";

	print {$index_file} XML_HEAD;
	printf {$index_file} "\n", XML_MAIN_NAMESPACE;

	for my $tag (sort keys %{$self->{tags}}) {
		my $data = $self->{tags}{$tag};

		$self->_close_file($tag);
		for my $page (1 .. $data->{page}) {
			printf {$index_file} "\n%s/%s", $self->{file_loc_prefix},
				$self->_file_name($tag, $page);
		}
	}

	print {$index_file} "\n";
	close $index_file;

	$self->_move_from_temp(
		$index_temp_file_name,
		$self->{output_dir} . '/' . $self->{index_name} . '.xml'
	);
}

sub _move_from_temp
{
	my ($self, $temp_file_name, $public_file_name) = @_;

	#printf "move %s -> %s\n", $temp_file_name, $public_file_name;

	if ($self->{move_from_temp_action}) {
		$self->{move_from_temp_action}($temp_file_name, $public_file_name);
	}
	else {
		File::Copy::move($temp_file_name, $public_file_name)
			or croak sprintf 'move %s -> %s error: %s', $temp_file_name, $public_file_name, $!;
	}
}

sub _file_limit_near
{
	my ($self, $tag, $new_portion_size) = @_;

	return 0 unless defined $self->{tags}{$tag};

	# printf("tag: %s.%d; url: %d; gzip_size: %d (%d)\n",
	# 	$tag,
	# 	$self->{tags}->{$tag}->{page},
	# 	$self->{tags}->{$tag}->{url_count},
	# 	$self->{tags}->{$tag}->{file_size},
	# 	$self->{file_size_limit}
	# );

	return (
		$self->{tags}{$tag}{url_count} >= $self->{url_limit}
			||

			# 200 bytes should be well enough for the closing tags at the end of the file
			($self->{tags}{$tag}{file_size} + $new_portion_size) >= ($self->{file_size_limit} - 200)
	);
}

sub _temp_file
{
	my ($self) = @_;

	return File::Temp->new(
		UNLINK => 1,
		$self->{temp_dir} ? (DIR => $self->{temp_dir}) : ()
	);
}

sub _set_new_file
{
	my ($self, $tag) = @_;

	my $temp_file = $self->_temp_file;

	$self->{tags}{$tag}{page}++;
	$self->{tags}{$tag}{url_count} = 0;
	$self->{tags}{$tag}{file_size} = 0;
	$self->{tags}{$tag}{file} = IO::Compress::Gzip->new($temp_file->filename)
		or croak "gzip failed: $GzipError\n";
	$self->{tags}{$tag}{file}->autoflush;
	$self->{tags}{$tag}{temp_file} = $temp_file;

	# Do not check the file for oversize because it is empty and will likely
	# not exceed 1MB with initial tags alone

	my @namespaces = (XML_MAIN_NAMESPACE);
	push @namespaces, XML_MOBILE_NAMESPACE
		if $self->{mobile};
	push @namespaces, XML_IMAGES_NAMESPACE
		if $self->{images};
	push @namespaces, @{$self->{namespace}}
		if $self->{namespace};

	$self->_append(
		$tag,
		sprintf("%s\n", XML_HEAD, join(' ', @namespaces))
	);
}

sub _file_handle
{
	my ($self, $tag) = @_;

	unless (exists $self->{tags}{$tag}) {
		$self->_set_new_file($tag);
	}

	return $self->{tags}{$tag}{file};
}

sub _append
{
	my ($self, $tag, $data) = @_;

	$self->_file_handle($tag)->print(Encode::encode($self->{charset}, $data));
	$self->{tags}{$tag}{file_size} += bytes::length $data;
}

sub _append_url
{
	my ($self, $tag, $data) = @_;

	$self->_append($tag, $data);
	$self->{tags}{$tag}{url_count}++;
}

sub _next_file
{
	my ($self, $tag) = @_;

	$self->_close_file($tag);
	$self->_set_new_file($tag);
}

sub _close_file
{
	my ($self, $tag) = @_;

	$self->_append($tag, "\n");
	$self->_file_handle($tag)->close;

	$self->_move_from_temp(
		$self->{tags}{$tag}{temp_file}->filename,
		$self->{output_dir} . '/' . $self->_file_name($tag)
	);
}

sub _file_name
{
	my ($self, $tag, $page) = @_;
	return
		$self->{file_prefix}
		. $tag
		. '.'
		. ($page || $self->{tags}{$tag}{page})
		. '.xml.gz'
		;
}

1;

__END__