File Coverage

blib/lib/Image/Magick/Tiler.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Image::Magick::Tiler;

# Name:
#	Image::Magick::Slice.
#
# Documentation:
#	POD-style documentation is at the end. Extract it with pod2html.*.
#
# Reference:
#	Object Oriented Perl
#	Damian Conway
#	Manning
#	1-884777-79-1
#	P 114
#
# Note:
#	o Tab = 4 spaces || die.
#
# Author:
#	Ron Savage
#	Home page: http://savage.net.au/index.html
#
# Licence:
#	Australian copyright (c) 1999-2002 Ron Savage.
#
#	All Programs of mine are 'OSI Certified Open Source Software';
#	you can redistribute them and/or modify them under the terms of
#	The Artistic License, a copy of which is available at:
#	http://www.opensource.org/licenses/index.html

use strict;
use warnings;

use Carp;
use File::Spec;
use Image::Magick;

require 5.005_62;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Image::Magick::Tiler ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);
our $VERSION = '1.03';

# -----------------------------------------------

# Preloaded methods go here.

# -----------------------------------------------

# Encapsulated class data.

{
	my(%_attr_data) =
	(
		_input_file		=> '',
		_geometry		=> '2x2+0+0',
		_output_dir		=> '',
		_output_type	=> 'png',
		_return			=> 1,
		_verbose		=> 0,
		_write			=> 0,
	);

	sub _default_for
	{
		my($self, $attr_name) = @_;

		$_attr_data{$attr_name};
	}

	sub _standard_keys
	{
		keys %_attr_data;
	}

}	# End of encapsulated class data.

# -----------------------------------------------

sub new
{
	my($caller, %arg)		= @_;
	my($caller_is_obj)		= ref($caller);
	my($class)				= $caller_is_obj || $caller;
	my($self)				= bless({}, $class);

	for my $attr_name ($self -> _standard_keys() )
	{
		my($arg_name) = $attr_name =~ /^_(.*)/;

		if (exists($arg{$arg_name}) )
		{
			$$self{$attr_name} = $arg{$arg_name};
		}
		elsif ($caller_is_obj)
		{
			$$self{$attr_name} = $$caller{$attr_name};
		}
		else
		{
			$$self{$attr_name} = $self -> _default_for($attr_name);
		}
	}

	Carp::croak("Error. You must call new as new(input_file => 'some file'). ") if (! $$self{'_input_file'});

	my($g) = $$self{'_geometry'};

	if ($g =~ /^(\d*)(x?)(\d*)([+-]?\d*)([+-]?\d*)$/i)
	{
		$$self{'_geometry'}		= [$1, $2, $3, $4, $5];
		$$self{'_geometry'}[0]	= 2		if ($$self{'_geometry'}[0] eq '');
		$$self{'_geometry'}[1]	= 'x'	if ($$self{'_geometry'}[1] eq '');
		$$self{'_geometry'}[2]	= 2		if ($$self{'_geometry'}[2] eq '');
		$$self{'_geometry'}[3]	= '+0'	if ($$self{'_geometry'}[3] =~ /^(|\+|-)$/);
		$$self{'_geometry'}[4]	= '+0'	if ($$self{'_geometry'}[4] =~ /^(|\+|-)$/);

		Carp::croak("Error. Input (NxM+x+y = $g) specifies N = 0") if ($$self{'_geometry'}[0] =~ /^0+$/);
		Carp::croak("Error. Input (NxM+x+y = $g) specifies M = 0") if ($$self{'_geometry'}[2] =~ /^0+$/);

		if ($$self{'_verbose'})
		{
			print "Image::Magick:        V $Image::Magick::VERSION. \n";
			print "Image::Magick::Tiler: V $Image::Magick::Tiler::VERSION. \n";
			print "Geometry:             $g parsed as NxM+x+y = " . join('', @{$$self{'_geometry'} }) . ". \n";
		}
	}
	else
	{
		Carp::croak("Error. Input (NxM+x+y = $g) is not in the correct format. ");
	}

	return $self;

}	# End of new.

# -----------------------------------------------

sub tile
{
	my($self)	= @_;
	my($image)	= Image::Magick -> new();
	my($result)	= $image -> Read($$self{'_input_file'});

	Carp::croak("Error. Unable to read file $$self{'_input_file'}. Image::Magick error: $result. ") if ($result);

	my($param)			= {};
	$$param{'image'}	= {};
	($$param{'image'}{'width'}, $$param{'image'}{'height'}) = $image -> Get('width', 'height');

	$$param{'tile'}				= {};
	$$param{'tile'}{'width'}	= int($$param{'image'}{'width'} / $$self{'_geometry'}[0]);
	$$param{'tile'}{'height'}	= int($$param{'image'}{'height'} / $$self{'_geometry'}[2]);

	if ($$self{'_verbose'})
	{
		print "Image:                $$self{'_input_file'}. \n";
		print "Image size:           ($$param{'image'}{'width'}, $$param{'image'}{'height'}). \n";
		print "Tile size:            ($$param{'tile'}{'width'}, $$param{'tile'}{'height'}) (before applying x and y). \n";
	}

	Carp::croak("Error. Tile width ($$param{'tile'}{'width'}) < input x ($$self{'_geometry'}[3]). ")	if ($$param{'tile'}{'width'} < abs($$self{'_geometry'}[3]) );
	Carp::croak("Error. Tile height ($$param{'tile'}{'height'}) < input y ($$self{'_geometry'}[4]). ")	if ($$param{'tile'}{'height'} < abs($$self{'_geometry'}[4]) );

	$$param{'tile'}{'width'}	+= $$self{'_geometry'}[3];
	$$param{'tile'}{'height'}	+= $$self{'_geometry'}[4];

	if ($$self{'_verbose'})
	{
		print "Tile size:            ($$param{'tile'}{'width'}, $$param{'tile'}{'height'}) (after applying x and y). \n";
	}

	my($output)	= [];
	my($x)		= 0;

	my($y, $tile, $output_file_name);

	for my $xg (1 .. $$self{'_geometry'}[0])
	{
		$y = 0;

		for my $yg (1 .. $$self{'_geometry'}[2])
		{
			$output_file_name	= "$yg-$xg.$$self{'_output_type'}";
			$output_file_name	= File::Spec -> catfile($$self{'_output_dir'}, $output_file_name) if ($$self{'_output_dir'});
			$tile				= $image -> Clone();

			Carp::croak("Error. Unable to clone image $output_file_name") if (! ref $tile);

			$result = $tile -> Crop(x => $x, y => $y, width => $$param{'tile'}{'width'}, height => $$param{'tile'}{'height'});

			Carp::croak("Error. Unable to crop image $output_file_name. Image::Magick error: $result. ") if ($result);

			if ($$self{'_return'})
			{
				push @{$output},
				{
					file_name	=> $output_file_name,
					image		=> $tile,
				};
			}

			if ($$self{'_write'})
			{
				$tile -> Write($output_file_name);

				print "Wrote:                $output_file_name. \n" if ($$self{'_verbose'});
			}

			$y += $$param{'tile'}{'height'};
		}

		$x += $$param{'tile'}{'width'};
	}

	$output;

}	# End of tile.

# -----------------------------------------------

1;

__END__