Tk-FontDialog-0.18/000755 001750 001750 00000000000 13064412634 014667 5ustar00eserteeserte000000 000000 Tk-FontDialog-0.18/MANIFEST000644 001750 001750 00000000374 13064412635 016025 0ustar00eserteeserte000000 000000 Changes lib/Tk/FontDialog.pm MANIFEST MANIFEST.SKIP Makefile.PL README t/00-basic.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Tk-FontDialog-0.18/t/000755 001750 001750 00000000000 13064412634 015132 5ustar00eserteeserte000000 000000 Tk-FontDialog-0.18/MANIFEST.SKIP000644 001750 001750 00000000166 12251161772 016571 0ustar00eserteeserte000000 000000 Tk-FontDialog-.*\.tar\.gz$ Makefile Makefile.old ^blib pm_to_blib ^\.git($|/) ^\.gitignore$ ^MYMETA\. ^\.travis\.yml$ Tk-FontDialog-0.18/Changes000644 001750 001750 00000003040 13064412500 016147 0ustar00eserteeserte000000 000000 Revision history for Perl extension Tk::FontDialog. 0.18 2017-03-22 - no real code changes, just fixes for perlcritic and cpants issues (by viviparous and Mohammad S Anwar) 0.17 - no code changes, just a test fix 0.16 - no code changes, just a minor Pod fix (RT #51766) and changed the repo address to github 0.15 - more non-latin1 samples - test script more robust, check for DISPLAY first 0.14 - fixed Makefile.PL problem under Windows (RT #29425) 0.13 - -altsample: do not display range from codepoint 128 to 160 rather display some non-latin1 samples 0.12 - new method Tk::Widget::GetDescriptiveFontName - InsertFamilies: ttf seem to need explicite size setting (visible in nicefonts) 0.11 - introduced FontGetPoints, needed for Tk804.xxx (font sizes are now in pixels, not in points) - more documentation (RefontTree, examples) - some GUI cleanup by Martin Thurn 0.10 - fixed test error if "if.pm" is not available (thanks Jack!) - canvas scrollregion fix 0.09 - cancel waitVariable if dialog is destroyed - test now in BATCH mode per default 0.08 - fix for Windows (noticed by Sheri) 0.07 - PREREQ_PM was missing in Makefile.PL - fixed failure when *font was not defined in the option database 0.06 - new options: -fixedfont, -fixedfontsbutton, -nicefontsbutton 0.04 - internationalization - solved problems with empty family names and dots in family names - cursor changes to watch for InsertFamilies 0.03 - some minor fixes 0.01 Sun Aug 23 02:21:15 1998 - original version; created by h2xs 1.18 Tk-FontDialog-0.18/lib/000755 001750 001750 00000000000 13064412634 015435 5ustar00eserteeserte000000 000000 Tk-FontDialog-0.18/README000644 001750 001750 00000000476 11777613521 015565 0ustar00eserteeserte000000 000000 Tk::FontDialog Module Tk::FontDialog is a font chooser for perl/Tk. Version 800 of Tk is required. To install, type $ perl Makefile.PL $ make $ make test $ make install "env BATCH=0 make test" starts a test window and serves as an example script. Send bug reports, comments and suggestions to slaven@rezic.de Tk-FontDialog-0.18/Makefile.PL000644 001750 001750 00000003044 12774005435 016646 0ustar00eserteeserte000000 000000 use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. my $eumm_recent_enough = $ExtUtils::MakeMaker::VERSION >= 6.54; if (!$eumm_recent_enough) { *MY::dist_core = sub { <<'EOF'; dist : $(NOECHO) $(ECHO) "Sorry, use a newer EUMM!" EOF }; } WriteMakefile( 'NAME' => 'Tk::FontDialog', 'VERSION_FROM' => 'lib/Tk/FontDialog.pm', # finds $VERSIO 'ABSTRACT_FROM' => 'lib/Tk/FontDialog.pm', 'MIN_PERL_VERSION' => 5.004, 'PREREQ_PM' => {'Tk' => 800}, 'dist' => {'POSTOP'=>'-$(CHMOD) 644 $(DISTVNAME).tar$(SUFFIX)'}, ($eumm_recent_enough ? (META_MERGE => { resources => { repository => 'git://github.com/eserte/tk-fontdialog.git' }, }) : () ), ); sub MY::postamble { my($MY) = @_; my $postamble = ""; if ($MY && UNIVERSAL::can($MY, "oneliner")) { my $demo_oneliner = $MY->oneliner("use blib; use Tk; use Tk::FontDialog; tkinit->FontDialog->Show"); $postamble = <FontDialog->Show' EOF } if (defined $ENV{USER} && $ENV{USER} eq 'eserte' && $^O =~ /bsd/i && -f "../../perl.release.mk") { $postamble .= <<'EOF'; # Test::Distribution complains about Tk::Font which is part of Tk PERL_TEST_DISTRIBUTION_OPTS=not podcover,prereq .include "../../perl.release.mk" .include "../../perl.git.mk" EOF } $postamble; } Tk-FontDialog-0.18/META.yml000644 001750 001750 00000001042 13064412634 016135 0ustar00eserteeserte000000 000000 --- abstract: 'a font dialog widget for perl/Tk' author: - unknown build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Tk-FontDialog no_index: directory: - t - inc requires: Tk: 800 perl: 5.004 resources: repository: git://github.com/eserte/tk-fontdialog.git version: 0.18 Tk-FontDialog-0.18/META.json000644 001750 001750 00000001750 13064412634 016313 0ustar00eserteeserte000000 000000 { "abstract" : "a font dialog widget for perl/Tk", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Tk-FontDialog", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Tk" : "800", "perl" : "5.004" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "git://github.com/eserte/tk-fontdialog.git" } }, "version" : "0.18" } Tk-FontDialog-0.18/lib/Tk/000755 001750 001750 00000000000 13064412634 016013 5ustar00eserteeserte000000 000000 Tk-FontDialog-0.18/lib/Tk/FontDialog.pm000644 001750 001750 00000060114 13064412545 020402 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # # Copyright (C) 1998,1999,2003,2004,2005,2010,2011,2013,2017 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: slaven@rezic.de # WWW: http://www.rezic.de/eserte/ # package Tk::FontDialog; use Tk 800; # new font function, Tk::ItemStyle use Tk::Font; use strict; use vars qw($VERSION @ISA); @ISA = qw(Tk::Toplevel); Construct Tk::Widget 'FontDialog'; $VERSION = '0.18'; sub Populate { my($w, $args) = @_; require Tk::HList; require Tk::ItemStyle; $w->SUPER::Populate($args); $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]); $w->withdraw; if (exists $args->{-font}) { $w->optionAdd('*font' => delete $args->{-font}); } my $dialog_font; my $font_name = $w->optionGet("font", "*"); if (!defined $font_name) { my $l = $w->Label; $dialog_font = $w->fontCreate($w->fontActual($l->cget(-font))); $l->destroy; } else { $dialog_font = $w->fontCreate($w->fontActual($font_name)); } if (exists $args->{-initfont}) { $w->{'curr_font'} = $w->fontCreate($w->fontActual (delete $args->{-initfont})); } else { $w->{'curr_font'} = $dialog_font; } my $bold_font = $w->fontCreate($w->fontActual($dialog_font), -weight => 'bold'); my $italic_font = $w->fontCreate($w->fontActual($dialog_font), -slant => 'italic'); my $underline_font = $w->fontCreate($w->fontActual($dialog_font), -underline => 1); my $overstrike_font = $w->fontCreate($w->fontActual($dialog_font), -overstrike => 1); my $f1 = $w->Frame->pack(-expand => 1, -fill => 'both', -padx => 2, -pady => 2); my $ffam = $f1->Frame->pack(-expand => 1, -fill => 'both', -padx => 2, -side => 'left'); my $fsize = $f1->Frame->pack(-expand => 0, -fill => 'y', -padx => 2, -side => 'left'); my $fstyle = $f1->Frame->pack(-expand => 0, -fill => 'both', -side => 'left'); my(%family_res) = _get_label(delete $args->{'-familylabel'} || '~Family:'); $ffam->Label (@{$family_res{'args'}}, -font => $bold_font, )->pack(-anchor => 'w'); my $famlb = $ffam->Scrolled ('HList', -scrollbars => 'osoe', -selectmode => 'single', -bg => 'white', -browsecmd => sub { my $family = $w->{'family_index'}[$_[0]]; $w->UpdateFont(-family => $family) }, )->pack(-expand => 1, -fill => 'both', -anchor => 'w'); $w->Advertise('family_list' => $famlb); my(%size_res) = _get_label(delete $args->{'-sizelabel'} || '~Size:'); $fsize->Label (@{$size_res{'args'}}, -font => $bold_font, )->pack(-anchor => 'w'); my $sizelb = $fsize->Scrolled ('HList', -scrollbars => 'oe', #-font => 'System 14', XXX this is MSWin32 specific -width => 4, -bg => 'white', -selectmode => 'single', -browsecmd => sub { $w->UpdateFont(-size => $_[0]) }, )->pack(-expand => 1, # Expand vertically but keep width constant: -fill => 'y', -anchor => 'w'); $w->Advertise('size_list' => $sizelb); $sizelb->bind("<3>" => [ $w, '_custom_size' ]); my @fontsizes; if (exists $args->{-fontsizes}) { @fontsizes = @{ delete $args->{-fontsizes} }; } else { @fontsizes = qw(0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 33 34 36 40 44 48 50 56 64 72); } my $curr_size = $w->FontGetPoints($w->fontActual($w->{'curr_font'}, -size)); foreach my $size (@fontsizes) { $sizelb->add($size, -text => $size); if ($size == $curr_size) { $sizelb->selectionSet($size); $sizelb->anchorSet($size); $sizelb->see($size); } } my %hs_checkbox_pack_args = ( -anchor => 'w', -expand => 0, -padx => 3, -pady => 3, # -fill => 'x', ); # This Label is above the style buttons: $fstyle->Label->pack; my $fstyle2 = $fstyle->Frame->pack(-side => 'top'); my(%weight_res) = _get_label(delete $args->{-weightlabel} || '~Bold'); my $weight = $w->fontActual($w->{'curr_font'}, -weight); my $wcb = $fstyle2->Checkbutton (-variable => \$weight, -font => $bold_font, -onvalue => 'bold', -offvalue => 'normal', @{$weight_res{'args'}}, -command => sub { $w->UpdateFont(-weight => $weight) } )->pack(%hs_checkbox_pack_args); my(%slant_res) = _get_label(delete $args->{-slantlabel} || '~Italic'); my $slant = $w->fontActual($w->{'curr_font'}, -slant); my $scb = $fstyle2->Checkbutton (-variable => \$slant, -font => $italic_font, -onvalue => 'italic', -offvalue => 'roman', @{$slant_res{'args'}}, -command => sub { $w->UpdateFont(-slant => $slant) } )->pack(%hs_checkbox_pack_args); my(%underline_res) = _get_label(delete $args->{-underlinelabel} || '~Underline'); my $underline = $w->fontActual($w->{'curr_font'}, -underline); my $ucb = $fstyle2->Checkbutton (-variable => \$underline, -font => $underline_font, -onvalue => 1, -offvalue => 0, @{$underline_res{'args'}}, -command => sub { $w->UpdateFont(-underline => $underline) } )->pack(%hs_checkbox_pack_args); my(%overstrike_res) = _get_label(delete $args->{-overstrikelabel} || 'O~verstrike'); my $overstrike = $w->fontActual($w->{'curr_font'}, -overstrike); my $ocb = $fstyle2->Checkbutton (-variable => \$overstrike, -font => $overstrike_font, -onvalue => 1, -offvalue => 0, @{$overstrike_res{'args'}}, -command => sub { $w->UpdateFont(-overstrike => $overstrike) } )->pack(%hs_checkbox_pack_args); my $c = $w->Scrolled ('Canvas', -scrollbars => 'osoe', -height => 36, -bg => 'white', -relief => 'sunken', -bd => 2, )->pack(-expand => 1, -fill => 'both', -padx => 3, -pady => 3); $w->Advertise('sample_canvas' => $c); my $bf = $w->Frame->pack(-fill => 'x', -padx => 3, -pady => 3); my(%ok_res) = _get_label(delete $args->{'-oklabel'} || "~OK"); my $okb = $bf->Button (@{$ok_res{'args'}}, -fg => 'green4', -font => $bold_font, -command => ['Accept', $w ], )->grid(-column => 0, -row => 0, -rowspan => 2, -sticky => 'ew', -padx => 5); my(%apply_res) = _get_label(delete $args->{'-applylabel'} || "~Apply"); my $applyb; # XXX evtl. in configure erledigen if ($args->{-applycmd}) { my $applycmd = delete $args->{-applycmd}; $applyb = $bf->Button (@{$apply_res{'args'}}, -fg => 'yellow4', -font => $bold_font, -command => sub { $applycmd->($w->ReturnFont($w->{'curr_font'})) }, )->grid(-column => 1, -row => 0, -rowspan => 2, -sticky => 'ew', -padx => 5); } my(%cancel_res) = _get_label(delete $args->{'-cancellabel'} || "~Cancel"); my $cancelb = $bf->Button (@{$cancel_res{'args'}}, -fg => 'red', -font => $bold_font, -command => ['Cancel', $w ], )->grid(-column => 2, -row => 0, -rowspan => 2, -sticky => 'ew', -padx => 5); $bf->grid('columnconfigure', 3, -weight => 1.0); my(%altsample_res) = _get_label(delete $args->{'-altsamplelabel'} || "A~lt sample"); my $altcb = $bf->Checkbutton (@{$altsample_res{'args'}}, -variable => \$w->{'alt_sample'}, -command => sub { $w->UpdateFont; }, )->grid(-column => 4, -row => 0, -sticky => 'w', -padx => 5); my(%nicefonts_res, $nicecb); if (!exists $args->{'-nicefontsbutton'} || $args->{'-nicefontsbutton'}) { %nicefonts_res = _get_label(delete $args->{'-nicefontslabel'} || "~Nicefonts"); $nicecb = $bf->Checkbutton (@{$nicefonts_res{'args'}}, -variable => \$w->{Configure}{-nicefont}, -command => sub { $w->InsertFamilies; }, )->grid(-column => 5, -row => 0, -sticky => 'w', -padx => 5); } delete $args->{'-nicefontsbutton'}; my(%fixedfonts_res, $fixedcb); if (!exists $args->{'-fixedfontsbutton'} || $args->{'-fixedfontsbutton'}) { %fixedfonts_res = _get_label(delete $args->{'-fixedfontslabel'} || "Fi~xed Only"); $fixedcb = $bf->Checkbutton (@{$fixedfonts_res{'args'}}, -variable => \$w->{Configure}{-fixedfont}, -command => sub { $w->InsertFamilies; }, )->grid(-column => 6, -row => 0, -sticky => 'w', -padx => 5); } delete $args->{'-fixedfontsbutton'}; $w->grid('columnconfigure', 0, -minsize => 4); $w->grid('columnconfigure', 4, -minsize => 4); $w->grid('rowconfigure', 0, -minsize => 4); $w->grid('rowconfigure', 8, -minsize => 4); $w->bind("<$family_res{'key'}>" => sub { $famlb->focus }) if $family_res{'key'}; $w->bind("<$size_res{'key'}>" => sub { $sizelb->focus }) if $size_res{'key'}; $w->bind("<$weight_res{'key'}>" => sub { $wcb->invoke }) if $weight_res{'key'}; $w->bind("<$slant_res{'key'}>" => sub { $scb->invoke }) if $slant_res{'key'}; $w->bind("<$underline_res{'key'}>" => sub { $ucb->invoke }) if $underline_res{'key'}; $w->bind("<$overstrike_res{'key'}>" => sub { $ocb->invoke }) if $overstrike_res{'key'}; $w->bind("<$ok_res{'key'}>" => sub { $okb->invoke }) if $ok_res{'key'}; $w->bind("" => sub { $okb->invoke }); $w->bind("<$apply_res{'key'}>" => sub { $applyb->invoke }) if $applyb && $apply_res{'key'}; $w->bind("<$cancel_res{'key'}>" => sub { $cancelb->invoke }) if $cancel_res{'key'}; $w->bind("" => sub { $cancelb->invoke }); $w->bind("<$altsample_res{'key'}>" => sub { $altcb->invoke }) if $altsample_res{'key'}; $w->bind("<$nicefonts_res{'key'}>" => sub { $nicecb->invoke }) if $nicefonts_res{'key'}; $w->bind("<$fixedfonts_res{'key'}>" => sub { $fixedcb->invoke }) if $fixedfonts_res{'key'}; # XXX -subbg: ugly workaround... $w->ConfigSpecs (-subbg => [ 'PASSIVE', 'subBackground', 'SubBackground', 'white'], -nicefont => [ 'PASSIVE', undef, undef, 0], -fixedfont => [ 'PASSIVE', undef, undef, 0], -sampletext => [ 'PASSIVE', undef, undef, 'The Quick Brown Fox Jumps Over The Lazy Dog.'], -title => [ 'METHOD', undef, undef, 'Choose font'], -customsizetitle => [ 'PASSIVE', undef, undef, 'Choose font size'], DEFAULT => [ 'family_list' ], ); $w->Delegates(DEFAULT => 'family_list'); # according to the manpage, the fonts are only destroyed if the # last reference to them is also destroyed # XXX disable for now # $w->fontDelete($dialog_font, # $bold_font, $italic_font, # $underline_font, $overstrike_font); $w; } sub UpdateFont { my($w, %args) = @_; $w->fontConfigure($w->{'curr_font'}, %args) if scalar %args; my $c = $w->Subwidget('sample_canvas'); $c->delete('font'); # XXX see below # $w->Busy; eval { my $sampletext; my $ch_width = $w->fontMeasure($w->{'curr_font'}, 'M'); my $ch_height = $w->fontMetrics($w->{'curr_font'}, -linespace); if ($w->{'alt_sample'}) { my $x_margin = 4; my $x; my $y = 4; for(my $i = 32; $i < 256; $i+=16) { $x = $x_margin; if ($Tk::VERSION >= 804) { # Tk804 operates on Unicode codepoints # and there are no printable characters # in this region next if $i >= 128 && $i < 160; } for my $j (0 .. 15) { next if $i+$j == 127; my $ch = chr($i + $j); unless ($ch eq "\r" || $ch eq "\n") { $c->createText($x, $y, -anchor => 'nw', -text => $ch, -font => $w->{'curr_font'}, -tags => 'font'); } $x += $ch_width + 4; } $y += $ch_height; } if ($Tk::VERSION >= 804) { $y += 5; for my $string ("Latin2: " . join("", map { chr } 0x0102,0x103,0x0104,0x0105,0x010c,0x010d,0x010e,0x010f,0x0141,0x0142,0x0160,0x0161,0x016e,0x016f,0x0170,0x0171,0x017d,0x017e), "Cyrillic: " . join("", map { chr } 0x410..0x419,0x0430..0x439), "Greek: " . join("", map { chr } 0x0391..0x039a,0x03B1..0x03ba), "Hebrew: " . join("", map { chr } 0x05D0..0x05E0), "Arabic: " . join("", map { chr($_). " " } 0x0627..0x0637), ) { $c->createText($x_margin, $y, -anchor => 'nw', -text => $string, -font => $w->{'curr_font'}, -tags => 'font', ); $y += $ch_height; } } } else { $c->createText(4, 4, -anchor => 'nw', -text => $w->cget(-sampletext), -font => $w->{'curr_font'}, -tags => 'font'); } $c->configure(-scrollregion => [$c->bbox("all")]); }; warn $@ if $@; # $w->Unbusy; } sub Cancel { my $w = shift; $w->{Selected} = undef; } sub Accept { my $w = shift; $w->{Selected} = $w->{'curr_font'}; } sub Show { my($w, %args) = @_; my $test_hack = delete $args{'-_testhack'}; $w->transient($w->Parent->toplevel); my $oldFocus = $w->focusCurrent; my $oldGrab = $w->grab('current'); my $grabStatus; $grabStatus = $oldGrab->grab('status') if ($oldGrab); $w->grab; $w->InsertFamilies(); $w->UpdateFont(); # XXX ugly... $w->Subwidget('family_list')->configure(-bg => $w->cget(-subbg)); $w->Subwidget('size_list')->configure(-bg => $w->cget(-subbg)); $w->Subwidget('sample_canvas')->configure(-bg => $w->cget(-subbg)); $w->Popup(%args); # XXX won't work with 800.015? #$w->waitVisibility; $w->focus; $w->OnDestroy(sub { $w->Cancel }); $w->waitVariable(\$w->{Selected}) unless $test_hack; return if !Tk::Exists($w); # probably MainWindow closed eval { $oldFocus->focus if $oldFocus; }; $w->grab('release'); $w->withdraw; if ($oldGrab) { if ($grabStatus eq 'global') { $oldGrab->grab('-global'); } else { $oldGrab->grab; } } $w->ReturnFont($w->{Selected}); } sub ReturnFont { my($w, $var) = @_; if (defined $var) { my $ret = $w->fontCreate($w->font('actual', $var)); $ret; } else { undef; } } sub InsertFamilies { my $w = shift; # XXX Busy ist gefaehrlich ... anscheinend wird der alte grab nicht # richtig gespeichert! # $w->Busy; my $old_cursor = $w->cget(-cursor); $w->configure(-cursor => 'watch'); $w->idletasks; eval { $w->{'family_index'} = []; my $nicefont = $w->cget(-nicefont); # XXX name? my $fixedfont = $w->cget(-fixedfont); my %fa = $w->fontActual($w->{'curr_font'}); my $curr_family = $fa{'-family'}; my $curr_size = $fa{'-size'}; my $famlb = $w->Subwidget('family_list'); $famlb->delete('all'); my @fam = sort $w->fontFamilies; my $bg = $w->cget(-subbg); my $i = 0; foreach my $fam (@fam) { next if $fam eq ''; next if $fixedfont and not $w->fontMetrics($w->Font(-family => $fam), '-fixed'); (my $u_fam = $fam) =~ s/\b(.)/\u$1/g; $w->{'family_index'}[$i] = $fam; my $f_style = $famlb->ItemStyle ('text', ($nicefont ? (-font => "{$fam} $curr_size") : ()), -background => $bg, ); $famlb->add($i, -text => $u_fam, -style => $f_style); if ($curr_family eq $fam) { $famlb->selectionSet($i); $famlb->anchorSet($i); $famlb->see($i); } $i++; } }; warn $@ if $@; $w->configure(-cursor => $old_cursor); # $w->Unbusy; } # get position of the tilde character and delete it sub _get_label { my $s = shift; my %res; if ($s =~ s/(.*)~(.)/$1$2/) { my $key = lc($2); my $underline = length($1); @{$res{'args'}} = (-text => $s, -underline => $underline); $res{'key'} = $key; } else { @{$res{'args'}} = (-text => $s); } %res; } sub _custom_size { my($w) = @_; my $t = $w->Toplevel; my $label = $w->cget(-customsizetitle); $t->title($label); my $sizelb = $w->Subwidget("size_list"); my $fontsize = 10; if (defined $sizelb->info("selection")) { $fontsize = $sizelb->entrycget($sizelb->info("selection"), -text); } my $f1 = $t->Frame->pack; $f1->Label(-text => $label)->pack(-side => 'left'); my $e = $f1->Entry(-width => 4, -textvariable => \$fontsize)->pack(-side => "left"); $e->focus; $e->selectionRange(0,'end'); $e->icursor('end'); my $f = $t->Frame->pack; my $waitvar = 0; my $ok = $f->Button (-text => "Ok", -command => sub { $w->UpdateFont(-size => $fontsize); $sizelb->selectionClear; $sizelb->anchorClear; foreach ($sizelb->info("children")) { if ($sizelb->entrycget($_, -text) eq $fontsize) { $sizelb->selectionSet($_); $sizelb->anchorSet($_); $sizelb->see($_); last; } } $waitvar = 1; })->pack(-side => "left"); $f->Button(-text => "Cancel", -command => sub { $waitvar = -1 })->pack(-side => "left"); $e->bind("" => sub { $ok->invoke }); $t->Popup(-popover => "cursor"); $t->waitVariable(\$waitvar); $t->destroy; } # Perl version of TkFontGetPoints sub FontGetPoints { my($w, $size) = @_; if ($size >= 0) { return $size; } my $d = -$size * 72.0 / 25.4; $d *= $w->screenmmwidth; $d /= $w->screenwidth; return int($d + 0.5); } # put some dirt into Tk::Widget... package # hide from CPAN indexer Tk::Widget; # XXX Refont Canvases? sub RefontTree { my ($w, %args) = @_; # my $dbOption; my $value; my $font = $args{-font} or die "No font specified"; eval { local $SIG{'__DIE__'}; $value = $w->cget(-font) }; if (defined $value) { $w->configure(-font => $font); } if ($w->isa('Tk::Canvas') and $args{-canvas}) { foreach my $item ($w->find('all')) { eval { local $SIG{'__DIE__'}; $value = $w->itemcget($item, -font) }; if (defined $value) { $w->itemconfigure($item, -font => $font); } } } foreach my $child ($w->children) { $child->RefontTree(%args); } } sub GetDescriptiveFontName { my($w, $fontname) = @_; my %fa = $w->fontActual($fontname); my $fontdescriptive = "{$fa{-family}} $fa{-size}"; if ($fa{-weight} ne "normal") { $fontdescriptive .= " $fa{-weight}"; } if ($fa{-slant} ne "roman") { $fontdescriptive .= " $fa{-slant}"; } if ($fa{-underline}) { $fontdescriptive .= " underline"; } if ($fa{-overstrike}) { $fontdescriptive .= " overstrike"; } $fontdescriptive; } 1; __END__ =head1 NAME Tk::FontDialog - a font dialog widget for perl/Tk =head1 SYNOPSIS use Tk::FontDialog; $font = $top->FontDialog->Show; =head1 DESCRIPTION Tk::FontDialog implements a font dialog widget. The dialog is displayed by calling the B method. The returned value is either the selected font (if the dialog was closed with the Ok button) or undef (otherwise). The exact type of the return value is either a L object (in Tk800) or a font name string (usually something like C). Both can be used as values in Tk C<-font> options. See L In the Family and Size listboxes, the font family and font size can be specified. The checkbuttons on the right turn on bold, italic, underlined and overstriked variants of the chosen font. A sample of the font is shown in the middle area. With the "Alt sample" checkbutton, it is possible to show all characters in the charset instead of the default text. "Fixed only" restricts the font family list to fixed fonts only. If the "Nicefonts" checkbutton is set, then the font names in the listbox are displayed in the corresponding font. Note that this option can be slow if a lot of fonts are installed or for 16 bit fonts. A click with the right button in the font size listbox pops up a window to enter arbitrary font sizes. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item -font The dialog font. =item -initfont The initial font. =item -fontsizes A list of font sizes. The default contains sizes from 0 to 72 points (XXX or pixels?). =item -nicefont If set, font names are displayed in its font style. This may be slow, especially if you have many fonts or 16 bit fonts (e.g. Asian fonts). =item -nicefontsbutton If set to false, then the "Nice fonts" button is not displayed. =item -fixedfont If set, proportional font families are not listed, leaving only the fixed fonts. This is slow, as each font must be checked to see if it is fixed or proportional. =item -fixedfontsbutton If set to false, then the "Fixed fonts" button is not displayed. =item -sampletext The sample text which should contain all letters. The default is "The Quick Brown Fox Jumps Over The Lazy Dog" German readers may probably use "Franz jagt im komplett verwahrlosten Taxi quer durch Bayern". =back =head1 INTERNATIONALIZATION There are a couple of options to change the labels of the dialog. Note that you can prepend a tilde (C<~>) to get an accelerator key with C. Here is a list of these options with the default (English) setting: =over 4 =item -familylabel (Family:) =item -sizelabel (Size:) =item -weightlabel (Bold) =item -slantlabel (Italic) =item -underlinelabel (Underline) =item -overstrikelabel (Overstrike) =item -oklabel (OK) =item -applylabel (Apply) =item -cancellabel (Cancel) =item -altsamplelabel (Alt sample) =item -nicefontslabel (Nicefonts) =item -fixedfontslabel (Fixed Only) =item -title (Choose font) =item -customsizetitle (Choose font size) =back =head1 METHODS IN Tk::Widget =over =item B(-font => I<$font>) Additionaly, the convenience method B is defined in the L namespace. Using this method a font definition could be applied to a complete subtree of a widget. This is similar to the method B. Calling B looks like this: $font = $mw->FontDialog->Show; $mainwindow->RefontTree(-font => $font) if defined $font; By default RefontTree does not change the font of canvas elements. This can be done by specifying C<< -canvas => 1 >>. =item B(I<$fontname>) Return a "descriptive" font name (just like form [3] as described in L). The return value from the Show() method has the disadvantage that it is only valid for the current Tk session. A "descriptive" font name may be stored and reused later. =back =head1 CAVEAT Note that font names with whitespace like "New century schoolbook" or "MS Sans Serif" can cause problems when using in a -font option. The solution is to put the names in Tcl-like braces, like -font => "{New century schoolbook} 10" =head1 EXAMPLES To apply a selected font to a specific widget, use the following snippet: $font = $mw->FontDialog->Show; if (defined $font) { $button->configure(-font => $font); } This example uses the convenience method B to apply the new font to the whole application: use Tk; use Tk::FontDialog; $mw = tkinit; $mw->Label(-text => "Test")->pack; $mw->Button(-text => "Another test")->pack; $mw->Button(-text => "Use Tk::FontDialog", -command => sub { my $font = $mw->FontDialog->Show; if (defined $font) { $mw->RefontTree(-font => $font); } })->pack; MainLoop; To get the "descriptive" font name: $font = $mw->FontDialog->Show; if (defined $font) { $font_descriptive = $mw->GetDescriptiveFontName($font); print $font_descriptive, "\n"; } =head1 AVAILABILITY The latest released version is available from cpan (e.g. L). The latest development version is available from github (L). =head1 BUGS/TODO - ConfigSpecs handling is poor put at least -font into configspecs - run test, call dialog for 2nd time: immediate change of font? - better name for nicefont - restrict on charsets and encodings (xlsfonts? X11::Protocol::ListFonts?) difficult because core Tk font handling ignores charsets and encodings =head1 SEE ALSO L =head1 AUTHOR Slaven Rezic Suggestions by Michael Houghton, Martin Thurn, Jack, Justin Kozlowitz and others. =head1 COPYRIGHT Copyright (c) 1998,1999,2003,2004,2005,2010 Slaven Rezic. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tk-FontDialog-0.18/t/00-basic.t000755 001750 001750 00000005536 12246162014 016624 0ustar00eserteeserte000000 000000 #!/usr/bin/perl -w # -*- perl -*- # # $Id: 00-basic.t,v 1.11 2008/09/23 19:26:00 eserte Exp $ # Author: Slaven Rezic # use strict; BEGIN { if (!eval q{ use Test::More; 1; }) { print "1..0 # skip: no Test::More module\n"; exit; } } my $real_tests = 3; plan tests => 1 + $real_tests; use Tk; my $sampletext; BEGIN { eval q{ use charnames ':full'; $sampletext = "The quick brown fox jumps over the lazy dog.\nUnicode: Euro=\N{EURO SIGN}, C with acute=\N{LATIN SMALL LETTER C WITH ACUTE}, cyrillic sh=\x{0428}"; }; #warn $@; } if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1 } use_ok("Tk::FontDialog"); my $top = eval { MainWindow->new }; SKIP: { skip "Cannot open main window. Error message <$@>", $real_tests if $@ || !$top; $top->geometry('+1+1'); my($b, $f, $fd); my $apply_font = sub { my $font = shift; if (defined $font) { $b->configure(-font => $font); $f->RefontTree(-font => $font, -canvas => 1); } }; $b = $top->Button(-text => 'Choose Font', -command => sub { my $font = $fd->Show; $apply_font->($font); })->pack; { $f = $top->Frame->pack; $f->Label(-text => 'Test RefontTree 1')->pack; my $f2 = $f->Frame->pack; $f2->Label(-text => 'Test RefontTree 2')->pack; my $c = $f2->Canvas(-width => 100, -height => 30)->pack; $c->createText(0,0,-anchor => 'nw', -text => 'Canvas Text'); } $fd = $top->FontDialog(-nicefont => 0, #-font => $b->cget(-font), -title => 'Schriftart?', #-familylabel => '~Schriftfamilie;', #-sizelabel => '~Größe:', #-weightlabel => '~Fett', #-slantlabel => '~Italic', #-underlinelabel => '~Unterstrichen', #-overstrikelabel => '~Durchgestrichen', #-applylabel => 'Ü~bernehmen', #-cancellabel => '~Abbruch', #-altsamplelabel => 'A~lternative', -applycmd => $apply_font, -familylabel => 'Schrift~familie', -fixedfontsbutton => 1, -nicefontsbutton => 1, ($Tk::VERSION >= 804 && $sampletext ? (-sampletext => $sampletext) : ()), ); my $fontname; eval { my $fd2 = $top->FontDialog; $fontname = $fd2->Show('-_testhack' => $ENV{BATCH}); }; is($@, "", "No exceptions"); SKIP: { skip("No font selected", 1) if (!defined $fontname); my $descriptive = $top->GetDescriptiveFontName($fontname); my %fa = $top->fontActual($fontname); my %fa2 = $top->fontActual($descriptive); is_deeply(\%fa, \%fa2, "Same font"); } my $bf = $top->Frame->pack; my $okb = $bf->Button(-text => 'OK', -command => sub { pass(); $top->destroy; } )->pack(-side => 'left'); $bf->Button(-text => 'Not OK', -command => sub { fail(); $top->destroy; } )->pack(-side => 'left'); if ($ENV{BATCH}) { $top->after(1000, sub { $okb->invoke; }); } MainLoop; }