Attachment "tip324-081210.diff" to
ticket [1477426f]
added by
das
2008-12-10 12:05:01.
Index: doc/fontchooser.n
===================================================================
RCS file: doc/fontchooser.n
diff -N doc/fontchooser.n
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ doc/fontchooser.n 10 Dec 2008 04:28:48 -0000
@@ -0,0 +1,183 @@
+'\"
+'\" Copyright (c) 2008 Daniel A. Steffen <[email protected]>
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" RCS: @(#) $Id$
+'\"
+.so man.macros
+.TH fontchooser n "" Tk "Tk Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+fontchooser \- control font selection dialog
+.SH SYNOPSIS
+\fBtk fontchooser\fR \fBconfigure\fR ?\fI\-option value \-option value ...\fR?
+.sp
+\fBtk fontchooser\fR \fBshow\fR
+.sp
+\fBtk fontchooser\fR \fBhide\fR
+.BE
+.SH DESCRIPTION
+.PP
+The \fBtk fontchooser\fR command controls the Tk font selection dialog. It uses
+the native platform font selection dialog where available, or a dialog
+implemented in Tcl otherwise.
+.PP
+Unlike most of the other Tk dialog commands, \fBtk fontchooser\fR does not
+return an immediate result, as on some platforms (Mac OS X) the standard font
+dialog is modeless while on others (Windows) it is modal. To accommodate this
+difference, all user interaction with the dialog will be communicated to the
+caller via callbacks or virtual events.
+.PP
+The \fBtk fontchooser\fR command can have one of the following forms:
+.TP
+\fBtk fontchooser\fR \fBconfigure \fR?\fI\-option value \-option value ...\fR?
+.
+Set or query one or more of the configurations options below (analogous to Tk
+widget configuration).
+.TP
+\fBtk fontchooser\fR \fBshow\fR
+.
+Show the font selection dialog. Depending on the platform, may return
+immediately or only once the dialog has been withdrawn.
+.TP
+\fBtk fontchooser\fR \fBhide\fR
+.
+Hide the font selection dialog if it is visible and cause any pending
+\fBtk fontchooser\fR \fBshow\fR command to return.
+.PP
+.SH "CONFIGURATION OPTIONS"
+.TP
+\fB\-parent\fR
+Specifies/returns the logical parent window of the font selection dialog
+(similar to the \fB\-parent\fR option to other dialogs). The font selection
+dialog is hidden if it is visible when the parent window is destroyed.
+.TP
+\fB\-title\fR
+Specifies/returns the title of the dialog. Has no effect on platforms where the
+font selection dialog does not support titles.
+.TP
+\fB\-font\fR
+Specifies/returns the font that is currently selected in the dialog if it is
+visible, or that will be initially selected when the dialog is shown (if
+supported by the platform). Can be set to the empty string to indicate that no
+font should be selected. Fonts can be specified in any form given by the "FONT
+DESCRIPTION" section in the \fBfont\fR manual page.
+.TP
+\fB\-command\fR
+Specifies/returns the command prefix to be called when a font selection has
+been made by the user. The command prefix is evaluated at the global level
+after having the specification of the selected font appended. On platforms
+where the font selection dialog offers the user control of further font
+attributes (such as color), additional key/value pairs may be appended before
+evaluation. Can be set to the empty string to indicate that no callback should
+be invoked. Fonts are specified by a list of form [3] of the "FONT DESCRIPTION"
+section in the \fBfont\fR manual page (i.e. a list of the form
+\fI{family size style ?style ...?}\fR).
+.TP
+\fB\-visible\fR
+Read-only option that returns a boolean indicating whether the font selection
+dialog is currently visible. Attempting to set this option results in an error.
+
+.PP
+.SH "VIRTUAL EVENTS"
+.TP
+\fB<<TkFontchooserVisibility>>\fR
+Sent to the dialog parent whenever the visibility of the font selection dialog
+changes, both as a result of user action (e.g. disposing of the dialog via
+OK/Cancel button or close box) and of the \fBtk fontchooser\fR
+\fBshow\fR/\fBhide\fR commands being called. Binding scripts can determine the
+current visibility of the dialog by querying the \fB\-visible\fR configuration
+option.
+.TP
+\fB<<TkFontchooserFontChanged>>\fR
+Sent to the dialog parent whenever the font selection dialog is visible and the
+selected font changes, both as a result of user action and of the \fB\-font\fR
+configuration option being set. Binding scripts can determine the currently
+selected font by querying the \fB\-font\fR configuration option.
+.PP
+.SH NOTES
+.PP
+Callers should not expect a result from \fBtk fontchooser\fR \fBshow\fR and may
+not assume that the dialog has been withdrawn or closed when the command
+returns. All user interaction with the dialog is communicated to the caller via
+the \fB\-command\fR callback and the \fB<<TkFontchooser*>>\fR virtual events.
+It is implementation dependent which exact user actions result in the callback
+being called resp. the virtual events being sent. Where an Apply or OK button
+is present in the dialog, that button will trigger the \fB\-command\fR callback
+and \fB<<TkFontchooserFontChanged>>\fR virtual event. On some implementations
+other user actions may also have that effect; on Mac OS X for instance, the
+standard font selection dialog immediately reflects all user choices to the
+caller.
+.PP
+In the presence of multiple widgets intended to be influenced by the font
+selection dialog, care needs to be taken to correctly handle focus changes: the
+font selected in the dialog should always match the current font of the widget
+with the focus, and the \fB\-command\fR callback should only act on the widget
+with the focus. The recommended practice is to set font dialog \fB\-font\fR and
+\fB\-command\fR configuration options in per\-widget \fB<FocusIn>\fR handlers
+(and if necessary to unset them \- i.e. set to the empty string \- in
+corresponding \fB<FocusOut>\fR handlers). This is particularly important for
+implementors of library code using the font selection dialog, to avoid
+conflicting with application code that may also want to use the dialog.
+.PP
+Because the font selection dialog is application-global, in the presence of
+multiple interpreters calling \fBtk fontchooser\fR, only the \fB\-command\fR
+callback set by the interpreter that most recently called \fBtk fontchooser\fR
+\fBconfigure\fR or \fBtk fontchooser\fR \fBshow\fR will be invoked in response
+to user action and only the \fB\-parent\fR set by that interpreter will receive
+\fB<<TkFontchooser*>>\fR virtual events.
+.PP
+The font dialog implementation may only store (and return) \fBfont\fR
+\fBactual\fR data as the value of the \fB\-font\fR configuration option. This
+can be an issue when \fB\-font\fR is set to a named font, if that font is
+subsequently changed, the font dialog \fB\-font\fR option needs to be set again
+to ensure its selected font matches the new value of the named font.
+.PP
+.SH EXAMPLE
+.PP
+.CS
+proc fontchooserDemo {} {
+ wm title . "Font Chooser Demo"
+ \fBtk fontchooser\fR \fBconfigure\fR \-parent .
+ button .b \-command fontchooserToggle \-takefocus 0
+ fontchooserVisibility .b
+ bind . \fB<<TkFontchooserVisibility>>\fR \\
+ [list fontchooserVisibility .b]
+ foreach w {.t1 .t2} {
+ text $w \-width 20 \-height 4 \-borderwidth 1 \-relief solid
+ bind $w <FocusIn> [list fontchooserFocus $w]
+ $w insert end "Text Widget $w"
+ }
+ .t1 configure \-font {Courier 14}
+ .t2 configure \-font {Times 16}
+ pack .b .t1 .t2; focus .t1
+}
+proc fontchooserToggle {} {
+ \fBtk fontchooser\fR [expr {
+ [\fBtk fontchooser\fR \fBconfigure\fR \-visible] ?
+ "\fBhide\fR" : "\fBshow\fR"}]
+}
+proc fontchooserVisibility {w} {
+ $w configure \-text [expr {
+ [\fBtk fontchooser\fR \fBconfigure\fR \-visible] ?
+ "Hide Font Dialog" : "Show Font Dialog"}]
+}
+proc fontchooserFocus {w} {
+ \fBtk fontchooser\fR \fBconfigure\fR \-font [$w cget \-font] \\
+ \-command [list fontchooserFontSelection $w]
+}
+proc fontchooserFontSelection {w font args} {
+ $w configure \-font [font actual $font]
+}
+fontchooserDemo
+.CE
+.SH "SEE ALSO"
+font(n), tk(n)
+.SH KEYWORDS
+dialog, font, font selection, font chooser, font panel
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
Index: doc/tk.n
===================================================================
RCS file: /cvsroot/tktoolkit/tk/doc/tk.n,v
retrieving revision 1.20
diff -u -p -r1.20 tk.n
--- doc/tk.n 18 Oct 2008 14:22:21 -0000 1.20
+++ doc/tk.n 10 Dec 2008 04:28:48 -0000
@@ -66,6 +66,28 @@ format. \fI\-x\fR and \fI\-y\fR represe
\fI\-height\fR is the height of the current cursor location, or the height
of the specified \fIwindow\fR if none is given.
.TP
+\fBtk inactive \fR?\fB\-displayof \fIwindow\fR? ?\fBreset\fR?
+.
+Returns a positive integer, the number of milliseconds since the last
+time the user interacted with the system. If the \fB\-displayof\fR
+option is given then the return value refers to the display of
+\fIwindow\fR; otherwise it refers to the display of the application's
+main window.
+.RS
+.PP
+\fBtk inactive\fR will return \-1, if querying the user inactive time
+is not supported by the system, and in safe interpreters.
+.PP
+If the literal string \fBreset\fR is given as an additional argument,
+the timer is reset and an empty string is returned. Resetting the
+inactivity time is forbidden in safe interpreters and will throw and
+error if tried.
+.RE
+.TP
+\fBtk fontchooser \fIsubcommand\fR ...
+Controls the Tk font selection dialog. For more details see the
+\fBfontchooser\fR manual page.
+.TP
\fBtk scaling \fR?\fB\-displayof \fIwindow\fR? ?\fInumber\fR?
.
Sets and queries the current scaling factor used by Tk to convert between
@@ -91,24 +113,6 @@ is undefined whether existing widgets wi
accommodate the new scaling factor.
.RE
.TP
-\fBtk inactive \fR?\fB\-displayof \fIwindow\fR? ?\fBreset\fR?
-.
-Returns a positive integer, the number of milliseconds since the last
-time the user interacted with the system. If the \fB\-displayof\fR
-option is given then the return value refers to the display of
-\fIwindow\fR; otherwise it refers to the display of the application's
-main window.
-.RS
-.PP
-\fBtk inactive\fR will return \-1, if querying the user inactive time
-is not supported by the system, and in safe interpreters.
-.PP
-If the literal string \fBreset\fR is given as an additional argument,
-the timer is reset and an empty string is returned. Resetting the
-inactivity time is forbidden in safe interpreters and will throw and
-error if tried.
-.RE
-.TP
\fBtk useinputmethods \fR?\fB\-displayof \fIwindow\fR? ?\fIboolean\fR?
.
Sets and queries the state of whether Tk should use XIM (X Input Methods)
@@ -125,7 +129,7 @@ Returns the current Tk windowing system,
\fBx11\fR (X11-based), \fBwin32\fR (MS Windows),
or \fBaqua\fR (Mac OS X Aqua).
.SH "SEE ALSO"
-busy(n), send(n), winfo(n)
+busy(n), fontchooser(n), send(n), winfo(n)
.SH KEYWORDS
application name, send
'\" Local Variables:
Index: generic/tkCmds.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkCmds.c,v
retrieving revision 1.48
diff -u -p -r1.48 tkCmds.c
--- generic/tkCmds.c 10 Dec 2008 00:34:51 -0000 1.48
+++ generic/tkCmds.c 10 Dec 2008 04:28:48 -0000
@@ -51,6 +51,12 @@ static int WindowingsystemCmd(ClientDat
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+#if defined(__WIN32__) || defined(MAC_OSX_TK)
+MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
+#else
+#define tkFontchooserEnsemble NULL
+#endif
+
/*
* Table of tk subcommand names and implementations.
*/
@@ -63,6 +69,7 @@ static const TkEnsemble tkCmdMap[] = {
{"scaling", ScalingCmd },
{"useinputmethods", UseinputmethodsCmd },
{"windowingsystem", WindowingsystemCmd },
+ {"fontchooser", NULL, tkFontchooserEnsemble},
{NULL}
};
@@ -635,6 +642,9 @@ int
TkInitTkCmd(Tcl_Interp *interp, ClientData clientData)
{
TkMakeEnsemble(interp, "::", "tk", clientData, tkCmdMap);
+#if defined(__WIN32__) || defined(MAC_OSX_TK)
+ TkInitFontchooser(interp, clientData);
+#endif
return TCL_OK;
}
Index: generic/tkInt.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkInt.h,v
retrieving revision 1.97
diff -u -p -r1.97 tkInt.h
--- generic/tkInt.h 10 Dec 2008 00:34:51 -0000 1.97
+++ generic/tkInt.h 10 Dec 2008 04:28:48 -0000
@@ -1040,9 +1040,6 @@ MODULE_SCOPE int Tk_ChooseColorObjCmd(Cl
MODULE_SCOPE int Tk_ChooseDirectoryObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tk_ChooseFontObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
MODULE_SCOPE int Tk_DestroyObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -1251,7 +1248,6 @@ MODULE_SCOPE void TkpMakeTransparentWind
MODULE_SCOPE void TkpCreateBusy(Tk_FakeWin *winPtr, Tk_Window tkRef,
Window *parentPtr, Tk_Window tkParent,
TkBusy busy);
-
MODULE_SCOPE void TkDrawAngledTextLayout(Display *display,
Drawable drawable, GC gc, Tk_TextLayout layout,
int x, int y, double angle, int firstChar,
@@ -1264,11 +1260,16 @@ MODULE_SCOPE void TkUnderlineAngledTextL
int x, int y, double angle, int underline);
MODULE_SCOPE int TkIntersectAngledTextLayout(Tk_TextLayout layout,
int x,int y, int width, int height, double angle);
+MODULE_SCOPE int TkBackgroundEvalObjv(Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv, int flags);
+MODULE_SCOPE void TkSendVirtualEvent(Tk_Window tgtWin, const char *eventName);
MODULE_SCOPE Tcl_Command TkMakeEnsemble(Tcl_Interp *interp,
const char *namespace, const char *name,
ClientData clientData, const TkEnsemble *map);
MODULE_SCOPE int TkInitTkCmd(Tcl_Interp *interp,
ClientData clientData);
+MODULE_SCOPE int TkInitFontchooser(Tcl_Interp *interp,
+ ClientData clientData);
/*
* Unsupported commands.
Index: generic/tkUtil.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/generic/tkUtil.c,v
retrieving revision 1.26
diff -u -p -r1.26 tkUtil.c
--- generic/tkUtil.c 10 Dec 2008 04:27:45 -0000 1.26
+++ generic/tkUtil.c 10 Dec 2008 04:28:49 -0000
@@ -978,6 +978,89 @@ TkFindStateNumObj(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * TkBackgroundEvalObjv --
+ *
+ * Evaluate a command while ensuring that we do not affect the
+ * interpreters state. This is important when evaluating script
+ * during background tasks.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side Effects:
+ * The interpreters variables and code may be modified by the script
+ * but the result will not be modified.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TkBackgroundEvalObjv(
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv,
+ int flags)
+{
+ Tcl_DString errorInfo, errorCode;
+ Tcl_SavedResult state;
+ int n, r = TCL_OK;
+
+ Tcl_DStringInit(&errorInfo);
+ Tcl_DStringInit(&errorCode);
+
+ Tcl_Preserve(interp);
+
+ /*
+ * Record the state of the interpreter
+ */
+
+ Tcl_SaveResult(interp, &state);
+ Tcl_DStringAppend(&errorInfo,
+ Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
+ Tcl_DStringAppend(&errorCode,
+ Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY), -1);
+
+ /*
+ * Evaluate the command and handle any error.
+ */
+
+ for (n = 0; n < objc; ++n) {
+ Tcl_IncrRefCount(objv[n]);
+ }
+ r = Tcl_EvalObjv(interp, objc, objv, flags);
+ for (n = 0; n < objc; ++n) {
+ Tcl_DecrRefCount(objv[n]);
+ }
+ if (r == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (background event handler)");
+ Tcl_BackgroundError(interp);
+ }
+
+ Tcl_Release(interp);
+
+ /*
+ * Restore the state of the interpreter
+ */
+
+ Tcl_SetVar(interp, "errorInfo",
+ Tcl_DStringValue(&errorInfo), TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "errorCode",
+ Tcl_DStringValue(&errorCode), TCL_GLOBAL_ONLY);
+ Tcl_RestoreResult(interp, &state);
+
+ /*
+ * Clean up references.
+ */
+
+ Tcl_DStringFree(&errorInfo);
+ Tcl_DStringFree(&errorCode);
+
+ return r;
+}
+
+/*
*----------------------------------------------------------------------
*
* TkMakeEnsemble --
@@ -1060,6 +1143,36 @@ TkMakeEnsemble(
Tcl_DStringFree(&ds);
return ensemble;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkSendVirtualEvent --
+ *
+ * Send a virtual event notification to the specified target window.
+ * Equivalent to "event generate $target <<$eventName>>"
+ *
+ * Note that we use Tk_QueueWindowEvent, not Tk_HandleEvent,
+ * so this routine does not reenter the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TkSendVirtualEvent(Tk_Window target, const char *eventName)
+{
+ XEvent event;
+
+ memset(&event, 0, sizeof(event));
+ event.xany.type = VirtualEvent;
+ event.xany.serial = NextRequest(Tk_Display(target));
+ event.xany.send_event = False;
+ event.xany.window = Tk_WindowId(target);
+ event.xany.display = Tk_Display(target);
+ ((XVirtualEvent *) &event)->name = Tk_GetUid(eventName);
+
+ Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL);
+}
/*
* Local Variables:
* mode: c
Index: library/console.tcl
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/console.tcl,v
retrieving revision 1.38
diff -u -p -r1.38 console.tcl
--- library/console.tcl 13 May 2008 13:25:18 -0000 1.38
+++ library/console.tcl 10 Dec 2008 04:28:49 -0000
@@ -8,7 +8,7 @@
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
-# Copyright (c) 2007 Daniel A. Steffen <[email protected]>
+# Copyright (c) 2007-2008 Daniel A. Steffen <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -22,11 +22,10 @@ namespace eval ::tk::console {
variable magicKeys 1 ; # enable brace matching and proc/var recognition
variable maxLines 600 ; # maximum # of lines buffered in console
variable showMatches 1 ; # show multiple expand matches
-
+ variable useFontchooser [llength [info command ::tk::fontchooser]]
variable inPlugin [info exists embed_args]
variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used
-
if {$inPlugin} {
set defaultPrompt {subst {[history nextid] % }}
} else {
@@ -98,6 +97,24 @@ proc ::tk::ConsoleInit {} {
}
AmpMenuArgs .menubar.edit add separator
+ if {$::tk::console::useFontchooser} {
+ if {[tk windowingsystem] eq "aqua"} {
+ .menubar.edit add command -label tk_choose_font_marker
+ set index [.menubar.edit index tk_choose_font_marker]
+ .menubar.edit entryconfigure $index \
+ -label [mc "Show Fonts"]\
+ -accelerator "$mod-T"\
+ -command [list ::tk::console::FontchooserToggle]
+ bind Console <<TkFontchooserVisibility>> \
+ [list ::tk::console::FontchooserVisibility $index]
+ ::tk::console::FontchooserVisibility $index
+ } else {
+ AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
+ -command [list ::tk::console::FontchooserToggle]
+ }
+ bind Console <FocusIn> [list ::tk::console::FontchooserFocus %W 1]
+ bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]
+ }
AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
-accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
@@ -396,6 +413,9 @@ proc ::tk::ConsoleBind {w} {
event add $ev $key
bind Console $key {}
}
+ if {$::tk::console::useFontchooser} {
+ bind Console <Command-Key-t> [list ::tk::console::FontchooserToggle]
+ }
}
bind Console <<Console_Expand>> {
if {[%W compare insert > promptEnd]} {
@@ -557,6 +577,9 @@ proc ::tk::ConsoleBind {w} {
if {$size < 0} {set sign -1} else {set sign 1}
set size [expr {(abs($size) + 1) * $sign}]
font configure TkConsoleFont -size $size
+ if {$::tk::console::useFontchooser} {
+ tk fontchooser configure -font TkConsoleFont
+ }
}
bind Console <<Console_FontSizeDecr>> {
set size [font configure TkConsoleFont -size]
@@ -564,6 +587,9 @@ proc ::tk::ConsoleBind {w} {
if {$size < 0} {set sign -1} else {set sign 1}
set size [expr {(abs($size) - 1) * $sign}]
font configure TkConsoleFont -size $size
+ if {$::tk::console::useFontchooser} {
+ tk fontchooser configure -font TkConsoleFont
+ }
}
##
@@ -669,6 +695,35 @@ Tcl $::tcl_patchLevel
Tk $::tk_patchLevel"
}
+# ::tk::console::Fontchooser* --
+# Let the user select the console font (TIP 324).
+
+proc ::tk::console::FontchooserToggle {} {
+ if {[tk fontchooser configure -visible]} {
+ tk fontchooser hide
+ } else {
+ tk fontchooser show
+ }
+}
+proc ::tk::console::FontchooserVisibility {index} {
+ if {[tk fontchooser configure -visible]} {
+ .menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]
+ } else {
+ .menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]
+ }
+}
+proc ::tk::console::FontchooserFocus {w isFocusIn} {
+ if {$isFocusIn} {
+ tk fontchooser configure -parent $w -font TkConsoleFont \
+ -command [namespace code [list FontchooserApply]]
+ } else {
+ tk fontchooser configure -parent $w -font {} -command {}
+ }
+}
+proc ::tk::console::FontchooserApply {font args} {
+ catch {font configure TkConsoleFont {*}[font actual $font]}
+}
+
# ::tk::console::TagProc --
#
# Tags a procedure in the console if it's recognized
Index: library/fontchooser.tcl
===================================================================
RCS file: library/fontchooser.tcl
diff -N library/fontchooser.tcl
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ library/fontchooser.tcl 10 Dec 2008 04:28:49 -0000
@@ -0,0 +1,398 @@
+# fontchooser.tcl -
+#
+# A themeable Tk font selection dialog. See TIP #324.
+#
+# Copyright (C) 2008 Keith Vetter
+# Copyright (C) 2008 Pat Thoyts <[email protected]>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id$
+
+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(-font) {}
+ set S(-command) {}
+
+ # 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
+ }
+}
+
+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)
+ }
+ 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] == 1 && [string equal [lindex $args 0] "-visible"]} {
+ return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
+ }
+
+ tclParseConfigSpec [namespace which -variable S] $specs "" $args
+ if {$S(-parent) ne "."} {
+ winfo toplevel $S(-parent)
+ }
+ 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>>
+ }
+}
+
+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)]
+ wm geometry $S(W) 430x316
+
+ 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 -textvariable [namespace which -variable S](font)
+ ttk::entry $S(W).estyle -textvariable [namespace which -variable S](style)
+ ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
+ -width 0 -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 6 -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]]
+
+ 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 8 -pady 6
+ 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
+ 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 10
+ grid columnconfigure $outer {0 2 4} -weight 1
+
+ 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 config -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) config -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]} {
+ destroy $f
+ return -code error $err
+ }
+ return $w
+}
Index: library/tclIndex
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/tclIndex,v
retrieving revision 1.10
diff -u -p -r1.10 tclIndex
--- library/tclIndex 30 Oct 2007 01:57:54 -0000 1.10
+++ library/tclIndex 10 Dec 2008 04:28:49 -0000
@@ -276,3 +276,4 @@ set auto_index(::tk::ListBoxKeyAccel_Res
set auto_index(tk_getFileType) [list source [file join $dir xmfbox.tcl]]
set auto_index(::tk::unsupported::ExposePrivateCommand) [list source [file join $dir unsupported.tcl]]
set auto_index(::tk::unsupported::ExposePrivateVariable) [list source [file join $dir unsupported.tcl]]
+set auto_index(::tk::fontchooser) [list source [file join $dir fontchooser.tcl]]
Index: library/demos/text.tcl
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/demos/text.tcl,v
retrieving revision 1.8
diff -u -p -r1.8 text.tcl
--- library/demos/text.tcl 13 Dec 2007 15:27:07 -0000 1.8
+++ library/demos/text.tcl 10 Dec 2008 04:28:49 -0000
@@ -19,7 +19,8 @@ wm iconname $w "text"
positionWindow $w
## See Code / Dismiss buttons
-set btns [addSeeDismiss $w.buttons $w]
+set btns [addSeeDismiss $w.buttons $w {} \
+ {ttk::button $w.buttons.fontchooser -command fontchooserToggle}]
pack $btns -side bottom -fill x
text $w.text -yscrollcommand [list $w.scroll set] -setgrid 1 \
@@ -27,6 +28,30 @@ text $w.text -yscrollcommand [list $w.sc
scrollbar $w.scroll -command [list $w.text yview]
pack $w.scroll -side right -fill y
pack $w.text -expand yes -fill both
+
+# TIP 324 Demo: [tk fontchooser]
+proc fontchooserToggle {} {
+ tk fontchooser [expr {[tk fontchooser configure -visible] ?
+ "hide" : "show"}]
+}
+proc fontchooserVisibility {w} {
+ $w configure -text [expr {[tk fontchooser configure -visible] ?
+ "Hide Font Dialog" : "Show Font Dialog"}]
+}
+proc fontchooserFocus {w} {
+ tk fontchooser configure -font [$w cget -font] \
+ -command [list fontchooserFontSel $w]
+}
+proc fontchooserFontSel {w font args} {
+ $w configure -font [font actual $font]
+}
+tk fontchooser configure -parent $w
+bind $w.text <FocusIn> [list fontchooserFocus $w.text]
+fontchooserVisibility $w.buttons.fontchooser
+bind $w <<TkFontchooserVisibility>> [list \
+ fontchooserVisibility $w.buttons.fontchooser]
+focus $w.text
+
$w.text insert 0.0 \
{This window is a text widget. It displays one or more lines of text
and allows you to edit the text. Here is a summary of the things you
Index: library/msgs/de.msg
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/msgs/de.msg,v
retrieving revision 1.7
diff -u -p -r1.7 de.msg
--- library/msgs/de.msg 14 Nov 2007 14:07:04 -0000 1.7
+++ library/msgs/de.msg 10 Dec 2008 04:28:49 -0000
@@ -5,6 +5,7 @@ namespace eval ::tk {
::msgcat::mcset de "Application Error" "Applikationsfehler"
::msgcat::mcset de "&Blue" "&Blau"
::msgcat::mcset de "&Cancel" "&Abbruch"
+ ::msgcat::mcset de "Cancel" "Abbruch"
::msgcat::mcset de "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kann nicht in das Verzeichnis \"%1\$s\" wechseln.\nKeine Rechte vorhanden."
::msgcat::mcset de "Choose Directory" "W\u00e4hle Verzeichnis"
::msgcat::mcset de "&Clear" "&R\u00fccksetzen"
Index: library/msgs/en.msg
===================================================================
RCS file: /cvsroot/tktoolkit/tk/library/msgs/en.msg,v
retrieving revision 1.6
diff -u -p -r1.6 en.msg
--- library/msgs/en.msg 6 Dec 2007 16:05:47 -0000 1.6
+++ library/msgs/en.msg 10 Dec 2008 04:28:49 -0000
@@ -3,7 +3,11 @@ namespace eval ::tk {
::msgcat::mcset en "&About..."
::msgcat::mcset en "All Files"
::msgcat::mcset en "Application Error"
+ ::msgcat::mcset en "&Apply"
+ ::msgcat::mcset en "Bold"
+ ::msgcat::mcset en "Bold Italic"
::msgcat::mcset en "&Blue"
+ ::msgcat::mcset en "Cancel"
::msgcat::mcset en "&Cancel"
::msgcat::mcset en "Cannot change to the directory \"%1\$s\".\nPermission denied."
::msgcat::mcset en "Choose Directory"
@@ -18,6 +22,7 @@ namespace eval ::tk {
::msgcat::mcset en "Directory \"%1\$s\" does not exist."
::msgcat::mcset en "&Directory:"
::msgcat::mcset en "&Edit"
+ ::msgcat::mcset en "Effects"
::msgcat::mcset en "Error: %1\$s"
::msgcat::mcset en "E&xit"
::msgcat::mcset en "&File"
@@ -30,15 +35,20 @@ namespace eval ::tk {
::msgcat::mcset en "Fi&les:"
::msgcat::mcset en "&Filter"
::msgcat::mcset en "Fil&ter:"
+ ::msgcat::mcset en "Font"
+ ::msgcat::mcset en "&Font:"
+ ::msgcat::mcset en "Font st&yle:"
::msgcat::mcset en "&Green"
::msgcat::mcset en "&Help"
::msgcat::mcset en "Hi"
::msgcat::mcset en "&Hide Console"
::msgcat::mcset en "&Ignore"
::msgcat::mcset en "Invalid file name \"%1\$s\"."
+ ::msgcat::mcset en "Italic"
::msgcat::mcset en "Log Files"
::msgcat::mcset en "&No"
::msgcat::mcset en "&OK"
+ ::msgcat::mcset en "OK"
::msgcat::mcset en "Ok"
::msgcat::mcset en "Open"
::msgcat::mcset en "&Open"
@@ -46,21 +56,26 @@ namespace eval ::tk {
::msgcat::mcset en "P&aste"
::msgcat::mcset en "&Quit"
::msgcat::mcset en "&Red"
+ ::msgcat::mcset en "Regular"
::msgcat::mcset en "Replace existing file?"
::msgcat::mcset en "&Retry"
+ ::msgcat::mcset en "Sample"
::msgcat::mcset en "&Save"
::msgcat::mcset en "Save As"
::msgcat::mcset en "Save To Log"
::msgcat::mcset en "Select Log File"
::msgcat::mcset en "Select a file to source"
::msgcat::mcset en "&Selection:"
+ ::msgcat::mcset en "&Size:"
::msgcat::mcset en "Show &Hidden Directories"
::msgcat::mcset en "Show &Hidden Files and Directories"
::msgcat::mcset en "Skip Messages"
::msgcat::mcset en "&Source..."
+ ::msgcat::mcset en "Stri&keout"
::msgcat::mcset en "Tcl Scripts"
::msgcat::mcset en "Tcl for Windows"
::msgcat::mcset en "Text Files"
+ ::msgcat::mcset en "&Underline"
::msgcat::mcset en "&Yes"
::msgcat::mcset en "abort"
::msgcat::mcset en "blue"
Index: macosx/tkMacOSXCarbonEvents.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXCarbonEvents.c,v
retrieving revision 1.21
diff -u -p -r1.21 tkMacOSXCarbonEvents.c
--- macosx/tkMacOSXCarbonEvents.c 8 Nov 2008 18:44:40 -0000 1.21
+++ macosx/tkMacOSXCarbonEvents.c 10 Dec 2008 04:28:49 -0000
@@ -211,6 +211,8 @@ TkMacOSXInitCarbonEvents(
{kEventClassApplication, kEventAppShown},
{kEventClassApplication, kEventAppAvailableWindowBoundsChanged},
{kEventClassAppearance, kEventAppearanceScrollBarVariantChanged},
+ {kEventClassFont, kEventFontPanelClosed},
+ {kEventClassFont, kEventFontSelection},
};
carbonEventHandlerUPP = NewEventHandlerUPP(CarbonEventHandlerProc);
Index: macosx/tkMacOSXDialog.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXDialog.c,v
retrieving revision 1.42
diff -u -p -r1.42 tkMacOSXDialog.c
--- macosx/tkMacOSXDialog.c 7 Dec 2008 16:36:26 -0000 1.42
+++ macosx/tkMacOSXDialog.c 10 Dec 2008 04:28:49 -0000
@@ -5,7 +5,7 @@
*
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
* Copyright 2001, Apple Computer, Inc.
- * Copyright (c) 2006-2007 Daniel A. Steffen <[email protected]>
+ * Copyright (c) 2006-2008 Daniel A. Steffen <[email protected]>
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -1741,3 +1741,566 @@ AlertHandler(
}
return eventNotHandledErr;
}
+
+/*
+ *----------------------------------------------------------------------
+ */
+#pragma mark [tk fontchooser] implementation (TIP 324)
+/*
+ *----------------------------------------------------------------------
+ */
+
+#include "tkMacOSXEvent.h"
+#include "tkMacOSXFont.h"
+
+typedef struct FontchooserData {
+ Tcl_Obj *titleObj;
+ Tcl_Obj *cmdObj;
+ Tk_Window parent;
+} FontchooserData;
+
+static Tcl_Obj *FontchooserCget(FontchooserData *fcdPtr, int optionIndex);
+static int FontchooserConfigureCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int FontchooserShowCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int FontchooserHideCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static void FontchooserParentEventHandler(ClientData clientData,
+ XEvent *eventPtr);
+static void DeleteFontchooserData(ClientData clientData, Tcl_Interp *interp);
+
+MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
+const TkEnsemble tkFontchooserEnsemble[] = {
+ { "configure", FontchooserConfigureCmd },
+ { "show", FontchooserShowCmd },
+ { "hide", FontchooserHideCmd },
+};
+
+static Tcl_Interp *fontchooserInterp = NULL;
+static FMFontFamily fontPanelFontFamily = kInvalidFontFamily;
+static FMFontStyle fontPanelFontStyle = -1;
+static FMFontSize fontPanelFontSize = 0;
+static FMFont fontPanelFontID = kInvalidFont;
+
+static const char *fontchooserOptionStrings[] = {
+ "-parent", "-title", "-font", "-command",
+ "-visible", NULL
+};
+enum FontchooserOption {
+ FontchooserParent, FontchooserTitle, FontchooserFont, FontchooserCmd,
+ FontchooserVisible
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkMacOSXProcessFontEvent --
+ *
+ * This processes events generated by user interaction with the
+ * font panel.
+ *
+ * Results:
+ * True if Tk events are generated - false otherwise.
+ *
+ * Side effects:
+ * Additional events may be place on the Tk event queue.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TkMacOSXProcessFontEvent(
+ TkMacOSXEvent * eventPtr,
+ MacEventStatus * statusPtr)
+{
+ OSStatus err;
+ int eventGenerated = 0;
+ FontchooserData *fcdPtr;
+
+ switch (eventPtr->eKind) {
+ case kEventFontPanelClosed:
+ case kEventFontSelection:
+ break;
+ default:
+ goto done;
+ }
+ if (!fontchooserInterp) {
+ goto done;
+ }
+ fcdPtr = Tcl_GetAssocData(fontchooserInterp, "::tk::fontchooser", NULL);
+ switch (eventPtr->eKind) {
+ case kEventFontPanelClosed:
+ if (!FPIsFontPanelVisible() && fcdPtr->parent != None) {
+ TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserVisibility");
+ fontchooserInterp = NULL;
+ eventGenerated = 1;
+ }
+ break;
+ case kEventFontSelection: {
+ Tcl_Obj *fontObj = NULL;
+
+ fontPanelFontFamily = kInvalidFontFamily;
+ fontPanelFontStyle = -1;
+ fontPanelFontSize = 0;
+ fontPanelFontID = kInvalidFont;
+ err = ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamFMFontFamily, typeFMFontFamily, NULL,
+ sizeof(FMFontFamily), NULL, &fontPanelFontFamily);
+ err |= ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamFMFontStyle, typeFMFontStyle, NULL,
+ sizeof(FMFontStyle), NULL, &fontPanelFontStyle);
+ err |= ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamFMFontSize, typeFMFontSize, NULL,
+ sizeof(FMFontSize), NULL, &fontPanelFontSize);
+ if (err != noErr) {
+ /*
+ * No/incomplete QD font spec, use ATSUI font ID
+ */
+ Fixed fontFixedSize;
+
+ err = ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamATSUFontID, typeATSUFontID, NULL,
+ sizeof(ATSUFontID), NULL, &fontPanelFontID);
+ if (err == noErr) {
+ ChkErr(FMGetFontFamilyInstanceFromFont, fontPanelFontID,
+ &fontPanelFontFamily, &fontPanelFontStyle);
+ }
+ err = ChkErr(GetEventParameter, eventPtr->eventRef,
+ kEventParamATSUFontSize, typeATSUSize, NULL,
+ sizeof(Fixed), NULL, &fontFixedSize);
+ if (err == noErr) {
+ fontPanelFontSize = FixedToInt(fontFixedSize);
+ }
+ }
+ fontObj = TkMacOSXFontDescriptionForFMFontInfo(
+ fontPanelFontFamily, fontPanelFontStyle,
+ fontPanelFontSize, fontPanelFontID);
+ if (fontObj) {
+ if (fcdPtr->cmdObj) {
+ int objc, result;
+ Tcl_Obj **objv, **tmpv;
+
+ result = Tcl_ListObjGetElements(fontchooserInterp,
+ fcdPtr->cmdObj, &objc, &objv);
+ if (result == TCL_OK) {
+ tmpv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) *
+ (unsigned)(objc + 2));
+ memcpy(tmpv, objv, sizeof(Tcl_Obj *) * objc);
+ tmpv[objc] = fontObj;
+ result = TkBackgroundEvalObjv(fontchooserInterp,
+ objc + 1, tmpv, TCL_EVAL_GLOBAL);
+ ckfree((char *)tmpv);
+ }
+ }
+ TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserFontChanged");
+ }
+ break;
+ }
+ }
+done:
+ return eventGenerated;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FontchooserCget --
+ *
+ * Helper for the FontchooserConfigure command to return the
+ * current value of any of the options (which may be NULL in
+ * the structure)
+ *
+ * Results:
+ * Tcl object of option value.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+FontchooserCget(
+ FontchooserData *fcdPtr,
+ int optionIndex)
+{
+ Tcl_Obj *resObj = NULL;
+
+ switch(optionIndex) {
+ case FontchooserParent: {
+ if (fcdPtr->parent != None) {
+ resObj = Tcl_NewStringObj(
+ ((TkWindow*)fcdPtr->parent)->pathName, -1);
+ } else {
+ resObj = Tcl_NewStringObj(".", 1);
+ }
+ break;
+ }
+ case FontchooserTitle: {
+ if (fcdPtr->titleObj) {
+ resObj = fcdPtr->titleObj;
+ } else {
+ resObj = Tcl_NewObj();
+ }
+ break;
+ }
+ case FontchooserFont: {
+ resObj = TkMacOSXFontDescriptionForFMFontInfo(
+ fontPanelFontFamily, fontPanelFontStyle,
+ fontPanelFontSize, fontPanelFontID);
+ if (!resObj) {
+ resObj = Tcl_NewObj();
+ }
+ break;
+ }
+ case FontchooserCmd: {
+ if (fcdPtr->cmdObj) {
+ resObj = fcdPtr->cmdObj;
+ } else {
+ resObj = Tcl_NewObj();
+ }
+ break;
+ }
+ case FontchooserVisible: {
+ resObj = Tcl_NewBooleanObj(FPIsFontPanelVisible());
+ break;
+ }
+ default: {
+ resObj = Tcl_NewObj();
+ }
+ }
+ return resObj;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserConfigureCmd --
+ *
+ * Implementation of the 'tk fontchooser configure' ensemble command.
+ * See the user documentation for what it does.
+ *
+ * Results:
+ * See the user documentation.
+ *
+ * Side effects:
+ * Per-interp data structure may be modified
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserConfigureCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tk_Window tkwin = (Tk_Window)clientData;
+ FontchooserData *fcdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser",
+ NULL);
+ int i, r = TCL_OK;
+
+ /*
+ * With no arguments we return all the options in a dict
+ */
+
+ if (objc == 1) {
+ Tcl_Obj *keyObj, *valueObj;
+ Tcl_Obj *dictObj = Tcl_NewDictObj();
+ for (i = 0; r == TCL_OK && fontchooserOptionStrings[i] != NULL; ++i) {
+ keyObj = Tcl_NewStringObj(fontchooserOptionStrings[i], -1);
+ valueObj = FontchooserCget(fcdPtr, i);
+ r = Tcl_DictObjPut(interp, dictObj, keyObj, valueObj);
+ }
+ if (r == TCL_OK) {
+ Tcl_SetObjResult(interp, dictObj);
+ }
+ return r;
+ }
+
+ for (i = 1; i < objc; i += 2) {
+ int optionIndex, len;
+ if (Tcl_GetIndexFromObj(interp, objv[i], fontchooserOptionStrings,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ /* With one option and no arg, return the current value */
+ Tcl_SetObjResult(interp, FontchooserCget(fcdPtr, optionIndex));
+ return TCL_OK;
+ }
+ if (i + 1 == objc) {
+ Tcl_AppendResult(interp, "value for \"",
+ Tcl_GetString(objv[i]), "\" missing", NULL);
+ return TCL_ERROR;
+ }
+ switch (optionIndex) {
+ case FontchooserVisible: {
+ const char *msg = "cannot change read-only option "
+ "\"-visible\": use the show or hide command";
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, sizeof(msg)-1));
+ return TCL_ERROR;
+ }
+ case FontchooserParent: {
+ Tk_Window parent = Tk_NameToWindow(interp,
+ Tcl_GetString(objv[i+1]), tkwin);
+ if (parent == None) {
+ return TCL_ERROR;
+ }
+ if (fcdPtr->parent) {
+ Tk_DeleteEventHandler(fcdPtr->parent, StructureNotifyMask,
+ FontchooserParentEventHandler, fcdPtr);
+ }
+ fcdPtr->parent = parent;
+ Tk_CreateEventHandler(fcdPtr->parent, StructureNotifyMask,
+ FontchooserParentEventHandler, fcdPtr);
+ break;
+ }
+ case FontchooserTitle:
+ if (fcdPtr->titleObj) {
+ Tcl_DecrRefCount(fcdPtr->titleObj);
+ }
+ Tcl_GetStringFromObj(objv[i+1], &len);
+ if (len) {
+ fcdPtr->titleObj = objv[i+1];
+ if (Tcl_IsShared(fcdPtr->titleObj)) {
+ fcdPtr->titleObj = Tcl_DuplicateObj(fcdPtr->titleObj);
+ }
+ Tcl_IncrRefCount(fcdPtr->titleObj);
+ } else {
+ fcdPtr->titleObj = NULL;
+ }
+ break;
+ case FontchooserFont: {
+
+ Tcl_GetStringFromObj(objv[i+1], &len);
+ if (len) {
+ Tk_Font f = Tk_AllocFontFromObj(interp, tkwin, objv[i+1]);
+ if (f) {
+ ATSUStyle atsuStyle;
+
+ TkMacOSXFMFontInfoForFont(f, &fontPanelFontFamily,
+ &fontPanelFontStyle, &fontPanelFontSize,
+ &atsuStyle);
+ ChkErr(SetFontInfoForSelection,
+ kFontSelectionATSUIType, 1, &atsuStyle, NULL);
+ Tk_FreeFont(f);
+ } else {
+ return TCL_ERROR;
+ }
+ } else {
+ fontPanelFontFamily = kInvalidFontFamily;
+ ChkErr(SetFontInfoForSelection,
+ kFontSelectionATSUIType, 0, NULL, NULL);
+ }
+ if (FPIsFontPanelVisible()) {
+ TkSendVirtualEvent(fcdPtr->parent,
+ "TkFontchooserFontChanged");
+ }
+ break;
+ }
+ case FontchooserCmd:
+ if (fcdPtr->cmdObj) {
+ Tcl_DecrRefCount(fcdPtr->cmdObj);
+ }
+ Tcl_GetStringFromObj(objv[i+1], &len);
+ if (len) {
+ fcdPtr->cmdObj = objv[i+1];
+ if (Tcl_IsShared(fcdPtr->cmdObj)) {
+ fcdPtr->cmdObj = Tcl_DuplicateObj(fcdPtr->cmdObj);
+ }
+ Tcl_IncrRefCount(fcdPtr->cmdObj);
+ } else {
+ fcdPtr->cmdObj = NULL;
+ }
+ break;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserShowCmd --
+ *
+ * Implements the 'tk fontchooser show' ensemble command. The
+ * per-interp configuration data for the dialog is held in an interp
+ * associated structure.
+ *
+ * Results:
+ * See the user documentation.
+ *
+ * Side effects:
+ * Font Panel may be shown.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserShowCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ FontchooserData *fcdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser",
+ NULL);
+
+ if (fcdPtr->parent == None) {
+ fcdPtr->parent = (Tk_Window) clientData;
+ Tk_CreateEventHandler(fcdPtr->parent, StructureNotifyMask,
+ FontchooserParentEventHandler, fcdPtr);
+ }
+ if (!FPIsFontPanelVisible()) {
+ ChkErr(FPShowHideFontPanel);
+ TkSendVirtualEvent(fcdPtr->parent, "TkFontchooserVisibility");
+ }
+ fontchooserInterp = interp;
+
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserHideCmd --
+ *
+ * Implementation of the 'tk fontchooser hide' ensemble. See the
+ * user documentation for details.
+ *
+ * Results:
+ * See the user documentation.
+ *
+ * Side effects:
+ * Font Panel may be hidden.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserHideCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (FPIsFontPanelVisible()) {
+ ChkErr(FPShowHideFontPanel);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserParentEventHandler --
+ *
+ * Event handler for StructureNotify events on the font chooser's
+ * parent window.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Font chooser parent info is cleared and font panel is hidden.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+FontchooserParentEventHandler(
+ ClientData clientData,
+ XEvent *eventPtr)
+{
+ FontchooserData *fcdPtr = clientData;
+
+ if (eventPtr->type == DestroyNotify) {
+ Tk_DeleteEventHandler(fcdPtr->parent, StructureNotifyMask,
+ FontchooserParentEventHandler, fcdPtr);
+ fcdPtr->parent = None;
+ if (FPIsFontPanelVisible()) {
+ ChkErr(FPShowHideFontPanel);
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteFontchooserData --
+ *
+ * Clean up the font chooser configuration data when the interp
+ * is destroyed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * per-interp configuration data is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteFontchooserData(
+ ClientData clientData,
+ Tcl_Interp *interp)
+{
+ FontchooserData *fcdPtr = clientData;
+
+ if (fcdPtr->titleObj) {
+ Tcl_DecrRefCount(fcdPtr->titleObj);
+ }
+ if (fcdPtr->cmdObj) {
+ Tcl_DecrRefCount(fcdPtr->cmdObj);
+ }
+ ckfree((char *)fcdPtr);
+
+ if (fontchooserInterp == interp) {
+ fontchooserInterp = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TkInitFontchooser --
+ *
+ * Associate the font chooser configuration data with the Tcl
+ * interpreter. There is one font chooser per interp.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * per-interp configuration data is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TkInitFontchooser(
+ Tcl_Interp *interp,
+ ClientData clientData)
+{
+ FontchooserData *fcdPtr = (FontchooserData*)
+ ckalloc(sizeof(FontchooserData));
+
+ bzero(fcdPtr, sizeof(FontchooserData));
+ Tcl_SetAssocData(interp, "::tk::fontchooser", DeleteFontchooserData,
+ fcdPtr);
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 79
+ * coding: utf-8
+ * End:
+ */
Index: macosx/tkMacOSXEvent.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXEvent.c,v
retrieving revision 1.24
diff -u -p -r1.24 tkMacOSXEvent.c
--- macosx/tkMacOSXEvent.c 27 Oct 2008 11:55:44 -0000 1.24
+++ macosx/tkMacOSXEvent.c 10 Dec 2008 04:28:49 -0000
@@ -103,6 +103,9 @@ TkMacOSXProcessEvent(
case kEventClassCommand:
TkMacOSXProcessCommandEvent(eventPtr, statusPtr);
break;
+ case kEventClassFont:
+ TkMacOSXProcessFontEvent(eventPtr, statusPtr);
+ break;
default: {
TkMacOSXDbgMsg("Unrecognised event: %s",
TkMacOSXCarbonEventToAscii(eventPtr->eventRef));
Index: macosx/tkMacOSXEvent.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXEvent.h,v
retrieving revision 1.12
diff -u -p -r1.12 tkMacOSXEvent.h
--- macosx/tkMacOSXEvent.h 23 Apr 2007 21:24:33 -0000 1.12
+++ macosx/tkMacOSXEvent.h 10 Dec 2008 04:28:49 -0000
@@ -98,6 +98,8 @@ MODULE_SCOPE int TkMacOSXProcessMenuEven
MacEventStatus *statusPtr);
MODULE_SCOPE int TkMacOSXProcessCommandEvent(TkMacOSXEvent *e,
MacEventStatus *statusPtr);
+MODULE_SCOPE int TkMacOSXProcessFontEvent(TkMacOSXEvent *e,
+ MacEventStatus *statusPtr);
MODULE_SCOPE int TkMacOSXKeycodeToUnicode(
UniChar * uniChars, int maxChars,
EventKind eKind,
Index: macosx/tkMacOSXFont.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXFont.c,v
retrieving revision 1.42
diff -u -p -r1.42 tkMacOSXFont.c
--- macosx/tkMacOSXFont.c 22 Nov 2008 22:29:14 -0000 1.42
+++ macosx/tkMacOSXFont.c 10 Dec 2008 04:28:50 -0000
@@ -2517,6 +2517,103 @@ TkMacOSXInitControlFontStyle(
/*
*----------------------------------------------------------------------
*
+ * TkMacOSXFMFontInfoForFont --
+ *
+ * Retrieve FontManager/ATSUI font information for a Tk font.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE void
+TkMacOSXFMFontInfoForFont(
+ Tk_Font tkfont,
+ FMFontFamily *fontFamilyPtr,
+ FMFontStyle *fontStylePtr,
+ FMFontSize *fontSizePtr,
+ ATSUStyle *fontATSUStylePtr)
+{
+ const MacFont * fontPtr = (MacFont *) tkfont;
+
+ if (fontFamilyPtr) {
+ *fontFamilyPtr = fontPtr->qdFont;
+ }
+ if (fontStylePtr) {
+ *fontStylePtr = fontPtr->qdStyle;
+ }
+ if (fontSizePtr) {
+ *fontSizePtr = fontPtr->qdSize;
+ }
+ if (fontATSUStylePtr) {
+ *fontATSUStylePtr = fontPtr->atsuStyle;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkMacOSXFontDescriptionForFMFontInfo --
+ *
+ * Get text description of a font specified by FontManager info.
+ *
+ * Results:
+ * List object or NULL.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE Tcl_Obj *
+TkMacOSXFontDescriptionForFMFontInfo(
+ FMFontFamily fontFamily,
+ FMFontStyle fontStyle,
+ FMFontSize fontSize,
+ FMFont fontID)
+{
+ Tcl_Obj *objv[6];
+ int i = 0;
+
+ if (fontFamily != kInvalidFontFamily && fontStyle != -1) {
+ const char *familyName = FamilyNameForFamilyID(fontFamily);
+
+ if (familyName) {
+ objv[i++] = Tcl_NewStringObj(familyName, -1);
+ objv[i++] = Tcl_NewIntObj(fontSize);
+#define S(s) Tcl_NewStringObj(STRINGIFY(s),(int)(sizeof(STRINGIFY(s))-1))
+ objv[i++] = (fontStyle & bold) ? S(bold) : S(normal);
+ objv[i++] = (fontStyle & italic) ? S(italic) : S(roman);
+ if (fontStyle & underline) objv[i++] = S(underline);
+ /*if (fontStyle & overstrike) objv[i++] = S(overstrike);*/
+#undef S
+ }
+ } else if (fontID != kInvalidFont) {
+ CFStringRef fontName = NULL;
+ Tcl_Obj *fontNameObj = NULL;
+
+ ChkErr(ATSFontGetName, FMGetATSFontRefFromFont(fontID),
+ kATSOptionFlagsDefault, &fontName);
+ if (fontName) {
+ fontNameObj = TkMacOSXGetStringObjFromCFString(fontName);
+ CFRelease(fontName);
+ }
+ if (fontNameObj) {
+ objv[i++] = fontNameObj;
+ objv[i++] = Tcl_NewIntObj(fontSize);
+ }
+ }
+ return i ? Tcl_NewListObj(i, objv) : NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TkMacOSXUseAntialiasedText --
*
* Enables or disables application-wide use of antialiased text (where
Index: macosx/tkMacOSXFont.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/tkMacOSXFont.h,v
retrieving revision 1.5
diff -u -p -r1.5 tkMacOSXFont.h
--- macosx/tkMacOSXFont.h 23 Apr 2007 21:24:33 -0000 1.5
+++ macosx/tkMacOSXFont.h 10 Dec 2008 04:28:50 -0000
@@ -30,5 +30,11 @@
MODULE_SCOPE void TkMacOSXInitControlFontStyle(Tk_Font tkfont,
ControlFontStylePtr fsPtr);
+MODULE_SCOPE void TkMacOSXFMFontInfoForFont(Tk_Font tkfont,
+ FMFontFamily *fontFamilyPtr, FMFontStyle *fontStylePtr,
+ FMFontSize *fontSizePtr, ATSUStyle *fontATSUStylePtr);
+MODULE_SCOPE Tcl_Obj * TkMacOSXFontDescriptionForFMFontInfo(
+ FMFontFamily fontFamily, FMFontStyle fontStyle, FMFontSize fontSize,
+ FMFont fontID);
#endif /*TKMACOSXFONT_H*/
Index: macosx/Wish.xcodeproj/project.pbxproj
===================================================================
RCS file: /cvsroot/tktoolkit/tk/macosx/Wish.xcodeproj/project.pbxproj,v
retrieving revision 1.48
diff -u -p -r1.48 project.pbxproj
--- macosx/Wish.xcodeproj/project.pbxproj 5 Dec 2008 17:10:30 -0000 1.48
+++ macosx/Wish.xcodeproj/project.pbxproj 10 Dec 2008 04:28:51 -0000
@@ -2087,10 +2087,13 @@
F97AE8330B65C87F00310EA2 /* Wish-Debug.xcconfig */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xcconfig; path = "Wish-Debug.xcconfig"; sourceTree = "<group>"; };
F9903CAF094FAADA004613E9 /* tclTomMath.decls */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclTomMath.decls; sourceTree = "<group>"; };
F9903CB0094FAADA004613E9 /* tclTomMathDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMathDecls.h; sourceTree = "<group>"; };
+ F99388380EE0114B0065FE6B /* fontchooser.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fontchooser.tcl; sourceTree = "<group>"; };
+ F99388950EE02D980065FE6B /* fontchooser.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fontchooser.test; sourceTree = "<group>"; };
F9A3082D08F2D4AB00BAE1AB /* Tk.framework */ = {isa = PBXFileReference; includeInIndex = 0; lastKnownFileType = wrapper.framework; path = Tk.framework; sourceTree = BUILT_PRODUCTS_DIR; };
F9A3084B08F2D4CE00BAE1AB /* Wish.app */ = {isa = PBXFileReference; explicitFileType = wrapper.application; includeInIndex = 0; path = Wish.app; sourceTree = BUILT_PRODUCTS_DIR; };
F9A3084E08F2D4F400BAE1AB /* Tcl.framework */ = {isa = PBXFileReference; includeInIndex = 0; lastKnownFileType = wrapper.framework; path = Tcl.framework; sourceTree = BUILT_PRODUCTS_DIR; };
F9A493240CEBF38300B78AE2 /* chanio.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = chanio.test; sourceTree = "<group>"; };
+ F9C888C20EEF6571003F63AD /* fontchooser.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = fontchooser.n; sourceTree = "<group>"; };
F9D1360A0CDC252C00DBE0B5 /* mclist.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = mclist.tcl; sourceTree = "<group>"; };
F9ECB1120B26521500A28025 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
F9ECB1130B26521500A28025 /* platform.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = platform.tcl; sourceTree = "<group>"; };
@@ -2229,6 +2232,7 @@
F966BA3908F27A37005CB29B /* focus.n */,
F966BA3A08F27A37005CB29B /* focusNext.n */,
F966BA3B08F27A37005CB29B /* font.n */,
+ F9C888C20EEF6571003F63AD /* fontchooser.n */,
F966BA3C08F27A37005CB29B /* FontId.3 */,
F966BA3D08F27A37005CB29B /* frame.n */,
F966BA3E08F27A37005CB29B /* FreeXId.3 */,
@@ -2487,6 +2491,7 @@
F966BB6208F27A3A005CB29B /* dialog.tcl */,
F966BB6308F27A3A005CB29B /* entry.tcl */,
F966BB6408F27A3A005CB29B /* focus.tcl */,
+ F99388380EE0114B0065FE6B /* fontchooser.tcl */,
F966BB7308F27A3A005CB29B /* listbox.tcl */,
F966BB7408F27A3A005CB29B /* menu.tcl */,
F966BB7508F27A3A005CB29B /* mkpsenc.tcl */,
@@ -2691,6 +2696,7 @@
F966BC2A08F27A3C005CB29B /* focus.test */,
F966BC2B08F27A3C005CB29B /* focusTcl.test */,
F966BC2C08F27A3C005CB29B /* font.test */,
+ F99388950EE02D980065FE6B /* fontchooser.test */,
F966BC2D08F27A3C005CB29B /* frame.test */,
F966BC2E08F27A3C005CB29B /* geometry.test */,
F966BC2F08F27A3C005CB29B /* get.test */,
Index: tests/fontchooser.test
===================================================================
RCS file: tests/fontchooser.test
diff -N tests/fontchooser.test
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/fontchooser.test 10 Dec 2008 04:28:51 -0000
@@ -0,0 +1,203 @@
+# Test the "tk::fontchooser" command
+#
+# Copyright (c) 2008 Pat Thoyts
+#
+# RCS: @(#) $Id$
+#
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# the following helper functions are related to the functions used
+# in winDialog.test where they are used to send messages to the win32
+# dialog (hence the wierdness).
+
+proc start {cmd} {
+ set ::tk_dialog {}
+ set ::iter_after 0
+ after 1 $cmd
+}
+proc then {cmd} {
+ set ::command $cmd
+ set ::dialogresult {}
+ set ::testfont {}
+ afterbody
+ vwait ::dialogresult
+ return $::dialogresult
+}
+proc afterbody {} {
+ if {$::tk_dialog == {}} {
+ if {[incr ::iter_after] > 30} {
+ set ::dialogresult ">30 iterations waiting for tk_dialog"
+ return
+ }
+ after 150 {afterbody}
+ return
+ }
+ uplevel #0 {set dialogresult [eval $command]}
+}
+proc Click {button} {
+ switch -exact -- $button {
+ ok { $::tk_dialog.ok invoke }
+ cancel { $::tk_dialog.cancel invoke }
+ apply { $::tk_dialog.apply invoke }
+ default { return -code error "invalid button name \"$button\"" }
+ }
+}
+proc ApplyFont {font} {
+# puts stderr "apply: $font"
+ set ::testfont $font
+}
+
+# -------------------------------------------------------------------------
+
+test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser -z
+} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}
+
+test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -z
+} -match glob -result {bad option "-z":*}
+
+test fontchooser-1.3 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -font
+} -result {value for "-font" missing}
+
+test fontchooser-1.4 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -title
+} -result {value for "-title" missing}
+
+test fontchooser-1.5 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -command
+} -result {value for "-command" missing}
+
+test fontchooser-1.6 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -title . -parent
+} -result {value for "-parent" missing}
+
+test fontchooser-1.7 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent abc
+} -result {bad window path name "abc"}
+
+test fontchooser-1.8 {tk fontchooser: usage} -returnCodes ok -body {
+ tk fontchooser configure -visible
+} -result {0}
+
+test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -visible 1
+} -match glob -result {*}
+
+# -------------------------------------------------------------------------
+# By explicitly calling the tk internal command we always test the script
+# implementation here even when the current platform defines a native
+# font dialog. This is intentional in this test file.
+
+source [file join $tk_library fontchooser.tcl]
+testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]
+
+test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -title "Hello"
+ tk::fontchooser::Show
+ }
+ then {
+ set x [wm title $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result {Hello}
+
+test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure \
+ -title "\u041f\u0440\u0438\u0432\u0435\u0442"
+ tk::fontchooser::Show
+ }
+ then {
+ set x [wm title $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
+test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -parent .
+ tk::fontchooser::Show
+ }
+ then {
+ set x [winfo parent $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result {.}
+
+test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -body {
+ tk::fontchooser::Configure -parent junk
+} -returnCodes error -match glob -result {bad window path *}
+
+test fontchooser-4.0 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font courier
+ tk::fontchooser::Show
+ }
+ then {
+ Click cancel
+ }
+ set ::testfont
+} -result {}
+
+test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font courier
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.4 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ lrange $::testfont 1 end
+} -result {14 bold}
+
+# -------------------------------------------------------------------------
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
Index: tests/winDialog.test
===================================================================
RCS file: /cvsroot/tktoolkit/tk/tests/winDialog.test,v
retrieving revision 1.23
diff -u -p -r1.23 winDialog.test
--- tests/winDialog.test 22 Nov 2008 12:22:12 -0000 1.23
+++ tests/winDialog.test 10 Dec 2008 04:28:51 -0000
@@ -34,6 +34,7 @@ proc start {arg} {
proc then {cmd} {
set ::command $cmd
set ::dialogresult {}
+ set ::testfont {}
afterbody
vwait ::dialogresult
@@ -73,6 +74,10 @@ proc SetText {id text} {
return [testwinevent $::tk_dialog $id WM_SETTEXT $text]
}
+proc ApplyFont {font} {
+ set ::testfont $font
+}
+
# ----------------------------------------------------------------------
test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints {
@@ -516,6 +521,118 @@ test winDialog-9.8 {Tk_ChooseDirectoryOb
tk_chooseDirectory -initialdir ~12x/455
} -returnCodes error -result {user "12x" doesn't exist}
+
+test winDialog-10.1 {Tk_FontchooserObjCmd: no arguments} -constraints {
+ nt testwinevent
+} -body {
+ start {tk fontchooser show}
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.2 {Tk_FontchooserObjCmd: -initialfont} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -font system
+ tk fontchooser show
+ }
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.3 {Tk_FontchooserObjCmd: -initialfont} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -font system
+ tk fontchooser show
+ }
+ list [then {
+ Click 1
+ }] [expr {[llength $::testfont] ne {}}]
+} -result {0 1}
+test winDialog-10.4 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -title "tk test"
+ tk fontchooser show
+ }
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.5 {Tk_FontchooserObjCmd: -parent} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {parent {}}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -parent .
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ list [expr {$a(parent) == [wm frame .]}] $::testfont
+} -result {1 {}}
+test winDialog-10.6 {Tk_FontchooserObjCmd: -apply} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command FooBarBaz
+ tk fontchooser show
+ }
+ then {
+ Click cancel
+ }
+} -result 0
+test winDialog-10.7 {Tk_FontchooserObjCmd: -apply} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -parent .
+ tk fontchooser show
+ }
+ list [then {
+ Click [expr {0x0402}] ;# value from XP
+ Click cancel
+ }] [expr {[llength $::testfont] > 0}]
+} -result {0 1}
+test winDialog-10.8 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {text failed}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -title "Hello"
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ set a(text)
+} -result "Hello"
+test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {text failed}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont \
+ -title "\u041f\u0440\u0438\u0432\u0435\u0442"
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ set a(text)
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
if {[testConstraint testwinevent]} {
catch {testwinevent debug 0}
}
Index: win/tkWinDialog.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinDialog.c,v
retrieving revision 1.55
diff -u -p -r1.55 tkWinDialog.c
--- win/tkWinDialog.c 8 Nov 2008 18:44:40 -0000 1.55
+++ win/tkWinDialog.c 10 Dec 2008 04:28:51 -0000
@@ -14,6 +14,7 @@
#include "tkWinInt.h"
#include "tkFileFilter.h"
+#include "tkFont.h"
#include <commdlg.h> /* includes common dialog functionality */
#ifdef _MSC_VER
@@ -2258,6 +2259,19 @@ MsgBoxCBTProc(
return CallNextHookEx(tsdPtr->hMsgBoxHook, nCode, wParam, lParam);
}
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SetTkDialog --
+ *
+ * Records the HWND for a native dialog in the 'tk_dialog' variable
+ * so that the test-suite can operate on the correct dialog window.
+ * Use of this is enabled when a test program calls TkWinDialogDebug
+ * by calling the test command 'tkwinevent debug 1'
+ *
+ * ----------------------------------------------------------------------
+ */
+
static void
SetTkDialog(
ClientData clientData)
@@ -2296,6 +2310,531 @@ ConvertExternalFilename(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * GetFontObj --
+ *
+ * Convert a windows LOGFONT into a Tk font description.
+ *
+ * Result:
+ * A list containing a Tk font description.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+GetFontObj(HDC hdc, LOGFONT *plf)
+{
+ Tcl_Obj *resObj;
+ int len = 0, pt = 0;
+
+ resObj = Tcl_NewListObj(0, NULL);
+ Tcl_ListObjAppendElement(NULL, resObj,
+ Tcl_NewStringObj(plf->lfFaceName, -1));
+ pt = -MulDiv(plf->lfHeight, 72, GetDeviceCaps(hdc, LOGPIXELSY));
+ Tcl_ListObjAppendElement(NULL, resObj, Tcl_NewIntObj(pt));
+ if (plf->lfWeight >= 700) {
+ Tcl_ListObjAppendElement(NULL, resObj,
+ Tcl_NewStringObj("bold", -1));
+ }
+ if (plf->lfItalic) {
+ Tcl_ListObjAppendElement(NULL, resObj,
+ Tcl_NewStringObj("italic", -1));
+ }
+ if (plf->lfUnderline) {
+ Tcl_ListObjAppendElement(NULL, resObj,
+ Tcl_NewStringObj("underline", -1));
+ }
+ if (plf->lfStrikeOut) {
+ Tcl_ListObjAppendElement(NULL, resObj,
+ Tcl_NewStringObj("overstrike", -1));
+ }
+ return resObj;
+}
+
+static void
+ApplyLogfont(Tcl_Interp *interp, Tcl_Obj *cmdObj, HDC hdc, LOGFONT *logfontPtr)
+{
+ int objc;
+ Tcl_Obj **objv, **tmpv;
+ Tcl_ListObjGetElements(NULL, cmdObj, &objc, &objv);
+ tmpv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 2));
+ memcpy(tmpv, objv, sizeof(Tcl_Obj *) * objc);
+ tmpv[objc] = GetFontObj(hdc, logfontPtr);
+ TkBackgroundEvalObjv(interp, objc+1, tmpv, TCL_EVAL_GLOBAL);
+ ckfree((char *)tmpv);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * HookProc --
+ *
+ * Font selection hook. If the user selects Apply on the dialog, we
+ * call the applyProc script with the currently selected font as
+ * arguments.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+typedef struct HookData {
+ Tcl_Interp *interp;
+ Tcl_Obj *titleObj;
+ Tcl_Obj *cmdObj;
+ Tcl_Obj *parentObj;
+ Tcl_Obj *fontObj;
+ HWND hwnd;
+ Tk_Window parent;
+} HookData;
+
+static UINT_PTR CALLBACK
+HookProc(HWND hwndDlg, UINT msg, WPARAM wParam, LPARAM lParam)
+{
+ CHOOSEFONT *pcf = (CHOOSEFONT *)lParam;
+ HWND hwndCtrl;
+ static HookData *phd = NULL;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+
+ if (WM_INITDIALOG == msg && lParam != 0) {
+ phd = (HookData *)pcf->lCustData;
+ phd->hwnd = hwndDlg;
+ if (tsdPtr->debugFlag) {
+ tsdPtr->debugInterp = (Tcl_Interp *) phd->interp;
+ Tcl_DoWhenIdle(SetTkDialog, (ClientData) hwndDlg);
+ }
+ if (phd->titleObj != NULL) {
+ Tcl_DString title;
+ Tcl_WinUtfToTChar(Tcl_GetString(phd->titleObj), -1, &title);
+ if (Tcl_DStringLength(&title) > 0) {
+ tkWinProcs->setWindowText(hwndDlg,
+ (LPCTSTR)Tcl_DStringValue(&title));
+ }
+ Tcl_DStringFree(&title);
+ }
+
+ /*
+ * Disable the colour combobox (0x473) and its label (0x443).
+ */
+
+ hwndCtrl = GetDlgItem(hwndDlg, 0x443);
+ if (IsWindow(hwndCtrl)) {
+ EnableWindow(hwndCtrl, FALSE);
+ }
+ hwndCtrl = GetDlgItem(hwndDlg, 0x473);
+ if (IsWindow(hwndCtrl)) {
+ EnableWindow(hwndCtrl, FALSE);
+ }
+ TkSendVirtualEvent(phd->parent, "TkFontchooserVisibility");
+ return 1; /* we handled the message */
+ }
+
+ if (WM_DESTROY == msg) {
+ phd->hwnd = NULL;
+ TkSendVirtualEvent(phd->parent, "TkFontchooserVisibility");
+ return 0;
+ }
+
+ /*
+ * Handle apply button by calling the provided command script as
+ * a background evaluation (ie: errors dont come back here).
+ */
+ if (WM_COMMAND == msg && LOWORD(wParam) == 1026) {
+ LOGFONT lf = {0};
+ int iPt = 0;
+ HDC hdc = GetDC(hwndDlg);
+ SendMessage(hwndDlg, WM_CHOOSEFONT_GETLOGFONT, 0, (LPARAM)&lf);
+ if (phd && phd->cmdObj) {
+ ApplyLogfont(phd->interp, phd->cmdObj, hdc, &lf);
+ }
+ if (phd && phd->parent) {
+ TkSendVirtualEvent(phd->parent, "TkFontchooserFontChanged");
+ }
+ return 1;
+ }
+ return 0; /* pass on for default processing */
+}
+
+/*
+ * Helper for the FontchooserConfigure command to return the
+ * current value of any of the options (which may be NULL in
+ * the structure)
+ */
+
+enum FontchooserOption {
+ FontchooserParent, FontchooserTitle, FontchooserFont, FontchooserCmd,
+ FontchooserVisible
+};
+
+static Tcl_Obj *
+FontchooserCget(HookData *hdPtr, int optionIndex)
+{
+ Tcl_Obj *resObj = NULL;
+ switch(optionIndex) {
+ case FontchooserParent: {
+ if (hdPtr->parentObj) {
+ resObj = hdPtr->parentObj;
+ } else {
+ resObj = Tcl_NewStringObj(".", 1);
+ }
+ break;
+ }
+ case FontchooserTitle: {
+ if (hdPtr->titleObj) {
+ resObj = hdPtr->titleObj;
+ } else {
+ resObj = Tcl_NewStringObj("", 0);
+ }
+ break;
+ }
+ case FontchooserFont: {
+ if (hdPtr->fontObj) {
+ resObj = hdPtr->fontObj;
+ } else {
+ resObj = Tcl_NewStringObj("", 0);
+ }
+ break;
+ }
+ case FontchooserCmd: {
+ if (hdPtr->cmdObj) {
+ resObj = hdPtr->cmdObj;
+ } else {
+ resObj = Tcl_NewStringObj("", 0);
+ }
+ break;
+ }
+ case FontchooserVisible: {
+ resObj = Tcl_NewBooleanObj(hdPtr->hwnd && IsWindow(hdPtr->hwnd));
+ break;
+ }
+ default: {
+ resObj = Tcl_NewStringObj("", 0);
+ }
+ }
+ return resObj;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserConfigureCmd --
+ *
+ * Implementation of the 'tk fontchooser configure' ensemble command.
+ * See the user documentation for what it does.
+ *
+ * Results:
+ * See the user documentation.
+ *
+ * Side effects:
+ * Per-interp data structure may be modified
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserConfigureCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tk_Window tkwin = (Tk_Window)clientData;
+ HookData *hdPtr = NULL;
+ int i, r = TCL_OK;
+ static const char *optionStrings[] = {
+ "-parent", "-title", "-font", "-command", "-visible", NULL
+ };
+
+ hdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser", NULL);
+
+ /*
+ * with no arguments we return all the options in a dict
+ */
+
+ if (objc == 1) {
+ Tcl_Obj *keyObj, *valueObj;
+ Tcl_Obj *dictObj = Tcl_NewDictObj();
+ for (i = 0; r == TCL_OK && optionStrings[i] != NULL; ++i) {
+ keyObj = Tcl_NewStringObj(optionStrings[i], -1);
+ valueObj = FontchooserCget(hdPtr, i);
+ r = Tcl_DictObjPut(interp, dictObj, keyObj, valueObj);
+ }
+ if (r == TCL_OK) {
+ Tcl_SetObjResult(interp, dictObj);
+ }
+ return r;
+ }
+
+ for (i = 1; i < objc; i += 2) {
+ int optionIndex;
+ if (Tcl_GetIndexFromObj(interp, objv[i], optionStrings,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ /* if one option and no arg - return the current value */
+ Tcl_SetObjResult(interp, FontchooserCget(hdPtr, optionIndex));
+ return TCL_OK;
+ }
+ if (i + 1 == objc) {
+ Tcl_AppendResult(interp, "value for \"",
+ Tcl_GetString(objv[i]), "\" missing", NULL);
+ return TCL_ERROR;
+ }
+ switch (optionIndex) {
+ case FontchooserVisible: {
+ const char *msg = "cannot change read-only option "
+ "\"-visible\": use the show or hide command";
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+ return TCL_ERROR;
+ }
+ case FontchooserParent: {
+ Tk_Window parent = Tk_NameToWindow(interp,
+ Tcl_GetString(objv[i+1]), tkwin);
+ if (parent == None) {
+ return TCL_ERROR;
+ }
+ if (hdPtr->parentObj) {
+ Tcl_DecrRefCount(hdPtr->parentObj);
+ }
+ hdPtr->parentObj = objv[i+1];
+ if (Tcl_IsShared(hdPtr->parentObj)) {
+ hdPtr->parentObj = Tcl_DuplicateObj(hdPtr->parentObj);
+ }
+ Tcl_IncrRefCount(hdPtr->parentObj);
+ break;
+ }
+ case FontchooserTitle: {
+ if (hdPtr->titleObj) {
+ Tcl_DecrRefCount(hdPtr->titleObj);
+ }
+ hdPtr->titleObj = objv[i+1];
+ if (Tcl_IsShared(hdPtr->titleObj)) {
+ hdPtr->titleObj = Tcl_DuplicateObj(hdPtr->titleObj);
+ }
+ Tcl_IncrRefCount(hdPtr->titleObj);
+ break;
+ }
+ case FontchooserFont: {
+ if (hdPtr->fontObj) {
+ Tcl_DecrRefCount(hdPtr->fontObj);
+ }
+ Tcl_GetStringFromObj(objv[i+1], &len);
+ if (len) {
+ hdPtr->fontObj = objv[i+1];
+ if (Tcl_IsShared(hdPtr->fontObj)) {
+ hdPtr->fontObj = Tcl_DuplicateObj(hdPtr->fontObj);
+ }
+ Tcl_IncrRefCount(hdPtr->fontObj);
+ } else {
+ hdPtr->fontObj = NULL;
+ }
+ break;
+ }
+ case FontchooserCmd: {
+ if (hdPtr->cmdObj) {
+ Tcl_DecrRefCount(hdPtr->cmdObj);
+ }
+ Tcl_GetStringFromObj(objv[i+1], &len);
+ if (len) {
+ hdPtr->cmdObj = objv[i+1];
+ if (Tcl_IsShared(hdPtr->cmdObj)) {
+ hdPtr->cmdObj = Tcl_DuplicateObj(hdPtr->cmdObj);
+ }
+ Tcl_IncrRefCount(hdPtr->cmdObj);
+ } else {
+ hdPtr->cmdObj = NULL;
+ }
+ break;
+ }
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserShowCmd --
+ *
+ * Implements the 'tk fontchooser show' ensemble command. The
+ * per-interp configuration data for the dialog is held in an interp
+ * associated structure.
+ * Calls the Win32 FontChooser API which provides a modal dialog.
+ * See HookProc where we make a few changes to the dialog and set
+ * some additional state.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserShowCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tk_Window tkwin, parent;
+ CHOOSEFONT cf;
+ LOGFONT lf;
+ HDC hdc;
+ HookData *hdPtr;
+ int r = TCL_OK, oldMode = 0;
+ Tcl_Obj *resObj = NULL;
+
+ hdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser", NULL);
+
+ tkwin = parent = (Tk_Window) clientData;
+ if (hdPtr->parentObj) {
+ parent = Tk_NameToWindow(interp, Tcl_GetString(hdPtr->parentObj), tkwin);
+ if (parent == None) {
+ return TCL_ERROR;
+ }
+ }
+
+ Tk_MakeWindowExist(parent);
+
+ ZeroMemory(&cf, sizeof(CHOOSEFONT));
+ ZeroMemory(&lf, sizeof(LOGFONT));
+ lf.lfCharSet = DEFAULT_CHARSET;
+ cf.lStructSize = sizeof(CHOOSEFONT);
+ cf.hwndOwner = Tk_GetHWND(Tk_WindowId(parent));
+ cf.lpLogFont = &lf;
+ cf.nFontType = SCREEN_FONTTYPE;
+ cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_ENABLEHOOK;
+ cf.rgbColors = RGB(0,0,0);
+ cf.lpfnHook = HookProc;
+ cf.lCustData = (INT_PTR)hdPtr;
+ hdPtr->interp = interp;
+ hdPtr->parent = parent;
+ hdc = GetDC(cf.hwndOwner);
+
+ if (hdPtr->fontObj != NULL) {
+ TkFont *fontPtr;
+ Tk_Font f = Tk_AllocFontFromObj(interp, tkwin, hdPtr->fontObj);
+ if (f == NULL) {
+ return TCL_ERROR;
+ }
+ fontPtr = (TkFont *)f;
+ cf.Flags |= CF_INITTOLOGFONTSTRUCT;
+ strncpy(lf.lfFaceName, Tk_GetUid(fontPtr->fa.family), LF_FACESIZE-1);
+ lf.lfFaceName[LF_FACESIZE-1] = 0;
+ lf.lfHeight = -MulDiv(TkFontGetPoints(tkwin, fontPtr->fa.size),
+ GetDeviceCaps(hdc, LOGPIXELSY), 72);
+ if (fontPtr->fa.weight == TK_FW_BOLD) lf.lfWeight = FW_BOLD;
+ if (fontPtr->fa.slant != TK_FS_ROMAN) lf.lfItalic = TRUE;
+ if (fontPtr->fa.underline) lf.lfUnderline = TRUE;
+ if (fontPtr->fa.overstrike) lf.lfStrikeOut = TRUE;
+ Tk_FreeFont(f);
+ }
+
+ if (TCL_OK == r && hdPtr->cmdObj != NULL) {
+ int len = 0;
+ r = Tcl_ListObjLength(interp, hdPtr->cmdObj, &len);
+ if (len > 0) cf.Flags |= CF_APPLY;
+ }
+
+ if (TCL_OK == r) {
+ oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
+ if (FontChooser(&cf)) {
+ if (hdPtr->cmdObj) {
+ ApplyLogfont(hdPtr->interp, hdPtr->cmdObj, hdc, &lf);
+ }
+ if (hdPtr->parent) {
+ TkSendVirtualEvent(hdPtr->parent, "TkFontchooserFontChanged");
+ }
+ }
+ Tcl_SetServiceMode(oldMode);
+ EnableWindow(cf.hwndOwner, 1);
+ }
+
+ ReleaseDC(cf.hwndOwner, hdc);
+
+ return r;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FontchooserHideCmd --
+ *
+ * Implementation of the 'tk fontchooser hide' ensemble. See the
+ * user documentation for details.
+ * As the Win32 FontChooser function is always modal all we do here
+ * is destroy the dialog
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+FontchooserHideCmd(
+ ClientData clientData, /* Main window */
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ HookData *hdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser", NULL);
+ if (hdPtr->hwnd && IsWindow(hdPtr->hwnd)) {
+ EndDialog(hdPtr->hwnd, 0);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteHookData --
+ *
+ * Clean up the font chooser configuration data when the interp
+ * is destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteHookData(ClientData clientData, Tcl_Interp *interp)
+{
+ HookData *hdPtr = clientData;
+ if (hdPtr->parentObj)
+ Tcl_DecrRefCount(hdPtr->parentObj);
+ if (hdPtr->fontObj)
+ Tcl_DecrRefCount(hdPtr->fontObj);
+ if (hdPtr->titleObj)
+ Tcl_DecrRefCount(hdPtr->titleObj);
+ if (hdPtr->cmdObj)
+ Tcl_DecrRefCount(hdPtr->cmdObj);
+ ckfree((char *)hdPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TkInitFontchooser --
+ *
+ * Associate the font chooser configuration data with the Tcl
+ * interpreter. There is one font chooser per interp.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
+const TkEnsemble tkFontchooserEnsemble[] = {
+ { "configure", FontchooserConfigureCmd, NULL },
+ { "show", FontchooserShowCmd, NULL },
+ { "hide", FontchooserHideCmd, NULL },
+};
+
+int
+TkInitFontchooser(Tcl_Interp *interp, ClientData clientData)
+{
+ HookData *hdPtr = NULL;
+ hdPtr = (HookData *)ckalloc(sizeof(HookData));
+ memset(hdPtr, 0, sizeof(HookData));
+ Tcl_SetAssocData(interp, "::tk::fontchooser", DeleteHookData, hdPtr);
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
Index: win/tkWinInt.h
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinInt.h,v
retrieving revision 1.31
diff -u -p -r1.31 tkWinInt.h
--- win/tkWinInt.h 14 Dec 2007 15:56:09 -0000 1.31
+++ win/tkWinInt.h 10 Dec 2008 04:28:51 -0000
@@ -211,6 +211,8 @@ typedef struct TkWinProcs {
BOOL (WINAPI *insertMenu)(HMENU hMenu, UINT uPosition, UINT uFlags,
UINT uIDNewItem, LPCTSTR lpNewItem);
int (WINAPI *getWindowText)(HWND hWnd, LPCTSTR lpString, int nMaxCount);
+ HWND (WINAPI *findWindow)(LPCTSTR lpClassName, LPCTSTR lpWindowName);
+ int (WINAPI *getClassName)(HWND hwnd, LPTSTR lpClassName, int nMaxCount);
} TkWinProcs;
EXTERN TkWinProcs *tkWinProcs;
Index: win/tkWinTest.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinTest.c,v
retrieving revision 1.23
diff -u -p -r1.23 tkWinTest.c
--- win/tkWinTest.c 27 Nov 2008 23:26:05 -0000 1.23
+++ win/tkWinTest.c 10 Dec 2008 04:28:51 -0000
@@ -373,18 +373,25 @@ TestfindwindowObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
- const char *title = NULL, *class = NULL;
+ const TCHAR *title = NULL, *class = NULL;
+ Tcl_DString titleString, classString;
HWND hwnd = NULL;
int r = TCL_OK;
+ Tcl_DStringInit(&classString);
+ Tcl_DStringInit(&titleString);
+
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "title ?class?");
return TCL_ERROR;
}
- title = Tcl_GetString(objv[1]);
- if (objc == 3)
- class = Tcl_GetString(objv[2]);
- hwnd = FindWindowA(class, title);
+
+ title = Tcl_WinUtfToTChar(Tcl_GetString(objv[1]), -1, &titleString);
+ if (objc == 3) {
+ class = Tcl_WinUtfToTChar(Tcl_GetString(objv[2]), -1, &classString);
+ }
+
+ hwnd = tkWinProcs->findWindow(class, title);
if (hwnd == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to find window: ", -1));
@@ -393,6 +400,9 @@ TestfindwindowObjCmd(
} else {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long)hwnd));
}
+
+ Tcl_DStringFree(&titleString);
+ Tcl_DStringFree(&classString);
return r;
}
@@ -416,7 +426,7 @@ TestgetwindowinfoObjCmd(
Tcl_Obj *const objv[])
{
HWND hwnd = NULL;
- Tcl_Obj *resObj = NULL, *classObj = NULL, *textObj = NULL;
+ Tcl_Obj *dictObj = NULL, *classObj = NULL, *textObj = NULL;
Tcl_Obj *childrenObj = NULL;
char buf[512];
int cch, cchBuf = tkWinProcs->useWide ? 256 : 512;
@@ -429,25 +439,21 @@ TestgetwindowinfoObjCmd(
if (Tcl_GetLongFromObj(interp, objv[1], (long *)&hwnd) != TCL_OK)
return TCL_ERROR;
- if (tkWinProcs->useWide) {
- cch = GetClassNameW(hwnd, (LPWSTR)buf, sizeof(buf)/sizeof(WCHAR));
- classObj = Tcl_NewUnicodeObj((LPWSTR)buf, cch);
- } else {
- cch = GetClassNameA(hwnd, (LPSTR)buf, sizeof(buf));
- classObj = Tcl_NewStringObj((LPSTR)buf, cch);
- }
+ cch = tkWinProcs->getClassName(hwnd, buf, cchBuf);
if (cch == 0) {
Tcl_SetResult(interp, "failed to get class name: ", TCL_STATIC);
AppendSystemError(interp, GetLastError());
return TCL_ERROR;
+ } else {
+ Tcl_DString ds;
+ Tcl_WinTCharToUtf(buf, -1, &ds);
+ classObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
}
- resObj = Tcl_NewListObj(0, NULL);
- Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("class", -1));
- Tcl_ListObjAppendElement(interp, resObj, classObj);
-
- Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("id", -1));
- Tcl_ListObjAppendElement(interp, resObj,
+ dictObj = Tcl_NewDictObj();
+ Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("class", 5), classObj);
+ Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("id", 2),
Tcl_NewLongObj(GetWindowLong(hwnd, GWL_ID)));
cch = tkWinProcs->getWindowText(hwnd, (LPTSTR)buf, cchBuf);
@@ -457,18 +463,15 @@ TestgetwindowinfoObjCmd(
textObj = Tcl_NewStringObj((LPCSTR)buf, cch);
}
- Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("text", -1));
- Tcl_ListObjAppendElement(interp, resObj, textObj);
- Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("parent", -1));
- Tcl_ListObjAppendElement(interp, resObj,
+ Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("text", 4), textObj);
+ Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("parent", 6),
Tcl_NewLongObj((long)GetParent(hwnd)));
childrenObj = Tcl_NewListObj(0, NULL);
EnumChildWindows(hwnd, EnumChildrenProc, (LPARAM)childrenObj);
- Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("children", -1));
- Tcl_ListObjAppendElement(interp, resObj, childrenObj);
+ Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("children", -1), childrenObj);
- Tcl_SetObjResult(interp, resObj);
+ Tcl_SetObjResult(interp, dictObj);
return TCL_OK;
}
Index: win/tkWinX.c
===================================================================
RCS file: /cvsroot/tktoolkit/tk/win/tkWinX.c,v
retrieving revision 1.58
diff -u -p -r1.58 tkWinX.c
--- win/tkWinX.c 27 Apr 2008 22:39:17 -0000 1.58
+++ win/tkWinX.c 10 Dec 2008 04:28:51 -0000
@@ -79,6 +79,8 @@ static TkWinProcs asciiProcs = {
(BOOL (WINAPI *)(HMENU hMenu, UINT uPosition, UINT uFlags,
UINT uIDNewItem, LPCTSTR lpNewItem)) InsertMenuA,
(int (WINAPI *)(HWND hWnd, LPCTSTR lpString, int nMaxCount)) GetWindowTextA,
+ (HWND (WINAPI *)(LPCTSTR lpClassName, LPCTSTR lpWindowName)) FindWindowA,
+ (int (WINAPI *)(HWND hwnd, LPTSTR lpClassName, int nMaxCount)) GetClassNameA,
};
static TkWinProcs unicodeProcs = {
@@ -97,6 +99,8 @@ static TkWinProcs unicodeProcs = {
(BOOL (WINAPI *)(HMENU hMenu, UINT uPosition, UINT uFlags,
UINT uIDNewItem, LPCTSTR lpNewItem)) InsertMenuW,
(int (WINAPI *)(HWND hWnd, LPCTSTR lpString, int nMaxCount)) GetWindowTextW,
+ (HWND (WINAPI *)(LPCTSTR lpClassName, LPCTSTR lpWindowName)) FindWindowW,
+ (int (WINAPI *)(HWND hwnd, LPTSTR lpClassName, int nMaxCount)) GetClassNameW,
};
TkWinProcs *tkWinProcs;
