home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _3aa8893bc8a207ab4d9ab45f433de694 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.2 KB  |  185 lines
  1. package Tk::X11Font;
  2. use vars qw($VERSION);
  3. $VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/X11Font.pm#7 $
  4.  
  5. require Tk::Widget;
  6. require Tk::Xlib;
  7. use strict;
  8.  
  9. Construct Tk::Widget 'X11Font';
  10.  
  11. my @field = qw(foundry family weight slant swidth adstyle pixel
  12.                point xres yres space avgwidth registry encoding);
  13.  
  14. map { eval "sub \u$_ { shift->elem('$_', \@_) }" } @field;
  15.  
  16. use overload '""' => 'as_string';
  17.  
  18. sub new
  19. {
  20.  my $pkg = shift;
  21.  my $w   = shift;
  22.  
  23.  my %me = ();
  24.  my $d  = $w->Display;
  25.  
  26.  local $_;
  27.  
  28.  if(scalar(@_) == 1)
  29.   {
  30.    my $pattern = shift;
  31.  
  32.    if($pattern =~ /\A(-[^-]*){14}\Z/)
  33.     {
  34.      @me{@field} = split(/-/, substr($pattern,1));
  35.     }
  36.    else
  37.     {
  38.      $me{Name} = $pattern;
  39.  
  40.      if($pattern =~ /^[^-]?-([^-]*-){2,}/)
  41.       {
  42.        my $f = $d->XListFonts($pattern,1);
  43.  
  44.        if($f && $f =~ /\A(-[^-]*){14}/)
  45.         {
  46.          my @f = split(/-/, substr($f,1));
  47.          my @n = split(/-/, $pattern);
  48.          my %f = ();
  49.          my $i = 0;
  50.  
  51.          shift @n if($pattern =~ /\A-/);
  52.  
  53.          while(@n && @f)
  54.           {
  55.            if($n[0] eq '*')
  56.             {
  57.              shift @n;
  58.             }
  59.            elsif($n[0] eq $f[0])
  60.             {
  61.              $f{$field[$i]} = shift @n;
  62.             }
  63.            $i++;
  64.            shift @f;
  65.           }
  66.  
  67.          %me = %f
  68.            unless(@n);
  69.         }
  70.       }
  71.     }
  72.   }
  73.  else
  74.   {
  75.    %me = @_;
  76.   }
  77.  
  78.  map { $me{$_} ||= '*' } @field;
  79.  
  80.  $me{Display} = $d;
  81.  $me{MainWin} = $w->MainWindow;
  82.  
  83.  bless \%me, $pkg;
  84. }
  85.  
  86. sub Pattern
  87. {
  88.  my $me  = shift;
  89.  return join('-', '',@{$me}{@field});
  90. }
  91.  
  92. sub Name
  93. {
  94.  my $me  = shift;
  95.  my $max = wantarray ? shift || 128 : 1;
  96.  
  97.  if ($^O eq 'MSWin32' or ($^O eq 'cygwin' and $Tk::platform eq 'MSWin32'))
  98.   {
  99.    my $name = $me->{Name};
  100.    if (!defined $name)
  101.     {
  102.      my $fm  = $me->{'family'} || 'system';
  103.      my $sz  = -int($me->{'point'}/10) || -($me->{'pixel'}) || 12;
  104.      my @opt = (-family => $fm, -size => $sz );
  105.      my $wt  = $me->{'weight'};
  106.      if (defined $wt)
  107.       {
  108.        $wt = 'normal' unless $wt =~ /bold/i;
  109.        push(@opt,-weight => lc($wt));
  110.       }
  111.      my $sl  = $me->{'slant'};
  112.      if (defined $sl)
  113.       {
  114.        $sl = ($sl =~ /^[io]/) ? 'italic' : 'roman';
  115.        push(@opt,-slant => $sl);
  116.       }
  117.      $name = join(' ',@opt);
  118.     }
  119.    return $name;
  120.   }
  121.  else
  122.   {
  123.    my $name = $me->{Name} ||
  124.               join('-', '',@{$me}{@field});
  125.    return $me->{Display}->XListFonts($name,$max);
  126.   }
  127. }
  128.  
  129. sub as_string
  130. {
  131.  return shift->Name;
  132. }
  133.  
  134. sub elem
  135. {
  136.  my $me   = shift;
  137.  my $elem = shift;
  138.  
  139.  return undef
  140.    if(exists $me->{'Name'});
  141.  
  142.  my $old  = $me->{$elem};
  143.  
  144.  $me->{$elem} = shift
  145.    if(@_);
  146.  
  147.  $old;
  148. }
  149.  
  150. sub Clone
  151. {
  152.  my $me = shift;
  153.  
  154.  $me = bless { %$me }, ref($me);
  155.  
  156.  unless(exists $me->{'Name'})
  157.   {
  158.    while(@_)
  159.     {
  160.      my $k = shift;
  161.      my $v = shift || $me->{MainWin}->BackTrace('Tk::Font->Clone( key => value, ... )');
  162.      $me->{$k} = $v;
  163.     }
  164.   }
  165.  
  166.  $me;
  167. }
  168.  
  169. sub ascent
  170. {
  171.  my $me = shift;
  172.  my $name = $me->Name;
  173.  $me->{MainWin}->fontMetrics($name, '-ascent');
  174. }
  175.  
  176. sub descent
  177. {
  178.  my $me = shift;
  179.  my $name = $me->Name;
  180.  $me->{MainWin}->fontMetrics($name, '-descent');
  181. }
  182.  
  183. 1;
  184.  
  185.