File Coverage

blib/lib/Tk/Image/Cut.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

#*** Cut.pm ***#
# Copyright (C) 2006 by Torsten Knorr
# [e-mail]
# All rights reserved!
#-------------------------------------------------
 package Tk::Image::Cut;
#-------------------------------------------------
 use strict;
 use warnings;
 use Tk;
 use Tk::Frame;
 use Tk::FileSelect;
 use Tk::JPEG;
 use Tk::PNG;
 use Tk::Image::Calculation;
#-------------------------------------------------
 @Tk::Image::Cut::ISA = qw(Tk::Frame Tk::Image::Calculation);
 $Tk::Image::Cut::VERSION = '0.07';
 Construct Tk::Widget "Cut";
#-------------------------------------------------
 sub Populate
 	{
 	require Tk::Button;
 	require Tk::BrowseEntry;
 	require Tk::Entry;
 	require Tk::Label;
 	require Tk::Canvas;
 	my ($cut, $args) = @_;
#-------------------------------------------------
 	my @grid = qw(
 		-column	0
 		-row	0
 		-sticky	nswe
 		);
 	$cut->{ap_x1} = $cut->{ap_x2} = $cut->{ap_y1} = $cut->{ap_y2} = 1;
#-------------------------------------------------
# 	-aperturecolor
# 	-aperturewidth
# 	-shape	=> rectangle, oval, circle, polygon
# 	-zoom
# 	-shrink
#-------------------------------------------------
 	$cut->{_aperturecolor} = (defined($args->{-aperturecolor}))	?
 		delete($args->{-aperturecolor})	:	"#00FF00";
 	$cut->{_aperturewidth} = (defined($args->{-aperturewidth}))	?
 		delete($args->{-aperturewidth})	:	4;
 	$cut->{_shape} = (defined($args->{-shape}))			?
 		delete($args->{-shape})		:	"rectangle";
 	$cut->{_zoom_out} = (defined($args->{-zoom}))			?
 		delete($args->{-zoom})		:		1;
 	$cut->{_shrink_out} = (defined($args->{-shrink}))			?
 		delete($args->{-shrink})		:		1;
 	$cut->SUPER::Populate($args);
#-------------------------------------------------
 	$cut->{button_select_image} = $cut->Button(
 		-text		=> "Select Image",
 		-command	=> [\&SelectImage, $cut],
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{label_shape} = $cut->Label(
 		-text		=> "Shape ->",
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{bentry_shape} = $cut->BrowseEntry(
 		-variable		=> \$cut->{_shape},
 		-browsecmd	=> [\&SetShape, $cut]
 		)->grid(
 		@grid,
 		);
 	$cut->{bentry_shape}->insert(qw/
 		end
 		rectangle
 		oval
 		circle
 		polygon
 		/);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{button_color} = $cut->Button(
 		-text		=> "Select Color",
 		-command	=> [\&SelectColor, $cut],
 		)->grid(
 		@grid
 		);
 	if($cut->{_shape} eq "rectangle")
 		{
 		$cut->{button_color}->configure(
 			-state		=> "disabled",
 			);
 		}
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{label_width_out} = $cut->Label(
 		-text		=> "Width ->",
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{entry_width_out} = $cut->Entry(
 		-textvariable	=> \$cut->{_new_image_width},
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{label_height_out} = $cut->Label(
 		-text		=> "Height ->",
 		)->grid(
 		@grid,
 		);
#------------------------------------------------
 	$grid[1]++;
 	$cut->{entry_height_out} = $cut->Entry(
 		-textvariable	=> \$cut->{_new_image_height},
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{button_increase} = $cut->Button(
 		-text		=> '+',
 		-command	=> [\&ImageIncrease, $cut]
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{button_reduce} = $cut->Button(
 		-text		=> '-',
 		-command	=> [\&ImageReduce, $cut],
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{label_name_out} = $cut->Label(
 		-text		=> "New Image Name ->",
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{entry_name_out} = $cut->Entry(
 		-textvariable	=> \$cut->{_new_image_name},
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{button_cut} = $cut->Button(
 		-text		=> "Cut",
 		-command	=> [\&ImageCut, $cut],
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{canvas} = $cut->Scrolled(
 		"Canvas",
 		)->grid(
 		-column		=> 0,
 		-row		=> 1,
 		-columnspan	=> $grid[1],
 		-sticky		=> "nswe",
 		);
#-------------------------------------------------
 	$cut->{childs} = {
 		"ButtonSelectImage"		=> $cut->{button_select_image},
 		"LabelShape"			=> $cut->{label_shape},
 		"bEntryShape"			=> $cut->{bentry_shape},
 		"ButtonColor"			=> $cut->{button_color},
 		"LabelWidthOut"			=> $cut->{label_width_out},
 		"EntryWidthOut"			=> $cut->{entry_width_out},
 		"LabelHeightOut"		=> $cut->{label_height_out},
 		"EntryHeightOut"		=> $cut->{entry_height_out},
 		"ButtonIncrease"			=> $cut->{button_increase},
 		"ButtonReduce"			=> $cut->{button_reduce},
 		"LabelNameOut"			=> $cut->{label_name_out},
 		"EntryNameOut"			=> $cut->{entry_name_out},
 		"ButtonCut"			=> $cut->{button_cut},
 		"Canvas"			=> $cut->{canvas},
 		};
 	$cut->Advertise($_, $cut->{childs}{$_}) for(keys(%{$cut->{childs}}));
 	$cut->Delegates(DEFAULT	=> $cut->{canvas});
 	$cut->ConfigSpecs(DEFAULT	=> ["ADVERTISED"]);
 	}
#-------------------------------------------------
 sub SelectImage
 	{
 	my ($self) = @_;
 	$self->{_zoom_out} = 1;
 	$self->{_shrink_out} = 1;
 	if($self->{file_in} = $self->FileSelect()->Show())
 		{
 		 $self->{canvas}->delete("all");
# GIF, XBM, XPM, BMP, JPEG, PNG, PPM, PGM
 		if($self->{file_in} =~ m/.+?\.(?:jpg|jpeg)$/i)
 			{
 			$self->{image_format} = "JPEG";
 			}
 		elsif($self->{file_in} =~ m/.+?\.([a-zA-Z]{3})$/)
 			{
 			$self->{image_format} = uc($1);
 			}
 		else
 			{
 			print("error in extracting image format at Tk::Image::Cut::SelectImage()\n");
 			$self->{canvas}->createText(10, 10,
 				-text	=> "error in extracting image format",
 				-anchor	=> "nw",
 				);
 			return;
 			}
 		$self->{image_in} = $self->Photo(
 			-file		=> $self->{file_in},
 			-format		=> $self->{image_format},
 			);
 		$self->{image_in_width} = $self->{image_in}->width();
 		$self->{image_in_height} = $self->{image_in}->height();
 		$self->{canvas}->configure(
 			-scrollregion	=> [0, 0, $self->{image_in_width}, $self->{image_in_height}],
 			);
 		$self->{canvas}->createImage(0, 0,
 			-image		=> $self->{image_in},
 			-anchor		=> "nw",
 			-tags		=> "image"
 			);
 		if(($self->{canvas}->width() < $self->{image_in_width}) or
 		($self->{canvas}->height() < $self->{image_in_height}))
 			{
 			$self->{canvas}->bind("image", "", [\&Scroll, $self, Ev('x'), Ev('y')]);
 			}
 		else
 			{
 			$self->{canvas}->bind("image", "", sub { });
 			}
 		$self->CreateAperture();
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub ImageIncrease
 	{
 	my ($self) = @_;
 	if($self->{_shrink_out} > 1) { $self->{_shrink_out}--; }
 	else { $self->{_zoom_out}++; }
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->SetImageOutName();
 	return 1;
 	}
#-------------------------------------------------
 sub ImageReduce
 	{
 	my ($self) = @_;
 	if($self->{_zoom_out} > 1) { $self->{_zoom_out}--; }
 	else { $self->{_shrink_out}++; }
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->SetImageOutName();
 	return 1;
 	}
#-------------------------------------------------
 sub ImageCut
 	{
 	my ($self) = @_;
 	my $temp_image = $self->Photo(
 		-file		=> $self->{file_in},
 		-format		=> $self->{image_format}
 		);
 	my $ref_p_out;
 	if($self->{_shape} eq "rectangle")
 		{
 		$ref_p_out = [];
 		}
 	elsif($self->{_shape} eq "oval")
 		{
		$ref_p_out = $self->GetPointsOutOval(
 			$self->{ap_x1},
 			$self->{ap_y1},
 			$self->{ap_x2},
 			$self->{ap_y2}
 			);
 		}
 	elsif($self->{_shape} eq "circle")
 		{
 		$ref_p_out = $self->GetPointsOutCircle(
 			$self->{ap_x1},
			$self->{ap_y1},
 			$self->{ap_x2},
 			$self->{ap_y2}
 			);
 		}
 	elsif($self->{_shape} eq "polygon")
 		{
 		$ref_p_out = $self->GetPointsOutPolygon(@{$self->{_points_polygon}});
 		}
 	else
 		{
 		warn("unknown picture shape\n");
 		return;
 		}
 	if(defined($self->{_color}))
 		{
 		$temp_image->put($self->{_color}, -to => $_->[0], $_->[1]) for(@{$ref_p_out});
 		}
 	else
 		{
 		$temp_image->transparencySet($_->[0], $_->[1], 1) for(@{$ref_p_out});
 		}
	$self->{image_out} = $self->Photo(
 		-format	=> $self->{image_format},
 		-width	=> $self->{_new_image_width},
 		-height	=> $self->{_new_image_height}
 		);
 	$self->{image_out}->copy($temp_image,
 		-zoom	=> $self->{_zoom_out},
 		-subsample => $self->{_shrink_out},
 		-from	=> $self->{ap_x1}, $self->{ap_y1}, $self->{ap_x2}, $self->{ap_y2},
 		-to	=> 0, 0, $self->{_new_image_width}, $self->{_new_image_height},
 		);
 	$self->{image_out}->write(
 		$self->{_new_image_name},
 		-format	=> $self->{image_format},
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub CreateAperture
 	{
 	my ($self) = @_;
 	return if(!(defined($self->{image_in})));
 	$self->DeleteBindings();
 	SWITCH:
 		{
#-------------------------------------------------
 ($self->{_shape}eq "rectangle")	&& do
 	{
 	$self->{ap_x1} = int($self->{image_in_width} / 5);
 	$self->{ap_y1} = int($self->{image_in_height} / 5);
 	$self->{ap_x2} = int($self->{image_in_width} * 0.8);
 	$self->{ap_y2} = int($self->{image_in_height} * 0.8);
 	$self->{canvas}->delete("aperture");
 	$self->{canvas}->delete("points_out");
 	$self->{aperture} = $self->{canvas}->createRectangle(
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2},
 		-outline		=> $self->{_aperturecolor},
 		-width		=> $self->{_aperturewidth},
 		-tags		=> "aperture",
 		);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->SetImageOutName();
 	$self->{canvas}->bind("aperture", "", [\&ShowCursor, $self, Ev('x'), Ev('y')]);
 	$self->{canvas}->bind(
 		"aperture",
 		"",
 		sub {
 		$self->{canvas}->itemconfigure(
 			"aperture",
 			-outline	=> "#FF0000",
 			);
 		}
 		);
 	$self->{canvas}->bind(
 		"aperture",
 		"",
 		sub { $self->{canvas}->itemconfigure(
 			"aperture",
 			-outline	=> $self->{_aperturecolor},
 			);
 		$self->{canvas}->configure(
 			-cursor		=> "arrow",
 			);
 		});
 	$self->{canvas}->bind("aperture", "", [\&StartMove, $self, Ev('x'), Ev('y')]);
 	$self->{canvas}->bind("aperture", "", [\&EndMove, $self]);
 	last(SWITCH);
 	};
#-------------------------------------------------
 ($self->{_shape} eq "oval")		&& do
 	{
 	for(qw/image aperture points_out/)
 		{
 		$self->{canvas}->bind($_, "", [\&DrawOval, $self, Ev('x'), Ev('y')]);
 		}
 	last(SWITCH);
 	};
#-------------------------------------------------
 ($self->{_shape} eq "circle")	&& do
 	{
 	for(qw/image aperture points_out/)
 		{
 		$self->{canvas}->bind($_, "", [\&DrawCircle, $self, Ev('x'), Ev('y')]);
 		}
 	last(SWITCH);
 	};
#-------------------------------------------------
 ($self->{_shape} eq "polygon")	&& do
 	{
 	for(qw/image aperture points_out/)
 		{
 		$self->{canvas}->bind($_, "", [\&DrawPolygon, $self, Ev('x'), Ev('y')]);
 		}
 	last(SWITCH);
 	};
#-------------------------------------------------
 warn("unknown picture shape\n");
 	}
 	return 1;
 	}
#-------------------------------------------------
 sub DeleteBindings
 	{
 	my ($self) = @_;
 	for my $tag (qw/
 		image
 		aperture
 		templine
 		points_out/)
 		{
 		for my $event (qw/




 			/)
 			{
 			$self->{canvas}->bind($tag, $event, sub { });
 			}
 		}
 	for(qw/ /)
 		{
 		$self->{canvas}->bind("aperture", $_, sub { });
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub StartDraw
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x1} = $canvas->canvasx($x);
 	$self->{ap_y1} = $canvas->canvasy($y);
 	$self->{canvas}->delete("aperture");
 	$self->{canvas}->delete("points_out");
 	$canvas->createOval(
 		$self->{ap_x1}, $self->{ap_y1}, $self->{ap_x1}, $self->{ap_y1},
 		-outline		=> $self->{_aperturecolor},
 		-width		=> $self->{_aperturewidth},
 		-tags		=> "aperture"
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub DrawPolygon
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	$self->{canvas}->delete("aperture");
 	$self->{canvas}->delete("points_out");
 	$self->{_point_start_templine} = $self->{_points_polygon} = [$x, $y];
 	$self->{ap_x1} = $self->{ap_x2} = $x;
 	$self->{ap_y1} = $self->{ap_y2} = $y;
 	$canvas->createLine(
 		$x, $y, $x, $y,
 		-tags		=> "templine",
 		-fill		=> "#FF0000",
 		-width		=> $self->{_aperturewidth},
 		);
 	 $canvas->createPolygon(
 			0, 0, 0, 0, 0, 0,
 			-outline		=> $self->{_aperturecolor},
 			-width		=> $self->{_aperturewidth},
 			-fill		=> "#FFFFFF",
 			-stipple		=> "gray25",
 			-tags		=> "aperture",
 			);
 	for(qw/image templine aperture/)
 		{
 		$canvas->bind($_, "", [\&MovePolygon, $self, Ev('x'), Ev('y')]);
 		$canvas->bind($_, "", [\&EndDrawPolygon, $self, Ev('x'), Ev('y')]);
 		$canvas->bind($_, "", [\&MoveTempLine, $self, Ev('x'), Ev('y')]);
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub MovePolygon
 	{
	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	push(@{$self->{_points_polygon}}, ($x, $y));
 	if($#{$self->{_points_polygon}} >= 5)
 		{
 		$canvas->coords("aperture", @{$self->{_points_polygon}});
 		}
 	else
 		{
 		$canvas->createLine(
 			@{$self->{_point_start_templine}}, $x, $y,
 			-fill		=> $self->{_aperturecolor},
 			-width		=> $self->{_aperturewidth},
 			-tags		=> "start_line",
 			);
 		}
 	$self->{_point_start_templine} = [$x, $y];
 	$canvas->coords(
 		"templine",
 		$x, $y, $x, $y
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub EndDrawPolygon
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	MovePolygon(@_);
 	for(my $i = 0; $i < $#{$self->{_points_polygon}}; $i += 2)
 		{
 		$self->{ap_x1} = $self->{_points_polygon}[$i] if($self->{_points_polygon}[$i] < $self->{ap_x1});
 		$self->{ap_y1} = $self->{_points_polygon}[$i + 1] if($self->{_points_polygon}[$i + 1] < $self->{ap_y1});
 		$self->{ap_x2} = $self->{_points_polygon}[$i] if($self->{_points_polygon}[$i] > $self->{ap_x2});
 		$self->{ap_y2} = $self->{_points_polygon}[$i + 1] if($self->{_points_polygon}[$i + 1] > $self->{ap_y2});
 		}
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->SetImageOutName();
 	my $ref_l_out = $self->GetLinesOutPolygon(@{$self->{_points_polygon}});
	for(@{$ref_l_out})
 		{
 		$canvas->createLine(
 			$_->[0], $_->[1], $_->[2], $_->[3],
 			-width		=> 1,
 			-fill		=> $self->{_color} || "#FFFFFF",
 			-tags		=> "points_out"
 			);
 		}
 	$canvas->delete("start_line");
 	$self->CreateAperture();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveTempLine
 	{
 	my ($canvas, $self, $x, $y) = @_;
	$canvas->coords(
 		"templine",
 		@{$self->{_point_start_templine}},
 		$canvas->canvasx($x),
 		$canvas->canvasy($y)
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub DrawCircle
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	StartDraw(@_);
 	for(qw/image aperture/)
 		{
 		$canvas->bind($_, "", [\&MoveCircle, $self, Ev('x'), Ev('y')]);
 		$canvas->bind($_, "", [\&EndDrawCircle, $self, Ev('x'), Ev('y')]);
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub MoveCircle
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	my $diff_x = ($x - $self->{ap_x1});
 	my $diff_y = ($y - $self->{ap_y1});
 	my $diff_max = (abs($diff_x) < abs($diff_y)) ? abs($diff_y) : abs($diff_x);
	if($diff_x < 0)
 		{
  		$self->{ap_x2} =  ($self->{ap_x1} - $diff_max);
 		}
 	else
 		{
 		$self->{ap_x2} = ($self->{ap_x1} + $diff_max);
 		}
 	if($diff_y < 0)
 		{
 		$self->{ap_y2} =  ($self->{ap_y1} - $diff_max);
 		}
 	else
 		{
 		$self->{ap_y2} =  ($self->{ap_y1} + $diff_max);
 		}
 	$canvas->coords(
 		"aperture",
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2},
 		);
 	$self->SetImageOutHeight();
 	$self->SetImageOutWidth();
 	return 1;
 	}
#-------------------------------------------------
 sub EndDrawCircle
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	MoveCircle(@_);
 	$self->SetImageOutName();
 	my ($ref_l_out) = $self->GetLinesOutCircle(
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2}
 		);
 	for(@{$ref_l_out})
 		{
 		$canvas->createLine(
 			$_->[0], $_->[1], $_->[2], $_->[3],
 			-width		=> 1,
 			-fill		=> $self->{_color} || "#FFFFFF",
 			-tags		=> "points_out"
 			);
 		}
 	$self->CreateAperture();
 	return 1;
 	}
#-------------------------------------------------
 sub DrawOval
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	StartDraw(@_);
 	for(qw/image aperture/)
 		{
 		$canvas->bind($_, "", [\&MoveOval, $self, Ev('x'), Ev('y')]);
 		$canvas->bind($_, "", [\&EndDrawOval, $self, Ev('x'), Ev('y')]);
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub MoveOval
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x2} = $canvas->canvasx($x);
 	$self->{ap_y2} = $canvas->canvasy($y);
 	$canvas->coords(
 		"aperture",
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2}
 		);
 	$self->SetImageOutHeight();
 	$self->SetImageOutWidth();
 	return 1;
 	}
#-------------------------------------------------
 sub EndDrawOval
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	MoveOval(@_);
 	$self->SetImageOutName();
 	my ($ref_l_out) = $self->GetLinesOutOval(
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2}
 		);
 	for(@{$ref_l_out})
 		{
 		$canvas->createLine(
 			$_->[0], $_->[1], $_->[2], $_->[3],
 			-width		=> 1,
 			-fill		=> $self->{_color} || "#FFFFFF",
 			-tags		=> "points_out"
 			);
 		}
 	$self->CreateAperture();
 	return 1;
 	}
#-------------------------------------------------
 sub Scroll
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	my ($part_x1, $part_x2) = $canvas->xview();
 	my ($part_y1, $part_y2) = $canvas->yview();
 	my $pos_x1 = ($self->{image_in_width} * $part_x1);
 	my $pos_x2 = ($self->{image_in_width} * $part_x2);
 	my $pos_y1 = ($self->{image_in_height} * $part_y1);
 	my $pos_y2 = ($self->{image_in_height} * $part_y2);
 	SWITCH:
 		{
 		(($x > $pos_x2) && ($y < $pos_y2))		&& do
 			{
 			$canvas->xviewScroll(1, "units");
 			last(SWITCH);
 			};
 		(($x < $pos_x1) && ($y < $pos_y2))		&& do
 			{
 			$canvas->xviewScroll(-1, "units");
 			last(SWITCH);
 			};
 		(($y > $pos_y2) && ($x < $pos_x2))		&& do
 			{
 			$canvas->yviewScroll(1, "units");
 			last(SWITCH);
 			};
 		(($y < $pos_y1) && ($x < $pos_x2))		&& do
 			{
 			$canvas->yviewScroll(-1, "units");
 			last(SWITCH);
 			};
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub ShowCursor
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	SWITCH:
 	{
 	(($x > ($self->{ap_x1} + 10))	&&
 	($x < ($self->{ap_x2} - 10))	&&
 	($y > ($self->{ap_y1} - 4))	&&
 	($y < ($self->{ap_y1} + 4)))	&& do
 		{
 		$self->{cursor_style} = "top_side";
 		last SWITCH;
 		};
 	(($x > ($self->{ap_x1} + 10))	&&
 	($x < ($self->{ap_x2} - 10))	&&
 	($y > ($self->{ap_y2} - 4))	&&
 	($y < ($self->{ap_y2} + 4)))	&& do
 		{
 		$self->{cursor_style} = "bottom_side",
 		last SWITCH;
 		};
 	(($y > ($self->{ap_y1} + 10))	&&
 	($y < ($self->{ap_y2} - 10))	&&
 	($x > ($self->{ap_x1} - 4))	&&
 	($x < ($self->{ap_x1} +4)))	&& do
 		{
 		$self->{cursor_style} = "left_side";
 		last SWITCH;
 		};
 	(($y > ($self->{ap_y1} + 10))	&&
 	($y < ($self->{ap_y2} - 10))	&&
 	($x > ($self->{ap_x2} - 4))	&&
 	($x < ($self->{ap_x2} + 4)))	&& do
 		{
 		$self->{cursor_style} = "right_side";
 		last SWITCH;
 		};
 	((($x >= $self->{ap_x1})		&&
 	($x <= ($self->{ap_x1} + 10))	&&
 	($y >= ($self->{ap_y1} - 4))		&&
 	($y <= ($self->{ap_y1} + 4)))	||
 	(($y >= $self->{ap_y1})		&&
 	($y <= ($self->{ap_y1} + 10))	&&
 	($x >= ($self->{ap_x1} - 4))		&&
 	($x <= ($self->{ap_x1} + 4))))	&& do
 		{
 		$self->{cursor_style} = "top_left_corner";
 		last SWITCH;
 		};
 	((($x <= $self->{ap_x2})		&&
 	($x >= ($self->{ap_x2} - 10))		&&
 	($y <= ($self->{ap_y1} + 4))		&&
 	($y >= ($self->{ap_y1} - 4)))		||
 	(($y >= $self->{ap_y1})		&&
 	($y <= ($self->{ap_y1} + 10))	&&
 	($x <= ($self->{ap_x2} + 4))		&&
 	($x >= ($self->{ap_x2} - 4))))	&& do
 		{
 		$self->{cursor_style} = "top_right_corner";
 		last SWITCH;
 		};
 	((($y >= ($self->{ap_y2} - 10))	&&
 	($y <= $self->{ap_y2})		&&
 	($x <= ($self->{ap_x1} + 4))		&&
 	($x >= ($self->{ap_x1} - 4)))		||
 	(($x >= $self->{ap_x1})		&&
 	($x <= ($self->{ap_x1} + 10))	&&
 	($y <= ($self->{ap_y2} + 4))		&&
 	($y >= ($self->{ap_y2} - 4))))	&& do
 		{
 		$self->{cursor_style} = "bottom_left_corner";
 		last SWITCH;
 		};
 	((($x <= $self->{ap_x2})		&&
 	($x >= ($self->{ap_x2} - 10))		&&
 	($y <= ($self->{ap_y2} + 4))		&&
 	($y >= ($self->{ap_y2} - 4)))		||
 	(($y <= $self->{ap_y2})		&&
 	($y >= ($self->{ap_y2} - 10))		&&
 	($x <= ($self->{ap_x2} + 4))		&&
 	($x >= ($self->{ap_x2} - 4))))	&& do
 		{
 		$self->{cursor_style} = "bottom_right_corner";
 		last SWITCH;
 		};
 	$self->{cursor_style} = "arrow";
 	}
 	$self->{canvas}->configure(
 		-cursor		=> $self->{cursor_style},
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub StartMove
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	SWITCH:
 	{
 	($self->{cursor_style} eq "top_side")		&& do
 		{
 		$canvas->bind("aperture", "", [\&MoveUpperLine, $self, Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "bottom_side")		&& do
 		{
 		$canvas->bind("aperture", "", [\&MoveUnderLine, $self, Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "left_side")			&& do
 		{
 		$canvas->bind("aperture", "", [\&MoveLeftLine, $self, Ev('x')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "right_side")		&& do
 		{
 		$canvas->bind("aperture", "", [\&MoveRightLine, $self, Ev('x')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "top_left_corner")		&& do
 		{
 		$canvas->bind("aperture", "", [\&MoveUpperLeftCorner, $self, Ev('x'), Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "top_right_corner")		&& do
 		{
 		$canvas->bind("aperture", "", [\&MoveUpperRightCorner, $self, Ev('x'), Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "bottom_left_corner")	&& do
 		{
 		$canvas->bind("aperture", "", [\&MoveUnderLeftCorner, $self, Ev('x'), Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "bottom_right_corner")	&& do
 		{
 		$canvas->bind("aperture", "", [\&MoveUnderRightCorner, $self, Ev('x'), Ev('y')]);
 		last SWITCH;
 		};
 	$canvas->bind("aperture", "", sub { });
 	}
 	return 1;
 	}
#-------------------------------------------------
 sub EndMove
 	{
 	my ($canvas, $self) = @_;
 	$canvas->bind("aperture", "", [\&ShowCursor, $self, Ev('x'), Ev('y')]);
 	$self->SetImageOutName();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUpperLine
 	{
 	my ($canvas, $self, $y) = @_;
 	$self->{ap_y1} = $canvas->canvasy($y);
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUnderLine
 	{
 	my ($canvas, $self, $y) = @_;
 	$self->{ap_y2} = $canvas->canvasy($y);
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveLeftLine
 	{
 	my($canvas, $self, $x) = @_;
 	$self->{ap_x1} = $canvas->canvasx($x);
 	$self->SetImageOutWidth();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveRightLine
 	{
 	my ($canvas, $self, $x) = @_;
 	$self->{ap_x2} = $canvas->canvasx($x);
 	$self->SetImageOutWidth();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUpperLeftCorner
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x1} = $canvas->canvasx($x);
 	$self->{ap_y1} = $canvas->canvasy($y);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUpperRightCorner
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x2} = $canvas->canvasx($x);
 	$self->{ap_y1} = $canvas->canvasy($y);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#--------------------------------------------------
 sub MoveUnderLeftCorner
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x1} = $canvas->canvasx($x);
 	$self->{ap_y2} = $canvas->canvasy($y);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUnderRightCorner
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x2} = $canvas->canvasx($x);
 	$self->{ap_y2} = $canvas->canvasy($y);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub Move
 	{
 	my ($self) = @_;
 	 $self->{canvas}->coords(
 		"aperture",
		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2},
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub SetImageOutWidth
 	{
 	my ($self) = @_;
 	($self->{ap_x1}, $self->{ap_x2}) = ($self->{ap_x2}, $self->{ap_x1}) if($self->{ap_x1} > $self->{ap_x2});
 	($self->{ap_y1}, $self->{ap_y2}) = ($self->{ap_y2}, $self->{ap_y1}) if($self->{ap_y1} > $self->{ap_y2});
 	$self->{_new_image_width} =
 		int(
 		($self->{ap_x2} - $self->{ap_x1} + 1) *
 		($self->{_zoom_out} / $self->{_shrink_out})
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub SetImageOutHeight
 	{
 	my ($self) = @_;
 	($self->{ap_x1}, $self->{ap_x2}) = ($self->{ap_x2}, $self->{ap_x1}) if($self->{ap_x1} > $self->{ap_x2});
 	($self->{ap_y1}, $self->{ap_y2}) = ($self->{ap_y2}, $self->{ap_y1}) if($self->{ap_y1} > $self->{ap_y2});
 	$self->{_new_image_height} =
 		int(
 		($self->{ap_y2} - $self->{ap_y1} + 1) *
 		($self->{_zoom_out} / $self->{_shrink_out})
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub SetImageOutName
 	{
 	my ($self) = @_;
 	$self->{file_in} =~ m/(.+?)(\.\w{3,4})$/;
 	$self->{_new_image_name} = $1 . '_' . $self->{_new_image_width} . 'X' . $self->{_new_image_height} . $2;
 	return 1;
 	}
#-------------------------------------------------
 sub SetShape
 	{
 	my ($self) = @_;
 	SWITCH:
 		{
 		($self->{_shape} eq "rectangle")	&& do
 			{
 			$self->{button_color}->configure(
 				-state		=> "disabled"
 				);
 			$self->CreateAperture();
 			last(SWITCH);
 			};
 		(($self->{_shape} eq "oval") or
 		($self->{_shape} eq "circle") or
 		($self->{_shape} eq "polygon"))	&& do
 			{
 			$self->{canvas}->delete("aperture");
 			$self->{canvas}->delete("points_out");
 			$self->{button_color}->configure(
 				-state		=> "normal"
 				);
 			$self->CreateAperture();
 			last(SWITCH);
 			};
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub SelectColor
 	{
 	my ($self) = @_;
 	$self->{_color} = undef;
 	$self->{_color} = $self->chooseColor();
 	$self->{canvas}->itemconfigure(
 		"points_out",
 		-fill		=> $self->{_color} || "#FFFFFF"
 		);
 	return 1;
 	}
#-------------------------------------------------
1;
#-------------------------------------------------
__END__