perlboy_emeritus has asked for the wisdom of the Perl Monks concerning the following question:

Greetings Monks, happy whatever each of you personally celebrate at this time of year.

The sample code, "fontviewer", I am including herein is not mine. I lifted it almost verbatim from "Mastering Perl/Tk", by Lidie and Walsh. The publisher offers a tar-ball for download of the book's source code. This example is from chapter 3. My mods, except for the unsuccessful hacking I did to get -underline and -overstrike to work are purely cosmetic. I chose font family Noteworthy solely to get a font that was instantly recognizable for what it is, rather than the generic font Tk chooses when it can't find the one you asked for. I call your attention to the sub: 

&apply_font

therein is the problem. I have tried numerous hacks, all fail, to get -underline and -overstrike to work. They take True/False values and the associated CheckBoxes send either 0 or 1. Interestingly, the book code itself, what I have labeled "style 2" does not work. Only the un-commented out anonymous array works, marginally. Any attempts to add -underline and/or -overstrike expressions to that array cause failure in one form or another. Can anyone make those two font style options work? BTW: the widget demo that comes with Tk has an example where those two styles work with Courier. I am using Perl 5.36, Tk 804.036 in macOS 12.7.1. Thanks for any help.

#!/usr/bin/env -S perl
##!/usr/bin/env -S perl -d

use Tk;
use strict;
use warnings;
use v5.36;      # not actually necessary, but it's what I run.

require Tk::BrowseEntry;

my $mw = MainWindow->new(-title => 'Font Viewer');

my $f = $mw->Frame->pack(-side => 'top');

my $family = 'Noteworthy';

my $be = $f->BrowseEntry(
    -label     => "Family:", 
    -variable  => \$family, 
    -browsecmd => \&apply_font,
)->pack(-fill => 'x', -side => 'left');
$be->insert('end', sort $mw->fontFamilies);

my $size = 20;

my $bentry = $f->BrowseEntry(
    -label     => 'Size',
    -variable  => \$size, 
    -browsecmd => \&apply_font,
)->pack(-side => 'left');
$bentry->insert('end', (3 .. 32));

my $weight = "normal";
$f->Checkbutton(
    -onvalue  => "bold",
    -offvalue => "normal",
    -text     => "Weight",
    -variable => \$weight,
    -command  => \&apply_font,
)->pack(-side => 'left');

my $slant = "roman";
$f->Checkbutton(
    -onvalue  => "italic",
    -offvalue => "roman", 
    -text     => "Slant",
    -variable => \$slant, 
    -command  => \&apply_font,
)->pack(-side => 'left');

my $underline = 0;
$f->Checkbutton(
    -text     => "Underline",
    -variable => \$underline,
    -command  => \&apply_font,
)->pack(-side => 'left');

my $overstrike = 0; 
$f->Checkbutton(
    -text     => "Overstrike",
    -variable => \$overstrike, 
    -command  => \&apply_font,
)->pack(-side => 'left');

my $stext = "Sample Text, 1234567890, ABCDEF abcdef";
my $sample = $mw->Entry(-textvariable => \$stext)->pack(-fill => 'x');

$mw->Button(-text => 'Quit',
    -command => sub { $mw->destroy() },
    -relief  => 'raised',
)->pack(-side => 'top', -ipadx => 5, -ipady => 5, -pady => 10);

&apply_font;

MainLoop;

sub apply_font {
    $sample->configure(-font => 
        [ $family, $size, $weight, $slant, ],
# style 1 [ -family => $family, -size => $size, -weight => $weight, -s
+lant => $slant, ],
# style 2 [ -family     => $family,
#           -size       => $size,
#           -weight     => $weight,
#           -slant      => $slant,
#           -underline  => $underline,
#           -overstrike => $overstrike,
#         ],
    );
    warn "\$family:     $family";
    warn "\$underline:  $underline";
    warn "\$overstrike: $overstrike";
}

[download]

