view release on metacpan or  search on metacpan

lib/Tk/StyledButton.pm  view on Meta::CPAN

	my ($xl, $yl, $w, $h) = $self->bbox($textid);

#print join(', ', $self->cget('-text'), $xl, $yl, $w, $h), "\n";
	$w -= $xl;
	$h -= $yl;
	$self->delete($textid);

print "Text bbox: $xl, $yl, $w, $h\n"
	if $self->{_debug};

	return $vert ? ($h, $w) : ($w, $h);
}
#
#	compute start/end position of underline
#	NOTE: we have no way to do this since justify
#	could position us; ideally we could switch to
#	underlined font for 1 character, but canvas
#	text doesn't support that very well either
#
sub _underlineText {
	my $self = shift;
	my $ulch = $self->cget('-underline');

	croak "Invalid -underline option $ulch"
		unless (length($ulch) == 1);

	my $pos = index($self->cget('-text'), $ulch);
	return undef
		unless ($pos >= 0);

	return undef;
}
#
#	get binding coordinates
#
sub _getBindCoords {
	my ($self, $w, $h) = @_;
	my $shape = $self->cget('-shape');

	if ($shape eq 'oval') {
		my @lhtags = _computePolyPoints(0, 0, $h, $h);
		my @rhtags = _computePolyPoints($w - $h, 0, $w, $h);
		return [ @lhtags[6..19], @rhtags[18..23], @rhtags[0..7] ];
	}

	my $orient = $self->cget('-orient');
	my $vert = (($shape eq 'bevel') || ($shape eq 'folio')) &&
		((substr($orient, 0, 1) eq 'w') || (substr($orient, 0, 1) eq 'e'));

	return [
		($shape eq 'round')		? _computePolyPoints(0, 0, $w, $h) :
		($shape eq 'rectangle') ? _drawRectangle($w,$h) :
		($shape eq 'bevel')		? _drawBevel($w,$h, 6, $orient) :
#		($shape eq 'folio')
								  _drawFolio($w,$h, 6, $orient) ];
}

sub _bindFromImage {
	my ($self, $w, $h, $xscale, $yscale) = @_;
#
#	embed image in center of canvas, then draw transparent overlay
#	to tag for binding
#
	my @tags = ();
	my $shape = $self->cget('-shape');
	if (($self->cget('-style') eq 'image') && (ref $shape) && (ref $shape eq 'ARRAY')) {
#
#	binding coords are provided
#
		@tags = @$shape;
	}
	elsif ($shape eq 'round') {
		push @tags, $self->createPolygon(_computePolyPoints(0, 0, $w, $h),
			-fill => 'white',
			-stipple => 'transparent');
	}
	elsif (($shape eq 'rectangle') || ($shape eq 'bevel') || ($shape eq 'folio')) {
		my $orient = $self->cget('-orient');
		my $vert = ((index($orient, 'w') == 0) || (index($orient, 'e') == 0));

		my @endpts =
			($shape eq 'rectangle')	? _drawRectangle($w,$h) :
			($shape eq 'bevel')		? _drawBevel($w, $h, 6, $orient) :
									_drawFolio($w, $h, 6, $orient);

		@endpts = $self->_rotateShape($w, @endpts)
			if $vert;

		push @tags, $self->createPolygon(@endpts,
			-fill => 'white',
			-stipple => 'transparent');
	}
	else { # ($shape eq 'oval')
#
#	compute offsets to the rectangle, and arc info for the ends
#	arcs overlap the rectangle; its more than needed, but gets the job done
#
		push @tags,
			$self->createRectangle($h, 0, $w - $h, $h,
				-outline => '',
				-fill => 'white',
				-stipple => 'transparent'),
			$self->createPolygon(_computePolyPoints(0, 0, $h, $h),
				-fill => 'white',
				-stipple => 'transparent'),
			$self->createPolygon(_computePolyPoints($w - $h, 0, $w, $h),
				-fill => 'white',
				-stipple => 'transparent');
	}
#
#	returns a transparent group bound to our events
#
	$self->{_bind_group} = $self->createGroup(0,0, -members => \@tags);
#
#	move everybody a tad
#
	$self->move($self->{_idle_group}, 2, 2);
	$self->move($self->{_active_group}, 2, 2);
	$self->move($self->{_bind_group}, 2, 2);
#
#	bind to bind group only