home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Font.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  3.7 KB  |  234 lines
  1. #
  2.  
  3. package Tk::Font;
  4.  
  5. =head1 NAME
  6.  
  7. Tk::Font - a class for finding X Fonts
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.  use Tk::Font;
  12.  
  13.  $font = $widget->Font(foundry => 'adobe',
  14.                        family  => 'times',
  15.                        point   => 120
  16.                       );
  17.  
  18.  $font = $widget->Font('*-courier-medium-r-normal-*-*');
  19.  
  20. =head1 DESCRIPTION
  21.  
  22.    This module can be use to interrogate the X server what fonts are
  23.    avaliable.
  24.  
  25. =head1 METHODS
  26.  
  27. =head2 Foundry( [ $val ] )
  28.  
  29. =head2 Family( [ $val ] )
  30.  
  31. =head2 Weight( [ $val ] )
  32.  
  33. =head2 Slant( [ $val ] )
  34.  
  35. =head2 Swidth( [ $val ] )
  36.  
  37. =head2 Adstyle( [ $val ] )
  38.  
  39. =head2 Pixel( [ $val ] )
  40.  
  41. =head2 Point( [ $val ] )
  42.  
  43. =head2 Xres( [ $val ] )
  44.  
  45. =head2 Yres( [ $val ] )
  46.  
  47. =head2 Space( [ $val ] )
  48.  
  49. =head2 Avgwidth( [ $val ] )
  50.  
  51. =head2 Registry( [ $val ] )
  52.  
  53. =head2 Encoding( [ $val ] )
  54.  
  55. Set the given field in the font name to C<$val> if given and return the current
  56. or previous value
  57.  
  58. =head2 Name( [ $max ] )
  59.  
  60. In a list context it returns a list of all font names that match the
  61. fields given. It will return a maximum of C<$max> names, or 128 if
  62. $max is not given.
  63.  
  64. In a scalar contex it returns the first matching name or undef
  65.  
  66. =head2 Clone( [ key => value, [ ...]] )
  67.  
  68. Create a duplicate of the curent font object and modify the given fields
  69.  
  70. =head1 AUTHOR
  71.  
  72. Graham Barr <Graham.Barr@tiuk.ti.com>
  73.  
  74. =head1 HISTORY
  75.  
  76. 11-Jan-96 Initial version
  77.  
  78. =head1 COPYRIGHT
  79.  
  80. Copyright (c) 1995-1996 Graham Barr. All rights reserved. This program is free
  81. software; you can redistribute it and/or modify it under the same terms
  82. as Perl itself.
  83.  
  84. =cut
  85.  
  86. require Tk::Widget;
  87. require Tk::Xlib;
  88. use strict;
  89.  
  90. Construct Tk::Widget 'Font';
  91.  
  92. my @field = qw(foundry family weight slant swidth adstyle pixel
  93.                point xres yres space avgwidth registry encoding);
  94.  
  95. map { eval "sub \u$_ { shift->elem('$_', \@_) }" } @field;
  96.  
  97. use overload '""' => 'as_string';
  98.  
  99. sub new
  100. {
  101.  my $pkg = shift;
  102.  my $w   = shift;
  103.  
  104.  my %me = ();
  105.  my $d  = $w->Display;
  106.  
  107.  local $_;
  108.  
  109.  if(scalar(@_) == 1)
  110.   {
  111.    my $pattern = shift;
  112.  
  113.    if($pattern =~ /\A(-[^-]*){14}\Z/)
  114.     {
  115.      @me{@field} = split(/-/, substr($pattern,1));
  116.     }
  117.    else
  118.     {
  119.      $me{Name} = $pattern;
  120.   
  121.      if($pattern =~ /^[^-]?-([^-]*-){2,}/)
  122.       {
  123.        my $f = $d->XListFonts($pattern,1);
  124.     
  125.        if($f && $f =~ /\A(-[^-]*){14}/)
  126.         {
  127.          my @f = split(/-/, substr($f,1));
  128.          my @n = split(/-/, $pattern);
  129.          my %f = ();
  130.          my $i = 0;
  131.     
  132.          shift @n if($pattern =~ /\A-/);
  133.   
  134.          while(@n && @f)
  135.           {
  136.            if($n[0] eq '*')
  137.             {
  138.              shift @n;
  139.             }
  140.            elsif($n[0] eq $f[0])
  141.             {
  142.              $f{$field[$i]} = shift @n;
  143.             }
  144.            $i++;
  145.            shift @f;
  146.           }
  147.  
  148.          %me = %f
  149.            unless(@n);
  150.         }
  151.       }
  152.     }
  153.   }
  154.  else
  155.   {
  156.    %me = @_;
  157.   }
  158.  
  159.  map { $me{$_} ||= '*' } @field;
  160.  
  161.  $me{Display} = $d;
  162.  $me{MainWin} = $w->MainWindow;
  163.  
  164.  bless \%me, $pkg;
  165. }
  166.  
  167. sub Name
  168. {
  169.  my $me  = shift;
  170.  my $max = wantarray ? shift || 128 : 1;
  171.  
  172.  my $name = $me->{Name} ||
  173.             join("-", "",@{$me}{@field});
  174.  
  175.  $me->{Display}->XListFonts($name,$max);
  176. }
  177.  
  178. sub as_string
  179. {
  180.  return shift->Name;
  181. }
  182.  
  183. sub elem
  184. {
  185.  my $me   = shift;
  186.  my $elem = shift;
  187.  
  188.  return undef
  189.    if(exists $me->{'Name'});
  190.  
  191.  my $old  = $me->{$elem};
  192.  
  193.  $me->{$elem} = shift
  194.    if(@_);
  195.  
  196.  $old;
  197. }
  198.  
  199. sub Clone
  200. {
  201.  my $me = shift;
  202.  
  203.  $me = bless { %$me }, ref($me);
  204.  
  205.  unless(exists $me->{'Name'})
  206.   {
  207.    while(@_)
  208.     {
  209.      my $k = shift;
  210.      my $v = shift || $me->{MainWin}->BackTrace('Tk::Font->Clone( key => value, ... )');
  211.      $me->{$k} = $v;
  212.     }
  213.   }
  214.  
  215.  $me;
  216. }
  217.  
  218. sub ascent
  219. {
  220.  my $me = shift;
  221.  my $name = $me->Name;
  222.  $me->{MainWin}->FontAscent($name);
  223. }
  224.  
  225. sub descent
  226. {
  227.  my $me = shift;
  228.  my $name = $me->Name;
  229.  $me->{MainWin}->FontDescent($name);
  230. }
  231.  
  232. 1;
  233.  
  234.