Replies are listed 'Best First'.
Re: Tk -font options configuration failing
by choroba (Cardinal) on Dec 25, 2023 at 19:31 UTC
    Interestingly, it seems to be a problem in Perl (or rather its XS interface), not the underlying tk. I wrote these two similar programs, one in Perl and one in Python: 
    #!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

use Tk;

my $w = 'MainWindow'->new;
my $t = $w->Label(-text => 'Sample', -font => ['Arial', 20, 'bold', 'u
+nderline'])->pack;
say ${ $t->cget('-font') };
MainLoop();

    [download]

    #!/usr/bin/python3
from tkinter import Tk, Label

w = Tk()
t = Label(text="Sample",font=['Arial', 20, 'bold', 'underline'])
t.pack()
print(t.cget('font'))
w.mainloop()

    [download]

    Both of them output 

    Arial 20 bold underline

    [download]
    but only the Python one has the text actually underlined.

    map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
[reply]
[d/l]
[select]
      The mystery continues...
      Your Tk code works correctly on my machine. I guess a release broke something along the way.

      This is perl 5, version 24, subversion 3 (v5.24.3) built for MSWin32-x
+64-multi-thread
(with 1 registered patch, see perl -V for more detail)

      [download]
      Tk version 804.034
[reply]
[d/l]
[select]

      Hello friend Monks;

      Hacking Perl/Tk is, or can be, challenging, depending on so many factors, least of which is the totally confusing documentation. Many changes and improvements to Tk are poorly documented, with limited examples, and tutorials are rudimentary. I'd like to see a 2nd ed of "Mastering Perl/Tk" that updates Tkx, ttk and themes, but it seems Python, as ugly as it is, has eclipsed Perl. If I were younger I'd take a stab at writing a successor to that otherwise fine book. Not being one to give up easily, here be a working Tkx program that implements an improved font viewer that permits changing a named font dynamically. This works for classic widgets rather than themed widgets, but in this example I chose to mix classic and ttk widgets, just to prove a point. The key, of course, is using a named font. Comments, please?

      #!/usr/bin/env -S perl
##!/usr/bin/env -S perl -d

use warnings;
use strict;
use v5.36;
use Tkx qw/MainLoop/;       # can import many more widgets: syntactic 
+sugar

my $mw = Tkx::widget->new(".",);
$mw->g_wm_title( 'Tkx/ttk Font Viewer',);
$mw->g_wm_minsize(320, 200);

my $f = $mw->new_ttk__frame();

my $_lab0 = $f->new_label(-text => 'Families', -width => 16,
    -font => 'courier',
);

my $_lab1 = $f->new_label(-text => 'Size ', -width => 10,
    -font => 'courier',
);

#
# Defaults
#
my $family     = 'Helvetica';
my $weight     = 'normal';
my $slant      = 'roman';
my $size       = 14;
my $underline  = 'off';
my $overstrike = 'off';

my $cbox1 = $f->new_ttk__combobox(
    -values       => [3 .. 32],
    -textvariable => \$size,
    -width        => '6',
    -height       => '10',
);

#
# Remove duplicate font names
#
my %fonts;
my @fonts;
foreach ( Tkx::SplitList( Tkx::font_families() )) {
#   say $_;
    push (@fonts, $_) unless $fonts{$_}++;
}

my $cbox0 = $f->new_ttk__combobox(
    -values       => [ sort @fonts ],
    -textvariable => \$family,
    -height       => '20',          # number of rows to display
);

my $_bQuit = $f->new_button(        # classic button
#my $_bQuit = $f->new_ttk__button(  # themed (Aqua) button; '__' == ':
+:'
    -text    => 'Quit',
    -relief  => 'raised',
    -width   => 10,
    -command => sub { Tkx::destroy("."); }
);

#
# Let's create a named font from defaults...
#
my $fontName = Tkx::font_create('PerlboysNewFont', -family => $family,
#my $fontName = $mw->Tkx::font_create( -family => $family,
    -size       => $size,
    -weight     => $weight,
    -slant      => $slant,
    -underline  => $underline,
    -overstrike => $overstrike,
);
say $fontName;
say "Named fonts: ${\Tkx::font_names()}";

#
# Here be how we change the named font dynamically...
#
my $apply_font = sub {
    say "Font selected: '$family' $size $weight $slant $underline $ove
+rstrike";
    $fontName->Tkx::font_configure(
        -family     => $family,
        -size       => $size,
        -weight     => $weight,
        -slant      => $slant,
        -underline  => $underline,
        -overstrike => $overstrike,
    );
};

$cbox0->Tkx::bind('<<ComboboxSelected>>', $apply_font );
$cbox1->Tkx::bind('<<ComboboxSelected>>', $apply_font );

my $stext = "Sample Text, ABCDEFghijkl, 1234567890";
my $sample = $f->new_tk__entry(-textvariable => \$stext,
    -width  => '38',
    -relief => 'sunken',
    -font   => $fontName,   # the point is to use the named font :-)
);

my $_cbWgt = $f->new_tk__checkbutton(
    -onvalue  => 'bold',
    -offvalue => 'normal',
    -text     => 'Weight',
    -variable => \$weight,
    -command  => $apply_font,
);

my $_cbSlant = $f->new_tk__checkbutton(
    -onvalue  => 'italic',
    -offvalue => 'roman', 
    -text     => 'Slant',
    -variable => \$slant, 
    -command  => $apply_font,
);

my $_cbUL = $f->new_tk__checkbutton(
    -text     => 'Underline',
    -onvalue  => 'on',
    -offvalue => 'off',
    -variable => \$underline,
    -command  => $apply_font,
);

my $_cbOverStrk = $f->new_tk__checkbutton(
    -text     => 'Overstrike',
    -onvalue  => 'on',
    -offvalue => 'off',
    -variable => \$overstrike, 
    -command  => $apply_font,
);

Tkx::grid("$f");
Tkx::grid("$_lab0", "$_lab1", -sticky => 'ew',);
Tkx::grid("$cbox0", "$cbox1", -sticky => 'ew',
    -ipadx => '2', -ipady => '4', -padx => 5, -pady => 5,);
Tkx::grid("$_cbWgt", "$_cbSlant",   -sticky => 'ew',);
Tkx::grid("$_cbUL", "$_cbOverStrk", -sticky => 'ew',);
Tkx::grid("$sample", -columnspan => '2',
    -ipadx => '2', -ipady => '4', -padx => 5, -pady => 5,);
Tkx::grid("$_bQuit", '-',);

MainLoop;

say "Here be the place to perform any post-MainLoop processing...";

exit(0);
__END__

      [download]

      Happy New Year, one and all. Perhaps this one will be better than the last, which was awful... The four horsemen are winning.

      U P D A T E: 01/01/2024

      The code as posted works but there is a subtle semantic error that compromises the robustness and scalability of the examples, specifically re the creation of a named font. The code

      my $fontName = $mw->Tkx::font_create( -family => $family,

      [download]

      yields a named font named '.'. This because the call to 'Tcl font create', 'Tkx::' becomes 'Tcl ', was from $mw. In essence, the create step used the Tcl pathName of the main window to name the new font. If you then try to create a second named font Tcl will attempt to also name it '.', which will result in a fatal error. The correct way to create a named font in Tkx with a unique name is:

      my $fontName = Tkx::font_create('PerlboysNewFont', -family => $family,

      [download]

      If you then interrogate the list of named fonts with:

      say $fontName;
say "Named fonts: ${\Tkx::font_names()}";

      [download]

      you will see in macOS something like:

        PerlboysNewFont
  Named fonts: TkCaptionFont PerlboysNewFont TkSmallCaptionFont TkTooltipFont TkFixedFont
  TkHeadingFont TkMenuFont TkIconFont TkTextFont TkDefaultFont

      I have taken the liberty of correcting the posted code for those who may download it in the future.

      Will

[reply]
[d/l]
[select]

Back to Seekers of Perl Wisdom