summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/X11Font.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/X11Font.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11Font.pm184
1 files changed, 184 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11Font.pm b/Master/tlpkg/tlperl/lib/Tk/X11Font.pm
new file mode 100644
index 00000000000..870dfd4b7dc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11Font.pm
@@ -0,0 +1,184 @@
+package Tk::X11Font;
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/X11Font.pm#7 $
+
+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;
+