Server IP : 92.204.138.22 / Your IP : 18.217.212.151 Web Server : Apache System : Linux ns1009439.ip-92-204-138.us 4.18.0-553.8.1.el8_10.x86_64 #1 SMP Tue Jul 2 07:26:33 EDT 2024 x86_64 User : internationaljou ( 1019) PHP Version : 7.4.33 Disable Function : NONE MySQL : OFF | cURL : ON | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : ON Directory : /usr/share/tk8.6/ |
Upload File : |
# fontchooser.tcl - # # A themeable Tk font selection dialog. See TIP #324. # # Copyright (C) 2008 Keith Vetter # Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. namespace eval ::tk::fontchooser { variable S set S(W) .__tk__fontchooser set S(fonts) [lsort -dictionary [font families]] set S(styles) [list \ [::msgcat::mc "Regular"] \ [::msgcat::mc "Italic"] \ [::msgcat::mc "Bold"] \ [::msgcat::mc "Bold Italic"] \ ] set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72} set S(strike) 0 set S(under) 0 set S(first) 1 set S(sampletext) [::msgcat::mc "AaBbYyZz01"] set S(-parent) . set S(-title) [::msgcat::mc "Font"] set S(-command) "" set S(-font) TkDefaultFont } proc ::tk::fontchooser::Setup {} { variable S # Canonical versions of font families, styles, etc. for easier searching set S(fonts,lcase) {} foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]} set S(styles,lcase) {} foreach style $S(styles) { lappend S(styles,lcase) [string tolower $style]} set S(sizes,lcase) $S(sizes) ::ttk::style layout FontchooserFrame { Entry.field -sticky news -border true -children { FontchooserFrame.padding -sticky news } } bind [winfo class .] <<ThemeChanged>> \ [list +ttk::style layout FontchooserFrame \ [ttk::style layout FontchooserFrame]] namespace ensemble create -map { show ::tk::fontchooser::Show hide ::tk::fontchooser::Hide configure ::tk::fontchooser::Configure } } ::tk::fontchooser::Setup proc ::tk::fontchooser::Show {} { variable S if {![winfo exists $S(W)]} { Create wm transient $S(W) [winfo toplevel $S(-parent)] tk::PlaceWindow $S(W) widget $S(-parent) } set S(fonts) [lsort -dictionary [font families]] set S(fonts,lcase) {} foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]} wm deiconify $S(W) } proc ::tk::fontchooser::Hide {} { variable S wm withdraw $S(W) } proc ::tk::fontchooser::Configure {args} { variable S set specs { {-parent "" "" . } {-title "" "" ""} {-font "" "" ""} {-command "" "" ""} } if {[llength $args] == 0} { set result {} foreach spec $specs { foreach {name xx yy default} $spec break lappend result $name \ [expr {[info exists S($name)] ? $S($name) : $default}] } lappend result -visible \ [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] return $result } if {[llength $args] == 1} { set option [lindex $args 0] if {[string equal $option "-visible"]} { return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] } elseif {[info exists S($option)]} { return $S($option) } return -code error -errorcode [list TK LOOKUP OPTION $option] \ "bad option \"$option\": must be\ -command, -font, -parent, -title or -visible" } set cache [dict create -parent $S(-parent) -title $S(-title) \ -font $S(-font) -command $S(-command)] set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args] if {![winfo exists $S(-parent)]} { set code [list TK LOOKUP WINDOW $S(-parent)] set err "bad window path name \"$S(-parent)\"" array set S $cache return -code error -errorcode $code $err } if {[string trim $S(-title)] eq ""} { set S(-title) [::msgcat::mc "Font"] } if {[winfo exists $S(W)] && [lsearch $args -font] != -1} { Init $S(-font) event generate $S(-parent) <<TkFontchooserFontChanged>> } return $r } proc ::tk::fontchooser::Create {} { variable S set windowName __tk__fontchooser if {$S(-parent) eq "."} { set S(W) .$windowName } else { set S(W) $S(-parent).$windowName } # Now build the dialog if {![winfo exists $S(W)]} { toplevel $S(W) -class TkFontDialog if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)} wm withdraw $S(W) wm title $S(W) $S(-title) wm transient $S(W) [winfo toplevel $S(-parent)] set outer [::ttk::frame $S(W).outer -padding {10 10}] ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"] ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"] ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] ttk::entry $S(W).efont -width 18 \ -textvariable [namespace which -variable S](font) ttk::entry $S(W).estyle -width 10 \ -textvariable [namespace which -variable S](style) ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \ -width 3 -validate key -validatecommand {string is double %P} ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \ -selectmode browse -activestyle none \ -listvariable [namespace which -variable S](fonts) ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \ -selectmode browse -activestyle none \ -listvariable [namespace which -variable S](styles) ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \ -selectmode browse -activestyle none \ -listvariable [namespace which -variable S](sizes) set WE $S(W).effects ::ttk::labelframe $WE -text [::msgcat::mc "Effects"] ::tk::AmpWidget ::ttk::checkbutton $WE.strike \ -variable [namespace which -variable S](strike) \ -text [::msgcat::mc "Stri&keout"] \ -command [namespace code [list Click strike]] ::tk::AmpWidget ::ttk::checkbutton $WE.under \ -variable [namespace which -variable S](under) \ -text [::msgcat::mc "&Underline"] \ -command [namespace code [list Click under]] set bbox [::ttk::frame $S(W).bbox] ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\ -command [namespace code [list Done 1]] ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \ -command [namespace code [list Done 0]] ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \ -command [namespace code [list Apply]] wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]] # Calculate minimum sizes ttk::scrollbar $S(W).tmpvs set scroll_width [winfo reqwidth $S(W).tmpvs] destroy $S(W).tmpvs set minsize(gap) 10 set minsize(bbox) [winfo reqwidth $S(W).ok] set minsize(fonts) \ [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}] set minsize(styles) \ [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}] set minsize(sizes) \ [expr {[font measure TkDefaultFont "-99"] + $scroll_width}] set min [expr {$minsize(gap) * 4}] foreach {what width} [array get minsize] { incr min $width } wm minsize $S(W) $min 260 bind $S(W) <Return> [namespace code [list Done 1]] bind $S(W) <Escape> [namespace code [list Done 0]] bind $S(W) <Map> [namespace code [list Visibility %W 1]] bind $S(W) <Unmap> [namespace code [list Visibility %W 0]] bind $S(W) <Destroy> [namespace code [list Visibility %W 0]] bind $S(W).lfonts.list <<ListboxSelect>> [namespace code [list Click font]] bind $S(W).lstyles.list <<ListboxSelect>> [namespace code [list Click style]] bind $S(W).lsizes.list <<ListboxSelect>> [namespace code [list Click size]] bind $S(W) <Alt-Key> [list ::tk::AltKeyInDialog $S(W) %A] bind $S(W).font <<AltUnderlined>> [list ::focus $S(W).efont] bind $S(W).style <<AltUnderlined>> [list ::focus $S(W).estyle] bind $S(W).size <<AltUnderlined>> [list ::focus $S(W).esize] bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]] bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke] bind $WE.under <<AltUnderlined>> [list $WE.under invoke] set WS $S(W).sample ::ttk::labelframe $WS -text [::msgcat::mc "Sample"] ::ttk::label $WS.sample -relief sunken -anchor center \ -textvariable [namespace which -variable S](sampletext) set S(sample) $WS.sample grid $WS.sample -sticky news -padx 6 -pady 4 grid rowconfigure $WS 0 -weight 1 grid columnconfigure $WS 0 -weight 1 grid propagate $WS 0 grid $S(W).ok -in $bbox -sticky new -pady {0 2} grid $S(W).cancel -in $bbox -sticky new -pady 2 if {$S(-command) ne ""} { grid $S(W).apply -in $bbox -sticky new -pady 2 } grid columnconfigure $bbox 0 -weight 1 grid $WE.strike -sticky w -padx 10 grid $WE.under -sticky w -padx 10 -pady {0 30} grid columnconfigure $WE 1 -weight 1 grid $S(W).font x $S(W).style x $S(W).size x -in $outer -sticky w grid $S(W).efont x $S(W).estyle x $S(W).esize x $bbox -in $outer -sticky ew grid $S(W).lfonts x $S(W).lstyles x $S(W).lsizes x ^ -in $outer -sticky news grid $WE x $WS - - x ^ -in $outer -sticky news -pady {15 30} grid configure $bbox -sticky n grid columnconfigure $outer {1 3 5} -minsize $minsize(gap) grid columnconfigure $outer {0 2 4} -weight 1 grid columnconfigure $outer 0 -minsize $minsize(fonts) grid columnconfigure $outer 2 -minsize $minsize(styles) grid columnconfigure $outer 4 -minsize $minsize(sizes) grid columnconfigure $outer 6 -minsize $minsize(bbox) grid $outer -sticky news grid rowconfigure $S(W) 0 -weight 1 grid columnconfigure $S(W) 0 -weight 1 Init $S(-font) trace add variable [namespace which -variable S](size) \ write [namespace code [list Tracer]] trace add variable [namespace which -variable S](style) \ write [namespace code [list Tracer]] trace add variable [namespace which -variable S](font) \ write [namespace code [list Tracer]] } else { Init $S(-font) } return } # ::tk::fontchooser::Done -- # # Handles teardown of the dialog, calling -command if needed # # Arguments: # ok true if user pressed OK # proc ::tk::::fontchooser::Done {ok} { variable S if {! $ok} { set S(result) "" } trace vdelete S(size) w [namespace code [list Tracer]] trace vdelete S(style) w [namespace code [list Tracer]] trace vdelete S(font) w [namespace code [list Tracer]] destroy $S(W) if {$ok && $S(-command) ne ""} { uplevel #0 $S(-command) [list $S(result)] } } # ::tk::fontchooser::Apply -- # # Call the -command procedure appending the current font # Errors are reported via the background error mechanism # proc ::tk::fontchooser::Apply {} { variable S if {$S(-command) ne ""} { if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} { ::bgerror $err } } event generate $S(-parent) <<TkFontchooserFontChanged>> } # ::tk::fontchooser::Init -- # # Initializes dialog to a default font # # Arguments: # defaultFont font to use as the default # proc ::tk::fontchooser::Init {{defaultFont ""}} { variable S if {$S(first) || $defaultFont ne ""} { if {$defaultFont eq ""} { set defaultFont [[entry .___e] cget -font] destroy .___e } array set F [font actual $defaultFont] set S(font) $F(-family) set S(size) $F(-size) set S(strike) $F(-overstrike) set S(under) $F(-underline) set S(style) "Regular" if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} { set S(style) "Bold Italic" } elseif {$F(-weight) eq "bold"} { set S(style) "Bold" } elseif {$F(-slant) eq "italic"} { set S(style) "Italic" } set S(first) 0 } Tracer a b c Update } # ::tk::fontchooser::Click -- # # Handles all button clicks, updating the appropriate widgets # # Arguments: # who which widget got pressed # proc ::tk::fontchooser::Click {who} { variable S if {$who eq "font"} { set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]] } elseif {$who eq "style"} { set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]] } elseif {$who eq "size"} { set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]] } Update } # ::tk::fontchooser::Tracer -- # # Handles traces on key variables, updating the appropriate widgets # # Arguments: # standard trace arguments (not used) # proc ::tk::fontchooser::Tracer {var1 var2 op} { variable S set bad 0 set nstate normal # Make selection in each listbox foreach var {font style size} { set value [string tolower $S($var)] $S(W).l${var}s selection clear 0 end set n [lsearch -exact $S(${var}s,lcase) $value] $S(W).l${var}s selection set $n if {$n != -1} { set S($var) [lindex $S(${var}s) $n] $S(W).e$var icursor end $S(W).e$var selection clear } else { ;# No match, try prefix # Size is weird: valid numbers are legal but don't display # unless in the font size list set n [lsearch -glob $S(${var}s,lcase) "$value*"] set bad 1 if {$var ne "size" || ! [string is double -strict $value]} { set nstate disabled } } $S(W).l${var}s see $n } if {!$bad} { Update } $S(W).ok configure -state $nstate } # ::tk::fontchooser::Update -- # # Shows a sample of the currently selected font # proc ::tk::fontchooser::Update {} { variable S set S(result) [list $S(font) $S(size)] if {$S(style) eq "Bold"} { lappend S(result) bold } if {$S(style) eq "Italic"} { lappend S(result) italic } if {$S(style) eq "Bold Italic"} { lappend S(result) bold italic} if {$S(strike)} { lappend S(result) overstrike} if {$S(under)} { lappend S(result) underline} $S(sample) configure -font $S(result) } # ::tk::fontchooser::Visibility -- # # Notify the parent when the dialog visibility changes # proc ::tk::fontchooser::Visibility {w visible} { variable S if {$w eq $S(W)} { event generate $S(-parent) <<TkFontchooserVisibility>> } } # ::tk::fontchooser::ttk_listbox -- # # Create a properly themed scrolled listbox. # This is exactly right on XP but may need adjusting on other platforms. # proc ::tk::fontchooser::ttk_slistbox {w args} { set f [ttk::frame $w -style FontchooserFrame -padding 2] if {[catch { listbox $f.list -relief flat -highlightthickness 0 -borderwidth 0 {*}$args ttk::scrollbar $f.vs -command [list $f.list yview] $f.list configure -yscrollcommand [list $f.vs set] grid $f.list $f.vs -sticky news grid rowconfigure $f 0 -weight 1 grid columnconfigure $f 0 -weight 1 interp hide {} $w interp alias {} $w {} $f.list } err opt]} { destroy $f return -options $opt $err } return $w }