home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _95b3e64f58d2f855c7b218606f4af038 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.0 KB  |  164 lines
  1. package Tk::Font;
  2. use vars qw($VERSION);
  3. $VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Font.pm#4 $
  4. require Tk::Widget;
  5. use strict;
  6. use Carp;
  7. use overload '""' => 'as_string';
  8. sub as_string { return ${$_[0]} }
  9.  
  10. *MainWindow = \&Tk::Widget::MainWindow;
  11.  
  12. foreach my $key (qw(actual metrics measure configure))
  13.  {
  14.   no strict 'refs';
  15.   *{$key} = sub { shift->Tk::font($key,@_) };
  16.  }
  17.  
  18. Construct Tk::Widget 'Font';
  19.  
  20. my @xfield  = qw(foundry family weight slant swidth adstyle pixel
  21.                point xres yres space avgwidth registry encoding);
  22. my @tkfield = qw(family size weight slant underline overstrike);
  23. my %tkfield = map { $_ => "-$_" } @tkfield;
  24.  
  25. sub _xonly { my $old = '*'; return $old }
  26.  
  27. sub Pixel
  28. {
  29.  my $me  = shift;
  30.  my $old = $me->configure('-size');
  31.  $old = '*' if ($old > 0);
  32.  if (@_)
  33.   {
  34.    $me->configure(-size => -$_[0]);
  35.   }
  36.  return $old;
  37. }
  38.  
  39. sub Point
  40. {
  41.  my $me  = shift;
  42.  my $old = 10*$me->configure('-size');
  43.  $old = '*' if ($old < 0);
  44.  if (@_)
  45.   {
  46.    $me->configure(-size => int($_[0]/10));
  47.   }
  48.  return $old;
  49. }
  50.  
  51. foreach my $f (@tkfield,@xfield)
  52.  {
  53.   no strict 'refs';
  54.   my $sub = "\u$f";
  55.   unless (defined &{$sub})
  56.    {
  57.     my $key = $tkfield{$f};
  58.     if (defined $key)
  59.      {
  60.       *{$sub} = sub { shift->configure($key,@_) };
  61.      }
  62.     else
  63.      {
  64.       *{$sub} = \&_xonly;
  65.      }
  66.    }
  67.  }
  68.  
  69. sub new
  70. {
  71.  my $pkg  = shift;
  72.  my $w    = shift;
  73.  my $me;
  74.  if (scalar(@_) == 1)
  75.   {
  76.    $me = $w->Tk::font('create',@_);
  77.   }
  78.  else
  79.   {
  80.    croak 'Odd number of args' if @_ & 1;
  81.    my %attr;
  82.    while (@_)
  83.     {
  84.      my $k = shift;
  85.      my $v = shift;
  86.      my $t = (substr($k,0,1) eq '-') ? $k : $tkfield{$k};
  87.      if (defined $t)
  88.       {
  89.        $attr{$t} = $v;
  90.       }
  91.      elsif ($k eq 'point')
  92.       {
  93.        $attr{'-size'} = -int($v/10+0.5);
  94.       }
  95.      elsif ($k eq 'pixel')
  96.       {
  97.        $attr{'-size'} = -$v;
  98.       }
  99.      else
  100.       {
  101.        carp "$k ignored" if $^W;
  102.       }
  103.     }
  104.    $me = $w->Tk::font('create',%attr);
  105.   }
  106.  return bless $me,$pkg;
  107. }
  108.  
  109. sub Pattern
  110. {
  111.  my $me  = shift;
  112.  my @str;
  113.  foreach my $f (@xfield)
  114.   {
  115.    my $meth = "\u$f";
  116.    my $str  = $me->$meth();
  117.    if ($f eq 'family')
  118.     {
  119.      $str =~ s/(?:Times\s+New\s+Roman|New York)/Times/i;
  120.      $str =~ s/(?:Courier\s+New|Monaco)/Courier/i;
  121.      $str =~ s/(?:Arial|Geneva)/Helvetica/i;
  122.     }
  123.    elsif ($f eq 'slant')
  124.     {
  125.      $str = substr($str,0,1);
  126.     }
  127.    elsif ($f eq 'weight')
  128.     {
  129.      $str = 'medium' if ($str eq 'normal');
  130.     }
  131.    push(@str,$str);
  132.   }
  133.  return join('-', '', @str);
  134. }
  135.  
  136. sub Name
  137. {
  138.  my $me  = shift;
  139.  return $$me if (!wantarray || ($^O eq 'MSWin32'));
  140.  my $max = shift || 128;
  141.  my $w = $me->MainWindow;
  142.  my $d = $w->Display;
  143.  return $d->XListFonts($me->Pattern,$max);
  144. }
  145.  
  146. sub Clone
  147. {
  148.  my $me = shift;
  149.  return ref($me)->new($me,$me->actual,@_);
  150. }
  151.  
  152. sub ascent
  153. {
  154.  return shift->metrics('-ascent');
  155. }
  156.  
  157. sub descent
  158. {
  159.  return shift->metrics('-descent');
  160. }
  161.  
  162. 1;
  163.  
  164.