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;