view release on metacpan or  search on metacpan

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

	$vert ?
		$btnimg->filledRectangle(0,0,$yh - 1,$xh - 1, $transparent) :
		$btnimg->filledRectangle(0,0,$xh - 1,$yh - 1, $transparent);

	unless ($style eq 'image') {
#
#	must explicitly allocate colors for GD,
#	so we'll create a map of the slotted color strings
#	to their GD index...and add the transparent color
#	must have a GD image object to allocate
#	NOTE: may need to alloc for text ??
#
		($colors, $lcolors, $offsets, $top, $bottom, $white, $black) =
			$self->_getColorMap($xh - 2, $yh - 2, $r, $g, $b);

		foreach (@$colors) {
#
#	make sure we don't collide transparent with existing
#
			$gdcolors{sprintf('#%04X%04X%04X', @$_)} =
				$btnimg->colorAllocate(
					($_->[0] >> 8) & 0xFF,
					($_->[1] >> 8) & 0xFF,
					($_->[2] >> 8) & 0xFF),
			next
				unless (($_->[0] == 256) && ($_->[1] == 256) && ($_->[2] == 256));
#
#	preserve original key since we've alreayd computed
#	the line colors based on the original
#
			$gdcolors{'#010001000100'} = $btnimg->colorAllocate(1, 1, 2),
		}
#
#	use midpt as base color
#
		$midpt = (scalar @$colors) >> 1;
		$basecolor = $gdcolors{sprintf('#%04X%04X%04X', @{$colors->[$midpt]})};
#
#	now xlate any line colors to the indexes
#
		$lcolors->[$_] = $gdcolors{$lcolors->[$_]}
			foreach (0..$#$lcolors);

		$textfactor = ((substr($orient, 1, 1) eq 'e') || (substr($orient, 1, 1) eq 's')) ? 1.2 : 0.8
			if ($shape eq 'bevel');
		@endpts =
			($shape eq 'rectangle') ? _drawRectangle($xh - 2, $yh - 2, $curve) :
			($shape eq 'bevel') ? _drawBevel($xh, $yh, $curve, $orient) :
			($shape eq 'folio') ? _drawFolio($xh, $yh, $curve, $orient) :
			();
	}

	if ($style eq 'image') {
#
#	create from an image; r, g, b are xscale, yscale, and the image,
#	respectively
#
		my $format = $b->cget('-format');
		my $data = $b->data(-format => $format);
		my $bgimg = ($format eq 'GIF') ? GD::Image->newFromGif($data) :
			($format eq 'PNG') ? GD::Image->newFromPng($data) :
			GD::Image->newFromJpeg($data); # ($format eq 'JPEG')

		if (($r == 1) && ($g == 1)) {
			$btnimg->copy($bgimg, 2, 2, 0, 0, $bgimg->width, $bgimg->height);
		}
		else {
			$btnimg->copyResampled($bgimg, 2, 2, 0, 0,
				$btnimg->width - 2, $btnimg->height - 2,
				$bgimg->width, $bgimg->height);
		}
	}
	elsif ($shape eq 'round') {
		my $extent = 180;
		my $start = 270;
#
#	get the closest to black and grey
#
		$black = $btnimg->colorClosest(0,0,0);
		my $grey = $btnimg->colorClosest(64, 64, 64);

		$btnimg->filledEllipse($xh>>1, $yh>>1, $xh, $yh, $basecolor);

		unless ($style eq 'flat') {
			$btnimg->ellipse($xh>>1, $yh>>1, $xh - 1, $yh - 2, $grey);
			$btnimg->ellipse($xh>>1, $yh>>1, $xh - 3, $yh - 4, $black);
#			$btnimg->ellipse($xh>>1, $yh>>1, $xh - 5, $yh - 6, $grey);
#			$btnimg->ellipse($xh>>1, $yh>>1, $xh - 7, $yh - 8, $grey);

			my ($cx, $cy) = (($xh - $xl)>>1, ($yh - $yl)>>1);
			$yl += 3;
			$yh -= 3;
			$xl += 3;
			$xh -= 3;
			my ($byl, $byh)  = ($yl, $yh);
			my $i = 0;
			while (($i < scalar @$lcolors) && ($yh - $yl > 0)) {
				$btnimg->arc($cx, $cy, $xh, $yh, 180, 360, $$lcolors[4+$i++]);
				$yl++; $yh--;

				$i++, next
					unless ($i%6 == 1);

				$btnimg->arc($cx, $cy, $xh, $byh, 20, 160, $$lcolors[$i++]);
				$byl++; $byh--;
			}
		}
	}
	elsif ($shape eq 'oval') {
#
#	this should be optimized to use a brush...
#
		$btnimg->line(
			$offsets->[$_ - $bottom], $_,
			$xh - $offsets->[$_ - $bottom], $_,
			shift @$lcolors),
		$btnimg->line(
			$offsets->[$_ - $bottom], $_,
			$offsets->[$_ - $bottom] + 2, $_,
			$basecolor),
		$btnimg->line(