Skip to content

Commit

Permalink
* library/bgerror.tcl: on aqua, use moveable alert resp. modal dialog
Browse files Browse the repository at this point in the history
	* library/dialog.tcl:	window class and corresponding system
				background pattern; fix button padding.

	* library/tearoff.tcl:	correct aqua menu bar height; vertically offset
	* library/tk.tcl:	aqua tearoff floating window to match menu.
  • Loading branch information
das committed Apr 23, 2007
1 parent 6f1c8c5 commit cf41012
Show file tree
Hide file tree
Showing 4 changed files with 25 additions and 9 deletions.
16 changes: 13 additions & 3 deletions library/bgerror.tcl
Expand Up @@ -9,15 +9,21 @@
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
#
# RCS: @(#) $Id: bgerror.tcl,v 1.32 2006/06/22 00:38:16 hobbs Exp $
# $Id: bgerror.tcl,v 1.32 2006/06/22 00:38:16 hobbs Exp $
# RCS: @(#) $Id: bgerror.tcl,v 1.33 2007/04/23 21:16:43 das Exp $
# $Id: bgerror.tcl,v 1.33 2007/04/23 21:16:43 das Exp $

namespace eval ::tk::dialog::error {
namespace import -force ::tk::msgcat::*
namespace export bgerror
option add *ErrorDialog.function.text [mc "Save To Log"] \
widgetDefault
option add *ErrorDialog.function.command [namespace code SaveToLog]
if {[tk windowingsystem] eq "aqua"} {
option add *ErrorDialog*background systemAlertBackgroundActive \
widgetDefault
option add *ErrorDialog*Button.highlightBackground \
systemAlertBackgroundActive widgetDefault
}
}

proc ::tk::dialog::error::Return {} {
Expand Down Expand Up @@ -139,7 +145,7 @@ proc ::tk::dialog::error::bgerror err {
wm protocol .bgerrorDialog WM_DELETE_WINDOW { }

if {$windowingsystem eq "aqua"} {
::tk::unsupported::MacWindowStyle style .bgerrorDialog zoomDocProc
::tk::unsupported::MacWindowStyle style .bgerrorDialog moveableAlert {}
}

frame .bgerrorDialog.bot
Expand All @@ -161,6 +167,9 @@ proc ::tk::dialog::error::bgerror err {
-relief $textRelief \
-highlightthickness $textHilight \
-wrap char
if {$windowingsystem eq "aqua"} {
$W.text configure -width 80 -background white
}

scrollbar $W.scroll -command [list $W.text yview]
pack $W.scroll -side right -fill y
Expand Down Expand Up @@ -218,6 +227,7 @@ proc ::tk::dialog::error::bgerror err {
if {($name eq "ok") || ($name eq "dismiss")} {
grid columnconfigure .bgerrorDialog.bot $i -minsize 79
}
grid configure .bgerrorDialog.$name -pady 7
}
incr i
}
Expand Down
8 changes: 6 additions & 2 deletions library/dialog.tcl
Expand Up @@ -3,7 +3,7 @@
# This file defines the procedure tk_dialog, which creates a dialog
# box containing a bitmap, a message, and one or more buttons.
#
# RCS: @(#) $Id: dialog.tcl,v 1.20 2006/01/25 18:22:04 dgp Exp $
# RCS: @(#) $Id: dialog.tcl,v 1.21 2007/04/23 21:16:43 das Exp $
#
# Copyright (c) 1992-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
Expand Down Expand Up @@ -67,7 +67,10 @@ proc ::tk_dialog {w title text bitmap default args} {

set windowingsystem [tk windowingsystem]
if {$windowingsystem eq "aqua"} {
::tk::unsupported::MacWindowStyle style $w dBoxProc
::tk::unsupported::MacWindowStyle style $w moveableModal {}
option add *Dialog*background systemDialogBackgroundActive widgetDefault
option add *Dialog*Button.highlightBackground \
systemDialogBackgroundActive widgetDefault
}

frame $w.bot
Expand Down Expand Up @@ -120,6 +123,7 @@ proc ::tk_dialog {w title text bitmap default args} {
if {$tmp eq "ok" || $tmp eq "cancel"} {
grid columnconfigure $w.bot $i -minsize [expr {59 + 20}]
}
grid configure $w.button$i -pady 7
}
incr i
}
Expand Down
6 changes: 4 additions & 2 deletions library/tearoff.tcl
Expand Up @@ -2,7 +2,7 @@
#
# This file contains procedures that implement tear-off menus.
#
# RCS: @(#) $Id: tearoff.tcl,v 1.10 2005/07/25 09:06:00 dkf Exp $
# RCS: @(#) $Id: tearoff.tcl,v 1.11 2007/04/23 21:16:43 das Exp $
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
Expand Down Expand Up @@ -38,8 +38,10 @@ proc ::tk::TearOffMenu {w {x 0} {y 0}} {
if {$y == 0} {
set y [winfo rooty $w]
if {[tk windowingsystem] eq "aqua"} {
# Shift by height of tearoff entry minus height of window titlebar
catch {incr y [expr {[$w yposition 1] - 16}]}
# Avoid the native menu bar which sits on top of everything.
if {$y < 20} { set y 20 }
if {$y < 22} { set y 22 }
}
}

Expand Down
4 changes: 2 additions & 2 deletions library/tk.tcl
Expand Up @@ -3,7 +3,7 @@
# Initialization script normally executed in the interpreter for each
# Tk-based application. Arranges class bindings for widgets.
#
# RCS: @(#) $Id: tk.tcl,v 1.60 2006/10/31 01:42:26 hobbs Exp $
# RCS: @(#) $Id: tk.tcl,v 1.61 2007/04/23 21:16:43 das Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
Expand Down Expand Up @@ -128,7 +128,7 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
}
if {[tk windowingsystem] eq "aqua"} {
# Avoid the native menu bar which sits on top of everything.
if {$y < 20} { set y 20 }
if {$y < 22} { set y 22 }
}
}
wm geometry $w +$x+$y
Expand Down

0 comments on commit cf41012

Please sign in to comment.