Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

Re: Tk: Set text size in a widget

by rcseege (Pilgrim)
on Nov 13, 2005 at 08:28 UTC ( #508082=note: print w/replies, xml ) Need Help??


in reply to Tk: Set text size in a widget

The posted code was interesting (++) - thanks for posting it. I played with it for a bit, and tried a few different things. It serves as a convenient way to highlight some minor issues with Tk's Font handling. As the snippet is written right now, I wouldn't suggest using it as an event handler. If it is called whenever Label is resized, it will introduce a small memory leak.

The code in this post was only tested on a Windows installation. I'd be interested to hear if it works differently on other platforms.

Every time $widget->Font is called in Tk, a new Font object is created and stored for the MainWindow. These font objects stay around for the life of the application unless explicitly deleted. The following code shows several fonts getting created:

use Tk; use Tk::Font; my $mw = MainWindow->new; my $l = $mw->Label; foreach (1 .. 10) { $l->Font } print "Fonts: " . join(",", $l->fontNames) . "\n";

All of the fonts created by the above are distinct instances consisting of the same attributes. On the surface this may seem strange. You might think it would be better if the Class was smart enough to detect that there was already a font with the same attributes, and return a reference to an existing one instead of creating another one, and indeed Tk::Font objects are available to be reused.

Using this feature, you can change the font used by many widgets by reconfiguring the font object that they all share. The next script illustrates this. This is not always be a desirable behavior so Tk leaves the management of reusable fonts to you.

use Tk; use Tk::Font; my $mw = MainWindow->new; my $font = $mw->Font(-size => 12); foreach (1 .. 10) { $mw->Label( -text => "Test", -font => $font )->pack; } $mw->Button( -text => "Enlarge Font", -command => sub { my $size = $font->configure('-size'); $font->configure(-size => ($size + 1)); } )->pack; MainLoop;

The Tk::Font class was intended to wrap all fonts used in Tk and provide an OO interface to create fonts in a platform independant way and query or modify their attributes. It works, but a bit imperfectly. Try running the following code:

use Tk; use Tk::Font; my $mw = MainWindow->new; print "Using Default Label Font:\n"; my $label = $mw->Label; printFontInfo($label); print "Using default Tk::Font:\n"; my $font = $label->Font; $label->configure(-font => $font); printFontInfo($label); print "Using custom Tk::Font\n"; $font = $label->Font(-family => 'Times'); $label->configure(-font => $font); printFontInfo($label); print "Using custom font:\n"; $label->configure(-font => "Arial"); printFontInfo($label); sub printFontInfo { my $w = shift; my $font = $w->cget('-font'); print "Name: $font\n"; print "Atrr: " . join(",", $font->actual) . "\n"; print "Fonts: " . join(",", $w->fontNames) . "\n\n"; }

Notice the differences in the information printed out by the printFontInfo sub. See how when $label->Font was used, it created a font that was registered and accessible using fontNames. Also, notice how the default Label font and the default font created by $label->Font are different.

If you are not repeatedly creating fonts, and are always specifying your own default, you may be thinking 'So What?' If you are using a lot of Tk::Font methods then you may have another problem: A consequence of the fonts not being "registered" is that some of the Tk::Font methods will not work correctly. If you added the following line to the printFontInfo sub:

print "Size: " . $font->configure('-size') . "\n";

And tried to run the code again it would fail, because it couldn't locate the font in the first case. Comment out the first case, and the the script will fail again on the fourth case -- again unable to find the font.

I mentioned these other details to put my revision of your code into context. I tried using it as is, and one problem I ran into was getting a resize event. In order to be notified of a resize, I bound Configure, after failing with ResizeRequest (I believe ResizeRequest may have been disabled). Configure is an ugly event to bind to because it tends to get called a lot. It resulted in my $font and label growing continuously until it reached some upper limit for the font. I'd be curious to see how you bound the event handler.

The following script uses a minor revision of your snippet, renamed ResizeText. Try experimenting with different ways of specifying the font. Some fonts seem to work better than others. Note that I didn't spend much time on reducing the amount of times that ResizeText gets called. A better implementation would check to ensure that the height or width really changed before resizing the font.

use Tk; use Tk::Font; my $mw = MainWindow->new; my $label = $mw->Label( -text => "Hello", -font => "Times 12" )->pack(-expand => 1, -fill => 'both'); $label->bind('<Configure>', \&ResizeText); MainLoop; sub ResizeText { my ($widget) = @_; $widget->bind('<Configure>', ""); ## Check to see if the font is "registered" ## so that we can use Tk::Font methods reliably my $knownFont = 0; my $font = $widget->cget('-font'); foreach my $f ($widget->fontNames()) { if ($$f eq $$font) { $knownFont = 1; last; } } ## If we're dealing with an unregistered font we ## could run into problems, so it's safest to create ## a new font based off the unregistered fonts attrs. ## Otherwise, reuse the existing font rather than ## recreating a new one. unless($knownFont) { $font = $widget->Font($font->actual); $widget->configure(-font => $font); } my $widthF = $font->measure($widget->cget('-text')); my $heightF = $font->metrics('-linespace'); my $xRatio = $widget->width / $widthF; my $yRatio = $widget->height / $heightF; my $minRatio = $xRatio < $yRatio ? $xRatio : $yRatio; my $fontSize = $font->actual('-size'); $font->configure(-size => ($minRatio * $fontSize)); $widget->update; $widget->bind('<Configure>', \&ResizeText); }

Updated: Removed useless line: my $called = 0; which I ended up not needing, and forgot to remove it. Served no purpose in the script.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://508082]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (2)
As of 2021-10-22 06:44 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My first memorable Perl project was:







    Results (85 votes). Check out past polls.

    Notices?