summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Font.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Font.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Font.pm163
1 files changed, 163 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Font.pm b/Master/tlpkg/tlperl/lib/Tk/Font.pm
new file mode 100644
index 00000000000..bb1b52cc7c5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Font.pm
@@ -0,0 +1,163 @@
+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;
+