Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / X11Font.pm

package Tk::X11Font;
use vars qw($VERSION);
$VERSION = '3.013'; # $Id: //depot/Tk8/Tk/X11Font.pm#13 $

require Tk::Widget;
require Tk::Xlib;
use strict;

Construct Tk::Widget 'X11Font';

my @field = qw(foundry family weight slant swidth adstyle pixel
              point xres yres space avgwidth registry encoding);

map { eval "sub \u$_ { shift->elem('$_', \@_) }" } @field;

use overload '""' => 'as_string';

sub new
{
my $pkg = shift;
my $w   = shift;

my %me = ();
my $d  = $w->Display;

local $_;

if(scalar(@_) == 1)
 {
  my $pattern = shift;

  if($pattern =~ /\A(-[^-]*){14}\Z/)
   {
    @me{@field} = split(/-/, substr($pattern,1));
   }
  else
   {
    $me{Name} = $pattern;

    if($pattern =~ /^[^-]?-([^-]*-){2,}/)
     {
      my $f = $d->XListFonts($pattern,1);

      if($f && $f =~ /\A(-[^-]*){14}/)
       {
        my @f = split(/-/, substr($f,1));
        my @n = split(/-/, $pattern);
        my %f = ();
        my $i = 0;

        shift @n if($pattern =~ /\A-/);

        while(@n && @f)
         {
          if($n[0] eq '*')
           {
            shift @n;
           }
          elsif($n[0] eq $f[0])
           {
            $f{$field[$i]} = shift @n;
           }
          $i++;
          shift @f;
         }

        %me = %f
          unless(@n);
       }
     }
   }
 }
else
 {
  %me = @_;
 }

map { $me{$_} ||= '*' } @field;

$me{Display} = $d;
$me{MainWin} = $w->MainWindow;

bless \%me, $pkg;
}

sub Pattern
{
my $me  = shift;
return join('-', '',@{$me}{@field});
}

sub Name
{
my $me  = shift;
my $max = wantarray ? shift || 128 : 1;

if ($^O eq 'MSWin32' or ($^O eq 'cygwin' and $Tk::platform eq 'MSWin32'))
 {
  my $name = $me->{Name};
  if (!defined $name)
   {
    my $fm  = $me->{'family'} || 'system';
    my $sz  = -int($me->{'point'}/10) || -($me->{'pixel'}) || 12;
    my @opt = (-family => $fm, -size => $sz );
    my $wt  = $me->{'weight'};
    if (defined $wt)
     {
      $wt = 'normal' unless $wt =~ /bold/i;
      push(@opt,-weight => lc($wt));
     }
    my $sl  = $me->{'slant'};
    if (defined $sl)
     {
      $sl = ($sl =~ /^[io]/) ? 'italic' : 'roman';
      push(@opt,-slant => $sl);
     }
    $name = join(' ',@opt);
   }
  return $name;
 }
else
 {
  my $name = $me->{Name} ||
             join('-', '',@{$me}{@field});
  return $me->{Display}->XListFonts($name,$max);
 }
}

sub as_string
{
return shift->Name;
}

sub elem
{
my $me   = shift;
my $elem = shift;

return undef
  if(exists $me->{'Name'});

my $old  = $me->{$elem};

$me->{$elem} = shift
  if(@_);

$old;
}

sub Clone
{
my $me = shift;

$me = bless { %$me }, ref($me);

unless(exists $me->{'Name'})
 {
  while(@_)
   {
    my $k = shift;
    my $v = shift || $me->{MainWin}->BackTrace('Tk::Font->Clone( key => value, ... )');
    $me->{$k} = $v;
   }
 }

$me;
}

sub ascent
{
my $me = shift;
my $name = $me->Name;
$me->{MainWin}->fontMetrics($name, '-ascent');
}

sub descent
{
my $me = shift;
my $name = $me->Name;
$me->{MainWin}->fontMetrics($name, '-descent');
}

1;