File Coverage

blib/lib/Tk/Win32RotLabel.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package Tk::Win32RotLabel;

our $VERSION = 0.4;

use Tk;
use Tk::widgets qw/Label/;
use base qw/Tk::Derived Tk::Label/;
use Win32::API;

use strict;
use Carp;

our (
     $CreateFont,
     $SelectObject,
     $DeleteObject,
     $GetDC,
     $ReleaseDC,
     $ExtTextOut,
     $GetTextExtent,
     $SetBkColor,
     $SetTextColor,

     %configured,
    );

Construct Tk::Widget 'Win32RotLabel';

# load the proper Win32::API suroutines at init.
sub ClassInit {
  my ($class, $mw) = @_;

  $class->SUPER::ClassInit($mw);

  $CreateFont    = new Win32::API('gdi32' , 'CreateFont',   [('N') x 13,
							     'P'], 'N');
  $SelectObject  = new Win32::API('gdi32' , 'SelectObject', [qw/N N/], 'N');
  $DeleteObject  = new Win32::API('gdi32' , 'DeleteObject', ['P'], 'I');
  $GetDC         = new Win32::API('user32', 'GetDC',        ['N'], 'N');
  $ReleaseDC     = new Win32::API('user32', 'ReleaseDC',    [qw/N N/], 'I');
  $ExtTextOut    = new Win32::API('gdi32' , 'ExtTextOut',   [qw/N I I N P P
							     I P/], 'I');
  $GetTextExtent = new Win32::API('user32', 'GetTabbedTextExtent', [qw/N P N
								    N P/], 'I');
  $SetBkColor    = new Win32::API('gdi32', 'SetBkColor', [qw/N N/], 'N');
  $SetTextColor  = new Win32::API('gdi32', 'SetTextColor', [qw/N N/], 'N');
}

sub Populate {
  my ($w, $args) = @_;

  # clean up any images the user adds .. that's not the point.
  delete $args->{-image};
  $args->{-bitmap} = 'transparent';

  $w->SUPER::Populate($args);

  $w->ConfigSpecs(
    -angle        => [qw/METHOD angle Angle/, 0],
    -text         => [qw/METHOD text Text/, ''],
    -textvariable => [qw/METHOD textvariabel Textvariable/, undef],
    -font         => [qw/PASSIVE font Font/, ['Times New Roman']],
   );

  my $top = $w->toplevel;
  unless ($configured{$top}) {
    $top->bind(''  => [\&_updateDescendants, $top]);
    $configured{$top} = 1;
  }
}

sub angle {
  my ($w, $a) = @_;

  if (defined $a) {
    # should check if it's numeric .. TBD
    $a = 0   if $a < 0;
    $a = 360 if $a > 360;

    $w->{ANGLE} = $a;
  }
  $w->{ANGLE};
}
sub text {
  my ($w, $t) = @_;

  if (defined $t) {
    $w->{TEXT} = $t;
  }
  $w->{TEXT};
}

sub textvariable {
  my ($w, $tv) = @_;

  if (defined $tv) {
    $w->{TEXTV} = $tv;
  }
  $w->{TEXTV};
}

sub configure {
  my $w = shift;
  $w->SUPER::configure(@_);

  # update label if there is anything worthy.
  my %a = @_;
  $w->_updateMe if $a{-text} || $a{-textvariable} || $a{-font} || $a{-angle};
}

# called by the top level.
# simply called _updateMe for every descendant Win32RotLabel widget.
sub _updateDescendants {
  my $m = shift;

  ref $_ eq 'Tk::Win32RotLabel' && $_->_updateMe for $m->children;
}

# this method draws the text.
sub _updateMe {
  my $w = shift;
  return unless $w->toplevel->ismapped;

  # first off, get the background and foreground colors
  # in rgb syntax.
  my $depth = $w->screendepth;
  my @vis   = $w->visualsavailable;
  my $bg    = $w->cget('-bg');
  my $fg    = $w->cget('-fg') || 'black';
  my @bgRGB = $w->rgb($bg);
  my @fgRGB = $w->rgb($fg);

  $_ = int(255 * $_ / 65535) for @bgRGB, @fgRGB;

  # Tk    uses #RGB
  # Win32 uses #BGR ... don't ask me why.
  my $wbg   = sprintf "0x%02X%02X%02X" => reverse @bgRGB;
  my $wfg   = sprintf "0x%02X%02X%02X" => reverse @fgRGB;

  # get the angle.
  my $angle = $w->{ANGLE};

  # get the font object.
  my $fontO  = $w->cget('-font');
  my $family = $w->fontActual($fontO, '-family');
  my $size   = $w->fontActual($fontO, '-size');
  my $weight = $w->fontActual($fontO, '-weight');
  my $slant  = $w->fontActual($fontO, '-slant');
  my $uline  = $w->fontActual($fontO, '-underline');
  my $strike = $w->fontActual($fontO, '-overstrike');

  # get the device context.
  $w->update;
  my $id  = eval($w->id);
  my $hdc = $GetDC->Call($id);

  # create the logical font.
  my $font = $CreateFont->Call(int($size * 108 / 72),  # by trial and error
          0, $angle * 10, 0,
          ($weight eq 'normal' ? 400 : 700),
          ($slant  eq 'roman'  ?   0 :   1),
          $uline,
          $strike,
          0, 0, 0, 0, 0,
          $family);

  # select the font into the device context.
  my $old = $SelectObject->Call($hdc, $font);

  # set the bg/fg colors.
  $SetBkColor  ->Call($hdc, eval $wbg);
  $SetTextColor->Call($hdc, eval $wfg);

  # get the text string.
  my $text;
  if (defined $w->{TEXTV} && ref($w->{TEXTV}) eq 'SCALAR') {
    $text = ${$w->{TEXTV}};
  } else {
    $text = $w->{TEXT};
  }
  my $len = length $text;

  # get the extent of the text.
  my $r = $GetTextExtent->Call($hdc, $text, $len, 0, 0);
  my $y = $r >> 16;
  my $x = $r & 65535;

  # calculate the desired size of the label.
  my $cos = abs(cos $angle * 3.14159 / 180);
  my $sin = abs(sin $angle * 3.14159 / 180);

  my $W = $x * $cos + $y * $sin;
  my $H = $y * $cos + $x * $sin;

  $w->configure(-width  => $W,
		-height => $H);

  $w->update;

  # get actual size.
  $W = $w->reqwidth;
  $H = $w->reqheight;

  # determine the location of the text.
  my ($X, $Y) = (0, 0);
  if ($angle <= 90) {
    $Y = $x * $sin;
  } elsif ($angle <= 180) {
    $Y = $H;
    $X = $x * $cos;
  } elsif ($angle <= 270) {
    $X = $W;
    $Y = $H - $x * $sin;
  } else {
    $X = $W - $x * $cos;
  }
  # dump out the text.
  $ExtTextOut->Call(
      $hdc,
      int $X,
      int $Y,
      0,
      0,
      $text, $len,
      0
     );

  # clean up.
  $SelectObject->Call($hdc, $old);
  $DeleteObject->Call($font);
  $ReleaseDC   ->Call($id, $hdc);
}

__END__