From 987b7068ea831ae0c3d20fb14f28499cc11449c3 Mon Sep 17 00:00:00 2001 From: das Date: Wed, 10 Dec 2008 05:02:39 +0000 Subject: TIP #324 IMPLEMENTATION --- ChangeLog | 36 ++- doc/fontchooser.n | 183 +++++++++++ doc/tk.n | 44 +-- generic/tkCmds.c | 12 +- generic/tkInt.h | 11 +- generic/tkUtil.c | 115 ++++++- library/console.tcl | 63 +++- library/demos/text.tcl | 29 +- library/fontchooser.tcl | 398 ++++++++++++++++++++++++ library/msgs/de.msg | 1 + library/msgs/en.msg | 15 + library/tclIndex | 1 + macosx/Wish.xcodeproj/project.pbxproj | 8 +- macosx/tkMacOSXCarbonEvents.c | 4 +- macosx/tkMacOSXDialog.c | 567 +++++++++++++++++++++++++++++++++- macosx/tkMacOSXEvent.c | 5 +- macosx/tkMacOSXEvent.h | 4 +- macosx/tkMacOSXFont.c | 99 +++++- macosx/tkMacOSXFont.h | 8 +- tests/fontchooser.test | 203 ++++++++++++ tests/winDialog.test | 119 ++++++- win/tkWinDialog.c | 541 +++++++++++++++++++++++++++++++- win/tkWinInt.h | 4 +- win/tkWinTest.c | 57 ++-- win/tkWinX.c | 6 +- 25 files changed, 2459 insertions(+), 74 deletions(-) create mode 100644 doc/fontchooser.n create mode 100644 library/fontchooser.tcl create mode 100644 tests/fontchooser.test diff --git a/ChangeLog b/ChangeLog index 9d0deb3..06375f1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,39 @@ 2008-12-10 Daniel Steffen - * generic/tkInt.h: Turn [tk] into an ensemble (thoyts, steffen) - * generic/tkBusy.c: + TIP #324 IMPLEMENTATION + + * generic/tkCmds.c: Implementation of [tk fontchooser] + * generic/tkInt.h: as a Ttk dialog for X11 and as a native + * library/fontchooser.tcl: platform dialog on Mac OS X & Windows. + * library/tclIndex: (thoyts, vetter, robert, steffen) + * library/msgs/de.msg: + * library/msgs/en.msg: + * macosx/tkMacOSXCarbonEvents.c: + * macosx/tkMacOSXDialog.c: + * macosx/tkMacOSXEvent.c: + * macosx/tkMacOSXEvent.h: + * macosx/tkMacOSXFont.c: + * macosx/tkMacOSXFont.h: + * macosx/Wish.xcodeproj/project.pbxproj: + * win/tkWinDialog.c: + * win/tkWinInt.h: + * win/tkWinTest.c: + * win/tkWinX.c: + * tests/fontchooser.test: + * tests/winDialog.test: + * doc/fontchooser.n: + * doc/tk.n: + + * library/console.tcl: Let user select console font via + [tk fontchooser]. + * library/demos/text.tcl: Add [tk fontchooser] demo. + + * generic/tkUtil.c: Add TkBackgroundEvalObjv() and + TkSendVirtualEvent() utility functions + (used by TIP #324 code). + + * generic/tkInt.h: Turn [tk] into an ensemble. + * generic/tkBusy.c: (thoyts, steffen) * generic/tkCmds.c: * generic/tkWindow.c: diff --git a/doc/fontchooser.n b/doc/fontchooser.n new file mode 100644 index 0000000..6e3a766 --- /dev/null +++ b/doc/fontchooser.n @@ -0,0 +1,183 @@ +'\" +'\" Copyright (c) 2008 Daniel A. Steffen +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: fontchooser.n,v 1.1 2008/12/10 05:02:40 das Exp $ +'\" +.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<>\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<>\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<>\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<>\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\fR handlers +(and if necessary to unset them \- i.e. set to the empty string \- in +corresponding \fB\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<>\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<>\fR \\ + [list fontchooserVisibility .b] + foreach w {.t1 .t2} { + text $w \-width 20 \-height 4 \-borderwidth 1 \-relief solid + bind $w [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: diff --git a/doc/tk.n b/doc/tk.n index ece777e..c762946 100644 --- a/doc/tk.n +++ b/doc/tk.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tk.n,v 1.20 2008/10/18 14:22:21 dkf Exp $ +'\" RCS: @(#) $Id: tk.n,v 1.21 2008/12/10 05:02:40 das Exp $ '\" .so man.macros .TH tk n 8.4 Tk "Tk Built-In Commands" @@ -66,6 +66,28 @@ format. \fI\-x\fR and \fI\-y\fR represent window-relative coordinates, and \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 will resize themselves dynamically to 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, one of \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: diff --git a/generic/tkCmds.c b/generic/tkCmds.c index 49d1f38..21bd8d4 100644 --- a/generic/tkCmds.c +++ b/generic/tkCmds.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkCmds.c,v 1.48 2008/12/10 00:34:51 das Exp $ + * RCS: @(#) $Id: tkCmds.c,v 1.49 2008/12/10 05:02:40 das Exp $ */ #include "tkInt.h" @@ -51,6 +51,12 @@ static int WindowingsystemCmd(ClientData dummy, 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; } diff --git a/generic/tkInt.h b/generic/tkInt.h index 7131bb7..214b428 100644 --- a/generic/tkInt.h +++ b/generic/tkInt.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: $Id: tkInt.h,v 1.97 2008/12/10 00:34:51 das Exp $ + * RCS: $Id: tkInt.h,v 1.98 2008/12/10 05:02:51 das Exp $ */ #ifndef _TKINT @@ -1040,9 +1040,6 @@ MODULE_SCOPE int Tk_ChooseColorObjCmd(ClientData clientData, 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 TkpMakeTransparentWindowExist(Tk_Window tkwin, 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 TkUnderlineAngledTextLayout(Display *display, 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. diff --git a/generic/tkUtil.c b/generic/tkUtil.c index 8cfaf9a..5218740 100644 --- a/generic/tkUtil.c +++ b/generic/tkUtil.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkUtil.c,v 1.26 2008/12/10 04:27:45 das Exp $ + * RCS: @(#) $Id: tkUtil.c,v 1.27 2008/12/10 05:02:51 das Exp $ */ #include "tkInt.h" @@ -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 diff --git a/library/console.tcl b/library/console.tcl index cc38ca5..2fddfe3 100644 --- a/library/console.tcl +++ b/library/console.tcl @@ -4,11 +4,11 @@ # can be used by non-unix systems that do not have built-in support # for shells. # -# RCS: @(#) $Id: console.tcl,v 1.38 2008/05/13 13:25:18 patthoyts Exp $ +# RCS: @(#) $Id: console.tcl,v 1.39 2008/12/10 05:02:51 das Exp $ # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. -# Copyright (c) 2007 Daniel A. Steffen +# Copyright (c) 2007-2008 Daniel A. Steffen # # 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 <> \ + [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 [list ::tk::console::FontchooserFocus %W 1] + bind Console [list ::tk::console::FontchooserFocus %W 0] + } AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \ -accel "$mod++" -command {event generate .console <>} 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 [list ::tk::console::FontchooserToggle] + } } bind Console <> { 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 <> { 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 diff --git a/library/demos/text.tcl b/library/demos/text.tcl index 6f25273..5b8341d 100644 --- a/library/demos/text.tcl +++ b/library/demos/text.tcl @@ -3,7 +3,7 @@ # This demonstration script creates a text widget that describes # the basic editing functions. # -# RCS: @(#) $Id: text.tcl,v 1.8 2007/12/13 15:27:07 dgp Exp $ +# RCS: @(#) $Id: text.tcl,v 1.9 2008/12/10 05:02:51 das Exp $ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." @@ -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.scroll set] -setgrid 1 \ 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 [list fontchooserFocus $w.text] +fontchooserVisibility $w.buttons.fontchooser +bind $w <> [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 diff --git a/library/fontchooser.tcl b/library/fontchooser.tcl new file mode 100644 index 0000000..290eebf --- /dev/null +++ b/library/fontchooser.tcl @@ -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 +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: fontchooser.tcl,v 1.1 2008/12/10 05:02:51 das Exp $ + +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 .] <> \ + [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) <> + } +} + +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) [namespace code [list Done 1]] + bind $S(W) [namespace code [list Done 0]] + bind $S(W) [namespace code [list Visibility %W 1]] + bind $S(W) [namespace code [list Visibility %W 0]] + bind $S(W) [namespace code [list Visibility %W 0]] + bind $S(W).lfonts.list <> [namespace code [list Click font]] + bind $S(W).lstyles.list <> [namespace code [list Click style]] + bind $S(W).lsizes.list <> [namespace code [list Click size]] + bind $S(W) [list ::tk::AltKeyInDialog $S(W) %A] + bind $S(W).font <> [list ::focus $S(W).efont] + bind $S(W).style <> [list ::focus $S(W).estyle] + bind $S(W).size <> [list ::focus $S(W).esize] + bind $S(W).apply <> [namespace code [list Apply]] + bind $WE.strike <> [list $WE.strike invoke] + bind $WE.under <> [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) <> +} + +# ::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) <> + } +} + +# ::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 +} diff --git a/library/msgs/de.msg b/library/msgs/de.msg index 39daf82..aa20340 100644 --- a/library/msgs/de.msg +++ b/library/msgs/de.msg @@ -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" diff --git a/library/msgs/en.msg b/library/msgs/en.msg index b4e51bf..5ad1094 100644 --- a/library/msgs/en.msg +++ b/library/msgs/en.msg @@ -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" diff --git a/library/tclIndex b/library/tclIndex index e7f5b81..df4c046 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -276,3 +276,4 @@ set auto_index(::tk::ListBoxKeyAccel_Reset) [list source [file join $dir xmfbox. 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]] diff --git a/macosx/Wish.xcodeproj/project.pbxproj b/macosx/Wish.xcodeproj/project.pbxproj index e4b3ece..d3c4f87 100644 --- a/macosx/Wish.xcodeproj/project.pbxproj +++ b/macosx/Wish.xcodeproj/project.pbxproj @@ -2087,10 +2087,13 @@ F97AE8330B65C87F00310EA2 /* Wish-Debug.xcconfig */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xcconfig; path = "Wish-Debug.xcconfig"; sourceTree = ""; }; F9903CAF094FAADA004613E9 /* tclTomMath.decls */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclTomMath.decls; sourceTree = ""; }; F9903CB0094FAADA004613E9 /* tclTomMathDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMathDecls.h; sourceTree = ""; }; + F99388380EE0114B0065FE6B /* fontchooser.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fontchooser.tcl; sourceTree = ""; }; + F99388950EE02D980065FE6B /* fontchooser.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fontchooser.test; sourceTree = ""; }; 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 = ""; }; + F9C888C20EEF6571003F63AD /* fontchooser.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = fontchooser.n; sourceTree = ""; }; F9D1360A0CDC252C00DBE0B5 /* mclist.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = mclist.tcl; sourceTree = ""; }; F9ECB1120B26521500A28025 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = ""; }; F9ECB1130B26521500A28025 /* platform.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = platform.tcl; sourceTree = ""; }; @@ -2148,7 +2151,7 @@ F966C06F08F281DC005CB29B /* Frameworks */, 1AB674ADFE9D54B511CA2CBB /* Products */, ); - comments = "Copyright (c) 2004-2008 Daniel A. Steffen \n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.48 2008/12/05 17:10:30 das Exp $\n"; + comments = "Copyright (c) 2004-2008 Daniel A. Steffen \n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.49 2008/12/10 05:02:52 das Exp $\n"; name = Wish; path = .; sourceTree = SOURCE_ROOT; @@ -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 */, diff --git a/macosx/tkMacOSXCarbonEvents.c b/macosx/tkMacOSXCarbonEvents.c index f7f04c4..7f99266 100644 --- a/macosx/tkMacOSXCarbonEvents.c +++ b/macosx/tkMacOSXCarbonEvents.c @@ -60,7 +60,7 @@ * software in accordance with the terms specified in this * license. * - * RCS: @(#) $Id: tkMacOSXCarbonEvents.c,v 1.21 2008/11/08 18:44:40 dkf Exp $ + * RCS: @(#) $Id: tkMacOSXCarbonEvents.c,v 1.22 2008/12/10 05:02:52 das Exp $ */ #include "tkMacOSXPrivate.h" @@ -211,6 +211,8 @@ TkMacOSXInitCarbonEvents( {kEventClassApplication, kEventAppShown}, {kEventClassApplication, kEventAppAvailableWindowBoundsChanged}, {kEventClassAppearance, kEventAppearanceScrollBarVariantChanged}, + {kEventClassFont, kEventFontPanelClosed}, + {kEventClassFont, kEventFontSelection}, }; carbonEventHandlerUPP = NewEventHandlerUPP(CarbonEventHandlerProc); diff --git a/macosx/tkMacOSXDialog.c b/macosx/tkMacOSXDialog.c index 1553592..e283f5c 100644 --- a/macosx/tkMacOSXDialog.c +++ b/macosx/tkMacOSXDialog.c @@ -5,12 +5,12 @@ * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright 2001, Apple Computer, Inc. - * Copyright (c) 2006-2007 Daniel A. Steffen + * Copyright (c) 2006-2008 Daniel A. Steffen * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkMacOSXDialog.c,v 1.42 2008/12/07 16:36:26 das Exp $ + * RCS: @(#) $Id: tkMacOSXDialog.c,v 1.43 2008/12/10 05:02:52 das Exp $ */ #include "tkMacOSXPrivate.h" @@ -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: + */ diff --git a/macosx/tkMacOSXEvent.c b/macosx/tkMacOSXEvent.c index 11114c2..9ca301d 100644 --- a/macosx/tkMacOSXEvent.c +++ b/macosx/tkMacOSXEvent.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkMacOSXEvent.c,v 1.24 2008/10/27 11:55:44 dkf Exp $ + * RCS: @(#) $Id: tkMacOSXEvent.c,v 1.25 2008/12/10 05:02:52 das Exp $ */ #include "tkMacOSXPrivate.h" @@ -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)); diff --git a/macosx/tkMacOSXEvent.h b/macosx/tkMacOSXEvent.h index 7fcb503..921e408 100644 --- a/macosx/tkMacOSXEvent.h +++ b/macosx/tkMacOSXEvent.h @@ -54,7 +54,7 @@ * software in accordance with the terms specified in this * license. * - * RCS: @(#) $Id: tkMacOSXEvent.h,v 1.12 2007/04/23 21:24:33 das Exp $ + * RCS: @(#) $Id: tkMacOSXEvent.h,v 1.13 2008/12/10 05:02:52 das Exp $ */ #ifndef _TKMACEVENT @@ -98,6 +98,8 @@ MODULE_SCOPE int TkMacOSXProcessMenuEvent(TkMacOSXEvent *e, 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, diff --git a/macosx/tkMacOSXFont.c b/macosx/tkMacOSXFont.c index aa4ea0c..51d0c4d 100644 --- a/macosx/tkMacOSXFont.c +++ b/macosx/tkMacOSXFont.c @@ -35,7 +35,7 @@ * that such fonts can not be used for controls, because controls * definitely require a family id (this assertion needs testing). * - * RCS: @(#) $Id: tkMacOSXFont.c,v 1.42 2008/11/22 22:29:14 das Exp $ + * RCS: @(#) $Id: tkMacOSXFont.c,v 1.43 2008/12/10 05:02:52 das Exp $ */ #include "tkMacOSXPrivate.h" @@ -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 diff --git a/macosx/tkMacOSXFont.h b/macosx/tkMacOSXFont.h index 56c0bbc..9c88409 100644 --- a/macosx/tkMacOSXFont.h +++ b/macosx/tkMacOSXFont.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkMacOSXFont.h,v 1.5 2007/04/23 21:24:33 das Exp $ + * RCS: @(#) $Id: tkMacOSXFont.h,v 1.6 2008/12/10 05:02:52 das Exp $ */ #ifndef TKMACOSXFONT_H @@ -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*/ diff --git a/tests/fontchooser.test b/tests/fontchooser.test new file mode 100644 index 0000000..0f90a46 --- /dev/null +++ b/tests/fontchooser.test @@ -0,0 +1,203 @@ +# Test the "tk::fontchooser" command +# +# Copyright (c) 2008 Pat Thoyts +# +# RCS: @(#) $Id: fontchooser.test,v 1.1 2008/12/10 05:02:52 das Exp $ +# + +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: diff --git a/tests/winDialog.test b/tests/winDialog.test index 5cc6e34..3a5c347 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 1998-1999 ActiveState Corporation. # -# RCS: @(#) $Id: winDialog.test,v 1.23 2008/11/22 12:22:12 patthoyts Exp $ +# RCS: @(#) $Id: winDialog.test,v 1.24 2008/12/10 05:02:52 das Exp $ package require tcltest 2.2 namespace import ::tcltest::* @@ -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_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFi 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} } diff --git a/win/tkWinDialog.c b/win/tkWinDialog.c index 8f41788..0f03f1d 100644 --- a/win/tkWinDialog.c +++ b/win/tkWinDialog.c @@ -8,12 +8,13 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkWinDialog.c,v 1.55 2008/11/08 18:44:40 dkf Exp $ + * RCS: @(#) $Id: tkWinDialog.c,v 1.56 2008/12/10 05:02:52 das Exp $ * */ #include "tkWinInt.h" #include "tkFileFilter.h" +#include "tkFont.h" #include /* 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 diff --git a/win/tkWinInt.h b/win/tkWinInt.h index aa35ed0..469d6e9 100644 --- a/win/tkWinInt.h +++ b/win/tkWinInt.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkWinInt.h,v 1.31 2007/12/14 15:56:09 patthoyts Exp $ + * RCS: @(#) $Id: tkWinInt.h,v 1.32 2008/12/10 05:02:52 das Exp $ */ #ifndef _TKWININT @@ -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; diff --git a/win/tkWinTest.c b/win/tkWinTest.c index c48dba5..3060dda 100644 --- a/win/tkWinTest.c +++ b/win/tkWinTest.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkWinTest.c,v 1.23 2008/11/27 23:26:05 nijtmans Exp $ + * RCS: @(#) $Id: tkWinTest.c,v 1.24 2008/12/10 05:02:52 das Exp $ */ #include "tkWinInt.h" @@ -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; } diff --git a/win/tkWinX.c b/win/tkWinX.c index 9632bd2..160e141 100644 --- a/win/tkWinX.c +++ b/win/tkWinX.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkWinX.c,v 1.58 2008/04/27 22:39:17 dkf Exp $ + * RCS: @(#) $Id: tkWinX.c,v 1.59 2008/12/10 05:02:52 das Exp $ */ /* @@ -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; -- cgit v0.12