diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Font.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Font.pm | 163 |
1 files changed, 0 insertions, 163 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Font.pm b/Master/tlpkg/tlperl/lib/Tk/Font.pm deleted file mode 100644 index bb1b52cc7c5..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/Font.pm +++ /dev/null @@ -1,163 +0,0 @@ -package Tk::Font; -use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Font.pm#4 $ -require Tk::Widget; -use strict; -use Carp; -use overload '""' => 'as_string'; -sub as_string { return ${$_[0]} } - -*MainWindow = \&Tk::Widget::MainWindow; - -foreach my $key (qw(actual metrics measure configure)) - { - no strict 'refs'; - *{$key} = sub { shift->Tk::font($key,@_) }; - } - -Construct Tk::Widget 'Font'; - -my @xfield = qw(foundry family weight slant swidth adstyle pixel - point xres yres space avgwidth registry encoding); -my @tkfield = qw(family size weight slant underline overstrike); -my %tkfield = map { $_ => "-$_" } @tkfield; - -sub _xonly { my $old = '*'; return $old } - -sub Pixel -{ - my $me = shift; - my $old = $me->configure('-size'); - $old = '*' if ($old > 0); - if (@_) - { - $me->configure(-size => -$_[0]); - } - return $old; -} - -sub Point -{ - my $me = shift; - my $old = 10*$me->configure('-size'); - $old = '*' if ($old < 0); - if (@_) - { - $me->configure(-size => int($_[0]/10)); - } - return $old; -} - -foreach my $f (@tkfield,@xfield) - { - no strict 'refs'; - my $sub = "\u$f"; - unless (defined &{$sub}) - { - my $key = $tkfield{$f}; - if (defined $key) - { - *{$sub} = sub { shift->configure($key,@_) }; - } - else - { - *{$sub} = \&_xonly; - } - } - } - -sub new -{ - my $pkg = shift; - my $w = shift; - my $me; - if (scalar(@_) == 1) - { - $me = $w->Tk::font('create',@_); - } - else - { - croak 'Odd number of args' if @_ & 1; - my %attr; - while (@_) - { - my $k = shift; - my $v = shift; - my $t = (substr($k,0,1) eq '-') ? $k : $tkfield{$k}; - if (defined $t) - { - $attr{$t} = $v; - } - elsif ($k eq 'point') - { - $attr{'-size'} = -int($v/10+0.5); - } - elsif ($k eq 'pixel') - { - $attr{'-size'} = -$v; - } - else - { - carp "$k ignored" if $^W; - } - } - $me = $w->Tk::font('create',%attr); - } - return bless $me,$pkg; -} - -sub Pattern -{ - my $me = shift; - my @str; - foreach my $f (@xfield) - { - my $meth = "\u$f"; - my $str = $me->$meth(); - if ($f eq 'family') - { - $str =~ s/(?:Times\s+New\s+Roman|New York)/Times/i; - $str =~ s/(?:Courier\s+New|Monaco)/Courier/i; - $str =~ s/(?:Arial|Geneva)/Helvetica/i; - } - elsif ($f eq 'slant') - { - $str = substr($str,0,1); - } - elsif ($f eq 'weight') - { - $str = 'medium' if ($str eq 'normal'); - } - push(@str,$str); - } - return join('-', '', @str); -} - -sub Name -{ - my $me = shift; - return $$me if (!wantarray || ($^O eq 'MSWin32')); - my $max = shift || 128; - my $w = $me->MainWindow; - my $d = $w->Display; - return $d->XListFonts($me->Pattern,$max); -} - -sub Clone -{ - my $me = shift; - return ref($me)->new($me,$me->actual,@_); -} - -sub ascent -{ - return shift->metrics('-ascent'); -} - -sub descent -{ - return shift->metrics('-descent'); -} - -1; - |