From ac7d8acb9d7b2d18335e5482304f837b1c499360 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Jul 2019 15:24:05 +0000 Subject: Fix [38dc27bd1d]: Tk does not support nor events. Now handle all events up to Button 9. On Windows and Mac, Buttons 8 and 9 are used for the mouse side buttons (as X11 already does). TIP needed for this. --- generic/tkBind.c | 8 ++++++++ generic/tkCanvas.c | 26 +++----------------------- generic/tkEvent.c | 35 ++++++++++++----------------------- generic/tkGrab.c | 13 +------------ generic/tkInt.h | 37 +++++++++++++++++++++++++++++++++++++ generic/tkPointer.c | 14 +------------- generic/tkTextTag.c | 35 ++++++----------------------------- macosx/tkMacOSXMouseEvent.c | 17 +++++++++++------ win/tkWinPointer.c | 6 ++++++ win/tkWinTest.c | 10 ++++++++++ win/tkWinX.c | 17 +++++++++++++++++ 11 files changed, 112 insertions(+), 106 deletions(-) diff --git a/generic/tkBind.c b/generic/tkBind.c index 953d936..15a66f1 100644 --- a/generic/tkBind.c +++ b/generic/tkBind.c @@ -388,6 +388,14 @@ static const ModInfo modArray[] = { {"Button4", Button4Mask, 0}, {"B5", Button5Mask, 0}, {"Button5", Button5Mask, 0}, + {"B6", Button6Mask, 0}, + {"Button6", Button6Mask, 0}, + {"B7", Button7Mask, 0}, + {"Button7", Button7Mask, 0}, + {"B8", Button8Mask, 0}, + {"Button8", Button8Mask, 0}, + {"B9", Button9Mask, 0}, + {"Button9", Button9Mask, 0}, {"Mod1", Mod1Mask, 0}, {"M1", Mod1Mask, 0}, {"Command", Mod1Mask, 0}, diff --git a/generic/tkCanvas.c b/generic/tkCanvas.c index 10e2ce2..7124d51 100644 --- a/generic/tkCanvas.c +++ b/generic/tkCanvas.c @@ -5092,26 +5092,7 @@ CanvasBindProc( switch (eventPtr->type) { case ButtonPress: case ButtonRelease: - switch (eventPtr->xbutton.button) { - case Button1: - mask = Button1Mask; - break; - case Button2: - mask = Button2Mask; - break; - case Button3: - mask = Button3Mask; - break; - case Button4: - mask = Button4Mask; - break; - case Button5: - mask = Button5Mask; - break; - default: - mask = 0; - break; - } + mask = TkGetButtonMask(eventPtr->xbutton.button); /* * For button press events, repick the current item using the button @@ -5194,7 +5175,7 @@ PickCurrentItem( * ButtonRelease, or MotionNotify. */ { double coords[2]; - int buttonDown; + unsigned int buttonDown; Tk_Item *prevItemPtr; SearchUids *searchUids = GetStaticUids(); @@ -5205,8 +5186,7 @@ PickCurrentItem( * for windows. */ - buttonDown = canvasPtr->state - & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask); + buttonDown = canvasPtr->state & ALL_BUTTONS; /* * Save information about this event in the canvas. The event in the diff --git a/generic/tkEvent.c b/generic/tkEvent.c index b36d5de..d8501c3 100644 --- a/generic/tkEvent.c +++ b/generic/tkEvent.c @@ -193,7 +193,6 @@ TCL_DECLARE_MUTEX(exitMutex) static void CleanUpTkEvent(XEvent *eventPtr); static void DelayedMotionProc(ClientData clientData); -static int GetButtonMask(unsigned int Button); static unsigned long GetEventMaskFromXEvent(XEvent *eventPtr); static TkWindow * GetTkWindowFromXEvent(XEvent *eventPtr); static void InvokeClientMessageHandlers(ThreadSpecificData *tsdPtr, @@ -524,7 +523,7 @@ RefreshKeyboardMappingIfNeeded( /* *---------------------------------------------------------------------- * - * GetButtonMask -- + * TkGetButtonMask -- * * Return the proper Button${n}Mask for the button. * @@ -537,23 +536,15 @@ RefreshKeyboardMappingIfNeeded( *---------------------------------------------------------------------- */ -static int -GetButtonMask( +static const int buttonMasks[] = { + 0, Button1Mask, Button2Mask, Button3Mask, Button4Mask, Button5Mask, Button6Mask, Button7Mask, Button8Mask, Button9Mask +}; + +int +TkGetButtonMask( unsigned int button) { - switch (button) { - case 1: - return Button1Mask; - case 2: - return Button2Mask; - case 3: - return Button3Mask; - case 4: - return Button4Mask; - case 5: - return Button5Mask; - } - return 0; + return (button > Button9) ? 0 : buttonMasks[button]; } /* @@ -582,8 +573,6 @@ UpdateButtonEventState( XEvent *eventPtr) { TkDisplay *dispPtr; - int allButtonsMask = Button1Mask | Button2Mask | Button3Mask - | Button4Mask | Button5Mask; switch (eventPtr->type) { case ButtonPress: @@ -591,19 +580,19 @@ UpdateButtonEventState( dispPtr->mouseButtonWindow = eventPtr->xbutton.window; eventPtr->xbutton.state |= dispPtr->mouseButtonState; - dispPtr->mouseButtonState |= GetButtonMask(eventPtr->xbutton.button); + dispPtr->mouseButtonState |= TkGetButtonMask(eventPtr->xbutton.button); break; case ButtonRelease: dispPtr = TkGetDisplay(eventPtr->xbutton.display); dispPtr->mouseButtonWindow = None; - dispPtr->mouseButtonState &= ~GetButtonMask(eventPtr->xbutton.button); + dispPtr->mouseButtonState &= ~TkGetButtonMask(eventPtr->xbutton.button); eventPtr->xbutton.state |= dispPtr->mouseButtonState; break; case MotionNotify: dispPtr = TkGetDisplay(eventPtr->xmotion.display); - if (dispPtr->mouseButtonState & allButtonsMask) { + if (dispPtr->mouseButtonState & ALL_BUTTONS) { if (eventPtr->xbutton.window != dispPtr->mouseButtonWindow) { /* * This motion event should not be interpreted as a button @@ -611,7 +600,7 @@ UpdateButtonEventState( * button was pressed down in. */ - dispPtr->mouseButtonState &= ~allButtonsMask; + dispPtr->mouseButtonState &= ~ALL_BUTTONS; dispPtr->mouseButtonWindow = None; } else { eventPtr->xmotion.state |= dispPtr->mouseButtonState; diff --git a/generic/tkGrab.c b/generic/tkGrab.c index 917ec69..50d2517 100644 --- a/generic/tkGrab.c +++ b/generic/tkGrab.c @@ -135,17 +135,6 @@ typedef struct NewGrabWinEvent { #define GENERATED_GRAB_EVENT_MAGIC ((Bool) 0x147321ac) /* - * Mask that selects any of the state bits corresponding to buttons, plus - * masks that select individual buttons' bits: - */ - -#define ALL_BUTTONS \ - (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask) -static const unsigned int buttonStates[] = { - Button1Mask, Button2Mask, Button3Mask, Button4Mask, Button5Mask -}; - -/* * Forward declarations for functions declared later in this file: */ @@ -883,7 +872,7 @@ TkPointerEvent( } else { if (eventPtr->xbutton.button != AnyButton && ((eventPtr->xbutton.state & ALL_BUTTONS) - == buttonStates[eventPtr->xbutton.button - Button1])) { + == (unsigned int)TkGetButtonMask(eventPtr->xbutton.button))) { ReleaseButtonGrab(dispPtr); /* Note 4. */ } } diff --git a/generic/tkInt.h b/generic/tkInt.h index 77b7725..10888f7 100644 --- a/generic/tkInt.h +++ b/generic/tkInt.h @@ -965,6 +965,43 @@ typedef struct TkpClipMask { #define ALT_MASK (AnyModifier<<2) #define EXTENDED_MASK (AnyModifier<<3) +#ifndef Button6 +# define Button6 6 +#endif +#ifndef Button7 +# define Button7 7 +#endif +#ifndef Button8 +# define Button8 8 +#endif +#ifndef Button9 +# define Button9 9 +#endif + +#ifndef Button6Mask +# define Button6Mask (AnyModifier<<4) +#endif +#ifndef Button7Mask +# define Button7Mask (AnyModifier<<5) +#endif +#ifndef Button8Mask +# define Button8Mask (AnyModifier<<6) +#endif +#ifndef Button9Mask +# define Button9Mask (AnyModifier<<7) +#endif + +/* + * Mask that selects any of the state bits corresponding to buttons, plus + * masks that select individual buttons' bits: + */ + +#define ALL_BUTTONS \ + (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask|Button6Mask|Button7Mask|Button8Mask|Button9Mask) + + +MODULE_SCOPE int TkGetButtonMask(unsigned int); + /* * Object types not declared in tkObj.c need to be mentioned here so they can * be properly registered with Tcl: diff --git a/generic/tkPointer.c b/generic/tkPointer.c index 6e87638..de9d49d 100644 --- a/generic/tkPointer.c +++ b/generic/tkPointer.c @@ -23,18 +23,6 @@ #define Cursor XCursor #endif -/* - * Mask that selects any of the state bits corresponding to buttons, plus - * masks that select individual buttons' bits: - */ - -#define ALL_BUTTONS \ - (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask) -static const unsigned int buttonMasks[] = { - Button1Mask, Button2Mask, Button3Mask, Button4Mask, Button5Mask -}; -#define ButtonMask(b) (buttonMasks[(b)-Button1]) - typedef struct { TkWindow *grabWinPtr; /* Window that defines the top of the grab * tree in a global grab. */ @@ -267,7 +255,7 @@ Tk_UpdatePointer( */ for (b = Button1; b <= Button5; b++) { - mask = ButtonMask(b); + mask = TkGetButtonMask(b); if (changes & mask) { if (state & mask) { type = ButtonPress; diff --git a/generic/tkTextTag.c b/generic/tkTextTag.c index cb0993b..bda315e 100644 --- a/generic/tkTextTag.c +++ b/generic/tkTextTag.c @@ -1446,9 +1446,6 @@ TkTextBindProc( TkText *textPtr = clientData; int repick = 0; -# define AnyButtonMask \ - (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask) - textPtr->refCount++; /* @@ -1460,35 +1457,16 @@ TkTextBindProc( if (eventPtr->type == ButtonPress) { textPtr->flags |= BUTTON_DOWN; } else if (eventPtr->type == ButtonRelease) { - int mask; + unsigned int mask; - switch (eventPtr->xbutton.button) { - case Button1: - mask = Button1Mask; - break; - case Button2: - mask = Button2Mask; - break; - case Button3: - mask = Button3Mask; - break; - case Button4: - mask = Button4Mask; - break; - case Button5: - mask = Button5Mask; - break; - default: - mask = 0; - break; - } - if ((eventPtr->xbutton.state & AnyButtonMask) == (unsigned) mask) { + mask = TkGetButtonMask(eventPtr->xbutton.button); + if ((eventPtr->xbutton.state & ALL_BUTTONS) == mask) { textPtr->flags &= ~BUTTON_DOWN; repick = 1; } } else if ((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) { - if (eventPtr->xcrossing.state & AnyButtonMask) { + if (eventPtr->xcrossing.state & ALL_BUTTONS) { textPtr->flags |= BUTTON_DOWN; } else { textPtr->flags &= ~BUTTON_DOWN; @@ -1496,7 +1474,7 @@ TkTextBindProc( TkTextPickCurrent(textPtr, eventPtr); goto done; } else if (eventPtr->type == MotionNotify) { - if (eventPtr->xmotion.state & AnyButtonMask) { + if (eventPtr->xmotion.state & ALL_BUTTONS) { textPtr->flags |= BUTTON_DOWN; } else { textPtr->flags &= ~BUTTON_DOWN; @@ -1513,8 +1491,7 @@ TkTextBindProc( unsigned int oldState; oldState = eventPtr->xbutton.state; - eventPtr->xbutton.state &= ~(Button1Mask|Button2Mask - |Button3Mask|Button4Mask|Button5Mask); + eventPtr->xbutton.state &= ~ALL_BUTTONS; if (!(textPtr->flags & DESTROYED)) { TkTextPickCurrent(textPtr, eventPtr); } diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c index 2517769..42fae98 100644 --- a/macosx/tkMacOSXMouseEvent.c +++ b/macosx/tkMacOSXMouseEvent.c @@ -178,22 +178,26 @@ enum { */ unsigned int state = 0; - NSInteger button = [theEvent buttonNumber]; + int button = [theEvent buttonNumber]; + if (++button > 3) { + button += 4; /* Map buttons 4/5 to 8/9 */ + } EventRef eventRef = (EventRef)[theEvent eventRef]; UInt32 buttons; OSStatus err = GetEventParameter(eventRef, kEventParamMouseChord, typeUInt32, NULL, sizeof(UInt32), NULL, &buttons); if (err == noErr) { - state |= (buttons & ((1<<5) - 1)) << 8; - } else if (button < 5) { + state |= (buttons & 0x07) << 8; + state |= (buttons & 0x18) << 12; + } else if (button <= 9) { switch (eventType) { case NSLeftMouseDown: case NSRightMouseDown: case NSLeftMouseDragged: case NSRightMouseDragged: case NSOtherMouseDown: - state |= 1 << (button + 8); + state |= TkGetButtonMask(button); break; default: break; @@ -361,10 +365,11 @@ ButtonModifiers2State( unsigned int state; /* - * Tk supports at most 5 buttons. + * Tk on OSX supports at most 5 buttons. */ - state = (buttonState & ((1<<5) - 1)) << 8; + state = (buttonState & 0x07) * Button1Mask; + state |= (buttonState & 0x18) * (Button8Mask >> 3); if (keyModifiers & alphaLock) { state |= LockMask; diff --git a/win/tkWinPointer.c b/win/tkWinPointer.c index 6f1f840..e3445c7 100644 --- a/win/tkWinPointer.c +++ b/win/tkWinPointer.c @@ -81,6 +81,12 @@ TkWinGetModifierState(void) if (GetKeyState(VK_RBUTTON) & 0x8000) { state |= Button3Mask; } + if (GetKeyState(VK_XBUTTON1) & 0x8000) { + state |= Button8Mask; + } + if (GetKeyState(VK_XBUTTON2) & 0x8000) { + state |= Button9Mask; + } return state; } diff --git a/win/tkWinTest.c b/win/tkWinTest.c index e58ee7c..e386605 100644 --- a/win/tkWinTest.c +++ b/win/tkWinTest.c @@ -287,6 +287,16 @@ TestwineventObjCmd( static const TkStateMap messageMap[] = { {WM_LBUTTONDOWN, "WM_LBUTTONDOWN"}, {WM_LBUTTONUP, "WM_LBUTTONUP"}, + {WM_LBUTTONDBLCLK, "WM_LBUTTONDBLCLK"}, + {WM_MBUTTONDOWN, "WM_MBUTTONDOWN"}, + {WM_MBUTTONUP, "WM_MBUTTONUP"}, + {WM_MBUTTONDBLCLK, "WM_MBUTTONDBLCLK"}, + {WM_RBUTTONDOWN, "WM_RBUTTONDOWN"}, + {WM_RBUTTONUP, "WM_RBUTTONUP"}, + {WM_RBUTTONDBLCLK, "WM_RBUTTONDBLCLK"}, + {WM_XBUTTONDOWN, "WM_XBUTTONDOWN"}, + {WM_XBUTTONUP, "WM_XBUTTONUP"}, + {WM_XBUTTONDBLCLK, "WM_XBUTTONDBLCLK"}, {WM_CHAR, "WM_CHAR"}, {WM_GETTEXT, "WM_GETTEXT"}, {WM_SETTEXT, "WM_SETTEXT"}, diff --git a/win/tkWinX.c b/win/tkWinX.c index db8bc4f..d724282 100644 --- a/win/tkWinX.c +++ b/win/tkWinX.c @@ -884,9 +884,12 @@ Tk_TranslateWinEvent( case WM_MBUTTONDBLCLK: case WM_RBUTTONDOWN: case WM_RBUTTONDBLCLK: + case WM_XBUTTONDOWN: + case WM_XBUTTONDBLCLK: case WM_LBUTTONUP: case WM_MBUTTONUP: case WM_RBUTTONUP: + case WM_XBUTTONUP: case WM_MOUSEMOVE: Tk_PointerEvent(hwnd, (short) LOWORD(lParam), (short) HIWORD(lParam)); return 1; @@ -1713,6 +1716,14 @@ TkWinResendEvent( msg = WM_RBUTTONDOWN; wparam = MK_RBUTTON; break; + case Button8: + msg = WM_XBUTTONDOWN; + wparam = MAKEWPARAM(MK_XBUTTON1, XBUTTON1); + break; + case Button9: + msg = WM_XBUTTONDOWN; + wparam = MAKEWPARAM(MK_XBUTTON2, XBUTTON2); + break; default: return 0; } @@ -1726,6 +1737,12 @@ TkWinResendEvent( if (eventPtr->xbutton.state & Button3Mask) { wparam |= MK_RBUTTON; } + if (eventPtr->xbutton.state & Button8Mask) { + wparam |= MK_XBUTTON1; + } + if (eventPtr->xbutton.state & Button9Mask) { + wparam |= MK_XBUTTON2; + } if (eventPtr->xbutton.state & ShiftMask) { wparam |= MK_SHIFT; } -- cgit v0.12 From 987d79373dc7dd75d2cc06cd55d34f3cb6624779 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Jul 2019 15:36:38 +0000 Subject: mis-counted modifier bits --- macosx/tkMacOSXMouseEvent.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c index 42fae98..94ebb75 100644 --- a/macosx/tkMacOSXMouseEvent.c +++ b/macosx/tkMacOSXMouseEvent.c @@ -188,8 +188,8 @@ enum { typeUInt32, NULL, sizeof(UInt32), NULL, &buttons); if (err == noErr) { - state |= (buttons & 0x07) << 8; - state |= (buttons & 0x18) << 12; + state |= (buttons & 0x07) * Button1Mask; + state |= (buttons & 0x18) * (Button8Mask >> 3); } else if (button <= 9) { switch (eventType) { case NSLeftMouseDown: -- cgit v0.12 From 2c41264be7ab081b18b9a7dfb177e5835917c4bc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Jul 2019 13:31:43 +0000 Subject: (cherry-pick): Patch by Arjen sent to core 2018-09-21 Also, do some renumbering of mouse-buttons, such that at script level the XButtons appear to be at 4/5 while - internally - they are at 8/9. --- doc/bind.n | 4 ---- generic/tkBind.c | 33 ++++++++++++++++++-------------- generic/tkEvent.c | 17 ++++++++++++++++- tests/bind.test | 56 ------------------------------------------------------- 4 files changed, 35 insertions(+), 75 deletions(-) diff --git a/doc/bind.n b/doc/bind.n index 7c39cfc..015bad5 100644 --- a/doc/bind.n +++ b/doc/bind.n @@ -114,10 +114,6 @@ Modifiers consist of any of the following values: \fBButton3\fR, \fBB3\fR \fBTriple\fR \fBButton4\fR, \fBB4\fR \fBQuadruple\fR \fBButton5\fR, \fBB5\fR -\fBButton6\fR, \fBB6\fR -\fBButton7\fR, \fBB7\fR -\fBButton8\fR, \fBB8\fR -\fBButton9\fR, \fBB9\fR .DE Where more than one value is listed, separated by commas, the values are equivalent. diff --git a/generic/tkBind.c b/generic/tkBind.c index 15a66f1..a6bd8ca 100644 --- a/generic/tkBind.c +++ b/generic/tkBind.c @@ -384,18 +384,10 @@ static const ModInfo modArray[] = { {"Button2", Button2Mask, 0}, {"B3", Button3Mask, 0}, {"Button3", Button3Mask, 0}, - {"B4", Button4Mask, 0}, - {"Button4", Button4Mask, 0}, - {"B5", Button5Mask, 0}, - {"Button5", Button5Mask, 0}, - {"B6", Button6Mask, 0}, - {"Button6", Button6Mask, 0}, - {"B7", Button7Mask, 0}, - {"Button7", Button7Mask, 0}, - {"B8", Button8Mask, 0}, - {"Button8", Button8Mask, 0}, - {"B9", Button9Mask, 0}, - {"Button9", Button9Mask, 0}, + {"B4", Button8Mask, 0}, + {"Button4", Button8Mask, 0}, + {"B5", Button9Mask, 0}, + {"Button5", Button9Mask, 0}, {"Mod1", Mod1Mask, 0}, {"M1", Mod1Mask, 0}, {"Command", Mod1Mask, 0}, @@ -1995,6 +1987,9 @@ ExpandPercents( case 'b': if (flags & BUTTON) { number = eventPtr->xbutton.button; + if (eventPtr->xbutton.button >= Button8) { + number += (Button4 - Button8); + } goto doNumber; } goto doString; @@ -3109,6 +3104,9 @@ HandleEventGenerate( return TCL_ERROR; } if (flags & BUTTON) { + if (number >= Button4) { + number += (Button8 - Button4); + } event.general.xbutton.button = number; } else { goto badopt; @@ -3997,7 +3995,7 @@ ParseEventDescription( p = GetField(p, field, FIELD_SIZE); } if (*field != '\0') { - if ((*field >= '1') && (*field <= '9') && (field[1] == '\0')) { + if ((*field >= '1') && (*field <= '5') && (field[1] == '\0')) { if (eventFlags == 0) { patPtr->eventType = ButtonPress; eventMask = ButtonPressMask; @@ -4012,6 +4010,9 @@ ParseEventDescription( goto done; } patPtr->detail.button = (*field - '0'); + if (patPtr->detail.button >= Button4) { + patPtr->detail.button += (Button8 - Button4); + } } else { getKeysym: @@ -4228,7 +4229,11 @@ GetPatternObj( Tcl_AppendToObj(patternObj, string, -1); } } else { - Tcl_AppendPrintfToObj(patternObj, "%d", patPtr->detail.button); + int button = patPtr->detail.button; + if (button >= Button8) { + button += (Button4 - Button8); + } + Tcl_AppendPrintfToObj(patternObj, "%d", button); } } diff --git a/generic/tkEvent.c b/generic/tkEvent.c index d8501c3..02c7de8 100644 --- a/generic/tkEvent.c +++ b/generic/tkEvent.c @@ -580,7 +580,22 @@ UpdateButtonEventState( dispPtr->mouseButtonWindow = eventPtr->xbutton.window; eventPtr->xbutton.state |= dispPtr->mouseButtonState; - dispPtr->mouseButtonState |= TkGetButtonMask(eventPtr->xbutton.button); + if ((eventPtr->xbutton.button >= Button4) && (eventPtr->xbutton.button <= Button7)) { + /* + * Turn the event into a mouse wheel event and queue it + * Note: modelled after the code in tkWinX.c + */ + eventPtr->type = MouseWheelEvent; + eventPtr->xany.send_event = -1; + eventPtr->xkey.nbytes = 0; + eventPtr->xkey.keycode = (eventPtr->xbutton.button & 1) ? 1 : -1; + if (eventPtr->xkey.keycode >= Button6) { + eventPtr->xkey.state |= ShiftMask; + } + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_TAIL); + } else { + dispPtr->mouseButtonState |= TkGetButtonMask(eventPtr->xbutton.button); + } break; case ButtonRelease: diff --git a/tests/bind.test b/tests/bind.test index ebc39b7..87e8e03 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -5862,62 +5862,6 @@ test bind-27.7 {button names} -setup { } -cleanup { destroy .t.f } -result { {button 5}} -test bind-27.8 {button names} -setup { - frame .t.f -class Test -width 150 -height 100 - pack .t.f - focus -force .t.f - update -} -body { - bind .t.f {lappend x "button 6"} - set x [bind .t.f] - event generate .t.f - event generate .t.f - set x -} -cleanup { - destroy .t.f -} -result { {button 6}} -test bind-27.9 {button names} -setup { - frame .t.f -class Test -width 150 -height 100 - pack .t.f - focus -force .t.f - update -} -body { - bind .t.f {lappend x "button 7"} - set x [bind .t.f] - event generate .t.f - event generate .t.f - set x -} -cleanup { - destroy .t.f -} -result { {button 7}} -test bind-27.10 {button names} -setup { - frame .t.f -class Test -width 150 -height 100 - pack .t.f - focus -force .t.f - update -} -body { - bind .t.f {lappend x "button 8"} - set x [bind .t.f] - event generate .t.f - event generate .t.f - set x -} -cleanup { - destroy .t.f -} -result { {button 8}} -test bind-27.11 {button names} -setup { - frame .t.f -class Test -width 150 -height 100 - pack .t.f - focus -force .t.f - update -} -body { - bind .t.f {lappend x "button 9"} - set x [bind .t.f] - event generate .t.f - event generate .t.f - set x -} -cleanup { - destroy .t.f -} -result { {button 9}} test bind-28.1 {keysym names} -body { bind .t foo -- cgit v0.12 From 89d0c9df2c0159f34bdb8080abef85a21fe9c0bb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Jul 2019 14:38:37 +0000 Subject: Code simplification: Don't bother keeping track of the Button[n]Mask's for Buttons 4-7, since those are not actually buttons (they are mouse-wheels). This means that Button4Mask/Button5Mask can be used for Buttons 8/9. --- generic/tkBind.c | 8 ++++---- generic/tkEvent.c | 11 +++++++---- generic/tkInt.h | 26 ++++++-------------------- macosx/tkMacOSXMouseEvent.c | 6 ++---- win/tkWinPointer.c | 4 ++-- win/tkWinX.c | 4 ++-- 6 files changed, 23 insertions(+), 36 deletions(-) diff --git a/generic/tkBind.c b/generic/tkBind.c index 8c77d93..3d5bb3e 100644 --- a/generic/tkBind.c +++ b/generic/tkBind.c @@ -384,10 +384,10 @@ static const ModInfo modArray[] = { {"Button2", Button2Mask, 0}, {"B3", Button3Mask, 0}, {"Button3", Button3Mask, 0}, - {"B4", Button8Mask, 0}, - {"Button4", Button8Mask, 0}, - {"B5", Button9Mask, 0}, - {"Button5", Button9Mask, 0}, + {"B4", Button4Mask, 0}, + {"Button4", Button4Mask, 0}, + {"B5", Button5Mask, 0}, + {"Button5", Button5Mask, 0}, {"Mod1", Mod1Mask, 0}, {"M1", Mod1Mask, 0}, {"Command", Mod1Mask, 0}, diff --git a/generic/tkEvent.c b/generic/tkEvent.c index 02c7de8..a8eaec1 100644 --- a/generic/tkEvent.c +++ b/generic/tkEvent.c @@ -525,7 +525,10 @@ RefreshKeyboardMappingIfNeeded( * * TkGetButtonMask -- * - * Return the proper Button${n}Mask for the button. + * Return the proper Button${n}Mask for the button. Don't care about + * Button4 - Button7, because those are not actually buttons: Those + * are used for the horizontal or vertical mouse wheels. The + * Button4Mask/Button5Mask's are actually used for Button 8 and 9. * * Results: * A button mask. @@ -537,7 +540,7 @@ RefreshKeyboardMappingIfNeeded( */ static const int buttonMasks[] = { - 0, Button1Mask, Button2Mask, Button3Mask, Button4Mask, Button5Mask, Button6Mask, Button7Mask, Button8Mask, Button9Mask + 0, Button1Mask, Button2Mask, Button3Mask, 0, 0, 0, 0, Button4Mask, Button5Mask }; int @@ -580,7 +583,7 @@ UpdateButtonEventState( dispPtr->mouseButtonWindow = eventPtr->xbutton.window; eventPtr->xbutton.state |= dispPtr->mouseButtonState; - if ((eventPtr->xbutton.button >= Button4) && (eventPtr->xbutton.button <= Button7)) { + if ((eventPtr->xbutton.button >= Button4) && (eventPtr->xbutton.button < Button8)) { /* * Turn the event into a mouse wheel event and queue it * Note: modelled after the code in tkWinX.c @@ -589,7 +592,7 @@ UpdateButtonEventState( eventPtr->xany.send_event = -1; eventPtr->xkey.nbytes = 0; eventPtr->xkey.keycode = (eventPtr->xbutton.button & 1) ? 1 : -1; - if (eventPtr->xkey.keycode >= Button6) { + if (eventPtr->xkey.keycode > Button5) { eventPtr->xkey.state |= ShiftMask; } Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_TAIL); diff --git a/generic/tkInt.h b/generic/tkInt.h index 10888f7..03ba420 100644 --- a/generic/tkInt.h +++ b/generic/tkInt.h @@ -965,12 +965,11 @@ typedef struct TkpClipMask { #define ALT_MASK (AnyModifier<<2) #define EXTENDED_MASK (AnyModifier<<3) -#ifndef Button6 -# define Button6 6 -#endif -#ifndef Button7 -# define Button7 7 -#endif +/* + * Buttons 8 and 9 are the Xbuttons (left and right side-buttons). On Windows/Mac, those + * are known as Buttons 4 and 5. At script level, they also get the numbers 4 and 5. + */ + #ifndef Button8 # define Button8 8 #endif @@ -978,26 +977,13 @@ typedef struct TkpClipMask { # define Button9 9 #endif -#ifndef Button6Mask -# define Button6Mask (AnyModifier<<4) -#endif -#ifndef Button7Mask -# define Button7Mask (AnyModifier<<5) -#endif -#ifndef Button8Mask -# define Button8Mask (AnyModifier<<6) -#endif -#ifndef Button9Mask -# define Button9Mask (AnyModifier<<7) -#endif - /* * Mask that selects any of the state bits corresponding to buttons, plus * masks that select individual buttons' bits: */ #define ALL_BUTTONS \ - (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask|Button6Mask|Button7Mask|Button8Mask|Button9Mask) + (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask) MODULE_SCOPE int TkGetButtonMask(unsigned int); diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c index fc4d1c2..78363d0 100644 --- a/macosx/tkMacOSXMouseEvent.c +++ b/macosx/tkMacOSXMouseEvent.c @@ -188,8 +188,7 @@ enum { typeUInt32, NULL, sizeof(UInt32), NULL, &buttons); if (err == noErr) { - state |= (buttons & 0x07) * Button1Mask; - state |= (buttons & 0x18) * (Button8Mask >> 3); + state |= (buttons & 0x1F) * Button1Mask; } else if (button <= 9) { switch (eventType) { case NSLeftMouseDown: @@ -368,8 +367,7 @@ ButtonModifiers2State( * Tk on OSX supports at most 5 buttons. */ - state = (buttonState & 0x07) * Button1Mask; - state |= (buttonState & 0x18) * (Button8Mask >> 3); + state = (buttonState & 0x1F) * Button1Mask; if (keyModifiers & alphaLock) { state |= LockMask; diff --git a/win/tkWinPointer.c b/win/tkWinPointer.c index e3445c7..251b5b9 100644 --- a/win/tkWinPointer.c +++ b/win/tkWinPointer.c @@ -82,10 +82,10 @@ TkWinGetModifierState(void) state |= Button3Mask; } if (GetKeyState(VK_XBUTTON1) & 0x8000) { - state |= Button8Mask; + state |= Button4Mask; } if (GetKeyState(VK_XBUTTON2) & 0x8000) { - state |= Button9Mask; + state |= Button5Mask; } return state; } diff --git a/win/tkWinX.c b/win/tkWinX.c index d724282..9d474ac 100644 --- a/win/tkWinX.c +++ b/win/tkWinX.c @@ -1737,10 +1737,10 @@ TkWinResendEvent( if (eventPtr->xbutton.state & Button3Mask) { wparam |= MK_RBUTTON; } - if (eventPtr->xbutton.state & Button8Mask) { + if (eventPtr->xbutton.state & Button4Mask) { wparam |= MK_XBUTTON1; } - if (eventPtr->xbutton.state & Button9Mask) { + if (eventPtr->xbutton.state & Button5Mask) { wparam |= MK_XBUTTON2; } if (eventPtr->xbutton.state & ShiftMask) { -- cgit v0.12 From 5c07a1409bb742e9fe41e7e523146ce75d71580a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Jul 2019 14:55:51 +0000 Subject: A few more minor adaptations, and make it compile on X11 (XKeyEvent structure doesn't have a nbytes field). --- generic/tkBind.c | 2 +- generic/tkEvent.c | 2 ++ macosx/tkMacOSXMouseEvent.c | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tkBind.c b/generic/tkBind.c index 3d5bb3e..0208a7a 100644 --- a/generic/tkBind.c +++ b/generic/tkBind.c @@ -1987,7 +1987,7 @@ ExpandPercents( case 'b': if (flags & BUTTON) { number = eventPtr->xbutton.button; - if (eventPtr->xbutton.button >= Button8) { + if (number >= Button8) { number += (Button4 - Button8); } goto doNumber; diff --git a/generic/tkEvent.c b/generic/tkEvent.c index a8eaec1..e94cdd5 100644 --- a/generic/tkEvent.c +++ b/generic/tkEvent.c @@ -590,7 +590,9 @@ UpdateButtonEventState( */ eventPtr->type = MouseWheelEvent; eventPtr->xany.send_event = -1; +#if defined(_WIN32) || defined(MAC_OSX_TK) eventPtr->xkey.nbytes = 0; +#endif eventPtr->xkey.keycode = (eventPtr->xbutton.button & 1) ? 1 : -1; if (eventPtr->xkey.keycode > Button5) { eventPtr->xkey.state |= ShiftMask; diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c index 78363d0..37e3568 100644 --- a/macosx/tkMacOSXMouseEvent.c +++ b/macosx/tkMacOSXMouseEvent.c @@ -189,7 +189,7 @@ enum { if (err == noErr) { state |= (buttons & 0x1F) * Button1Mask; - } else if (button <= 9) { + } else if (button <= Button9) { switch (eventType) { case NSLeftMouseDown: case NSRightMouseDown: -- cgit v0.12 From f97059c69925b78f7f7e291b86fa2089f58291a6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Jul 2019 09:06:10 +0000 Subject: Further experiment: Bring scalefactor back to 120 (as it was for win32) --- doc/event.n | 4 ++-- generic/tkBind.c | 4 ++-- generic/tkEvent.c | 2 +- generic/tkPointer.c | 3 +-- library/demos/cscroll.tcl | 8 ++++---- library/listbox.tcl | 8 ++++---- library/scrlbar.tcl | 8 ++++---- library/text.tcl | 8 ++++---- library/ttk/utils.tcl | 35 ++++++++++------------------------- macosx/tkMacOSXMouseEvent.c | 14 ++++++++------ tests/scrollbar.test | 4 ++-- win/tkWinX.c | 4 ++-- 12 files changed, 44 insertions(+), 58 deletions(-) diff --git a/doc/event.n b/doc/event.n index be42fa5..5109794 100644 --- a/doc/event.n +++ b/doc/event.n @@ -119,8 +119,8 @@ for the event. Only valid for virtual events. Corresponds to the for the \fBMouseWheel\fR event. The \fIdelta\fR refers to the direction and magnitude the mouse wheel was rotated. Note the value is not a screen distance but are units of motion in the mouse wheel. -Typically these values are multiples of 40. For example, 40 should -scroll the text widget up 4 lines and \-80 would scroll the text +Typically these values are multiples of 120. For example, 120 should +scroll the text widget up 4 lines and \-240 would scroll the text widget down 8 lines. Of course, other widgets may define different behaviors for mouse wheel motion. This field corresponds to the \fB%D\fR substitution for binding scripts. diff --git a/generic/tkBind.c b/generic/tkBind.c index 03e4a2b..45e07be 100644 --- a/generic/tkBind.c +++ b/generic/tkBind.c @@ -1996,7 +1996,7 @@ ExpandPercents( if (flags & BUTTON) { number = eventPtr->xbutton.button; if (number >= Button8) { - number += (Button4 - Button8); + number -= (Button8 - Button4); } goto doNumber; } @@ -4239,7 +4239,7 @@ GetPatternObj( } else { int button = patPtr->detail.button; if (button >= Button8) { - button += (Button4 - Button8); + button -= (Button8 - Button4); } Tcl_AppendPrintfToObj(patternObj, "%d", button); } diff --git a/generic/tkEvent.c b/generic/tkEvent.c index dd77c2b..39d9d4b 100644 --- a/generic/tkEvent.c +++ b/generic/tkEvent.c @@ -594,7 +594,7 @@ UpdateButtonEventState( #if defined(_WIN32) || defined(MAC_OSX_TK) eventPtr->xkey.nbytes = 0; #endif - eventPtr->xkey.keycode = (eventPtr->xbutton.button & 1) ? 40 : -40; + eventPtr->xkey.keycode = (eventPtr->xbutton.button & 1) ? 120 : -120; if (eventPtr->xkey.keycode > Button5) { eventPtr->xkey.state |= ShiftMask; } diff --git a/generic/tkPointer.c b/generic/tkPointer.c index af5e311..57680c3 100644 --- a/generic/tkPointer.c +++ b/generic/tkPointer.c @@ -226,8 +226,7 @@ Tk_UpdatePointer( XPoint pos; XEvent event; int changes = (state ^ tsdPtr->lastState) & ALL_BUTTONS; - int type, b; - int mask; + int type, b, mask; pos.x = x; pos.y = y; diff --git a/library/demos/cscroll.tcl b/library/demos/cscroll.tcl index 24d5f89..c709668 100644 --- a/library/demos/cscroll.tcl +++ b/library/demos/cscroll.tcl @@ -59,16 +59,16 @@ $c bind all <1> "scrollButton $c" bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c { - %W yview scroll [expr {-(%D / 40)}] units + %W yview scroll [expr {-((%D+60) / 120)}] units } bind $c { - %W yview scroll [expr {-(%D / 4)}] units + %W yview scroll [expr {-((%D+6) / 12)}] units } bind $c { - %W xview scroll [expr {-(%D / 40)}] units + %W xview scroll [expr {-((%D+60) / 120)}] units } bind $c { - %W xview scroll [expr {-(%D / 4)}] units + %W xview scroll [expr {-((%D+6) / 12)}] units } proc scrollEnter canvas { diff --git a/library/listbox.tcl b/library/listbox.tcl index fd10fe4..ffd7def 100644 --- a/library/listbox.tcl +++ b/library/listbox.tcl @@ -177,16 +177,16 @@ bind Listbox { } bind Listbox { - %W yview scroll [expr {-(%D / 40)}] units + %W yview scroll [expr {-((%D+60) / 120)}] units } bind Listbox { - %W yview scroll [expr {-(%D / 4)}] units + %W yview scroll [expr {-((%D+6) / 12)}] units } bind Listbox { - %W xview scroll [expr {-(%D / 40)}] units + %W xview scroll [expr {-((%D+60) / 120)}] units } bind Listbox { - %W xview scroll [expr {-(%D / 4)}] units + %W xview scroll [expr {-((%D+6) / 12)}] units } diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl index 93ded56..dae11ae 100644 --- a/library/scrlbar.tcl +++ b/library/scrlbar.tcl @@ -130,16 +130,16 @@ bind Scrollbar <> { } bind Scrollbar { - tk::ScrollByUnits %W v [expr {-(%D / 40)}] + tk::ScrollByUnits %W v [expr {-((%D+60) / 120)}] } bind Scrollbar { - tk::ScrollByUnits %W v [expr {-(%D / 4)}] + tk::ScrollByUnits %W v [expr {-((%D+6) / 12)}] } bind Scrollbar { - tk::ScrollByUnits %W h [expr {-(%D / 40)}] + tk::ScrollByUnits %W h [expr {-((%D+60) / 120)}] } bind Scrollbar { - tk::ScrollByUnits %W h [expr {-(%D / 4)}] + tk::ScrollByUnits %W h [expr {-((%D+6) / 12)}] } # tk::ScrollButtonDown -- diff --git a/library/text.tcl b/library/text.tcl index 9d635de..72da6ff 100644 --- a/library/text.tcl +++ b/library/text.tcl @@ -428,16 +428,16 @@ bind Text { set ::tk::Priv(prevPos) {} bind Text { - %W yview scroll [expr {-(%D)}] pixels + %W yview scroll [expr {-((%D+1)/3)}] pixels } bind Text { - %W yview scroll [expr {-10 * (%D)}] pixels + %W yview scroll [expr {-4 * (%D)}] pixels } bind Text { - %W xview scroll [expr {-(%D)}] pixels + %W xview scroll [expr {-((%D+1)/3)}] pixels } bind Text { - %W xview scroll [expr {-10 * (%D)}] pixels + %W xview scroll [expr {-4 * (%D)}] pixels } # ::tk::TextClosestGap -- diff --git a/library/ttk/utils.tcl b/library/ttk/utils.tcl index 140e061..ad36927 100644 --- a/library/ttk/utils.tcl +++ b/library/ttk/utils.tcl @@ -285,7 +285,8 @@ proc ttk::copyBindings {from to} { # proc ttk::bindMouseWheel {bindtag callback} { - bind $bindtag [append callback { [expr {-(%D/40)}]}] + bind $bindtag [append callback { [expr {-((%D+60)/120)}]}] + bind $bindtag [append callback { [expr {-((%D+6)/12)}]}] } ## Mousewheel bindings for standard scrollable widgets. @@ -296,29 +297,13 @@ proc ttk::bindMouseWheel {bindtag callback} { # standard scrollbar protocol. # -switch -- [tk windowingsystem] { - x11 { - bind TtkScrollable { %W yview scroll -5 units } - bind TtkScrollable { %W yview scroll 5 units } - bind TtkScrollable { %W xview scroll -5 units } - bind TtkScrollable { %W xview scroll 5 units } - } - win32 { - bind TtkScrollable \ - { %W yview scroll [expr {-(%D/120)}] units } - bind TtkScrollable \ - { %W xview scroll [expr {-(%D/120)}] units } - } - aqua { - bind TtkScrollable \ - { %W yview scroll [expr {-(%D)}] units } - bind TtkScrollable \ - { %W xview scroll [expr {-(%D)}] units } - bind TtkScrollable \ - { %W yview scroll [expr {-10*(%D)}] units } - bind TtkScrollable \ - { %W xview scroll [expr {-10*(%D)}] units } - } -} +bind TtkScrollable \ +{ %W yview scroll [expr {-((%D+60)/120)}] units } +bind TtkScrollable \ +{ %W yview scroll [expr {-((%D+6)/12)}] units } +bind TtkScrollable \ +{ %W xview scroll [expr {-((%D+60)/120)}] units } +bind TtkScrollable \ +{ %W xview scroll [expr {-((%D+6)/12)}] units } #*EOF* diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c index ed67bae..92d2daf 100644 --- a/macosx/tkMacOSXMouseEvent.c +++ b/macosx/tkMacOSXMouseEvent.c @@ -267,21 +267,23 @@ enum { xEvent.xany.display = Tk_Display(tkwin); xEvent.xany.window = Tk_WindowId(tkwin); - delta = [theEvent deltaY] * 40; + delta = [theEvent deltaY] * 120; if (delta != 0.0) { - coarseDelta = (delta > -40.0 && delta < 40.0) ? - (signbit(delta) ? -40 : 40 : lround(delta); + coarseDelta = (delta > -120.0 && delta < 120.0) ? + (signbit(delta) ? -120 : 120 : lround(delta); xEvent.xbutton.state = state; xEvent.xkey.keycode = coarseDelta; + xEvent.xkey.nbytes = 0; xEvent.xany.serial = LastKnownRequestProcessed(Tk_Display(tkwin)); Tk_QueueWindowEvent(&xEvent, TCL_QUEUE_TAIL); } - delta = [theEvent deltaX] * 40; + delta = [theEvent deltaX] * 120; if (delta != 0.0) { - coarseDelta = (delta > -40.0 && delta < 40.0) ? - (signbit(delta) ? -40 : 40) : lround(delta); + coarseDelta = (delta > -120.0 && delta < 120.0) ? + (signbit(delta) ? -120 : 120) : lround(delta); xEvent.xbutton.state = state | ShiftMask; xEvent.xkey.keycode = coarseDelta; + xEvent.xkey.nbytes = 0; xEvent.xany.serial = LastKnownRequestProcessed(Tk_Display(tkwin)); Tk_QueueWindowEvent(&xEvent, TCL_QUEUE_TAIL); } diff --git a/tests/scrollbar.test b/tests/scrollbar.test index d235656..e6e6bdd 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -693,7 +693,7 @@ test scrollbar-10.1 { event on scrollbar} -setup { pack [scrollbar .s -command {.t yview}] -fill y -expand 1 -side left update focus -force .s - event generate .s -delta -150 + event generate .s -delta -120 after 200 {set eventprocessed 1} ; vwait eventprocessed .t index @0,0 } -cleanup { @@ -708,7 +708,7 @@ test scrollbar-10.2 { event on scrollbar} -setup { pack [scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top update focus -force .s - event generate .s -delta -150 + event generate .s -delta -120 after 200 {set eventprocessed 1} ; vwait eventprocessed .t index @0,0 } -cleanup { diff --git a/win/tkWinX.c b/win/tkWinX.c index 8127eef..9d474ac 100644 --- a/win/tkWinX.c +++ b/win/tkWinX.c @@ -1142,7 +1142,7 @@ GenerateXEvent( event.type = MouseWheelEvent; event.xany.send_event = -1; event.xkey.nbytes = 0; - event.xkey.keycode = tsdPtr->vWheelAcc / WHEEL_DELTA * WHEEL_DELTA / 3; + event.xkey.keycode = tsdPtr->vWheelAcc / WHEEL_DELTA * WHEEL_DELTA; tsdPtr->vWheelAcc = tsdPtr->vWheelAcc % WHEEL_DELTA; break; } @@ -1175,7 +1175,7 @@ GenerateXEvent( event.xany.send_event = -1; event.xkey.nbytes = 0; event.xkey.state |= ShiftMask; - event.xkey.keycode = tsdPtr->hWheelAcc / WHEEL_DELTA * WHEEL_DELTA / 3; + event.xkey.keycode = tsdPtr->hWheelAcc / WHEEL_DELTA * WHEEL_DELTA; tsdPtr->hWheelAcc = tsdPtr->hWheelAcc % WHEEL_DELTA; break; } -- cgit v0.12 From 6162cfbddcf8e3a169053a09e42e89f5d7b56b28 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Jul 2019 09:57:24 +0000 Subject: Fix MouseWheel bindings for listbox and scrollbar: This fixes test-failures on Win32. Still to be tested on MacOS and X11 --- generic/tkInt.h | 2 +- library/listbox.tcl | 8 ++++---- library/scrlbar.tcl | 8 ++++---- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tkInt.h b/generic/tkInt.h index a3aa36f..07591d1 100644 --- a/generic/tkInt.h +++ b/generic/tkInt.h @@ -981,7 +981,7 @@ typedef struct TkpClipMask { # define Button6Mask (1<<13) #endif #ifndef Button7Mask -# define Button7Mask (1<<13) +# define Button7Mask (1<<14) #endif #ifndef Button8Mask # define Button8Mask (AnyModifier<<4) diff --git a/library/listbox.tcl b/library/listbox.tcl index ffd7def..769fe25 100644 --- a/library/listbox.tcl +++ b/library/listbox.tcl @@ -177,16 +177,16 @@ bind Listbox { } bind Listbox { - %W yview scroll [expr {-((%D+60) / 120)}] units + %W yview scroll [expr {-((%D+15) / 30)}] units } bind Listbox { - %W yview scroll [expr {-((%D+6) / 12)}] units + %W yview scroll [expr {-((%D+1) / 3)}] units } bind Listbox { - %W xview scroll [expr {-((%D+60) / 120)}] units + %W xview scroll [expr {-((%D+15) / 30)}] units } bind Listbox { - %W xview scroll [expr {-((%D+6) / 12)}] units + %W xview scroll [expr {-((%D+1) / 3)}] units } diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl index dae11ae..a20f1a0 100644 --- a/library/scrlbar.tcl +++ b/library/scrlbar.tcl @@ -130,16 +130,16 @@ bind Scrollbar <> { } bind Scrollbar { - tk::ScrollByUnits %W v [expr {-((%D+60) / 120)}] + tk::ScrollByUnits %W v [expr {-((%D+15) / 30)}] } bind Scrollbar { - tk::ScrollByUnits %W v [expr {-((%D+6) / 12)}] + tk::ScrollByUnits %W v [expr {-((%D+1) / 3)}] } bind Scrollbar { - tk::ScrollByUnits %W h [expr {-((%D+60) / 120)}] + tk::ScrollByUnits %W h [expr {-((%D+15) / 30)}] } bind Scrollbar { - tk::ScrollByUnits %W h [expr {-((%D+6) / 12)}] + tk::ScrollByUnits %W h [expr {-((%D+1) / 3)}] } # tk::ScrollButtonDown -- -- cgit v0.12 From 9e83cbe850e17780f646217d932645e2105b605c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Jul 2019 12:48:00 +0000 Subject: Add support for "(x|y)view scroll number mouseunits" for text widget, and use it in mouse bindings. --- generic/tkTextDisp.c | 20 +++++++++++++++++--- generic/tkUtil.c | 8 ++++---- library/text.tcl | 8 ++++---- tests/entry.test | 4 ++-- tests/spinbox.test | 4 ++-- tests/textDisp.test | 16 ++++++++-------- tests/util.test | 6 +++--- 7 files changed, 40 insertions(+), 26 deletions(-) diff --git a/generic/tkTextDisp.c b/generic/tkTextDisp.c index d4f6b83..2aeec2e 100644 --- a/generic/tkTextDisp.c +++ b/generic/tkTextDisp.c @@ -631,6 +631,7 @@ static int IsStartOfNotMergedLine(TkText *textPtr, #define TKTEXT_SCROLL_UNITS 3 #define TKTEXT_SCROLL_ERROR 4 #define TKTEXT_SCROLL_PIXELS 5 +#define TKTEXT_SCROLL_MOUSE 6 /* *---------------------------------------------------------------------- @@ -5893,6 +5894,10 @@ TkTextXviewCmd( case TKTEXT_SCROLL_PIXELS: dInfoPtr->newXPixelOffset += count; break; + case TKTEXT_SCROLL_MOUSE: + if (count < 0) count -= 2; + dInfoPtr->newXPixelOffset += (-count)/3; + break; } dInfoPtr->flags |= DINFO_OUT_OF_DATE; @@ -6297,6 +6302,10 @@ TkTextYviewCmd( case TKTEXT_SCROLL_PIXELS: YScrollByPixels(textPtr, count); break; + case TKTEXT_SCROLL_MOUSE: + if (count < 0) count -= 2; + YScrollByPixels(textPtr, (-count)/3); + break; case TKTEXT_SCROLL_UNITS: YScrollByLines(textPtr, count); break; @@ -8770,10 +8779,10 @@ TextGetScrollInfoObj( VIEW_MOVETO, VIEW_SCROLL }; static const char *const units[] = { - "units", "pages", "pixels", NULL + "mouseunits", "pages", "pixels", "units", NULL }; enum viewUnits { - VIEW_SCROLL_UNITS, VIEW_SCROLL_PAGES, VIEW_SCROLL_PIXELS + VIEW_SCROLL_MOUSE, VIEW_SCROLL_PAGES, VIEW_SCROLL_PIXELS, VIEW_SCROLL_UNITS }; int index; @@ -8794,7 +8803,7 @@ TextGetScrollInfoObj( return TKTEXT_SCROLL_MOVETO; case VIEW_SCROLL: if (objc != 5) { - Tcl_WrongNumArgs(interp, 3, objv, "number units|pages|pixels"); + Tcl_WrongNumArgs(interp, 3, objv, "number mouseunits|pages|pixels|units"); return TKTEXT_SCROLL_ERROR; } if (Tcl_GetIndexFromObjStruct(interp, objv[4], units, @@ -8802,6 +8811,11 @@ TextGetScrollInfoObj( return TKTEXT_SCROLL_ERROR; } switch ((enum viewUnits) index) { + case VIEW_SCROLL_MOUSE: + if (Tcl_GetIntFromObj(interp, objv[3], intPtr) != TCL_OK) { + return TKTEXT_SCROLL_ERROR; + } + return TKTEXT_SCROLL_MOUSE; case VIEW_SCROLL_PAGES: if (Tcl_GetIntFromObj(interp, objv[3], intPtr) != TCL_OK) { return TKTEXT_SCROLL_ERROR; diff --git a/generic/tkUtil.c b/generic/tkUtil.c index 2950fe0..4844bc2 100644 --- a/generic/tkUtil.c +++ b/generic/tkUtil.c @@ -668,7 +668,7 @@ Tk_GetScrollInfo( if (argc != 5) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "wrong # args: should be \"%s %s %s\"", - argv[0], argv[1], "scroll number units|pages")); + argv[0], argv[1], "scroll number pages|units")); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TK_SCROLL_ERROR; } @@ -684,7 +684,7 @@ Tk_GetScrollInfo( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad argument \"%s\": must be units or pages", argv[4])); + "bad argument \"%s\": must be pages or units", argv[4])); Tcl_SetErrorCode(interp, "TK", "VALUE", "SCROLL_UNITS", NULL); return TK_SCROLL_ERROR; } @@ -746,7 +746,7 @@ Tk_GetScrollInfoObj( return TK_SCROLL_MOVETO; } else if (ArgPfxEq("scroll")) { if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "scroll number units|pages"); + Tcl_WrongNumArgs(interp, 2, objv, "scroll number pages|units"); return TK_SCROLL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[3], intPtr) != TCL_OK) { @@ -761,7 +761,7 @@ Tk_GetScrollInfoObj( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad argument \"%s\": must be units or pages", arg)); + "bad argument \"%s\": must be pages or units", arg)); Tcl_SetErrorCode(interp, "TK", "VALUE", "SCROLL_UNITS", NULL); return TK_SCROLL_ERROR; } diff --git a/library/text.tcl b/library/text.tcl index 72da6ff..98255e4 100644 --- a/library/text.tcl +++ b/library/text.tcl @@ -428,16 +428,16 @@ bind Text { set ::tk::Priv(prevPos) {} bind Text { - %W yview scroll [expr {-((%D+1)/3)}] pixels + %W yview scroll %D mouseunits } bind Text { - %W yview scroll [expr {-4 * (%D)}] pixels + %W yview scroll [expr {10 * (%D)}] mouseunits } bind Text { - %W xview scroll [expr {-((%D+1)/3)}] pixels + %W xview scroll %D mouseunits } bind Text { - %W xview scroll [expr {-4 * (%D)}] pixels + %W xview scroll [expr {10 * (%D)}] mouseunits } # ::tk::TextClosestGap -- diff --git a/tests/entry.test b/tests/entry.test index 75a5da8..6207c69 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -1435,7 +1435,7 @@ test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll 24 } -cleanup { destroy .e -} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"} +} -returnCodes error -result {wrong # args: should be ".e xview scroll number pages|units"} test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} -setup { entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e @@ -1512,7 +1512,7 @@ test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll 23 foobars } -cleanup { destroy .e -} -returnCodes error -result {bad argument "foobars": must be units or pages} +} -returnCodes error -result {bad argument "foobars": must be pages or units} test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} -setup { entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e diff --git a/tests/spinbox.test b/tests/spinbox.test index 28ebe68..efd5b63 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -1773,7 +1773,7 @@ test spinbox-3.71 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll 24 } -cleanup { destroy .e -} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"} +} -returnCodes error -result {wrong # args: should be ".e xview scroll number pages|units"} test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e @@ -1850,7 +1850,7 @@ test spinbox-3.77 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll 23 foobars } -cleanup { destroy .e -} -returnCodes error -result {bad argument "foobars": must be units or pages} +} -returnCodes error -result {bad argument "foobars": must be pages or units} test spinbox-3.78 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e diff --git a/tests/textDisp.test b/tests/textDisp.test index 5df5467..698f8a7 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -1867,10 +1867,10 @@ test textDisp-14.9 {TkTextXviewCmd procedure} { } [list [expr {9.0/14}] 1.0] test textDisp-14.10 {TkTextXviewCmd procedure} { list [catch {.t xview scroll a} msg] $msg -} {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}} +} {1 {wrong # args: should be ".t xview scroll number mouseunits|pages|pixels|units"}} test textDisp-14.11 {TkTextXviewCmd procedure} { list [catch {.t xview scroll a b c} msg] $msg -} {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}} +} {1 {wrong # args: should be ".t xview scroll number mouseunits|pages|pixels|units"}} test textDisp-14.12 {TkTextXviewCmd procedure} { list [catch {.t xview scroll gorp units} msg] $msg } {1 {expected integer but got "gorp"}} @@ -1904,7 +1904,7 @@ test textDisp-14.14 {TkTextXviewCmd procedure} { } {2.21 2.20 2.99 2.84} test textDisp-14.15 {TkTextXviewCmd procedure} { list [catch {.t xview scroll 14 globs} msg] $msg -} {1 {bad argument "globs": must be units, pages, or pixels}} +} {1 {bad argument "globs": must be mouseunits, pages, pixels, or units}} test textDisp-14.16 {TkTextXviewCmd procedure} { list [catch {.t xview flounder} msg] $msg } {1 {bad option "flounder": must be moveto or scroll}} @@ -2086,13 +2086,13 @@ test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {textfonts} { } [list [expr {1.0/3}] [expr {5.0/6}]] test textDisp-16.19 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a} msg] $msg -} {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}} +} {1 {wrong # args: should be ".t yview scroll number mouseunits|pages|pixels|units"}} test textDisp-16.20 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a b c} msg] $msg -} {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}} +} {1 {wrong # args: should be ".t yview scroll number mouseunits|pages|pixels|units"}} test textDisp-16.21 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll badInt bogus} msg] $msg -} {1 {bad argument "bogus": must be units, pages, or pixels}} +} {1 {bad argument "bogus": must be mouseunits, pages, pixels, or units}} test textDisp-16.21.2 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll badInt units} msg] $msg } {1 {expected integer but got "badInt"}} @@ -2104,7 +2104,7 @@ test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { } {42.0} test textDisp-16.22.1 {TkTextYviewCmd procedure, "scroll" option, back pages} { list [catch {.t yview scroll -3 p} res] $res -} {1 {ambiguous argument "p": must be units, pages, or pixels}} +} {1 {ambiguous argument "p": must be mouseunits, pages, pixels, or units}} test textDisp-16.23 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 update @@ -2175,7 +2175,7 @@ test textDisp-16.31 {TkTextYviewCmd procedure, "scroll units" option} { } {151.40} test textDisp-16.32 {TkTextYviewCmd procedure} { list [catch {.t yview scroll 12 bogoids} msg] $msg -} {1 {bad argument "bogoids": must be units, pages, or pixels}} +} {1 {bad argument "bogoids": must be mouseunits, pages, pixels, or units}} test textDisp-16.33 {TkTextYviewCmd procedure} { list [catch {.t yview bad_arg 1 2} msg] $msg } {1 {bad option "bad_arg": must be moveto or scroll}} diff --git a/tests/util.test b/tests/util.test index c1ec6a5..d457b50 100644 --- a/tests/util.test +++ b/tests/util.test @@ -28,10 +28,10 @@ test util-1.3 {Tk_GetScrollInfo procedure} -body { } -result {0.5 0.75} test util-1.4 {Tk_GetScrollInfo procedure} -body { .l yview scroll a -} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"} +} -returnCodes error -result {wrong # args: should be ".l yview scroll number pages|units"} test util-1.5 {Tk_GetScrollInfo procedure} -body { .l yview scroll a b c -} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"} +} -returnCodes error -result {wrong # args: should be ".l yview scroll number pages|units"} test util-1.6 {Tk_GetScrollInfo procedure} -body { .l yview scroll xyz units } -returnCodes error -result {expected integer but got "xyz"} @@ -57,7 +57,7 @@ test util-1.10 {Tk_GetScrollInfo procedure} -body { } -result {13} test util-1.11 {Tk_GetScrollInfo procedure} -body { .l yview scroll 3 zips -} -returnCodes error -result {bad argument "zips": must be units or pages} +} -returnCodes error -result {bad argument "zips": must be pages or units} test util-1.12 {Tk_GetScrollInfo procedure} -body { .l yview dropdead 3 times } -returnCodes error -result {unknown option "dropdead": must be moveto or scroll} -- cgit v0.12 From 099f9695819a7024079f79db648c326601bac8b4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Jul 2019 07:27:43 +0000 Subject: Put (x|y)view scroll options in alphabetical order --- doc/GetScroll.3 | 8 ++++---- doc/canvas.n | 16 ++++++++-------- doc/entry.n | 12 ++++++------ doc/listbox.n | 16 +++++++++------- doc/scrollbar.n | 18 +++++++++--------- doc/spinbox.n | 10 +++++----- doc/text.n | 32 ++++++++++++++++++-------------- doc/ttk_scrollbar.n | 16 ++++++++-------- doc/ttk_widget.n | 14 ++++++++------ 9 files changed, 75 insertions(+), 67 deletions(-) diff --git a/doc/GetScroll.3 b/doc/GetScroll.3 index c0b302d..dd12cca 100644 --- a/doc/GetScroll.3 +++ b/doc/GetScroll.3 @@ -50,18 +50,18 @@ and parses the words starting with \fIobjv\fR[2]. The words starting with \fIobjv\fR[2] must have one of the following forms: .CS \fBmoveto \fIfraction\fR -\fBscroll \fInumber\fB units\fR \fBscroll \fInumber\fB pages\fR +\fBscroll \fInumber\fB units\fR .CE .LP -Any of the \fBmoveto\fR, \fBscroll\fR, \fBunits\fR, and \fBpages\fR +Any of the \fBmoveto\fR, \fBscroll\fR, \fBpages\fR, and \fBunits\fR keywords may be abbreviated. If \fIobjv\fR has the \fBmoveto\fR form, \fBTK_SCROLL_MOVETO\fR is returned as result and \fI*fractionPtr\fR is filled in with the \fIfraction\fR argument to the command, which must be a proper real value. -If \fIobjv\fR has the \fBscroll\fR form, \fBTK_SCROLL_UNITS\fR -or \fBTK_SCROLL_PAGES\fR is returned and \fI*stepsPtr\fR is filled +If \fIobjv\fR has the \fBscroll\fR form, \fBTK_SCROLL_PAGES\fR +or \fBTK_SCROLL_UNITS\fR is returned and \fI*stepsPtr\fR is filled in with the \fInumber\fR value, which must be a proper integer. If an error occurs in parsing the arguments, \fBTK_SCROLL_ERROR\fR is returned and an error message is left in interpreter diff --git a/doc/canvas.n b/doc/canvas.n index bad9113..ddaebcf 100644 --- a/doc/canvas.n +++ b/doc/canvas.n @@ -1147,16 +1147,16 @@ total width of the canvas is off-screen to the left. This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. \fINumber\fR must be an integer. -\fIWhat\fR must be either \fBunits\fR or \fBpages\fR or an abbreviation +\fIWhat\fR must be either \fBpages\fR or \fBunits\fR or an abbreviation of one of these. -If \fIwhat\fR is \fBunits\fR, the view adjusts left or right in units -of the \fBxScrollIncrement\fR option, if it is greater than zero, -or in units of one-tenth the window's width otherwise. If \fIwhat is \fBpages\fR then the view adjusts in units of nine-tenths the window's width. If \fInumber\fR is negative then information farther to the left becomes visible; if it is positive then information farther to the right becomes visible. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right in units +of the \fBxScrollIncrement\fR option, if it is greater than zero, +or in units of one-tenth the window's width otherwise. .RE .TP \fIpathName \fByview \fI?args\fR? @@ -1188,15 +1188,15 @@ area is off-screen to the top. This command adjusts the view in the window up or down according to \fInumber\fR and \fIwhat\fR. \fINumber\fR must be an integer. -\fIWhat\fR must be either \fBunits\fR or \fBpages\fR. -If \fIwhat\fR is \fBunits\fR, the view adjusts up or down in units -of the \fByScrollIncrement\fR option, if it is greater than zero, -or in units of one-tenth the window's height otherwise. +\fIWhat\fR must be either \fBpages\fR or \fBunits\fR. If \fIwhat\fR is \fBpages\fR then the view adjusts in units of nine-tenths the window's height. If \fInumber\fR is negative then higher information becomes visible; if it is positive then lower information becomes visible. +If \fIwhat\fR is \fBunits\fR, the view adjusts up or down in units +of the \fByScrollIncrement\fR option, if it is greater than zero, +or in units of one-tenth the window's height otherwise. .RE .SH "OVERVIEW OF ITEM TYPES" .PP diff --git a/doc/entry.n b/doc/entry.n index abbf53d..4589af0 100644 --- a/doc/entry.n +++ b/doc/entry.n @@ -404,14 +404,14 @@ way through the text appears at the left edge of the window. This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. \fINumber\fR must be an integer. -\fIWhat\fR must be either \fBunits\fR or \fBpages\fR or an abbreviation +\fIWhat\fR must be either \fBpages\fR or \fBunits\fR or an abbreviation of one of these. -If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by -\fInumber\fR average-width characters on the display; if it is -\fBpages\fR then the view adjusts by \fInumber\fR screenfuls. -If \fInumber\fR is negative then characters farther to the left -become visible; if it is positive then characters farther to the right +If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR screenfuls. +If \fInumber\fR is negative then characters farther to the left become +visible; if it is positive then characters farther to the right become visible. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by +\fInumber\fR average-width characters on the display. .RE .SH "DEFAULT BINDINGS" .PP diff --git a/doc/listbox.n b/doc/listbox.n index 66b75b9..ef3ae1c 100644 --- a/doc/listbox.n +++ b/doc/listbox.n @@ -384,15 +384,16 @@ total width of the listbox text is off-screen to the left. This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. \fINumber\fR must be an integer. -\fIWhat\fR must be either \fBunits\fR or \fBpages\fR or an abbreviation +\fIWhat\fR must be either \fBpages\fR or \fBunits\fR or an abbreviation of one of these. -If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by -\fInumber\fR character units (the width of the \fB0\fR character) -on the display; if it is \fBpages\fR then the view adjusts by +If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR screenfuls. If \fInumber\fR is negative then characters farther to the left become visible; if it is positive then characters farther to the right become visible. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by +\fInumber\fR character units (the width of the \fB0\fR character) +on the display. .RE .TP \fIpathName \fByview \fR?\fIargs\fR? @@ -431,13 +432,14 @@ way through the listbox, and so on. This command adjusts the view in the window up or down according to \fInumber\fR and \fIwhat\fR. \fINumber\fR must be an integer. -\fIWhat\fR must be either \fBunits\fR or \fBpages\fR. -If \fIwhat\fR is \fBunits\fR, the view adjusts up or down by -\fInumber\fR lines; if it is \fBpages\fR then +\fIWhat\fR must be either \fBpages\fR or \fBunits\fR. +If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR screenfuls. If \fInumber\fR is negative then earlier elements become visible; if it is positive then later elements become visible. +If \fIwhat\fR is \fBunits\fR, the view adjusts up or down by +\fInumber\fR lines. .RE .SH "DEFAULT BINDINGS" .PP diff --git a/doc/scrollbar.n b/doc/scrollbar.n index 4b1d4ba..5a062ce 100644 --- a/doc/scrollbar.n +++ b/doc/scrollbar.n @@ -215,15 +215,6 @@ document. 1.0 refers to the end of the document, 0.333 refers to a point one-third of the way through the document, and so on. .TP -\fIprefix \fBscroll \fInumber \fBunits\fR -. -The widget should adjust its view by \fInumber\fR units. -The units are defined in whatever way makes sense for the widget, -such as characters or lines in a text widget. -\fINumber\fR is either 1, which means one unit should scroll off -the top or left of the window, or \-1, which means that one unit -should scroll off the bottom or right of the window. -.TP \fIprefix \fBscroll \fInumber \fBpages\fR . The widget should adjust its view by \fInumber\fR pages. @@ -233,6 +224,15 @@ is a slight overlap between the old and new views. \fINumber\fR is either 1, which means the next page should become visible, or \-1, which means that the previous page should become visible. +.TP +\fIprefix \fBscroll \fInumber \fBunits\fR +. +The widget should adjust its view by \fInumber\fR units. +The units are defined in whatever way makes sense for the widget, +such as characters or lines in a text widget. +\fINumber\fR is either 1, which means one unit should scroll off +the top or left of the window, or \-1, which means that one unit +should scroll off the bottom or right of the window. .SH "OLD COMMAND SYNTAX" .PP In versions of Tk before 4.0, the \fBset\fR and \fBget\fR widget diff --git a/doc/spinbox.n b/doc/spinbox.n index f2b1ff2..6719ca3 100644 --- a/doc/spinbox.n +++ b/doc/spinbox.n @@ -471,14 +471,14 @@ way through the text appears at the left edge of the window. This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. \fINumber\fR must be an integer. -\fIWhat\fR must be either \fBunits\fR or \fBpages\fR or an abbreviation +\fIWhat\fR must be either \fBpages\fR or \fBunits\fR or an abbreviation of one of these. -If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by -\fInumber\fR average-width characters on the display; if it is -\fBpages\fR then the view adjusts by \fInumber\fR screenfuls. -If \fInumber\fR is negative then characters farther to the left +If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR +screenfuls. If \fInumber\fR is negative then characters farther to the left become visible; if it is positive then characters farther to the right become visible. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by +\fInumber\fR average-width characters on the display. .RE .SH "DEFAULT BINDINGS" .PP diff --git a/doc/text.n b/doc/text.n index 250dff7..95a4272 100644 --- a/doc/text.n +++ b/doc/text.n @@ -1930,20 +1930,22 @@ and 1. \fIpathName \fBxview scroll \fInumber what\fR . This command shifts the view in the window left or right according to -\fInumber\fR and \fIwhat\fR. \fIWhat\fR must be \fBunits\fR, \fBpages\fR or -\fBpixels\fR. If \fIwhat\fR is \fBunits\fR or \fBpages\fR then \fInumber\fR -must be an integer, otherwise number may be specified in any of the forms -acceptable to \fBTk_GetPixels\fR, such as +\fInumber\fR and \fIwhat\fR. \fIWhat\fR must be \fBmouseunits\fR, \fBpages\fR, +\fBpixels\fR, or \fBunits\fR. If \fIwhat\fR is \fBmouseunits\fR, \fBpages\fR or +\fBunits\fR then \fInumber\fR must be an integer, otherwise number may be +specified in any of the forms acceptable to \fBTk_GetPixels\fR, such as .QW 2.0c or .QW 1i (the result is rounded to the nearest integer value. If no units are given, -pixels are assumed). If \fIwhat\fR is \fBunits\fR, the view adjusts left or -right by \fInumber\fR average-width characters on the display; if it is -\fBpages\fR then the view adjusts by \fInumber\fR screenfuls; if it is -\fBpixels\fR then the view adjusts by \fInumber\fR pixels. If \fInumber\fR is +pixels are assumed). If \fIwhat\fR is \fBpages\fR then the view adjusts by +\fInumber\fR screenfuls; if it is \fBpixels\fR then the view adjusts by +\fInumber\fR pixels; if it is \fBunits\fR, the view adjusts left or +right by \fInumber\fR average-width characters on the display. If \fInumber\fR is negative then characters farther to the left become visible; if it is positive -then characters farther to the right become visible. +then characters farther to the right become visible. If \fIwhat\fR is +\fBmouseunits\fR then the view adjusts about -\fInumber\fR/3 pixels, since +mouse units work in the other direction than pixels. .RE .TP \fIpathName \fByview \fR?\fIargs\fR? @@ -1978,10 +1980,10 @@ the bottom of the window, and some other pixel is at the top. \fIpathName \fByview scroll \fInumber what\fR . This command adjust the view in the window up or down according to -\fInumber\fR and \fIwhat\fR. \fIWhat\fR must be \fBunits\fR, \fBpages\fR or -\fBpixels\fR. If \fIwhat\fR is \fBunits\fR or \fBpages\fR then \fInumber\fR -must be an integer, otherwise number may be specified in any of the forms -acceptable to \fBTk_GetPixels\fR, such as +\fInumber\fR and \fIwhat\fR. \fIWhat\fR must be \fBmouseunits\fR, \fBpages\fR, +\fBpixels\fR, or \fBunits\fR. If \fIwhat\fR is \fBunits\fR or \fBpages\fR then +\fInumber\fR must be an integer, otherwise number may be specified in any of +the forms acceptable to \fBTk_GetPixels\fR, such as .QW 2.0c or .QW 1i @@ -1991,7 +1993,9 @@ by \fInumber\fR lines on the display; if it is \fBpages\fR then the view adjusts by \fInumber\fR screenfuls; if it is \fBpixels\fR then the view adjusts by \fInumber\fR pixels. If \fInumber\fR is negative then earlier positions in the text become visible; if it is positive then later positions -in the text become visible. +in the text become visible. If \fIwhat\fR is \fBmouseunits\fR then the view +adjusts about -\fInumber\fR/3 pixels, since mouse units work in the other +direction than pixels. .TP \fIpathName \fByview \fR?\fB\-pickplace\fR? \fIindex\fR . diff --git a/doc/ttk_scrollbar.n b/doc/ttk_scrollbar.n index bd80760..08c7f52 100644 --- a/doc/ttk_scrollbar.n +++ b/doc/ttk_scrollbar.n @@ -118,14 +118,6 @@ document. 1.0 refers to the end of the document, 0.333 refers to a point one-third of the way through the document, and so on. .TP -\fIprefix \fBscroll \fInumber \fBunits\fR -The widget should adjust its view by \fInumber\fR units. -The units are defined in whatever way makes sense for the widget, -such as characters or lines in a text widget. -\fINumber\fR is either 1, which means one unit should scroll off -the top or left of the window, or \-1, which means that one unit -should scroll off the bottom or right of the window. -.TP \fIprefix \fBscroll \fInumber \fBpages\fR The widget should adjust its view by \fInumber\fR pages. It is up to the widget to define the meaning of a page; typically @@ -134,6 +126,14 @@ is a slight overlap between the old and new views. \fINumber\fR is either 1, which means the next page should become visible, or \-1, which means that the previous page should become visible. +.TP +\fIprefix \fBscroll \fInumber \fBunits\fR +The widget should adjust its view by \fInumber\fR units. +The units are defined in whatever way makes sense for the widget, +such as characters or lines in a text widget. +\fINumber\fR is either 1, which means one unit should scroll off +the top or left of the window, or \-1, which means that one unit +should scroll off the bottom or right of the window. .SH "WIDGET STATES" .PP The scrollbar automatically sets the \fBdisabled\fR state bit. diff --git a/doc/ttk_widget.n b/doc/ttk_widget.n index b1c280d..2dca269 100644 --- a/doc/ttk_widget.n +++ b/doc/ttk_widget.n @@ -254,14 +254,15 @@ way through the content appears at the left edge of the window. This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. \fINumber\fR must be an integer. -\fIWhat\fR must be either \fBunits\fR or \fBpages\fR. +\fIWhat\fR must be either \fBpages\fR or \fBunits\fR. '\" or an abbreviation of one of these, but we don't document that. -If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by -\fInumber\fR average-width characters on the display; if it is +If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR screenfuls. If \fInumber\fR is negative then characters farther to the left become visible; if it is positive then characters farther to the right become visible. +If \fIwhat\fR is \fBunits\fR, the view adjusts left or right by +\fInumber\fR average-width characters on the display. .RE .TP \fIpathName \fByview \fIargs\fR @@ -293,14 +294,15 @@ way through the content appears at the top edge of the window. This command shifts the view in the window up or down according to \fInumber\fR and \fIwhat\fR. \fINumber\fR must be an integer. -\fIWhat\fR must be either \fBunits\fR or \fBpages\fR. +\fIWhat\fR must be either \fBpages\fR or \fBunits\fR. '\" or an abbreviation of one of these, but we don't document that. -If \fIwhat\fR is \fBunits\fR, the view adjusts up or down by -\fInumber\fR average-width characters on the display; if it is +If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR screenfuls. If \fInumber\fR is negative then items farther to the top become visible; if it is positive then items farther to the bottom become visible. +If \fIwhat\fR is \fBunits\fR, the view adjusts up or down by +\fInumber\fR average-width characters on the display. .RE .SH "WIDGET STATES" The widget state is a bitmap of independent state flags. -- cgit v0.12 From 127c180c66bf291cae359b4c83fcfce3961af8be Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Aug 2019 15:02:23 +0000 Subject: Allow using floating-point number in "scroll (x|y)view (units|pages)". They are rounded away from zero towards an integer. --- doc/GetScroll.3 | 3 ++- doc/canvas.n | 3 ++- doc/entry.n | 3 ++- doc/listbox.n | 3 ++- doc/spinbox.n | 3 ++- doc/text.n | 14 +++++--------- doc/ttk_widget.n | 3 ++- generic/tkTextDisp.c | 11 ++++++++++- library/listbox.tcl | 8 ++++---- library/scrlbar.tcl | 8 ++++---- library/ttk/utils.tcl | 12 ++++++------ tests/entry.test | 2 +- tests/spinbox.test | 2 +- tests/textDisp.test | 8 ++++---- tests/util.test | 2 +- 15 files changed, 48 insertions(+), 37 deletions(-) diff --git a/doc/GetScroll.3 b/doc/GetScroll.3 index dd12cca..d61e744 100644 --- a/doc/GetScroll.3 +++ b/doc/GetScroll.3 @@ -62,7 +62,8 @@ is returned as result and \fI*fractionPtr\fR is filled in with the value. If \fIobjv\fR has the \fBscroll\fR form, \fBTK_SCROLL_PAGES\fR or \fBTK_SCROLL_UNITS\fR is returned and \fI*stepsPtr\fR is filled -in with the \fInumber\fR value, which must be a proper integer. +in with the \fInumber\fR value, which must be a integer or a float, +but if it is a float then it is converted to an integer, rounded away from 0. If an error occurs in parsing the arguments, \fBTK_SCROLL_ERROR\fR is returned and an error message is left in interpreter \fIinterp\fR's result. diff --git a/doc/canvas.n b/doc/canvas.n index ddaebcf..95c732e 100644 --- a/doc/canvas.n +++ b/doc/canvas.n @@ -1146,7 +1146,8 @@ total width of the canvas is off-screen to the left. . This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. -\fINumber\fR must be an integer. +\fINumber\fR must be an integer or a float, but if it is a float then +it is converted to an integer, rounded away from 0. \fIWhat\fR must be either \fBpages\fR or \fBunits\fR or an abbreviation of one of these. If \fIwhat is \fBpages\fR then the view diff --git a/doc/entry.n b/doc/entry.n index 4589af0..dd198a7 100644 --- a/doc/entry.n +++ b/doc/entry.n @@ -403,7 +403,8 @@ way through the text appears at the left edge of the window. \fIpathName \fBxview scroll \fInumber what\fR This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. -\fINumber\fR must be an integer. +\fINumber\fR must be an integer or a float, but if it is a float then +it is converted to an integer, rounded away from 0. \fIWhat\fR must be either \fBpages\fR or \fBunits\fR or an abbreviation of one of these. If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR screenfuls. diff --git a/doc/listbox.n b/doc/listbox.n index ef3ae1c..c2ff09e 100644 --- a/doc/listbox.n +++ b/doc/listbox.n @@ -383,7 +383,8 @@ total width of the listbox text is off-screen to the left. . This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. -\fINumber\fR must be an integer. +\fINumber\fR must be an integer or a float, but if it is a float then +it is converted to an integer, rounded away from 0. \fIWhat\fR must be either \fBpages\fR or \fBunits\fR or an abbreviation of one of these. If \fIwhat\fR is \fBpages\fR then the view adjusts by diff --git a/doc/spinbox.n b/doc/spinbox.n index 6719ca3..6d0646b 100644 --- a/doc/spinbox.n +++ b/doc/spinbox.n @@ -470,7 +470,8 @@ way through the text appears at the left edge of the window. \fIpathName \fBxview scroll \fInumber what\fR This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. -\fINumber\fR must be an integer. +\fINumber\fR must be an integer or a float, but if it is a float then +it is converted to an integer, rounded away from 0. \fIWhat\fR must be either \fBpages\fR or \fBunits\fR or an abbreviation of one of these. If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR diff --git a/doc/text.n b/doc/text.n index 95a4272..c4128a1 100644 --- a/doc/text.n +++ b/doc/text.n @@ -1930,8 +1930,8 @@ and 1. \fIpathName \fBxview scroll \fInumber what\fR . This command shifts the view in the window left or right according to -\fInumber\fR and \fIwhat\fR. \fIWhat\fR must be \fBmouseunits\fR, \fBpages\fR, -\fBpixels\fR, or \fBunits\fR. If \fIwhat\fR is \fBmouseunits\fR, \fBpages\fR or +\fInumber\fR and \fIwhat\fR. \fIWhat\fR must be \fBpages\fR, +\fBpixels\fR, or \fBunits\fR. If \fIwhat\fR is \fBpages\fR or \fBunits\fR then \fInumber\fR must be an integer, otherwise number may be specified in any of the forms acceptable to \fBTk_GetPixels\fR, such as .QW 2.0c @@ -1943,9 +1943,7 @@ pixels are assumed). If \fIwhat\fR is \fBpages\fR then the view adjusts by \fInumber\fR pixels; if it is \fBunits\fR, the view adjusts left or right by \fInumber\fR average-width characters on the display. If \fInumber\fR is negative then characters farther to the left become visible; if it is positive -then characters farther to the right become visible. If \fIwhat\fR is -\fBmouseunits\fR then the view adjusts about -\fInumber\fR/3 pixels, since -mouse units work in the other direction than pixels. +then characters farther to the right become visible. .RE .TP \fIpathName \fByview \fR?\fIargs\fR? @@ -1980,7 +1978,7 @@ the bottom of the window, and some other pixel is at the top. \fIpathName \fByview scroll \fInumber what\fR . This command adjust the view in the window up or down according to -\fInumber\fR and \fIwhat\fR. \fIWhat\fR must be \fBmouseunits\fR, \fBpages\fR, +\fInumber\fR and \fIwhat\fR. \fIWhat\fR must be \fBpages\fR, \fBpixels\fR, or \fBunits\fR. If \fIwhat\fR is \fBunits\fR or \fBpages\fR then \fInumber\fR must be an integer, otherwise number may be specified in any of the forms acceptable to \fBTk_GetPixels\fR, such as @@ -1993,9 +1991,7 @@ by \fInumber\fR lines on the display; if it is \fBpages\fR then the view adjusts by \fInumber\fR screenfuls; if it is \fBpixels\fR then the view adjusts by \fInumber\fR pixels. If \fInumber\fR is negative then earlier positions in the text become visible; if it is positive then later positions -in the text become visible. If \fIwhat\fR is \fBmouseunits\fR then the view -adjusts about -\fInumber\fR/3 pixels, since mouse units work in the other -direction than pixels. +in the text become visible. .TP \fIpathName \fByview \fR?\fB\-pickplace\fR? \fIindex\fR . diff --git a/doc/ttk_widget.n b/doc/ttk_widget.n index 2dca269..fdacfd0 100644 --- a/doc/ttk_widget.n +++ b/doc/ttk_widget.n @@ -253,7 +253,8 @@ way through the content appears at the left edge of the window. \fIpathName \fBxview scroll \fInumber what\fR This command shifts the view in the window left or right according to \fInumber\fR and \fIwhat\fR. -\fINumber\fR must be an integer. +\fINumber\fR must be an integer or a float, but if it is a float then +it is converted to an integer, rounded away from 0. \fIWhat\fR must be either \fBpages\fR or \fBunits\fR. '\" or an abbreviation of one of these, but we don't document that. If \fIwhat\fR is diff --git a/generic/tkTextDisp.c b/generic/tkTextDisp.c index 33b9720..e6dc988 100644 --- a/generic/tkTextDisp.c +++ b/generic/tkTextDisp.c @@ -8776,6 +8776,7 @@ TextGetScrollInfoObj( VIEW_SCROLL_PAGES, VIEW_SCROLL_PIXELS, VIEW_SCROLL_UNITS }; int index; + double d; if (Tcl_GetIndexFromObjStruct(interp, objv[2], subcommands, sizeof(char *), "option", 0, &index) != TCL_OK) { @@ -8814,9 +8815,17 @@ TextGetScrollInfoObj( } return TKTEXT_SCROLL_PIXELS; case VIEW_SCROLL_UNITS: - if (Tcl_GetIntFromObj(interp, objv[3], intPtr) != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, objv[3], &d) != TCL_OK) { return TKTEXT_SCROLL_ERROR; } + if (d > 0) { + *intPtr = ceil(d); + } else { + *intPtr = floor(d); + } + if (dblPtr) { + *dblPtr = d; + } return TKTEXT_SCROLL_UNITS; } } diff --git a/library/listbox.tcl b/library/listbox.tcl index 4a76a18..7400494 100644 --- a/library/listbox.tcl +++ b/library/listbox.tcl @@ -177,16 +177,16 @@ bind Listbox { } bind Listbox { - %W yview scroll [expr {-(%D/30)}] units + %W yview scroll [expr {%D/-30}] units } bind Listbox { - %W yview scroll [expr {-(%D/3)}] units + %W yview scroll [expr {%D/-3}] units } bind Listbox { - %W xview scroll [expr {-(%D/30)}] units + %W xview scroll [expr {%D/-30}] units } bind Listbox { - %W xview scroll [expr {-(%D/3)}] units + %W xview scroll [expr {%D/-3}] units } # ::tk::ListboxBeginSelect -- diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl index d797b24..2b3503a 100644 --- a/library/scrlbar.tcl +++ b/library/scrlbar.tcl @@ -130,16 +130,16 @@ bind Scrollbar <> { } bind Scrollbar { - tk::ScrollByUnits %W v [expr {-(%D / 30)}] + tk::ScrollByUnits %W v [expr {%D/-30.0}] } bind Scrollbar { - tk::ScrollByUnits %W v [expr {-(%D / 3)}] + tk::ScrollByUnits %W v [expr {%D/-3.0}] } bind Scrollbar { - tk::ScrollByUnits %W h [expr {-(%D / 30)}] + tk::ScrollByUnits %W h [expr {%D/-30.0}] } bind Scrollbar { - tk::ScrollByUnits %W h [expr {-(%D / 3)}] + tk::ScrollByUnits %W h [expr {%D/-3.0}] } # tk::ScrollButtonDown -- diff --git a/library/ttk/utils.tcl b/library/ttk/utils.tcl index fc8b4e0..4827aa3 100644 --- a/library/ttk/utils.tcl +++ b/library/ttk/utils.tcl @@ -285,8 +285,8 @@ proc ttk::copyBindings {from to} { # proc ttk::bindMouseWheel {bindtag callback} { - bind $bindtag [append callback { [expr {-(%D / 120)}]}] - bind $bindtag [append callback { [expr {-(%D / 12)}]}] + bind $bindtag [append callback { [expr {%D/-120.0}]}] + bind $bindtag [append callback { [expr {%D/-12.0}]}] } ## Mousewheel bindings for standard scrollable widgets. @@ -298,12 +298,12 @@ proc ttk::bindMouseWheel {bindtag callback} { # bind TtkScrollable \ - { %W yview scroll [expr {-(%D / 120)}] units } + { %W yview scroll [expr {%D/-120}] units } bind TtkScrollable \ - { %W yview scroll [expr {-(%D / 12)}] units } + { %W yview scroll [expr {%D/-12}] units } bind TtkScrollable \ - { %W xview scroll [expr {-(%D / 120)}] units } + { %W xview scroll [expr {%D/-120}] units } bind TtkScrollable \ - { %W xview scroll [expr {-(%D / 12)}] units } + { %W xview scroll [expr {%D/-12}] units } #*EOF* diff --git a/tests/entry.test b/tests/entry.test index 6207c69..47b459d 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -1446,7 +1446,7 @@ test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll gorp units } -cleanup { destroy .e -} -returnCodes error -result {expected integer but got "gorp"} +} -returnCodes error -result {expected floating-point number but got "gorp"} test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} -setup { entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e diff --git a/tests/spinbox.test b/tests/spinbox.test index efd5b63..65c5bd9 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -1784,7 +1784,7 @@ test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { .e xview scroll gorp units } -cleanup { destroy .e -} -returnCodes error -result {expected integer but got "gorp"} +} -returnCodes error -result {expected floating-point number but got "gorp"} test spinbox-3.73 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 pack .e diff --git a/tests/textDisp.test b/tests/textDisp.test index 1b6f4c5..c029a69 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -1873,7 +1873,7 @@ test textDisp-14.11 {TkTextXviewCmd procedure} { } {1 {wrong # args: should be ".t xview scroll number pages|pixels|units"}} test textDisp-14.12 {TkTextXviewCmd procedure} { list [catch {.t xview scroll gorp units} msg] $msg -} {1 {expected integer but got "gorp"}} +} {1 {expected floating-point number but got "gorp"}} test textDisp-14.13 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n @@ -2091,11 +2091,11 @@ test textDisp-16.20 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a b c} msg] $msg } {1 {wrong # args: should be ".t yview scroll number pages|pixels|units"}} test textDisp-16.21 {TkTextYviewCmd procedure, "scroll" option} { - list [catch {.t yview scroll badInt bogus} msg] $msg + list [catch {.t yview scroll bogus bogus} msg] $msg } {1 {bad argument "bogus": must be pages, pixels, or units}} test textDisp-16.21.2 {TkTextYviewCmd procedure, "scroll" option} { - list [catch {.t yview scroll badInt units} msg] $msg -} {1 {expected integer but got "badInt"}} + list [catch {.t yview scroll bogus units} msg] $msg +} {1 {expected floating-point number but got "bogus"}} test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 update diff --git a/tests/util.test b/tests/util.test index d457b50..c2f4542 100644 --- a/tests/util.test +++ b/tests/util.test @@ -34,7 +34,7 @@ test util-1.5 {Tk_GetScrollInfo procedure} -body { } -returnCodes error -result {wrong # args: should be ".l yview scroll number pages|units"} test util-1.6 {Tk_GetScrollInfo procedure} -body { .l yview scroll xyz units -} -returnCodes error -result {expected integer but got "xyz"} +} -returnCodes error -result {expected floating-point number but got "xyz"} test util-1.7 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview scroll 2 pages -- cgit v0.12 From 68fc0a0ef4781d53802b28f569935acedc875a92 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Aug 2019 15:29:53 +0000 Subject: Use some more "(x|y)view scroll units" automatic rounding in bindings. --- library/demos/cscroll.tcl | 15 ++++++++++++++- library/iconlist.tcl | 6 +----- library/listbox.tcl | 8 ++++---- library/ttk/utils.tcl | 8 ++++---- 4 files changed, 23 insertions(+), 14 deletions(-) diff --git a/library/demos/cscroll.tcl b/library/demos/cscroll.tcl index 7bbb91c..1740f94 100644 --- a/library/demos/cscroll.tcl +++ b/library/demos/cscroll.tcl @@ -58,7 +58,20 @@ $c bind all "scrollLeave $c" $c bind all <1> "scrollButton $c" bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" -if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { +if {[package vsatisfies [package provide Tk] 8.7-]} { + bind $c { + %W yview scroll [expr {%D/-30.0}] units + } + bind $c { + %W yview scroll [expr {%D/-3.0}] units + } + bind $c { + %W xview scroll [expr {%D/-30.0}] units + } + bind $c { + %W xview scroll [expr {%D/-3.0}] units + } +} elseif {[tk windowingsystem] eq "aqua"} { bind $c { %W yview scroll [expr {-(%D)}] units } diff --git a/library/iconlist.tcl b/library/iconlist.tcl index 30352a1..65c66b1 100644 --- a/library/iconlist.tcl +++ b/library/iconlist.tcl @@ -509,11 +509,7 @@ package require Tk 8.6 if {$noScroll || $::tk_strictMotif} { return } - if {$amount > 0} { - $canvas xview scroll [expr {(-119-$amount) / 120}] units - } else { - $canvas xview scroll [expr {-($amount / 120)}] units - } + $canvas xview scroll [expr {$amount/-120.0}] units } method Btn1 {x y} { focus $canvas diff --git a/library/listbox.tcl b/library/listbox.tcl index 7400494..500c32e 100644 --- a/library/listbox.tcl +++ b/library/listbox.tcl @@ -177,16 +177,16 @@ bind Listbox { } bind Listbox { - %W yview scroll [expr {%D/-30}] units + %W yview scroll [expr {%D/-30.0}] units } bind Listbox { - %W yview scroll [expr {%D/-3}] units + %W yview scroll [expr {%D/-3.0}] units } bind Listbox { - %W xview scroll [expr {%D/-30}] units + %W xview scroll [expr {%D/-30.0}] units } bind Listbox { - %W xview scroll [expr {%D/-3}] units + %W xview scroll [expr {%D/-3.0}] units } # ::tk::ListboxBeginSelect -- diff --git a/library/ttk/utils.tcl b/library/ttk/utils.tcl index 4827aa3..3729254 100644 --- a/library/ttk/utils.tcl +++ b/library/ttk/utils.tcl @@ -298,12 +298,12 @@ proc ttk::bindMouseWheel {bindtag callback} { # bind TtkScrollable \ - { %W yview scroll [expr {%D/-120}] units } + { %W yview scroll [expr {%D/-120.0}] units } bind TtkScrollable \ - { %W yview scroll [expr {%D/-12}] units } + { %W yview scroll [expr {%D/-12.0}] units } bind TtkScrollable \ - { %W xview scroll [expr {%D/-120}] units } + { %W xview scroll [expr {%D/-120.0}] units } bind TtkScrollable \ - { %W xview scroll [expr {%D/-12}] units } + { %W xview scroll [expr {%D/-12.0}] units } #*EOF* -- cgit v0.12 From e7fd8a6d2e5e2e7c3a4b8b4a833e7cf5778e27e7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Sep 2020 15:01:34 +0000 Subject: scrollbar and iconlist bindings can be simplified too --- library/iconlist.tcl | 15 +++------------ library/scrlbar.tcl | 6 ------ 2 files changed, 3 insertions(+), 18 deletions(-) diff --git a/library/iconlist.tcl b/library/iconlist.tcl index 4c50122..f9dff2e 100644 --- a/library/iconlist.tcl +++ b/library/iconlist.tcl @@ -446,18 +446,9 @@ package require Tk bind $canvas {;} bind $canvas [namespace code {my ShiftMotion1 %x %y}] - if {[tk windowingsystem] eq "aqua"} { - bind $canvas [namespace code {my MouseWheel [expr {40 * (%D)}]}] - bind $canvas [namespace code {my MouseWheel [expr {400 * (%D)}]}] - } else { - bind $canvas [namespace code {my MouseWheel %D}] - } - if {[tk windowingsystem] eq "x11"} { - bind $canvas [namespace code {my MouseWheel 120}] - bind $canvas [namespace code {my MouseWheel -120}] - bind $canvas [namespace code {my MouseWheel 120}] - bind $canvas [namespace code {my MouseWheel -120}] - } + bind $canvas [namespace code {my MouseWheel %D}] + bind $canvas [namespace code {my MouseWheel [expr {10*%D}]}] + bind $canvas <> [namespace code {my UpDown -1}] bind $canvas <> [namespace code {my UpDown 1}] diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl index a25194a..a8ea3bf 100644 --- a/library/scrlbar.tcl +++ b/library/scrlbar.tcl @@ -135,12 +135,6 @@ bind Scrollbar { bind Scrollbar { tk::ScrollByUnits %W hv [expr {%D/-3.0}] } -bind Scrollbar { - tk::ScrollByUnits %W hv [expr {%D/-30.0}] -} -bind Scrollbar { - tk::ScrollByUnits %W hv [expr {%D/-3.0}] -} # tk::ScrollButtonDown -- # This procedure is invoked when a button is pressed in a scrollbar. -- cgit v0.12 From 06ab717260bbdc988e95498dc27019590a249f5a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Sep 2020 15:10:17 +0000 Subject: Adjust documentation to new behaviour --- doc/bind.n | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/doc/bind.n b/doc/bind.n index 96c5d34..94f63a1 100644 --- a/doc/bind.n +++ b/doc/bind.n @@ -214,11 +214,7 @@ values should scroll up and negative values should scroll down. Horizontal scrolling uses \fBShift-MouseWheel\fR events, with positive \fB%D\fR \fIdelta\fR substitution indicating left scrolling and negative right scrolling. -Only Windows and macOS Aqua typically fire \fBMouseWheel\fR and -\fBShift-MouseWheel\fR events. On -X11 vertical scrolling is rather supported through \fBButton-4\fR and -\fBButton-5\fR events, and horizontal scrolling through \fBShift-Button-4\fR -and \fBShift-Button-5\fR events. Horizontal scrolling events may fire from +Horizontal scrolling events may fire from many different hardware units such as tilt wheels or touchpads. Horizontal scrolling can also be emulated by holding Shift and scrolling vertically. .RE -- cgit v0.12 From aa1c6622027872fa5412d9bb438494b3e54588ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Sep 2020 21:07:40 +0000 Subject: Now (really) swap Buttons 2|3 on MacOS. Adapt all bindings not depending on aqua any more --- library/demos/cscroll.tcl | 8 ++++++-- library/demos/ctext.tcl | 6 +++++- library/demos/floor.tcl | 9 +++++++-- library/demos/items.tcl | 17 ++++++++++++----- library/entry.tcl | 25 ++++++------------------- library/scale.tcl | 8 -------- library/spinbox.tcl | 27 +++++++-------------------- library/text.tcl | 27 +++++++-------------------- library/tk.tcl | 9 +++------ library/ttk/entry.tcl | 16 +++++----------- library/ttk/scrollbar.tcl | 14 ++------------ macosx/tkMacOSXMouseEvent.c | 3 +++ 12 files changed, 63 insertions(+), 106 deletions(-) diff --git a/library/demos/cscroll.tcl b/library/demos/cscroll.tcl index aa0a948..186ee48 100644 --- a/library/demos/cscroll.tcl +++ b/library/demos/cscroll.tcl @@ -56,9 +56,9 @@ for {set i 0} {$i < 20} {incr i} { $c bind all "scrollEnter $c" $c bind all "scrollLeave $c" $c bind all "scrollButton $c" -bind $c "$c scan mark %x %y" -bind $c "$c scan dragto %x %y" if {[package vsatisfies [package provide Tk] 8.7-]} { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" bind $c { %W yview scroll [expr {%D/-30.0}] units } @@ -72,6 +72,8 @@ if {[package vsatisfies [package provide Tk] 8.7-]} { %W xview scroll [expr {%D/-3.0}] units } } elseif {[tk windowingsystem] eq "aqua"} { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" bind $c { %W yview scroll [expr {-(%D)}] units } @@ -85,6 +87,8 @@ if {[package vsatisfies [package provide Tk] 8.7-]} { %W xview scroll [expr {-10 * (%D)}] units } } else { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" # We must make sure that positive and negative movements are rounded # equally to integers, avoiding the problem that # (int)1/30 = 0, diff --git a/library/demos/ctext.tcl b/library/demos/ctext.tcl index 502c9d0..d3fec33 100644 --- a/library/demos/ctext.tcl +++ b/library/demos/ctext.tcl @@ -50,7 +50,11 @@ $c bind text "textInsert $c \\n" $c bind text "textBs $c" $c bind text "textBs $c" $c bind text "textDel $c" -$c bind text "textPaste $c @%x,%y" +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { + $c bind text "textPaste $c @%x,%y" +} else { + $c bind text "textPaste $c @%x,%y" +} # Next, create some items that allow the text's anchor position # to be edited. diff --git a/library/demos/floor.tcl b/library/demos/floor.tcl index b5d3c64..eb2ea7f 100644 --- a/library/demos/floor.tcl +++ b/library/demos/floor.tcl @@ -1359,8 +1359,13 @@ $c bind floor2 "floorDisplay $c 2" $c bind floor3 "floorDisplay $c 3" $c bind room "newRoom $c" $c bind room {set currentRoom ""} -bind $c "$c scan mark %x %y" -bind $c "$c scan dragto %x %y" +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" +} else { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" +} bind $c "unset currentRoom" set currentRoom "" trace variable currentRoom w "roomChanged $c" diff --git a/library/demos/items.tcl b/library/demos/items.tcl index 30fda5c..1297046 100644 --- a/library/demos/items.tcl +++ b/library/demos/items.tcl @@ -17,7 +17,7 @@ wm iconname $w "Items" positionWindow $w set c $w.frame.c -label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." +label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Left-Button drag:\tmoves item under pointer.\n Middle-Button drag:\trepositions view.\n Right-Button drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." pack $w.msg -side top ## See Code / Dismiss buttons @@ -173,10 +173,17 @@ $c create text 28.5c 17.4c -text Scale: -anchor s $c bind item "itemEnter $c" $c bind item "itemLeave $c" -bind $c "$c scan mark %x %y" -bind $c "$c scan dragto %x %y" -bind $c "itemMark $c %x %y" -bind $c "itemStroke $c %x %y" +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { + bind $c "itemMark $c %x %y" + bind $c "itemStroke $c %x %y" + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" +} else { + bind $c "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" + bind $c "itemMark $c %x %y" + bind $c "itemStroke $c %x %y" +} bind $c <> "itemsUnderArea $c" bind $c "itemStartDrag $c %x %y" bind $c "itemDrag $c %x %y" diff --git a/library/entry.tcl b/library/entry.tcl index 6539af7..f95d6bd 100644 --- a/library/entry.tcl +++ b/library/entry.tcl @@ -293,28 +293,15 @@ bind Entry <> { # A few additional bindings of my own. -if {[tk windowingsystem] ne "aqua"} { - bind Entry { - if {!$tk_strictMotif} { - ::tk::EntryScanMark %W %x - } - } - bind Entry { - if {!$tk_strictMotif} { - ::tk::EntryScanDrag %W %x - } - } -} else { - bind Entry { - if {!$tk_strictMotif} { +bind Entry { + if {!$tk_strictMotif} { ::tk::EntryScanMark %W %x - } } - bind Entry { - if {!$tk_strictMotif} { +} +bind Entry { + if {!$tk_strictMotif} { ::tk::EntryScanDrag %W %x - } - } + } } # ::tk::EntryClosestGap -- diff --git a/library/scale.tcl b/library/scale.tcl index cc0de20..130c491 100644 --- a/library/scale.tcl +++ b/library/scale.tcl @@ -60,14 +60,6 @@ bind Scale { tk::ScaleEndDrag %W tk::ScaleActivate %W %x %y } -if {[tk windowingsystem] eq "win32"} { - # On Windows do the same with button 3, as that is the right mouse button - bind Scale [bind Scale ] - bind Scale [bind Scale ] - bind Scale [bind Scale ] - bind Scale [bind Scale ] - bind Scale [bind Scale ] -} bind Scale { tk::ScaleControlPress %W %x %y } diff --git a/library/spinbox.tcl b/library/spinbox.tcl index 6ba7842..938e409 100644 --- a/library/spinbox.tcl +++ b/library/spinbox.tcl @@ -280,27 +280,14 @@ bind Spinbox { # A few additional bindings of my own. -if {[tk windowingsystem] ne "aqua"} { - bind Spinbox { - if {!$tk_strictMotif} { - ::tk::EntryScanMark %W %x - } - } - bind Spinbox { - if {!$tk_strictMotif} { - ::tk::EntryScanDrag %W %x - } - } -} else { - bind Spinbox { - if {!$tk_strictMotif} { - ::tk::EntryScanMark %W %x - } +bind Spinbox { + if {!$tk_strictMotif} { + ::tk::EntryScanMark %W %x } - bind Spinbox { - if {!$tk_strictMotif} { - ::tk::EntryScanDrag %W %x - } +} +bind Spinbox { + if {!$tk_strictMotif} { + ::tk::EntryScanDrag %W %x } } diff --git a/library/text.tcl b/library/text.tcl index 67a787a..7f56c0b 100644 --- a/library/text.tcl +++ b/library/text.tcl @@ -429,27 +429,14 @@ bind Text { %W see insert } } -if {[tk windowingsystem] ne "aqua"} { - bind Text { - if {!$tk_strictMotif} { - tk::TextScanMark %W %x %y - } - } - bind Text { - if {!$tk_strictMotif} { - tk::TextScanDrag %W %x %y - } - } -} else { - bind Text { - if {!$tk_strictMotif} { - tk::TextScanMark %W %x %y - } +bind Text { + if {!$tk_strictMotif} { + tk::TextScanMark %W %x %y } - bind Text { - if {!$tk_strictMotif} { - tk::TextScanDrag %W %x %y - } +} +bind Text { + if {!$tk_strictMotif} { + tk::TextScanDrag %W %x %y } } set ::tk::Priv(prevPos) {} diff --git a/library/tk.tcl b/library/tk.tcl index 85421ef..dfa60d4 100644 --- a/library/tk.tcl +++ b/library/tk.tcl @@ -366,15 +366,16 @@ if {![llength [info command tk_chooseDirectory]]} { # Define the set of common virtual events. #---------------------------------------------------------------------- +event add <> +event add <> + switch -exact -- [tk windowingsystem] { "x11" { event add <> event add <> event add <> - event add <> event add <> event add <> - event add <> # On Darwin/Aqua, buttons from left to right are 1,3,2. On Darwin/X11 with recent # XQuartz as the X server, they are 1,2,3; other X servers may differ. @@ -422,10 +423,8 @@ switch -exact -- [tk windowingsystem] { event add <> event add <> event add <> - event add <> event add <> event add <> - event add <> event add <> event add <> @@ -455,9 +454,7 @@ switch -exact -- [tk windowingsystem] { event add <> event add <> event add <> - event add <> event add <> - event add <> # Official bindings # See http://support.apple.com/kb/HT1343 diff --git a/library/ttk/entry.tcl b/library/ttk/entry.tcl index 2f3c1a6..a4528fa 100644 --- a/library/ttk/entry.tcl +++ b/library/ttk/entry.tcl @@ -82,20 +82,14 @@ bind TEntry <> { %W instate {!readonly !disabled} { %W icursor @%x ; focus %W } } -## Button2 (Button3 on Aqua) bindings: +## Button2 bindings: # Used for scanning and primary transfer. -# Note: ButtonRelease-2 (ButtonRelease-3 on Aqua) +# Note: ButtonRelease-2 # is mapped to <> in tk.tcl. # -if {[tk windowingsystem] ne "aqua"} { - bind TEntry { ttk::entry::ScanMark %W %x } - bind TEntry { ttk::entry::ScanDrag %W %x } - bind TEntry { ttk::entry::ScanRelease %W %x } -} else { - bind TEntry { ttk::entry::ScanMark %W %x } - bind TEntry { ttk::entry::ScanDrag %W %x } - bind TEntry { ttk::entry::ScanRelease %W %x } -} +bind TEntry { ttk::entry::ScanMark %W %x } +bind TEntry { ttk::entry::ScanDrag %W %x } +bind TEntry { ttk::entry::ScanRelease %W %x } bind TEntry <> { ttk::entry::ScanRelease %W %x } ## Keyboard navigation bindings: diff --git a/library/ttk/scrollbar.tcl b/library/ttk/scrollbar.tcl index 4ac0760..8f6cf64 100644 --- a/library/ttk/scrollbar.tcl +++ b/library/ttk/scrollbar.tcl @@ -19,18 +19,8 @@ bind TScrollbar { ttk::scrollbar::Release %W %x %y } # Redirect scrollwheel bindings to the scrollbar widget # -# The shift-bindings scroll left/right (not up/down) -# if a widget has both possibilities -set eventList [list ] -switch [tk windowingsystem] { - aqua { - lappend eventList - } -} -foreach event $eventList { - bind TScrollbar $event [bind Scrollbar $event] -} -unset eventList event +bind TScrollbar [bind Scrollbar ] +bind TScrollbar [bind Scrollbar ] proc ttk::scrollbar::Scroll {w n units} { set cmd [$w cget -command] diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c index 67840ed..58e2f73 100644 --- a/macosx/tkMacOSXMouseEvent.c +++ b/macosx/tkMacOSXMouseEvent.c @@ -89,6 +89,9 @@ enum { } button = [theEvent buttonNumber] + Button1; + if ((button & -2) == Button2) { + button ^= 1; /* Swap buttons 2/3 */ + } switch (eventType) { case NSRightMouseUp: case NSOtherMouseUp: -- cgit v0.12 From 483a7f2dbd65aef5e33e27a71af323d481383a3a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Sep 2020 11:30:12 +0000 Subject: Invert Scrollwheel direction on X11 --- generic/tkEvent.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tkEvent.c b/generic/tkEvent.c index d05557a..dfadc3e 100644 --- a/generic/tkEvent.c +++ b/generic/tkEvent.c @@ -1148,7 +1148,7 @@ Tk_HandleEvent( } else if (eventPtr->type == ButtonPress) { eventPtr->type = MouseWheelEvent; eventPtr->xany.send_event = -1; - eventPtr->xkey.keycode = (eventPtr->xbutton.button & 1) ? 120 : -120; + eventPtr->xkey.keycode = (eventPtr->xbutton.button & 1) ? -120 : 120; if (eventPtr->xkey.keycode > Button5) { eventPtr->xkey.state ^= ShiftMask; } -- cgit v0.12 From 5e2225d853694bed068a250b19d22a5dea0abcf3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Sep 2020 12:59:20 +0000 Subject: Another bugfix: xbutton.button and xkey.keycode are actually the same field. Doogh.... --- generic/tkEvent.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tkEvent.c b/generic/tkEvent.c index dfadc3e..ea7b282 100644 --- a/generic/tkEvent.c +++ b/generic/tkEvent.c @@ -1146,10 +1146,11 @@ Tk_HandleEvent( if (eventPtr->type == ButtonRelease) { return; } else if (eventPtr->type == ButtonPress) { + int but = eventPtr->xbutton.button; eventPtr->type = MouseWheelEvent; eventPtr->xany.send_event = -1; - eventPtr->xkey.keycode = (eventPtr->xbutton.button & 1) ? -120 : 120; - if (eventPtr->xkey.keycode > Button5) { + eventPtr->xkey.keycode = (but & 1) ? -120 : 120; + if (but > Button5) { eventPtr->xkey.state ^= ShiftMask; } } -- cgit v0.12 From 806e7862d404cf9f85f85ff6d4b3e74eb09317f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Sep 2020 09:21:04 +0000 Subject: New utility function ::tk::MouseWheel --- library/demos/cscroll.tcl | 8 ++++---- library/iconlist.tcl | 6 +++--- library/listbox.tcl | 8 ++++---- library/scrlbar.tcl | 10 +++++----- library/tclIndex | 1 + library/text.tcl | 16 ++++------------ library/tk.tcl | 7 +++++++ library/ttk/combobox.tcl | 8 ++++++-- library/ttk/spinbox.tcl | 6 +++--- library/ttk/utils.tcl | 12 ++++++------ 10 files changed, 43 insertions(+), 39 deletions(-) diff --git a/library/demos/cscroll.tcl b/library/demos/cscroll.tcl index 52a9e1a..90b1afc 100644 --- a/library/demos/cscroll.tcl +++ b/library/demos/cscroll.tcl @@ -60,16 +60,16 @@ if {[package vsatisfies [package provide Tk] 8.7-]} { bind $c "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c { - %W yview scroll [expr {%D/-30.0}] units + tk::MouseWheel %W y %D -30.0 } bind $c { - %W yview scroll [expr {%D/-3.0}] units + tk::MouseWheel %W y %D -3.0 } bind $c { - %W xview scroll [expr {%D/-30.0}] units + tk::MouseWheel %W x %D -30.0 } bind $c { - %W xview scroll [expr {%D/-3.0}] units + tk::MouseWheel %W x %D -3.0 } } elseif {[tk windowingsystem] eq "aqua"} { bind $c "$c scan mark %x %y" diff --git a/library/iconlist.tcl b/library/iconlist.tcl index f9dff2e..c052efb 100644 --- a/library/iconlist.tcl +++ b/library/iconlist.tcl @@ -447,7 +447,7 @@ package require Tk bind $canvas [namespace code {my ShiftMotion1 %x %y}] bind $canvas [namespace code {my MouseWheel %D}] - bind $canvas [namespace code {my MouseWheel [expr {10*%D}]}] + bind $canvas [namespace code {my MouseWheel %D -12}] bind $canvas <> [namespace code {my UpDown -1}] @@ -496,11 +496,11 @@ package require Tk # ---------------------------------------------------------------------- # Event handlers - method MouseWheel {amount} { + method MouseWheel {amount {factor -120.0}} { if {$noScroll || $::tk_strictMotif} { return } - $canvas xview scroll [expr {$amount/-120.0}] units + $canvas xview scroll [expr {$amount/$factor}] units } method Btn1 {x y} { focus $canvas diff --git a/library/listbox.tcl b/library/listbox.tcl index f6ece12..ffedee6 100644 --- a/library/listbox.tcl +++ b/library/listbox.tcl @@ -177,16 +177,16 @@ bind Listbox { } bind Listbox { - %W yview scroll [expr {%D/-30.0}] units + tk::MouseWheel %W y %D -30.0 } bind Listbox { - %W yview scroll [expr {%D/-3.0}] units + tk::MouseWheel %W y %D -3.0 } bind Listbox { - %W xview scroll [expr {%D/-30.0}] units + tk::MouseWheel %W x %D -30.0 } bind Listbox { - %W xview scroll [expr {%D/-3.0}] units + tk::MouseWheel %W x %D -3.0 } # ::tk::ListboxBeginSelect -- diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl index a8ea3bf..f545785 100644 --- a/library/scrlbar.tcl +++ b/library/scrlbar.tcl @@ -130,10 +130,10 @@ bind Scrollbar <> { } bind Scrollbar { - tk::ScrollByUnits %W hv [expr {%D/-30.0}] + tk::ScrollByUnits %W hv %D -30.0 } bind Scrollbar { - tk::ScrollByUnits %W hv [expr {%D/-3.0}] + tk::ScrollByUnits %W hv %D -3.0 } # tk::ScrollButtonDown -- @@ -306,7 +306,7 @@ proc ::tk::ScrollEndDrag {w x y} { # horizontal, "v" for vertical, "hv" for both. # amount - How many units to scroll: typically 1 or -1. -proc ::tk::ScrollByUnits {w orient amount} { +proc ::tk::ScrollByUnits {w orient amount {factor 1.0}} { set cmd [$w cget -command] if {$cmd eq "" || ([string first \ [string index [$w cget -orient] 0] $orient] < 0)} { @@ -314,9 +314,9 @@ proc ::tk::ScrollByUnits {w orient amount} { } set info [$w get] if {[llength $info] == 2} { - uplevel #0 $cmd scroll $amount units + uplevel #0 $cmd scroll [expr {$amount/$factor}] units } else { - uplevel #0 $cmd [expr {[lindex $info 2] + $amount}] + uplevel #0 $cmd [expr {[lindex $info 2] + [expr {$amount/$factor}]}] } } diff --git a/library/tclIndex b/library/tclIndex index 919fa8a..06006cd 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -199,6 +199,7 @@ set auto_index(::tk::RestoreFocusGrab) [list source [file join $dir tk.tcl]] set auto_index(::tk::ScreenChanged) [list source [file join $dir tk.tcl]] set auto_index(::tk::EventMotifBindings) [list source [file join $dir tk.tcl]] set auto_index(::tk::CancelRepeat) [list source [file join $dir tk.tcl]] +set auto_index(::tk::MouseWheel) [list source [file join $dir tk.tcl]] set auto_index(::tk::TabToWindow) [list source [file join $dir tk.tcl]] set auto_index(::tk::dialog::file::) [list source [file join $dir tkfbox.tcl]] set auto_index(::tk::dialog::file::Config) [list source [file join $dir tkfbox.tcl]] diff --git a/library/text.tcl b/library/text.tcl index 24dd6d2..f25f639 100644 --- a/library/text.tcl +++ b/library/text.tcl @@ -453,24 +453,16 @@ set ::tk::Priv(prevPos) {} # (int)-1/3 = -1 # The following code ensure equal +/- behaviour. bind Text { - if {%D >= 0} { - %W yview scroll [expr {-%D/3}] pixels - } else { - %W yview scroll [expr {(2-%D)/3}] pixels - } + tk::MouseWheel y %D -3.0 pixels } bind Text { - %W yview scroll [expr {-3*%D}] pixels + tk::MouseWheel y %D -0.3 pixels } bind Text { - if {%D >= 0} { - %W xview scroll [expr {-%D/3}] pixels - } else { - %W xview scroll [expr {(2-%D)/3}] pixels - } + tk::MouseWheel x %D -3.0 pixels } bind Text { - %W xview scroll [expr {-3*%D}] pixels + tk::MouseWheel x %D -0.3 pixels } # ::tk::TextClosestGap -- diff --git a/library/tk.tcl b/library/tk.tcl index dfa60d4..bf00e6f 100644 --- a/library/tk.tcl +++ b/library/tk.tcl @@ -533,6 +533,13 @@ proc ::tk::CancelRepeat {} { set Priv(afterId) {} } +## ::tk::MouseWheel $w $dir $amount $factor $units + +proc ::tk::MouseWheel {w dir amount factor {units units}} { + $w ${dir}view scroll [expr {$amount/$factor}] $units +} + + # ::tk::TabToWindow -- # This procedure moves the focus to the given widget. # It sends a <> virtual event to the previous focus window, diff --git a/library/ttk/combobox.tcl b/library/ttk/combobox.tcl index 0a7e519..c72d02e 100644 --- a/library/ttk/combobox.tcl +++ b/library/ttk/combobox.tcl @@ -182,11 +182,15 @@ proc ttk::combobox::SelectEntry {cb index} { ## Scroll -- Mousewheel binding # -proc ttk::combobox::Scroll {cb dir} { +proc ttk::combobox::Scroll {cb dir {factor 1.0}} { $cb instate disabled { return } set max [llength [$cb cget -values]] set current [$cb current] - incr current $dir + set d [expr {round($dir/factor)}] + if {$d == 0 && $dir != 0} { + if {$dir > 0} {set d 1} else {set d -1} + } + incr current $d if {$max != 0 && $current == $current % $max} { SelectEntry $cb $current } diff --git a/library/ttk/spinbox.tcl b/library/ttk/spinbox.tcl index 33936d9..19a330f 100644 --- a/library/ttk/spinbox.tcl +++ b/library/ttk/spinbox.tcl @@ -82,11 +82,11 @@ proc ttk::spinbox::Release {w} { # Mousewheel callback. Turn these into <> (-1, up) # or < (+1, down) events. # -proc ttk::spinbox::MouseWheel {w dir} { +proc ttk::spinbox::MouseWheel {w dir {factor 1}} { if {[$w instate disabled]} { return } - if {$dir < 0} { + if {($dir < 0) ^ ($factor < 0)} { event generate $w <> - } else { + } elseif {$dir > 0} { event generate $w <> } } diff --git a/library/ttk/utils.tcl b/library/ttk/utils.tcl index c58d39e..de7565c 100644 --- a/library/ttk/utils.tcl +++ b/library/ttk/utils.tcl @@ -285,8 +285,8 @@ proc ttk::copyBindings {from to} { # proc ttk::bindMouseWheel {bindtag callback} { - bind $bindtag [append callback { [expr {%D/-120.0}]}] - bind $bindtag [append callback { [expr {%D/-12.0}]}] + bind $bindtag [append callback { %D -120.0}] + bind $bindtag [append callback { %D -12.0}] } ## Mousewheel bindings for standard scrollable widgets. @@ -298,12 +298,12 @@ proc ttk::bindMouseWheel {bindtag callback} { # bind TtkScrollable \ - { %W yview scroll [expr {%D/-120.0}] units } + { tk::MouseWheel %W y %D -120.0 } bind TtkScrollable \ - { %W yview scroll [expr {%D/-12.0}] units } + { tk::MouseWheel %W y %D -12.0 } bind TtkScrollable \ - { %W xview scroll [expr {%D/-120.0}] units } + { tk::MouseWheel %W x %D -120.0 } bind TtkScrollable \ - { %W xview scroll [expr {%D/-12.0}] units } + { tk::MouseWheel %W x %D -120.0 } #*EOF* -- cgit v0.12 From ce0c027625867ef8a707a520b19fe1e053774a93 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Sep 2020 15:04:04 +0000 Subject: Tk demo, taking advantage of TIP #587 --- library/demos/bind.tcl | 12 +++++------ library/demos/goldberg.tcl | 8 +++---- library/demos/knightstour.tcl | 6 +++--- library/demos/pendulum.tcl | 4 ++-- library/demos/toolbar.tcl | 2 +- library/demos/ttkbut.tcl | 2 +- library/demos/ttkprogress.tcl | 2 +- library/demos/unicodeout.tcl | 49 +++++++++++++------------------------------ 8 files changed, 33 insertions(+), 52 deletions(-) diff --git a/library/demos/bind.tcl b/library/demos/bind.tcl index 9146362..8b56639 100644 --- a/library/demos/bind.tcl +++ b/library/demos/bind.tcl @@ -67,12 +67,12 @@ foreach tag {d1 d2 d3 d4 d5 d6} { $w.text tag bind $tag "$w.text tag configure $tag $normal" } # Main widget program sets variable tk_demoDirectory -$w.text tag bind d1 {source [file join $tk_demoDirectory items.tcl]} -$w.text tag bind d2 {source [file join $tk_demoDirectory plot.tcl]} -$w.text tag bind d3 {source [file join $tk_demoDirectory ctext.tcl]} -$w.text tag bind d4 {source [file join $tk_demoDirectory arrow.tcl]} -$w.text tag bind d5 {source [file join $tk_demoDirectory ruler.tcl]} -$w.text tag bind d6 {source [file join $tk_demoDirectory cscroll.tcl]} +$w.text tag bind d1 {source -encoding utf-8 [file join $tk_demoDirectory items.tcl]} +$w.text tag bind d2 {source -encoding utf-8 [file join $tk_demoDirectory plot.tcl]} +$w.text tag bind d3 {source -encoding utf-8 [file join $tk_demoDirectory ctext.tcl]} +$w.text tag bind d4 {source -encoding utf-8 [file join $tk_demoDirectory arrow.tcl]} +$w.text tag bind d5 {source -encoding utf-8 [file join $tk_demoDirectory ruler.tcl]} +$w.text tag bind d6 {source -encoding utf-8 [file join $tk_demoDirectory cscroll.tcl]} $w.text mark set insert 0.0 $w.text configure -state disabled diff --git a/library/demos/goldberg.tcl b/library/demos/goldberg.tcl index 1cc52c6..14ddb0b 100644 --- a/library/demos/goldberg.tcl +++ b/library/demos/goldberg.tcl @@ -113,9 +113,9 @@ proc DoDisplay {w} { DoCtrlFrame $w DoDetailFrame $w if {[tk windowingsystem] ne "aqua"} { - ttk::button $w.show -text "\u00bb" -command [list ShowCtrl $w] -width 2 + ttk::button $w.show -text "»" -command [list ShowCtrl $w] -width 2 } else { - button $w.show -text "\u00bb" -command [list ShowCtrl $w] -width 2 -highlightbackground $C(bg) + button $w.show -text "»" -command [list ShowCtrl $w] -width 2 -highlightbackground $C(bg) } place $w.show -in $w.c -relx 1 -rely 0 -anchor ne update @@ -204,10 +204,10 @@ proc DoDetailFrame {w} { proc ShowCtrl {w} { if {[winfo ismapped $w.ctrl]} { pack forget $w.ctrl - $w.show config -text "\u00bb" + $w.show config -text "»" } else { pack $w.ctrl -side right -fill both -ipady 5 - $w.show config -text "\u00ab" + $w.show config -text "»" } } diff --git a/library/demos/knightstour.tcl b/library/demos/knightstour.tcl index 11b3b5c..09ceff0 100644 --- a/library/demos/knightstour.tcl +++ b/library/demos/knightstour.tcl @@ -1,4 +1,4 @@ -# Copyright (C) 2008 Pat Thoyts +# Copyright © 2008 Pat Thoyts # # Calculate a Knight's tour of a chessboard. # @@ -205,10 +205,10 @@ proc CreateGUI {} { } if {[tk windowingsystem] ne "x11"} { catch {eval font create KnightFont -size -24} - $c create text 0 0 -font KnightFont -text "\u265e" \ + $c create text 0 0 -font KnightFont -text "♞" \ -anchor nw -tags knight -fill black -activefill "#600000" } else { - # On X11 we cannot reliably tell if the \u265e glyph is available + # On X11 we cannot reliably tell if the ♞ glyph is available # so just use a polygon set pts { 2 25 24 25 21 19 20 8 14 0 10 0 0 13 0 16 diff --git a/library/demos/pendulum.tcl b/library/demos/pendulum.tcl index 9833e8f..04f276b 100644 --- a/library/demos/pendulum.tcl +++ b/library/demos/pendulum.tcl @@ -50,8 +50,8 @@ for {set i 90} {$i>=0} {incr i -10} { $w.k create line 0 0 1 1 -smooth true -tags graph$i -fill grey$i } -$w.k create text 0 0 -anchor ne -text "\u03b8" -tags label_theta -$w.k create text 0 0 -anchor ne -text "\u03b4\u03b8" -tags label_dtheta +$w.k create text 0 0 -anchor ne -text "θ" -tags label_theta +$w.k create text 0 0 -anchor ne -text "δθ" -tags label_dtheta pack $w.k -in $w.p.l2 -fill both -expand true # Initialize some variables diff --git a/library/demos/toolbar.tcl b/library/demos/toolbar.tcl index cb2a495..a53e390 100644 --- a/library/demos/toolbar.tcl +++ b/library/demos/toolbar.tcl @@ -17,7 +17,7 @@ positionWindow $w ttk::label $w.msg -wraplength 4i -text "This is a demonstration of how to do\ a toolbar that is styled correctly and which can be torn off. The\ - buttons are configured to be \u201Ctoolbar style\u201D buttons by\ + buttons are configured to be “toolbar style” buttons by\ telling them that they are to use the Toolbutton style. At the left\ end of the toolbar is a simple marker that the cursor changes to a\ movement icon over; drag that away from the toolbar to tear off the\ diff --git a/library/demos/ttkbut.tcl b/library/demos/ttkbut.tcl index ab49cf4..f6d94ac 100644 --- a/library/demos/ttkbut.tcl +++ b/library/demos/ttkbut.tcl @@ -17,7 +17,7 @@ wm title $w "Simple Ttk Widgets" wm iconname $w "ttkbut" positionWindow $w -ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set. This is a Ttk themed label, and below are three groups of Ttk widgets in Ttk labelframes. The first group are all buttons that set the current application theme when pressed. The second group contains three sets of checkbuttons, with a separator widget between the sets. Note that the \u201cEnabled\u201d button controls whether all the other themed widgets in this toplevel are in the disabled state. The third group has a collection of linked radiobuttons." +ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set. This is a Ttk themed label, and below are three groups of Ttk widgets in Ttk labelframes. The first group are all buttons that set the current application theme when pressed. The second group contains three sets of checkbuttons, with a separator widget between the sets. Note that the “Enabled” button controls whether all the other themed widgets in this toplevel are in the disabled state. The third group has a collection of linked radiobuttons." pack $w.msg -side top -fill x ## See Code / Dismiss diff --git a/library/demos/ttkprogress.tcl b/library/demos/ttkprogress.tcl index 8a72cf9..29ac508 100644 --- a/library/demos/ttkprogress.tcl +++ b/library/demos/ttkprogress.tcl @@ -15,7 +15,7 @@ wm title $w "Progress Bar Demonstration" wm iconname $w "ttkprogress" positionWindow $w -ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Below are two progress bars. The top one is a \u201Cdeterminate\u201D progress bar, which is used for showing how far through a defined task the program has got. The bottom one is an \u201Cindeterminate\u201D progress bar, which is used to show that the program is busy but does not know how long for. Both are run here in self-animated mode, which can be turned on and off using the buttons underneath." +ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Below are two progress bars. The top one is a “determinate” progress bar, which is used for showing how far through a defined task the program has got. The bottom one is an “indeterminate” progress bar, which is used to show that the program is busy but does not know how long for. Both are run here in self-animated mode, which can be turned on and off using the buttons underneath." pack $w.msg -side top -fill x ## See Code / Dismiss buttons diff --git a/library/demos/unicodeout.tcl b/library/demos/unicodeout.tcl index ca325a4..9e7180c 100644 --- a/library/demos/unicodeout.tcl +++ b/library/demos/unicodeout.tcl @@ -21,9 +21,7 @@ label $w.msg -font $font -wraplength 4i -anchor w -justify left \ non-Western character sets. However, what you will actually see\ below depends largely on what character sets you have installed,\ and what you see for characters that are not present varies greatly\ - between platforms as well. The strings are written in Tcl using\ - UNICODE characters using the \\uXXXX (or \\UXXXXXX) escape so as to\ - do so in a portable fashion." + between platforms as well." pack $w.msg -side top ## See Code / Dismiss buttons @@ -98,47 +96,30 @@ update ## Add the samples... if {[usePresentationFormsFor Arabic]} { # Using presentation forms (pre-layouted) - addSample $w Arabic \ - "\uFE94\uFEF4\uFE91\uFEAE\uFECC\uFEDF\uFE8D " \ - "\uFE94\uFEE4\uFEE0\uFEDC\uFEDF\uFE8D" + addSample $w Arabic "ﺔﻴﺑﺮﻌﻟﺍ ﺔﻤﻠﻜﻟﺍ" } else { # Using standard text characters - addSample $w Arabic \ - "\u0627\u0644\u0643\u0644\u0645\u0629 " \ - "\u0627\u0644\u0639\u0631\u0628\u064A\u0629" + addSample $w Arabic "الكلمة العربية" } -addSample $w "Trad. Chinese" "\u4E2D\u570B\u7684\u6F22\u5B57" -addSample $w "Simpl. Chinese" "\u6C49\u8BED" -addSample $w French "Langue fran\xE7aise" +addSample $w "Trad. Chinese" "中國的漢字" +addSample $w "Simpl. Chinese" "汉语" +addSample $w French "Langue française" addSample $w Greek \ - "\u0395\u03BB\u03BB\u03B7\u03BD\u03B9\u03BA\u03AE " \ - "\u03B3\u03BB\u03CE\u03C3\u03C3\u03B1" + "Ελληνική γλώσσα" if {[usePresentationFormsFor Hebrew]} { # Visual order (pre-layouted) - addSample $w Hebrew \ - "\u05EA\u05D9\u05E8\u05D1\u05E2 \u05D1\u05EA\u05DB" + addSample $w Hebrew "תירבע בתכ" } else { # Standard logical order - addSample $w Hebrew \ - "\u05DB\u05EA\u05D1 \u05E2\u05D1\u05E8\u05D9\u05EA" + addSample $w Hebrew "כתב עברית" } -addSample $w Hindi \ - "\u0939\u093F\u0928\u094D\u0926\u0940 \u092D\u093E\u0937\u093E" -addSample $w Icelandic "\xCDslenska" -addSample $w Japanese \ - "\u65E5\u672C\u8A9E\u306E\u3072\u3089\u304C\u306A, " \ - "\u6F22\u5B57\u3068\u30AB\u30BF\u30AB\u30CA" -addSample $w Korean "\uB300\uD55C\uBBFC\uAD6D\uC758 \uD55C\uAE00" -addSample $w Russian \ - "\u0420\u0443\u0441\u0441\u043A\u0438\u0439 \u044F\u0437\u044B\u043A" +addSample $w Hindi "हिन्दी भाषा" +addSample $w Icelandic "Íslenska" +addSample $w Japanese "日本語のひらがな, 漢字とカタカナ" +addSample $w Korean "대한민국의 한글" +addSample $w Russian "Русский язык" if {([tk windowingsystem] ne "x11") || (![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft"))} { - if {[package vsatisfies [package provide Tcl] 8.7-]} { - addSample $w Emoji \ - "\U1F600\U1F4A9\U1F44D\U1F1F3\U1F1F1" - } else { - addSample $w Emoji \ - "\uD83D\uDE00\uD83D\uDCA9\uD83D\uDC4D\uD83C\uDDF3\uD83C\uDDF1" - } + addSample $w Emoji "😀💩👍🇳🇱" } ## We're done processing, so change things back to normal running... -- cgit v0.12 From 272678ee37956bea49401b322ec32afd4fcc4753 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Sep 2020 15:07:27 +0000 Subject: little tweak --- library/demos/unicodeout.tcl | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/library/demos/unicodeout.tcl b/library/demos/unicodeout.tcl index 9e7180c..1ecc064 100644 --- a/library/demos/unicodeout.tcl +++ b/library/demos/unicodeout.tcl @@ -104,8 +104,7 @@ if {[usePresentationFormsFor Arabic]} { addSample $w "Trad. Chinese" "中國的漢字" addSample $w "Simpl. Chinese" "汉语" addSample $w French "Langue française" -addSample $w Greek \ - "Ελληνική γλώσσα" +addSample $w Greek "Ελληνική γλώσσα" if {[usePresentationFormsFor Hebrew]} { # Visual order (pre-layouted) addSample $w Hebrew "תירבע בתכ" -- cgit v0.12 From ad0d8ceeb439f7151ce2378527b87cf81e17d1bd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 13 Oct 2020 13:05:57 +0000 Subject: Protect ttk::spinbox::Spin against empty lsearch result. Discovered when running against Tcl's "empty-not-found" branch. Some formatting --- library/ttk/spinbox.tcl | 43 ++++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/library/ttk/spinbox.tcl b/library/ttk/spinbox.tcl index 33936d9..8aba5e1 100644 --- a/library/ttk/spinbox.tcl +++ b/library/ttk/spinbox.tcl @@ -32,7 +32,7 @@ proc ttk::spinbox::Motion {w x y} { variable State ttk::saveCursor $w State(userConfCursor) [ttk::cursor text] if { [$w identify $x $y] eq "textarea" - && [$w instate {!readonly !disabled}] + && [$w instate {!readonly !disabled}] } { ttk::setCursor $w text } else { @@ -46,16 +46,16 @@ proc ttk::spinbox::Press {w x y} { if {[$w instate disabled]} { return } focus $w switch -glob -- [$w identify $x $y] { - *textarea { ttk::entry::Press $w $x } + *textarea { ttk::entry::Press $w $x } *rightarrow - - *uparrow { ttk::Repeatedly event generate $w <> } + *uparrow { ttk::Repeatedly event generate $w <> } *leftarrow - - *downarrow { ttk::Repeatedly event generate $w <> } + *downarrow { ttk::Repeatedly event generate $w <> } *spinbutton { if {$y * 2 >= [winfo height $w]} { - set event <> + set event <> } else { - set event <> + set event <> } ttk::Repeatedly event generate $w $event } @@ -69,7 +69,7 @@ proc ttk::spinbox::DoubleClick {w x y} { if {[$w instate disabled]} { return } switch -glob -- [$w identify $x $y] { - *textarea { SelectAll $w } + *textarea { SelectAll $w } * { Press $w $x $y } } } @@ -140,25 +140,26 @@ proc ttk::spinbox::Spin {w dir} { if {[$w instate disabled]} { return } if {![info exists State($w,values.length)]} { - set State($w,values.index) -1 - set State($w,values.last) {} + set State($w,values.index) -1 + set State($w,values.last) {} } set State($w,values) [$w cget -values] set State($w,values.length) [llength $State($w,values)] if {$State($w,values.length) > 0} { - set value [$w get] - set current $State($w,values.index) - if {$value ne $State($w,values.last)} { - set current [lsearch -exact $State($w,values) $value] - } - set State($w,values.index) [Adjust $w [expr {$current + $dir}] 0 \ - [expr {$State($w,values.length) - 1}]] - set State($w,values.last) [lindex $State($w,values) $State($w,values.index)] - $w set $State($w,values.last) + set value [$w get] + set current $State($w,values.index) + if {$value ne $State($w,values.last)} { + set current [lsearch -exact $State($w,values) $value] + if {$current < 0} {set current -1} + } + set State($w,values.index) [Adjust $w [expr {$current + $dir}] 0 \ + [expr {$State($w,values.length) - 1}]] + set State($w,values.last) [lindex $State($w,values) $State($w,values.index)] + $w set $State($w,values.last) } else { - if {[catch { - set v [expr {[scan [$w get] %f] + $dir * [$w cget -increment]}] + if {[catch { + set v [expr {[scan [$w get] %f] + $dir * [$w cget -increment]}] }]} { set v [$w cget -from] } @@ -176,7 +177,7 @@ proc ttk::spinbox::FormatValue {w val} { if {$fmt eq ""} { # Try to guess a suitable -format based on -increment. set delta [expr {abs([$w cget -increment])}] - if {0 < $delta && $delta < 1} { + if {0 < $delta && $delta < 1} { # NB: This guesses wrong if -increment has more than 1 # significant digit itself, e.g., -increment 0.25 set nsd [expr {int(ceil(-log10($delta)))}] -- cgit v0.12 From 0ce2a3994f63c21742fc4f937f58852e167e996a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 15 Oct 2020 14:51:07 +0000 Subject: Sync rules.vc with Tcl --- win/rules.vc | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 6dca6d9..f3e5439 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -415,9 +415,6 @@ _INSTALLDIR=$(_INSTALLDIR)\lib # NATIVE_ARCH - set to IX86 or AMD64 for the host machine # MACHINE - same as $(ARCH) - legacy # _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed -# CFG_ENCODING - set to an character encoding. -# TBD - this is passed to compiler as TCL_CFGVAL_ENCODING but can't -# see where it is used cc32 = $(CC) # built-in default. link32 = link @@ -503,10 +500,6 @@ _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -ou _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif -!ifndef CFG_ENCODING -CFG_ENCODING = \"cp1252\" -!endif - ################################################################ # 4. Build the nmakehlp program # This is a helper app we need to overcome nmake's limiting @@ -1043,7 +1036,7 @@ BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif -!if !$(DEBUG) || $(DEBUG) && $(UNCHECKED) +!if !$(DEBUG) || $(TCL_VERSION) > 86 || $(DEBUG) && $(UNCHECKED) SUFX = $(SUFX:g=) !endif @@ -1292,7 +1285,7 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed -OPTDEFINES = /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS +OPTDEFINES = /DSTDC_HEADERS !if $(VCVERSION) >= 1600 OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 !else -- cgit v0.12 From ba6beed687edac8e849dc8fcd7eb32aeae1939ce Mon Sep 17 00:00:00 2001 From: marc_culler Date: Thu, 15 Oct 2020 17:48:14 +0000 Subject: Simpler, better fix of [c2483bfe4b]: unwanted fontchooser can appear. Uses Tcl_SetExitProc. --- macosx/tkMacOSXHLEvents.c | 5 ++++ macosx/tkMacOSXInit.c | 64 +++++++++++++++++++++++++++++++++++++++++++++++ macosx/tkMacOSXPrivate.h | 1 + 3 files changed, 70 insertions(+) diff --git a/macosx/tkMacOSXHLEvents.c b/macosx/tkMacOSXHLEvents.c index 258740b..615653d 100644 --- a/macosx/tkMacOSXHLEvents.c +++ b/macosx/tkMacOSXHLEvents.c @@ -68,6 +68,11 @@ static const char *scriptTextProc = "::tk::mac::DoScriptText"; [self handleQuitApplicationEvent:Nil withReplyEvent:Nil]; } +- (void) superTerminate: (id) sender +{ + [super terminate:nil]; +} + - (void) preferences: (id) sender { [self handleShowPreferencesEvent:Nil withReplyEvent:Nil]; diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index bda5f46..cfaf631 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -270,6 +270,55 @@ static int TkMacOSXGetAppPathCmd(ClientData cd, Tcl_Interp *ip, *---------------------------------------------------------------------- */ +/* + * Helper function which closes the shared NSFontPanel and NSColorPanel. + */ + +static void closePanels( + void) +{ + if ([NSFontPanel sharedFontPanelExists]) { + [[NSFontPanel sharedFontPanel] orderOut:nil]; + } + if ([NSColorPanel sharedColorPanelExists]) { + [[NSColorPanel sharedColorPanel] orderOut:nil]; + } +} + +/* + * This custom exit procedure is called by Tcl_Exit in place of the exit + * function from the C runtime. It calls the terminate method of the + * NSApplication class (superTerminate for a TKApplication). The purpose of + * doing this is to ensure that the NSFontPanel and the NSColorPanel are closed + * before the process exits, and that the application state is recorded + * correctly for all termination scenarios. If this is called a second time + * (as can happen) call the C runtime exit function. + */ + +TCL_NORETURN void TkMacOSXExitProc( + ClientData clientdata) +{ + static bool calledBefore = NO; + if (!calledBefore) { + calledBefore = YES; + closePanels(); + Tcl_Finalize(); + [(TKApplication *)NSApp superTerminate:nil]; /* Should not return. */ + } + exit((int)clientdata); +} + +/* + * This SIGINT handler is installed when Wish is run in a shell to make sure + * that normal finalization occurs when SIGINT is received (i.e. when ^C is + * pressed in the shell). It calls Tcl_Exit instead of the C runtime exit + * function called by the default handler. + */ + +static void sigintHandler(int signal) { + Tcl_Exit(1); +} + int TkpInit( Tcl_Interp *interp) @@ -439,6 +488,21 @@ TkpInit( break; } } + + /* + * Install our custom exit proc, which terminates the NSApplication. + */ + + Tcl_SetExitProc(TkMacOSXExitProc); + + /* + * When Wish is run from a terminal, install a sigint handler to make + * sure that normal cleanup takes place if the app is killed with ^C. + */ + + if (isatty(0)) { + signal(SIGINT, sigintHandler); + } } /* diff --git a/macosx/tkMacOSXPrivate.h b/macosx/tkMacOSXPrivate.h index 4c07557..9617712 100644 --- a/macosx/tkMacOSXPrivate.h +++ b/macosx/tkMacOSXPrivate.h @@ -381,6 +381,7 @@ VISIBILITY_HIDDEN @end @interface TKApplication(TKHLEvents) - (void) terminate: (id) sender; +- (void) superTerminate: (id) sender; - (void) preferences: (id) sender; - (void) handleQuitApplicationEvent: (NSAppleEventDescriptor *)event withReplyEvent: (NSAppleEventDescriptor *)replyEvent; -- cgit v0.12 From 2a312582921609ee854c5af4e608e2e3065371c8 Mon Sep 17 00:00:00 2001 From: marc_culler Date: Thu, 15 Oct 2020 18:08:31 +0000 Subject: Even simpler - remove out of place calls to Tcl_Finalize --- macosx/tkMacOSXInit.c | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index cfaf631..e1d586c 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -291,21 +291,15 @@ static void closePanels( * NSApplication class (superTerminate for a TKApplication). The purpose of * doing this is to ensure that the NSFontPanel and the NSColorPanel are closed * before the process exits, and that the application state is recorded - * correctly for all termination scenarios. If this is called a second time - * (as can happen) call the C runtime exit function. + * correctly for all termination scenarios. */ TCL_NORETURN void TkMacOSXExitProc( ClientData clientdata) { - static bool calledBefore = NO; - if (!calledBefore) { - calledBefore = YES; - closePanels(); - Tcl_Finalize(); - [(TKApplication *)NSApp superTerminate:nil]; /* Should not return. */ - } - exit((int)clientdata); + closePanels(); + [(TKApplication *)NSApp superTerminate:nil]; /* Does not return. */ + exit((int)clientdata); /* Convince the compiler that we don't return. */ } /* -- cgit v0.12 From 6379b15d7f1ac05c4943c92f28ad7cc2486facc5 Mon Sep 17 00:00:00 2001 From: marc_culler Date: Thu, 15 Oct 2020 18:37:42 +0000 Subject: Use Tcl_Exit when handling SIGHUP and SIGTERM too. --- macosx/tkMacOSXInit.c | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index e1d586c..950a50f 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -303,13 +303,15 @@ TCL_NORETURN void TkMacOSXExitProc( } /* - * This SIGINT handler is installed when Wish is run in a shell to make sure - * that normal finalization occurs when SIGINT is received (i.e. when ^C is - * pressed in the shell). It calls Tcl_Exit instead of the C runtime exit - * function called by the default handler. + * This signal handler is installed for the SIGINT, SIGHUP and SIGTERM signals + * so that normal finalization occurs when a Tk app is killed by one of these + * signals (e.g when ^C is pressed while running Wish in the shell). It calls + * Tcl_Exit instead of the C runtime exit function called by the default handler. + * This is consistent with the Tcl_Exit manual page, which says that Tcl_Exit + * should always be called instead of exit. */ -static void sigintHandler(int signal) { +static void TkMacOSXSignalHandler(int signal) { Tcl_Exit(1); } @@ -490,13 +492,14 @@ TkpInit( Tcl_SetExitProc(TkMacOSXExitProc); /* - * When Wish is run from a terminal, install a sigint handler to make - * sure that normal cleanup takes place if the app is killed with ^C. + * Install a signal handler for SIGINT, SIGHUP and SIGTERM which uses + * Tcl_Exit instead of exit so that normal cleanup takes place if a TK + * application is killed with one of these signals. */ - if (isatty(0)) { - signal(SIGINT, sigintHandler); - } + signal(SIGINT, TkMacOSXSignalHandler); + signal(SIGHUP, TkMacOSXSignalHandler); + signal(SIGTERM, TkMacOSXSignalHandler); } /* -- cgit v0.12 From 5783d04a34a4c680ea7db932c5db2c4aa8691a2e Mon Sep 17 00:00:00 2001 From: marc_culler Date: Fri, 16 Oct 2020 13:11:57 +0000 Subject: Do not call Tcl_SetExitProc when the Tk process is part of an exec pipeline. --- macosx/tkMacOSXInit.c | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index 950a50f..73d2b82 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -308,7 +308,8 @@ TCL_NORETURN void TkMacOSXExitProc( * signals (e.g when ^C is pressed while running Wish in the shell). It calls * Tcl_Exit instead of the C runtime exit function called by the default handler. * This is consistent with the Tcl_Exit manual page, which says that Tcl_Exit - * should always be called instead of exit. + * should always be called instead of exit. When Tk is killed by a signal we + * return exit status 1. */ static void TkMacOSXSignalHandler(int signal) { @@ -329,6 +330,7 @@ TkpInit( if (!initialized) { struct stat st; Bool shouldOpenConsole = NO; + Bool isLaunched = NO; Bool stdinIsNullish = (!isatty(0) && (fstat(0, &st) || (S_ISCHR(st.st_mode) && st.st_blocks == 0))); @@ -343,6 +345,7 @@ TkpInit( initialized = 1; #ifdef TK_FRAMEWORK + /* * When Tk is in a framework, force tcl_findLibrary to look in the * framework scripts directory. @@ -449,6 +452,7 @@ TkpInit( FILE *null = fopen("/dev/null", "w"); dup2(fileno(null), STDOUT_FILENO); dup2(fileno(null), STDERR_FILENO); + isLaunched = YES; } /* @@ -486,10 +490,15 @@ TkpInit( } /* - * Install our custom exit proc, which terminates the NSApplication. + * Install our custom exit proc, which terminates the process by + * calling [NSApplication terminate]. This does not work correctly if + * we are part of an exec pipeline, so only use it if this process + * was launched by the launcher or if both stdin and stdout are tttys. */ - Tcl_SetExitProc(TkMacOSXExitProc); + if (isLaunched || (isatty(0) && isatty(1))) { + Tcl_SetExitProc(TkMacOSXExitProc); + } /* * Install a signal handler for SIGINT, SIGHUP and SIGTERM which uses -- cgit v0.12 From ff9955565a1fcf3cec963f198a2f48e61e7fc402 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Oct 2020 16:40:55 +0000 Subject: Another select-* testcase which sometimes fails --- tests/select.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/select.test b/tests/select.test index 31d6494..6bd2c9d 100644 --- a/tests/select.test +++ b/tests/select.test @@ -1132,7 +1132,7 @@ test select-12.6 {DefaultSelection procedure} -body { } -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-13.1 {SelectionSize procedure, handler deleted} -constraints { - x11 + x11 failsOnUbuntu } -setup { setup setupbg -- cgit v0.12 From c85b5609e7aad61ee31d389f004694f3be62db35 Mon Sep 17 00:00:00 2001 From: culler Date: Fri, 16 Oct 2020 20:45:29 +0000 Subject: Allow opting out of using the custom Tcl_ExitProc by defining USE_SYSTEM_EXIT --- macosx/tkMacOSXInit.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index 73d2b82..e895cc0 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -492,14 +492,19 @@ TkpInit( /* * Install our custom exit proc, which terminates the process by * calling [NSApplication terminate]. This does not work correctly if - * we are part of an exec pipeline, so only use it if this process - * was launched by the launcher or if both stdin and stdout are tttys. + * the process is part of an exec pipeline, so it is only used if the + * process was launched by the launcher or if both stdin and stdout are + * ttys. */ +# if !defined(USE_SYSTEM_EXIT) + if (isLaunched || (isatty(0) && isatty(1))) { Tcl_SetExitProc(TkMacOSXExitProc); } +# endif + /* * Install a signal handler for SIGINT, SIGHUP and SIGTERM which uses * Tcl_Exit instead of exit so that normal cleanup takes place if a TK -- cgit v0.12 From bf3d9667d064c7fc220c59d38964f335a01b0a26 Mon Sep 17 00:00:00 2001 From: culler Date: Fri, 16 Oct 2020 21:52:16 +0000 Subject: Use TCL_UNUSED in the signal handler --- macosx/tkMacOSXInit.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index e895cc0..ded25fc 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -312,7 +312,7 @@ TCL_NORETURN void TkMacOSXExitProc( * return exit status 1. */ -static void TkMacOSXSignalHandler(int signal) { +static void TkMacOSXSignalHandler(TCL_UNUSED(int)) { Tcl_Exit(1); } -- cgit v0.12 From 2a92717a443e8caee17f51dae951666b9191d803 Mon Sep 17 00:00:00 2001 From: marc_culler Date: Sat, 17 Oct 2020 17:31:40 +0000 Subject: Small adjustment to d69b5cec: make sure Tcl_Finalize *always* gets called. --- macosx/tkMacOSXInit.c | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index e895cc0..c7ee971 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -298,7 +298,20 @@ TCL_NORETURN void TkMacOSXExitProc( ClientData clientdata) { closePanels(); - [(TKApplication *)NSApp superTerminate:nil]; /* Does not return. */ + + /* + * Make sure we don't get called again. This can happen, e.g. with + * fossil diff -tk. + */ + + Tcl_SetExitProc(NULL); + + /* + * Tcl_Exit does not call Tcl_Finalize if there is an exit proc installed. + */ + + Tcl_Finalize(); + [(TKApplication *)NSApp superTerminate:nil]; /* Should not return. */ exit((int)clientdata); /* Convince the compiler that we don't return. */ } @@ -430,6 +443,7 @@ TkpInit( Tcl_SetVar2(interp, "tcl_interactive", NULL, "1", TCL_GLOBAL_ONLY); } + isLaunched = YES; shouldOpenConsole = YES; } if (shouldOpenConsole) { @@ -494,13 +508,16 @@ TkpInit( * calling [NSApplication terminate]. This does not work correctly if * the process is part of an exec pipeline, so it is only used if the * process was launched by the launcher or if both stdin and stdout are - * ttys. + * ttys. If an exit proc was already installed we leave it in place. */ # if !defined(USE_SYSTEM_EXIT) if (isLaunched || (isatty(0) && isatty(1))) { - Tcl_SetExitProc(TkMacOSXExitProc); + Tcl_ExitProc *prevExitProc = Tcl_SetExitProc(TkMacOSXExitProc); + if (prevExitProc) { + Tcl_SetExitProc(prevExitProc); + } } # endif -- cgit v0.12 From b8204820666fbfae9d5ea23deb3e1281ed131164 Mon Sep 17 00:00:00 2001 From: marc_culler Date: Sat, 17 Oct 2020 18:07:39 +0000 Subject: Add cast to fix annoying compiler warning. --- macosx/tkMacOSXInit.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index c7ee971..0e7dfe4 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -516,7 +516,7 @@ TkpInit( if (isLaunched || (isatty(0) && isatty(1))) { Tcl_ExitProc *prevExitProc = Tcl_SetExitProc(TkMacOSXExitProc); if (prevExitProc) { - Tcl_SetExitProc(prevExitProc); + Tcl_SetExitProc((TCL_NORETURN Tcl_ExitProc *)prevExitProc); } } -- cgit v0.12 From ee57c6cb6fe12b3fb2cceb7d3112f03c66f36c3f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Oct 2020 12:41:45 +0000 Subject: Update to latest 'install-sh' --- unix/install-sh | 412 +++++++++++++++++++++++++++----------------------------- 1 file changed, 201 insertions(+), 211 deletions(-) diff --git a/unix/install-sh b/unix/install-sh index 7c34c3f..21b733a 100755 --- a/unix/install-sh +++ b/unix/install-sh @@ -1,7 +1,7 @@ #!/bin/sh # install - install a program, script, or datafile -scriptversion=2011-04-20.01; # UTC +scriptversion=2020-07-26.22; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the @@ -35,25 +35,21 @@ scriptversion=2011-04-20.01; # UTC # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it +# 'make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. +tab=' ' nl=' ' -IFS=" "" $nl" +IFS=" $tab$nl" -# set DOITPROG to echo to test this script +# Set DOITPROG to "echo" to test this script. -# Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} -if test -z "$doit"; then - doit_exec=exec -else - doit_exec=$doit -fi +doit_exec=${doit:-exec} # Put in absolute file names if you don't have them in your path; # or use environment vars. @@ -68,22 +64,15 @@ mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} -posix_glob='?' -initialize_posix_glob=' - test "$posix_glob" != "?" || { - if (set -f) 2>/dev/null; then - posix_glob= - else - posix_glob=: - fi - } -' - posix_mkdir= # Desired mode of installed file. mode=0755 +# Create dirs (including intermediate dirs) using mode 755. +# This is like GNU 'install' as of coreutils 8.32 (2020). +mkdir_umask=22 + chgrpcmd= chmodcmd=$chmodprog chowncmd= @@ -97,7 +86,7 @@ dir_arg= dst_arg= copy_on_change=false -no_target_directory= +is_target_a_directory=possibly usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE @@ -120,7 +109,7 @@ Options: -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. - -S $stripprog installed files. + -S OPTION $stripprog installed files using OPTION. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. @@ -138,45 +127,60 @@ while test $# -ne 0; do -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" - shift;; + shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 - case $mode in - *' '* | *' '* | *' -'* | *'*'* | *'?'* | *'['*) - echo "$0: invalid mode: $mode" >&2 - exit 1;; - esac - shift;; + case $mode in + *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; -o) chowncmd="$chownprog $2" - shift;; + shift;; -s) stripcmd=$stripprog;; -S) stripcmd="$stripprog $2" - shift;; + shift;; - -t) dst_arg=$2 - shift;; + -t) + is_target_a_directory=always + dst_arg=$2 + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + shift;; - -T) no_target_directory=true;; + -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; - --) shift - break;; + --) shift + break;; - -*) echo "$0: invalid option: $1" >&2 - exit 1;; + -*) echo "$0: invalid option: $1" >&2 + exit 1;; *) break;; esac shift done +# We allow the use of options -d and -T together, by making -d +# take the precedence; this is for compatibility with GNU install. + +if test -n "$dir_arg"; then + if test -n "$dst_arg"; then + echo "$0: target directory not allowed when installing a directory." >&2 + exit 1 + fi +fi + if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. @@ -190,6 +194,10 @@ if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then fi shift # arg dst_arg=$arg + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac done fi @@ -198,12 +206,21 @@ if test $# -eq 0; then echo "$0: no input file specified." >&2 exit 1 fi - # It's OK to call `install-sh -d' without argument. + # It's OK to call 'install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then + if test $# -gt 1 || test "$is_target_a_directory" = always; then + if test ! -d "$dst_arg"; then + echo "$0: $dst_arg: Is not a directory." >&2 + exit 1 + fi + fi +fi + +if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 @@ -219,16 +236,16 @@ if test -z "$dir_arg"; then *[0-7]) if test -z "$stripcmd"; then - u_plus_rw= + u_plus_rw= else - u_plus_rw='% 200' + u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then - u_plus_rw= + u_plus_rw= else - u_plus_rw=,u+rw + u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac @@ -236,9 +253,9 @@ fi for src do - # Protect names starting with `-'. + # Protect names problematic for 'test' and other utilities. case $src in - -*) src=./$src;; + -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then @@ -260,185 +277,150 @@ do echo "$0: no destination specified." >&2 exit 1 fi - dst=$dst_arg - # Protect names starting with `-'. - case $dst in - -*) dst=./$dst;; - esac - # If destination is a directory, append the input filename; won't work - # if double slashes aren't ignored. + # If destination is a directory, append the input filename. if test -d "$dst"; then - if test -n "$no_target_directory"; then - echo "$0: $dst_arg: Is a directory" >&2 - exit 1 + if test "$is_target_a_directory" = never; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 fi dstdir=$dst - dst=$dstdir/`basename "$src"` + dstbase=`basename "$src"` + case $dst in + */) dst=$dst$dstbase;; + *) dst=$dst/$dstbase;; + esac dstdir_status=0 else - # Prefer dirname, but fall back on a substitute if dirname fails. - dstdir=` - (dirname "$dst") 2>/dev/null || - expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$dst" : 'X\(//\)[^/]' \| \ - X"$dst" : 'X\(//\)$' \| \ - X"$dst" : 'X\(/\)' \| . 2>/dev/null || - echo X"$dst" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q' - ` - + dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi fi + case $dstdir in + */) dstdirslash=$dstdir;; + *) dstdirslash=$dstdir/;; + esac + obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') - # Create intermediate dirs using mode 755 as modified by the umask. - # This is like FreeBSD 'install' as of 1997-10-28. - umask=`umask` - case $stripcmd.$umask in - # Optimize common cases. - *[2367][2367]) mkdir_umask=$umask;; - .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; - - *[0-7]) - mkdir_umask=`expr $umask + 22 \ - - $umask % 100 % 40 + $umask % 20 \ - - $umask % 10 % 4 + $umask % 2 - `;; - *) mkdir_umask=$umask,go-w;; - esac - - # With -d, create the new directory with the user-specified mode. - # Otherwise, rely on $mkdir_umask. - if test -n "$dir_arg"; then - mkdir_mode=-m$mode + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + # The $RANDOM variable is not portable (e.g., dash). Use it + # here however when possible just to lower collision chance. + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + + trap ' + ret=$? + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null + exit $ret + ' 0 + + # Because "mkdir -p" follows existing symlinks and we likely work + # directly in world-writeable /tmp, make sure that the '$tmpdir' + # directory is successfully created first before we actually test + # 'mkdir -p'. + if (umask $mkdir_umask && + $mkdirprog $mkdir_mode "$tmpdir" && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + test_tmpdir="$tmpdir/a" + ls_ld_tmpdir=`ls -ld "$test_tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" else - mkdir_mode= + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null fi - - posix_mkdir=false - case $umask in - *[123567][0-7][0-7]) - # POSIX mkdir -p sets u+wx bits regardless of umask, which - # is incompatible with FreeBSD 'install' when (umask & 300) != 0. - ;; - *) - tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ - trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 - - if (umask $mkdir_umask && - exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 - then - if test -z "$dir_arg" || { - # Check for POSIX incompatibilities with -m. - # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or - # other-writeable bit of parent directory when it shouldn't. - # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. - ls_ld_tmpdir=`ls -ld "$tmpdir"` - case $ls_ld_tmpdir in - d????-?r-*) different_mode=700;; - d????-?--*) different_mode=755;; - *) false;; - esac && - $mkdirprog -m$different_mode -p -- "$tmpdir" && { - ls_ld_tmpdir_1=`ls -ld "$tmpdir"` - test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" - } - } - then posix_mkdir=: - fi - rmdir "$tmpdir/d" "$tmpdir" - else - # Remove any dirs left behind by ancient mkdir implementations. - rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null - fi - trap '' 0;; - esac;; + trap '' 0;; esac if $posix_mkdir && ( - umask $mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else - # The umask is ridiculous, or mkdir does not conform to POSIX, + # mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in - /*) prefix='/';; - -*) prefix='./';; - *) prefix='';; + /*) prefix='/';; + [-=\(\)!]*) prefix='./';; + *) prefix='';; esac - eval "$initialize_posix_glob" - oIFS=$IFS IFS=/ - $posix_glob set -f + set -f set fnord $dstdir shift - $posix_glob set +f + set +f IFS=$oIFS prefixes= for d do - test -z "$d" && continue - - prefix=$prefix$d - if test -d "$prefix"; then - prefixes= - else - if $posix_mkdir; then - (umask=$mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break - # Don't fail if two instances are running concurrently. - test -d "$prefix" || exit 1 - else - case $prefix in - *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; - *) qprefix=$prefix;; - esac - prefixes="$prefixes '$qprefix'" - fi - fi - prefix=$prefix/ + test X"$d" = X && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ done if test -n "$prefixes"; then - # Don't fail if two instances are running concurrently. - (umask $mkdir_umask && - eval "\$doit_exec \$mkdirprog $prefixes") || - test -d "$dstdir" || exit 1 - obsolete_mkdir_used=true + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true fi fi fi @@ -451,14 +433,25 @@ do else # Make a couple of temp file names in the proper directory. - dsttmp=$dstdir/_inst.$$_ - rmtmp=$dstdir/_rm.$$_ + dsttmp=${dstdirslash}_inst.$$_ + rmtmp=${dstdirslash}_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. - (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + (umask $cp_umask && + { test -z "$stripcmd" || { + # Create $dsttmp read-write so that cp doesn't create it read-only, + # which would cause strip to fail. + if test -z "$doit"; then + : >"$dsttmp" # No need to fork-exec 'touch'. + else + $doit touch "$dsttmp" + fi + } + } && + $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # @@ -473,15 +466,12 @@ do # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && - old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && - new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && - - eval "$initialize_posix_glob" && - $posix_glob set -f && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && - $posix_glob set +f && - + set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then @@ -494,24 +484,24 @@ do # to itself, or perhaps because mv is so ancient that it does not # support -f. { - # Now remove or move aside any old file at destination location. - # We try this two ways since rm can't unlink itself on some - # systems and the destination file might be busy for other - # reasons. In this case, the final cleanup might fail but the new - # file should still install successfully. - { - test ! -f "$dst" || - $doit $rmcmd -f "$dst" 2>/dev/null || - { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && - { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } - } || - { echo "$0: cannot unlink or rename $dst" >&2 - (exit 1); exit 1 - } - } && - - # Now rename the file to the real destination. - $doit $mvcmd "$dsttmp" "$dst" + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 @@ -520,9 +510,9 @@ do done # Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) +# eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" -# End: +# End: \ No newline at end of file -- cgit v0.12 From 0b7c717e2ae38744c93c132854c2913a6ef76f5e Mon Sep 17 00:00:00 2001 From: marc_culler Date: Mon, 19 Oct 2020 19:27:04 +0000 Subject: Add a make variable to GNUmakefile for building the Tk.framework for use as a subframework --- macosx/GNUmakefile | 19 ++++++++++++++++--- macosx/README | 14 ++++++++++++++ 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index 3b4dd1a..2c9ea6f 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -211,8 +211,14 @@ install-${PROJECT}: build-${PROJECT} ifeq (${EMBEDDED_BUILD}_${INSTALL_ROOT},1_) @echo "Cannot install-embedded with empty INSTALL_ROOT !" && false endif +ifeq (${SUBFRAMEWORK}_${DYLIB_INSTALL_DIR},1_) + @echo "Cannot install-subframework with empty DYLIB_INSTALL_DIR !" && false +endif ifeq (${EMBEDDED_BUILD},1) - @rm -rf "${INSTALL_ROOT}/${LIBDIR}/Tk.framework" + @rm -rf "${INSTALL_ROOT}${LIBDIR}/Tk.framework" +endif +ifeq (${SUBFRAMEWORK},1) + @rm -rf "${INSTALL_ROOT}/Frameworks/Tk.framework" endif ${DO_MAKE} ifeq (${EMBEDDED_BUILD}_${TK_X11},1_) @@ -239,7 +245,8 @@ ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_) ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug" endif ifeq (${TK_X11},) -ifeq (${EMBEDDED_BUILD},) +ifeq (${SUBFRAMEWORK},) +ifeq (${EMBEDDED_BUILD},1) # install Wish.app link in APPLICATION_INSTALL_PATH and setup 'Wish Shell' compatibility links @cd "${TOP_DIR}" && if [ -n "${APP_DIR}" ]; then mkdir -p "./${APP_DIR}" && rm -rf "./${APP_DIR}/Wish.app" && \ ln -fsh "./$$(echo "${APP_DIR}" | sed -e 's#/[^/][^/]*#/..#g')/${FMWK_DIR}/${PRODUCT_NAME}.framework/Resources/Wish.app" "./${APP_DIR}" && \ @@ -270,10 +277,16 @@ else } && \ fix_install_id Frameworks/Tcl.framework/Tcl Tcl && fix_install_id Frameworks/Tk.framework/Tk Tk && \ fix_install_name MacOS/Wish Tcl && fix_install_name MacOS/Wish Tk -ifeq (${INSTALL_BUILD},1) +ifeq (${INSTALL_BUILD},) @cd "${TOP_DIR}" && rm -rf "./${FMWK_DIR}"/T{cl,k}.framework && rmdir -p "./${FMWK_DIR}" 2>&- || true endif endif +else +# Clean up the destination directory + @rm -rf ${INSTALL_ROOT}/Frameworks + @mv "${INSTALL_ROOT}/Library/Frameworks" "${INSTALL_ROOT}" + @rm -rf ${INSTALL_ROOT}/Library +endif endif clean-${PROJECT}: %-${PROJECT}: diff --git a/macosx/README b/macosx/README index 0a02999..e0316f0 100644 --- a/macosx/README +++ b/macosx/README @@ -455,6 +455,20 @@ make overrides to the tk/macosx GNUmakefile, e.g. TCL_FRAMEWORK_DIR=$HOME/Library/Frameworks TCLSH_DIR=$HOME/usr/bin The Makefile variables TCL_FRAMEWORK_DIR and TCLSH_DIR were added with Tk 8.4.3. +- To build a Tcl.framework and Tk.framework for use as subframeworks in another +framework, use the install-embedded target and set SUBFRAMEWORK=1. Set the +DYLIB_INSTALL_DIR variable to the path which should be the install_name path of +the shared library and set the DESTDIR variable to the pathname of a staging +directory where the frameworks will be written. For example, running the commands: + cd Tcl_src + make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcltk \ + DYLIB_INSTALL_DIR=/Library/Frameworks/Python.framework/Versions/3.9/Frameworks/Tcl + cd ../Tk_src + make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcltk \ + DYLIB_INSTALL_DIR=/Library/Frameworks/Python.framework/Versions/3.9/Frameworks/Tk +will produce a Tcl.framework and a Tk.framework usable as subframeworks of the +Python.framework. The frameworks will be found in /tmp/tcl/Library/Frameworks/ + 5. Details regarding the macOS port of Tk. ------------------------------------------- -- cgit v0.12 From 61ae443d9fcf2d03327ec43fe5a0320125c2592f Mon Sep 17 00:00:00 2001 From: marc_culler Date: Mon, 19 Oct 2020 19:42:05 +0000 Subject: typo --- macosx/README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/macosx/README b/macosx/README index e0316f0..3b38299 100644 --- a/macosx/README +++ b/macosx/README @@ -467,7 +467,7 @@ directory where the frameworks will be written. For example, running the comman make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcltk \ DYLIB_INSTALL_DIR=/Library/Frameworks/Python.framework/Versions/3.9/Frameworks/Tk will produce a Tcl.framework and a Tk.framework usable as subframeworks of the -Python.framework. The frameworks will be found in /tmp/tcl/Library/Frameworks/ +Python.framework. The frameworks will be found in /tmp/tcltk/Frameworks/ 5. Details regarding the macOS port of Tk. ------------------------------------------- -- cgit v0.12 From 479ffca988d6556e568f4fb393a2ced2e93ad8ad Mon Sep 17 00:00:00 2001 From: marc_culler Date: Mon, 19 Oct 2020 20:28:40 +0000 Subject: Fix the build by removing calls to deprecated Tcl_SetExitProc. This means that [c2483bfe4b] is not fixed for 8.7. --- macosx/tkMacOSXInit.c | 64 --------------------------------------------------- 1 file changed, 64 deletions(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index 7299e93..d49422b 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -271,51 +271,6 @@ static int TkMacOSXGetAppPathCmd(ClientData cd, Tcl_Interp *ip, */ /* - * Helper function which closes the shared NSFontPanel and NSColorPanel. - */ - -static void closePanels( - void) -{ - if ([NSFontPanel sharedFontPanelExists]) { - [[NSFontPanel sharedFontPanel] orderOut:nil]; - } - if ([NSColorPanel sharedColorPanelExists]) { - [[NSColorPanel sharedColorPanel] orderOut:nil]; - } -} - -/* - * This custom exit procedure is called by Tcl_Exit in place of the exit - * function from the C runtime. It calls the terminate method of the - * NSApplication class (superTerminate for a TKApplication). The purpose of - * doing this is to ensure that the NSFontPanel and the NSColorPanel are closed - * before the process exits, and that the application state is recorded - * correctly for all termination scenarios. - */ - -TCL_NORETURN void TkMacOSXExitProc( - ClientData clientdata) -{ - closePanels(); - - /* - * Make sure we don't get called again. This can happen, e.g. with - * fossil diff -tk. - */ - - Tcl_SetExitProc(NULL); - - /* - * Tcl_Exit does not call Tcl_Finalize if there is an exit proc installed. - */ - - Tcl_Finalize(); - [(TKApplication *)NSApp superTerminate:nil]; /* Should not return. */ - exit((int)clientdata); /* Convince the compiler that we don't return. */ -} - -/* * This signal handler is installed for the SIGINT, SIGHUP and SIGTERM signals * so that normal finalization occurs when a Tk app is killed by one of these * signals (e.g when ^C is pressed while running Wish in the shell). It calls @@ -504,25 +459,6 @@ TkpInit( } /* - * Install our custom exit proc, which terminates the process by - * calling [NSApplication terminate]. This does not work correctly if - * the process is part of an exec pipeline, so it is only used if the - * process was launched by the launcher or if both stdin and stdout are - * ttys. If an exit proc was already installed we leave it in place. - */ - -# if !defined(USE_SYSTEM_EXIT) - - if (isLaunched || (isatty(0) && isatty(1))) { - Tcl_ExitProc *prevExitProc = Tcl_SetExitProc(TkMacOSXExitProc); - if (prevExitProc) { - Tcl_SetExitProc((TCL_NORETURN Tcl_ExitProc *)prevExitProc); - } - } - -# endif - - /* * Install a signal handler for SIGINT, SIGHUP and SIGTERM which uses * Tcl_Exit instead of exit so that normal cleanup takes place if a TK * application is killed with one of these signals. -- cgit v0.12 From 688d1318a11f09dd8b0300bf67ac783abe1b85d4 Mon Sep 17 00:00:00 2001 From: culler Date: Tue, 20 Oct 2020 04:32:25 +0000 Subject: Fix ifeq test which accidentally got reversed in GNUmakefile --- macosx/GNUmakefile | 24 ++++++++++++------------ macosx/README | 10 +++++++++- 2 files changed, 21 insertions(+), 13 deletions(-) diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index 2c9ea6f..f9410cc 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -212,10 +212,10 @@ ifeq (${EMBEDDED_BUILD}_${INSTALL_ROOT},1_) @echo "Cannot install-embedded with empty INSTALL_ROOT !" && false endif ifeq (${SUBFRAMEWORK}_${DYLIB_INSTALL_DIR},1_) - @echo "Cannot install-subframework with empty DYLIB_INSTALL_DIR !" && false + @echo "Cannot install subframework with empty DYLIB_INSTALL_DIR !" && false endif ifeq (${EMBEDDED_BUILD},1) - @rm -rf "${INSTALL_ROOT}${LIBDIR}/Tk.framework" + @rm -rf "${INSTALL_ROOT}/${LIBDIR}/Tk.framework" endif ifeq (${SUBFRAMEWORK},1) @rm -rf "${INSTALL_ROOT}/Frameworks/Tk.framework" @@ -234,8 +234,8 @@ ifeq (${EMBEDDED_BUILD},1) else # install wish symbolic link @ln -fs ${WISH} "${INSTALL_ROOT}${BINDIR}/${wish}" -endif -endif +endif # embedded +endif # install ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_) # keep copy of debug library around, so that # Deployment build can be installed on top @@ -243,10 +243,10 @@ ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_) # the debug library @cd "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}" && \ ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug" -endif +endif # Development, not embedded ifeq (${TK_X11},) ifeq (${SUBFRAMEWORK},) -ifeq (${EMBEDDED_BUILD},1) +ifeq (${EMBEDDED_BUILD},) # install Wish.app link in APPLICATION_INSTALL_PATH and setup 'Wish Shell' compatibility links @cd "${TOP_DIR}" && if [ -n "${APP_DIR}" ]; then mkdir -p "./${APP_DIR}" && rm -rf "./${APP_DIR}/Wish.app" && \ ln -fsh "./$$(echo "${APP_DIR}" | sed -e 's#/[^/][^/]*#/..#g')/${FMWK_DIR}/${PRODUCT_NAME}.framework/Resources/Wish.app" "./${APP_DIR}" && \ @@ -277,17 +277,17 @@ else } && \ fix_install_id Frameworks/Tcl.framework/Tcl Tcl && fix_install_id Frameworks/Tk.framework/Tk Tk && \ fix_install_name MacOS/Wish Tcl && fix_install_name MacOS/Wish Tk -ifeq (${INSTALL_BUILD},) +ifeq (${INSTALL_BUILD},1) @cd "${TOP_DIR}" && rm -rf "./${FMWK_DIR}"/T{cl,k}.framework && rmdir -p "./${FMWK_DIR}" 2>&- || true -endif -endif +endif # install +endif # embedded else -# Clean up the destination directory +# Clean up the destination directory if this is a subframework @rm -rf ${INSTALL_ROOT}/Frameworks @mv "${INSTALL_ROOT}/Library/Frameworks" "${INSTALL_ROOT}" @rm -rf ${INSTALL_ROOT}/Library -endif -endif +endif # not subframework +endif # not X11 clean-${PROJECT}: %-${PROJECT}: ${DO_MAKE} diff --git a/macosx/README b/macosx/README index 3b38299..0cc7715 100644 --- a/macosx/README +++ b/macosx/README @@ -459,13 +459,21 @@ The Makefile variables TCL_FRAMEWORK_DIR and TCLSH_DIR were added with Tk 8.4.3. framework, use the install-embedded target and set SUBFRAMEWORK=1. Set the DYLIB_INSTALL_DIR variable to the path which should be the install_name path of the shared library and set the DESTDIR variable to the pathname of a staging -directory where the frameworks will be written. For example, running the commands: +directory where the frameworks will be written. Since the install_name is written +at compile time, this build requires starting with an empty build directory. +Also, the build will leave frameworks in the build directory that cannot be +installed in the standard /Library/Frameworks directory. To avoid surprises, +delete the build directory after the frameworks are built. +For example, running the commands: + rm -rf build cd Tcl_src make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcltk \ DYLIB_INSTALL_DIR=/Library/Frameworks/Python.framework/Versions/3.9/Frameworks/Tcl cd ../Tk_src make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcltk \ DYLIB_INSTALL_DIR=/Library/Frameworks/Python.framework/Versions/3.9/Frameworks/Tk + cd .. + rm -rf build will produce a Tcl.framework and a Tk.framework usable as subframeworks of the Python.framework. The frameworks will be found in /tmp/tcltk/Frameworks/ -- cgit v0.12 From 6453a55538a3e3af1fbf3ae0b905988967a2200a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 20 Oct 2020 10:10:34 +0000 Subject: Proposed fix for [c2483bfe4b]: tk fontchooser on macOS can automatically open on startup, can lead to crashes. Which also works for Tcl 8.7 and 9.0 --- generic/tkPlatDecls.h | 5 +++++ macosx/tkMacOSXInit.c | 45 +++++++++++++++++++++++++++------------------ unix/tkAppInit.c | 8 ++++++++ 3 files changed, 40 insertions(+), 18 deletions(-) diff --git a/generic/tkPlatDecls.h b/generic/tkPlatDecls.h index bad633f..2fea41e 100644 --- a/generic/tkPlatDecls.h +++ b/generic/tkPlatDecls.h @@ -193,6 +193,11 @@ extern const TkPlatStubs *tkPlatStubsPtr; /* !END!: Do not edit above this line. */ +#if !defined(USE_SYSTEM_EXIT) && defined(MAC_OSX_TK) +EXTERN int TkMacOSXIsLaunched(void); +EXTERN TCL_NORETURN void TkMacOSXExitProc(void *); +#endif + #ifdef __cplusplus } #endif diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index 0e7dfe4..1323333 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -294,26 +294,33 @@ static void closePanels( * correctly for all termination scenarios. */ +#if !defined(USE_SYSTEM_EXIT) +static Bool doCleanupFromExit = NO; + +int TkMacOSXIsLaunched(void) { + return doCleanupFromExit == YES; +} + TCL_NORETURN void TkMacOSXExitProc( - ClientData clientdata) + void *clientdata) { - closePanels(); - - /* - * Make sure we don't get called again. This can happen, e.g. with - * fossil diff -tk. - */ - - Tcl_SetExitProc(NULL); + Bool doCleanup = doCleanupFromExit; + if (doCleanupFromExit) { + doCleanupFromExit = NO; /* prevent possible recursive call. */ + closePanels(); + } /* * Tcl_Exit does not call Tcl_Finalize if there is an exit proc installed. */ Tcl_Finalize(); - [(TKApplication *)NSApp superTerminate:nil]; /* Should not return. */ + if (doCleanup == YES) { + [(TKApplication *)NSApp superTerminate:nil]; /* Should not return. */ + } exit((int)clientdata); /* Convince the compiler that we don't return. */ } +#endif /* * This signal handler is installed for the SIGINT, SIGHUP and SIGTERM signals @@ -326,6 +333,8 @@ TCL_NORETURN void TkMacOSXExitProc( */ static void TkMacOSXSignalHandler(int signal) { + (void)signal; + Tcl_Exit(1); } @@ -343,7 +352,6 @@ TkpInit( if (!initialized) { struct stat st; Bool shouldOpenConsole = NO; - Bool isLaunched = NO; Bool stdinIsNullish = (!isatty(0) && (fstat(0, &st) || (S_ISCHR(st.st_mode) && st.st_blocks == 0))); @@ -443,7 +451,9 @@ TkpInit( Tcl_SetVar2(interp, "tcl_interactive", NULL, "1", TCL_GLOBAL_ONLY); } - isLaunched = YES; +#if !defined(USE_SYSTEM_EXIT) + doCleanupFromExit = YES; +#endif shouldOpenConsole = YES; } if (shouldOpenConsole) { @@ -466,7 +476,9 @@ TkpInit( FILE *null = fopen("/dev/null", "w"); dup2(fileno(null), STDOUT_FILENO); dup2(fileno(null), STDERR_FILENO); - isLaunched = YES; +#if !defined(USE_SYSTEM_EXIT) + doCleanupFromExit = YES; +#endif } /* @@ -513,11 +525,8 @@ TkpInit( # if !defined(USE_SYSTEM_EXIT) - if (isLaunched || (isatty(0) && isatty(1))) { - Tcl_ExitProc *prevExitProc = Tcl_SetExitProc(TkMacOSXExitProc); - if (prevExitProc) { - Tcl_SetExitProc((TCL_NORETURN Tcl_ExitProc *)prevExitProc); - } + if ((isatty(0) && isatty(1))) { + doCleanupFromExit = YES; } # endif diff --git a/unix/tkAppInit.c b/unix/tkAppInit.c index 13bcdde..aa9315c 100644 --- a/unix/tkAppInit.c +++ b/unix/tkAppInit.c @@ -15,6 +15,9 @@ #undef BUILD_tk #undef STATIC_BUILD #include "tk.h" +#if !defined(USE_SYSTEM_EXIT) && defined(MAC_OSX_TK) +# include "tkMacOSX.h" +#endif #ifdef TK_TEST extern Tcl_PackageInitProc Tktest_Init; @@ -110,6 +113,11 @@ Tcl_AppInit( return TCL_ERROR; } Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit); +#if !defined(USE_SYSTEM_EXIT) && defined(MAC_OSX_TK) + if (TkMacOSXIsLaunched()) { + Tcl_SetExitProc(TkMacOSXExitProc); + } +#endif #ifdef TK_TEST if (Tktest_Init(interp) == TCL_ERROR) { -- cgit v0.12 From 4c940e28df4d5740b0ab2904ed4c673e5678ddf0 Mon Sep 17 00:00:00 2001 From: marc_culler Date: Tue, 20 Oct 2020 17:41:43 +0000 Subject: Avoid platform-specific conditional compilation where possible. --- generic/tkPlatDecls.h | 5 ----- macosx/tkMacOSXInit.c | 19 +++++++++++-------- macosx/tkMacOSXPort.h | 8 ++++++++ unix/tkAppInit.c | 12 ++++++------ 4 files changed, 25 insertions(+), 19 deletions(-) diff --git a/generic/tkPlatDecls.h b/generic/tkPlatDecls.h index 2fea41e..bad633f 100644 --- a/generic/tkPlatDecls.h +++ b/generic/tkPlatDecls.h @@ -193,11 +193,6 @@ extern const TkPlatStubs *tkPlatStubsPtr; /* !END!: Do not edit above this line. */ -#if !defined(USE_SYSTEM_EXIT) && defined(MAC_OSX_TK) -EXTERN int TkMacOSXIsLaunched(void); -EXTERN TCL_NORETURN void TkMacOSXExitProc(void *); -#endif - #ifdef __cplusplus } #endif diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index 1323333..5103a84 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -113,6 +113,7 @@ static int TkMacOSXGetAppPathCmd(ClientData cd, Tcl_Interp *ip, /* * Initialize event processing. */ + TkMacOSXInitAppleEvents(_eventInterp); /* @@ -294,14 +295,14 @@ static void closePanels( * correctly for all termination scenarios. */ -#if !defined(USE_SYSTEM_EXIT) +#if defined(USE_CUSTOM_EXIT_PROC) static Bool doCleanupFromExit = NO; -int TkMacOSXIsLaunched(void) { +int TkpWantsExitProc(void) { return doCleanupFromExit == YES; } -TCL_NORETURN void TkMacOSXExitProc( +TCL_NORETURN void TkpExitProc( void *clientdata) { Bool doCleanup = doCleanupFromExit; @@ -318,7 +319,7 @@ TCL_NORETURN void TkMacOSXExitProc( if (doCleanup == YES) { [(TKApplication *)NSApp superTerminate:nil]; /* Should not return. */ } - exit((int)clientdata); /* Convince the compiler that we don't return. */ + exit((long)clientdata); /* Convince the compiler that we don't return. */ } #endif @@ -451,9 +452,11 @@ TkpInit( Tcl_SetVar2(interp, "tcl_interactive", NULL, "1", TCL_GLOBAL_ONLY); } -#if !defined(USE_SYSTEM_EXIT) + +#if defined(USE_CUSTOM_EXIT_PROC) doCleanupFromExit = YES; #endif + shouldOpenConsole = YES; } if (shouldOpenConsole) { @@ -476,7 +479,7 @@ TkpInit( FILE *null = fopen("/dev/null", "w"); dup2(fileno(null), STDOUT_FILENO); dup2(fileno(null), STDERR_FILENO); -#if !defined(USE_SYSTEM_EXIT) +#if defined(USE_CUSTOM_EXIT_PROC) doCleanupFromExit = YES; #endif } @@ -520,10 +523,10 @@ TkpInit( * calling [NSApplication terminate]. This does not work correctly if * the process is part of an exec pipeline, so it is only used if the * process was launched by the launcher or if both stdin and stdout are - * ttys. If an exit proc was already installed we leave it in place. + * ttys. */ -# if !defined(USE_SYSTEM_EXIT) +# if defined(USE_CUSTOM_EXIT_PROC) if ((isatty(0) && isatty(1))) { doCleanupFromExit = YES; diff --git a/macosx/tkMacOSXPort.h b/macosx/tkMacOSXPort.h index 76dd974..461204e 100644 --- a/macosx/tkMacOSXPort.h +++ b/macosx/tkMacOSXPort.h @@ -185,4 +185,12 @@ MODULE_SCOPE void TkMacOSXHandleMapOrUnmap(Tk_Window tkwin, XEvent *event); #define TkpHandleMapOrUnmap(tkwin, event) TkMacOSXHandleMapOrUnmap(tkwin, event) +/* + * Used by tkAppInit + */ + +#define USE_CUSTOM_EXIT_PROC +EXTERN int TkpWantsExitProc(void); +EXTERN TCL_NORETURN void TkpExitProc(void *); + #endif /* _TKMACPORT */ diff --git a/unix/tkAppInit.c b/unix/tkAppInit.c index aa9315c..ecd9dfe 100644 --- a/unix/tkAppInit.c +++ b/unix/tkAppInit.c @@ -15,9 +15,7 @@ #undef BUILD_tk #undef STATIC_BUILD #include "tk.h" -#if !defined(USE_SYSTEM_EXIT) && defined(MAC_OSX_TK) -# include "tkMacOSX.h" -#endif +#include "tkPort.h" #ifdef TK_TEST extern Tcl_PackageInitProc Tktest_Init; @@ -113,9 +111,11 @@ Tcl_AppInit( return TCL_ERROR; } Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit); -#if !defined(USE_SYSTEM_EXIT) && defined(MAC_OSX_TK) - if (TkMacOSXIsLaunched()) { - Tcl_SetExitProc(TkMacOSXExitProc); + +#if defined(USE_CUSTOM_EXIT_PROC) + if (TkpWantsExitProc()) { + /* The cast below avoids warnings from old gcc compilers. */ + Tcl_SetExitProc((void *)TkpExitProc); } #endif -- cgit v0.12 From 9c472e72196238d8550cab9eeeb10bf9ed74be31 Mon Sep 17 00:00:00 2001 From: marc_culler Date: Tue, 20 Oct 2020 20:15:00 +0000 Subject: Make Tcl_Finalize run when a launched app is terminated with command-Q --- macosx/tkMacOSXHLEvents.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/macosx/tkMacOSXHLEvents.c b/macosx/tkMacOSXHLEvents.c index 615653d..5055f38 100644 --- a/macosx/tkMacOSXHLEvents.c +++ b/macosx/tkMacOSXHLEvents.c @@ -570,13 +570,18 @@ TkMacOSXDoHLEvent( static int ReallyKillMe( Tcl_Event *eventPtr, - int flags) + TCL_UNUSED(int)) { Tcl_Interp *interp = ((KillEvent *) eventPtr)->interp; int quit = Tcl_FindCommand(interp, "::tk::mac::Quit", NULL, 0)!=NULL; - int code = Tcl_EvalEx(interp, quit ? "::tk::mac::Quit" : "exit", -1, TCL_EVAL_GLOBAL); + if (!quit) { + Tcl_Exit(0); + } + + int code = Tcl_EvalEx(interp, "::tk::mac::Quit", -1, TCL_EVAL_GLOBAL); if (code != TCL_OK) { + /* * Should be never reached... */ -- cgit v0.12 From 0757ec2df6ba5375e6c6eb57612ffe4dbba9335f Mon Sep 17 00:00:00 2001 From: marc_culler Date: Tue, 20 Oct 2020 20:42:29 +0000 Subject: Cherrypick changes to comments. --- macosx/tkMacOSXInit.c | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index 5103a84..9479a00 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -293,6 +293,13 @@ static void closePanels( * doing this is to ensure that the NSFontPanel and the NSColorPanel are closed * before the process exits, and that the application state is recorded * correctly for all termination scenarios. + * + * TkpWantsExitProc tells Tcl_AppInit whether to install our custom exit proc, + * which terminates the process by calling [NSApplication terminate]. This + * does not work correctly if the process is part of an exec pipeline, so it is + * only done if the process was launched by the launcher or if both stdin and + * stdout are ttys. To disable using the custom exit proc altogether, undefine + * USE_CUSTOM_EXIT_PROC. */ #if defined(USE_CUSTOM_EXIT_PROC) @@ -518,14 +525,6 @@ TkpInit( } } - /* - * Install our custom exit proc, which terminates the process by - * calling [NSApplication terminate]. This does not work correctly if - * the process is part of an exec pipeline, so it is only used if the - * process was launched by the launcher or if both stdin and stdout are - * ttys. - */ - # if defined(USE_CUSTOM_EXIT_PROC) if ((isatty(0) && isatty(1))) { -- cgit v0.12 From 06bdf94419612cb578502cf30fa89ef013ecebc2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 20 Oct 2020 22:36:13 +0000 Subject: One TCL_UNUSED and some eol-spacing --- macosx/README | 2 +- macosx/tkMacOSXInit.c | 5 ++--- macosx/tkMacOSXWindowEvent.c | 2 +- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/macosx/README b/macosx/README index 0cc7715..83a3c63 100644 --- a/macosx/README +++ b/macosx/README @@ -463,7 +463,7 @@ directory where the frameworks will be written. Since the install_name is writte at compile time, this build requires starting with an empty build directory. Also, the build will leave frameworks in the build directory that cannot be installed in the standard /Library/Frameworks directory. To avoid surprises, -delete the build directory after the frameworks are built. +delete the build directory after the frameworks are built. For example, running the commands: rm -rf build cd Tcl_src diff --git a/macosx/tkMacOSXInit.c b/macosx/tkMacOSXInit.c index 9479a00..06ff367 100644 --- a/macosx/tkMacOSXInit.c +++ b/macosx/tkMacOSXInit.c @@ -321,7 +321,7 @@ TCL_NORETURN void TkpExitProc( /* * Tcl_Exit does not call Tcl_Finalize if there is an exit proc installed. */ - + Tcl_Finalize(); if (doCleanup == YES) { [(TKApplication *)NSApp superTerminate:nil]; /* Should not return. */ @@ -340,8 +340,7 @@ TCL_NORETURN void TkpExitProc( * return exit status 1. */ -static void TkMacOSXSignalHandler(int signal) { - (void)signal; +static void TkMacOSXSignalHandler(TCL_UNUSED(int)) { Tcl_Exit(1); } diff --git a/macosx/tkMacOSXWindowEvent.c b/macosx/tkMacOSXWindowEvent.c index ca7f526..0075fb8 100644 --- a/macosx/tkMacOSXWindowEvent.c +++ b/macosx/tkMacOSXWindowEvent.c @@ -1021,7 +1021,7 @@ ConfigureRestrictProc( if([NSApp isDrawing] || [self inLiveResize]) { [self generateExposeEvents: [self bounds]]; } - + /* * Finally, unlock the main autoreleasePool. */ -- cgit v0.12 From 6b7a70d3adc1fa78b3cfee9baa8e1f25d27eef8b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Oct 2020 15:58:38 +0000 Subject: Adapt some demo's to TIP #474 (runtime switchable, depending on Tk version) , --- library/demos/cscroll.tcl | 28 ++++++++++++++++++---------- library/demos/ctext.tcl | 2 +- library/demos/floor.tcl | 2 +- library/demos/goldberg.tcl | 12 ++++++------ library/demos/items.tcl | 2 +- 5 files changed, 27 insertions(+), 19 deletions(-) diff --git a/library/demos/cscroll.tcl b/library/demos/cscroll.tcl index f64ca5d..d210c7d 100644 --- a/library/demos/cscroll.tcl +++ b/library/demos/cscroll.tcl @@ -56,29 +56,29 @@ for {set i 0} {$i < 20} {incr i} { $c bind all "scrollEnter $c" $c bind all "scrollLeave $c" $c bind all "scrollButton $c" -if {[tk windowingsystem] eq "aqua"} { +if {([tk windowingsystem] eq "aqua") && ![package vsatisfies [package provide Tk] 8.7-]} { bind $c "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c { - %W yview scroll [expr {-(%D)}] units + %W yview scroll [expr {-%D}] units } bind $c { - %W yview scroll [expr {-10 * (%D)}] units + %W yview scroll [expr {-10*%D}] units } bind $c { - %W xview scroll [expr {-(%D)}] units + %W xview scroll [expr {-%D}] units } bind $c { - %W xview scroll [expr {-10 * (%D)}] units + %W xview scroll [expr {-10*%D}] units } } else { bind $c "$c scan mark %x %y" bind $c "$c scan dragto %x %y" # We must make sure that positive and negative movements are rounded # equally to integers, avoiding the problem that - # (int)1/30 = 0, + # (int)1/-30 = -1, # but - # (int)-1/30 = -1 + # (int)-1/-30 = 0 # The following code ensure equal +/- behaviour. bind $c { if {%D >= 0} { @@ -88,7 +88,11 @@ if {[tk windowingsystem] eq "aqua"} { } } bind $c { - %W yview scroll [expr {%D/-3}] units + if {%D >= 0} { + %W yview scroll [expr {%D/-3}] units + } else { + %W yview scroll [expr {(%D-2)/-3}] units + } } bind $c { if {%D >= 0} { @@ -98,11 +102,15 @@ if {[tk windowingsystem] eq "aqua"} { } } bind $c { - %W xview scroll [expr {%D/-3}] units + if {%D >= 0} { + %W xview scroll [expr {%D/-3}] units + } else { + %W xview scroll [expr {(%D-2)/-3}] units + } } } -if {[tk windowingsystem] eq "x11"} { +if {[tk windowingsystem] eq "x11" && ![package vsatisfies [package provide Tk] 8.7-]} { # Support for mousewheels on Linux/Unix commonly comes through mapping # the wheel to the extended buttons. If you have a mousewheel, find # Linux configuration info at: diff --git a/library/demos/ctext.tcl b/library/demos/ctext.tcl index 5acc82f..d3fec33 100644 --- a/library/demos/ctext.tcl +++ b/library/demos/ctext.tcl @@ -50,7 +50,7 @@ $c bind text "textInsert $c \\n" $c bind text "textBs $c" $c bind text "textBs $c" $c bind text "textDel $c" -if {[tk windowingsystem] eq "aqua"} { +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { $c bind text "textPaste $c @%x,%y" } else { $c bind text "textPaste $c @%x,%y" diff --git a/library/demos/floor.tcl b/library/demos/floor.tcl index 37e1b95..eb2ea7f 100644 --- a/library/demos/floor.tcl +++ b/library/demos/floor.tcl @@ -1359,7 +1359,7 @@ $c bind floor2 "floorDisplay $c 2" $c bind floor3 "floorDisplay $c 3" $c bind room "newRoom $c" $c bind room {set currentRoom ""} -if {[tk windowingsystem] eq "aqua"} { +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { bind $c "$c scan mark %x %y" bind $c "$c scan dragto %x %y" } else { diff --git a/library/demos/goldberg.tcl b/library/demos/goldberg.tcl index 284b5c2..1cc52c6 100644 --- a/library/demos/goldberg.tcl +++ b/library/demos/goldberg.tcl @@ -105,7 +105,7 @@ proc DoDisplay {w} { $w.c yview moveto .05 pack $w.c -in $w.screen -side top -fill both -expand 1 - bind $w.c <3> [list $w.pause invoke] + bind $w.c [list $w.pause invoke] bind $w.c { after cancel $animationCallbacks(goldberg) unset animationCallbacks(goldberg) @@ -162,7 +162,7 @@ proc DoCtrlFrame {w} { grid $w.speed -in $w.ctrl -row 99 -sticky ew -pady {0 5} pack $w.speed.scale -fill both -expand 1 grid $w.about -in $w.ctrl -row 100 -sticky ew - bind $w.reset <3> {set S(mode) -1} ;# Debugging + bind $w.reset {set S(mode) -1} ;# Debugging ## See Code / Dismiss buttons hack! set btns [addSeeDismiss $w.ctrl.buttons $w] @@ -342,7 +342,7 @@ proc Draw0 {w} { set xy {719 119 763 119} $w.c create line $xy -tag I0 -fill $color -width 5 -arrow last \ -arrowshape {18 18 5} - $w.c bind I0 <1> Start + $w.c bind I0 Start } proc Move0 {w {step {}}} { set step [GetStep 0 $step] @@ -372,7 +372,7 @@ proc Draw1 {w} { set xy [box 812 122 9] $w.c create oval $xy -tag I1 -fill $color2 -outline {} - $w.c bind I1 <1> Start + $w.c bind I1 Start } proc Move1 {w {step {}}} { set step [GetStep 1 $step] @@ -1620,7 +1620,7 @@ proc Move26 {w {step {}}} { $w.c delete I24 I26 $w.c create text 430 755 -anchor s -tag I26 \ -text "click to continue" -font {{Times Roman} 24 bold} - bind $w.c <1> [list Reset $w] + bind $w.c [list Reset $w] return 4 } @@ -1675,7 +1675,7 @@ proc RotateC {x y Ox Oy beta} { proc Reset {w} { global S DrawAll $w - bind $w.c <1> {} + bind $w.c {} set S(mode) $::MSTART set S(active) 0 } diff --git a/library/demos/items.tcl b/library/demos/items.tcl index 545877c..1297046 100644 --- a/library/demos/items.tcl +++ b/library/demos/items.tcl @@ -173,7 +173,7 @@ $c create text 28.5c 17.4c -text Scale: -anchor s $c bind item "itemEnter $c" $c bind item "itemLeave $c" -if {[tk windowingsystem] eq "aqua"} { +if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} { bind $c "itemMark $c %x %y" bind $c "itemStroke $c %x %y" bind $c "$c scan mark %x %y" -- cgit v0.12 From ea46afa849cd4996b2897694cdb3b3b0150c5518 Mon Sep 17 00:00:00 2001 From: marc_culler Date: Wed, 21 Oct 2020 18:26:50 +0000 Subject: cherrypick the changes to GNUmakefile, accidentally committed to the rc branch first. Fix a typo. --- macosx/GNUmakefile | 20 ++++++++++++++------ macosx/README | 22 +++++++--------------- 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index f9410cc..c2e1b77 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -44,6 +44,18 @@ INSTALL_MANPAGES ?= # set to non-empty value to build TkX11 instead of TkAqua: TK_X11 ?= +# Checks and overrides for subframework builds +ifeq (${SUBFRAMEWORK}_${TK_X11},1_) +ifeq (${DYLIB_INSTALL_DIR},) + @echo "Cannot install subframework with empty DYLIB_INSTALL_DIR !" && false +endif +ifeq (${DESTDIR},) + @echo "Cannot install subframework with empty DESTDIR !" && false +endif +override BUILD_DIR = ${DESTDIR}/build +override INSTALL_PATH = /Frameworks +endif + #------------------------------------------------------------------------------------------------------- # meta targets @@ -278,14 +290,10 @@ else fix_install_id Frameworks/Tcl.framework/Tcl Tcl && fix_install_id Frameworks/Tk.framework/Tk Tk && \ fix_install_name MacOS/Wish Tcl && fix_install_name MacOS/Wish Tk ifeq (${INSTALL_BUILD},1) + echo removing frameworks @cd "${TOP_DIR}" && rm -rf "./${FMWK_DIR}"/T{cl,k}.framework && rmdir -p "./${FMWK_DIR}" 2>&- || true -endif # install +endif # install not subframework endif # embedded -else -# Clean up the destination directory if this is a subframework - @rm -rf ${INSTALL_ROOT}/Frameworks - @mv "${INSTALL_ROOT}/Library/Frameworks" "${INSTALL_ROOT}" - @rm -rf ${INSTALL_ROOT}/Library endif # not subframework endif # not X11 diff --git a/macosx/README b/macosx/README index 83a3c63..834dea4 100644 --- a/macosx/README +++ b/macosx/README @@ -459,23 +459,15 @@ The Makefile variables TCL_FRAMEWORK_DIR and TCLSH_DIR were added with Tk 8.4.3. framework, use the install-embedded target and set SUBFRAMEWORK=1. Set the DYLIB_INSTALL_DIR variable to the path which should be the install_name path of the shared library and set the DESTDIR variable to the pathname of a staging -directory where the frameworks will be written. Since the install_name is written -at compile time, this build requires starting with an empty build directory. -Also, the build will leave frameworks in the build directory that cannot be -installed in the standard /Library/Frameworks directory. To avoid surprises, -delete the build directory after the frameworks are built. +directory where the frameworks will be written. The Tcl framework must be +built first. For example, running the commands: - rm -rf build - cd Tcl_src + make -C ../tcl8.6/macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcltk \ + DYLIB_INSTALL_DIR=/Library/Frameworks/Some.framework/Versions/X.Y/Frameworks/Tcl.framework make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcltk \ - DYLIB_INSTALL_DIR=/Library/Frameworks/Python.framework/Versions/3.9/Frameworks/Tcl - cd ../Tk_src - make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcltk \ - DYLIB_INSTALL_DIR=/Library/Frameworks/Python.framework/Versions/3.9/Frameworks/Tk - cd .. - rm -rf build -will produce a Tcl.framework and a Tk.framework usable as subframeworks of the -Python.framework. The frameworks will be found in /tmp/tcltk/Frameworks/ + DYLIB_INSTALL_DIR=/Library/Frameworks/Some.framework/Versions/X.Y/Frameworks/Tk.framework +will produce a Tcl.framework and a Tk.framework usable as subframeworks of +Some.framework. The frameworks will be found in /tmp/tcltk/Frameworks/ 5. Details regarding the macOS port of Tk. ------------------------------------------- -- cgit v0.12 From 57eaec1ea3999782e496cbc34ca0e1df6615b82f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Oct 2020 08:41:11 +0000 Subject: Assume utf-8 encoding for demo's (although they actually are still ASCII) --- library/demos/tree.tcl | 1 + library/demos/widget | 11 ++++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/library/demos/tree.tcl b/library/demos/tree.tcl index 8decdf2..1cc70f8 100644 --- a/library/demos/tree.tcl +++ b/library/demos/tree.tcl @@ -39,6 +39,7 @@ proc populateTree {tree node} { set path [$tree set $node fullpath] $tree delete [$tree children $node] foreach f [lsort -dictionary [glob -nocomplain -dir $path *]] { + set f [file normalize $f] set type [file type $f] set id [$tree insert $node end -text [file tail $f] \ -values [list $f $type]] diff --git a/library/demos/widget b/library/demos/widget index e543846..58da12f 100644 --- a/library/demos/widget +++ b/library/demos/widget @@ -516,7 +516,7 @@ proc invoke index { .t configure -cursor [::ttk::cursor busy] update set demo [string range [lindex $tags $i] 5 end] - uplevel 1 [list source [file join $tk_demoDirectory $demo.tcl]] + uplevel 1 [list source -encoding utf-8 [file join $tk_demoDirectory $demo.tcl]] update .t configure -cursor $cursor @@ -624,6 +624,7 @@ proc showCode w { wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]] wm iconname $top $file set id [open [file join $tk_demoDirectory $file]] + fconfigure $id -encoding utf-8 -eofchar \032 $top.f.text delete 1.0 end $top.f.text insert 1.0 [read $id] $top.f.text mark set insert 1.0 @@ -722,10 +723,10 @@ proc PrintTextWin32 {filename} { proc tkAboutDialog {} { tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \ -message [mc "Tk widget demonstration application"] -detail \ -"[mc "Copyright \u00a9 %s" {1996-1997 Sun Microsystems, Inc.}] -[mc "Copyright \u00a9 %s" {1997-2000 Ajuba Solutions, Inc.}] -[mc "Copyright \u00a9 %s" {2001-2009 Donal K. Fellows}] -[mc "Copyright \u00a9 %s" {2002-2007 Daniel A. Steffen}]" +"[mc "Copyright \xA9 %s" {1996-1997 Sun Microsystems, Inc.}] +[mc "Copyright \xA9 %s" {1997-2000 Ajuba Solutions, Inc.}] +[mc "Copyright \xA9 %s" {2001-2009 Donal K. Fellows}] +[mc "Copyright \xA9 %s" {2002-2007 Daniel A. Steffen}]" } # Local Variables: -- cgit v0.12 From 299096a5bc3efceb79c93c0f948d80f74565c858 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Oct 2020 11:10:47 +0000 Subject: Always use "source -encoding utf-8" in the demos just to be sure. --- library/demos/bind.tcl | 12 ++--- library/demos/tclIndex | 118 ++++++++++++++++++++++++------------------------- 2 files changed, 65 insertions(+), 65 deletions(-) diff --git a/library/demos/bind.tcl b/library/demos/bind.tcl index 9146362..8b56639 100644 --- a/library/demos/bind.tcl +++ b/library/demos/bind.tcl @@ -67,12 +67,12 @@ foreach tag {d1 d2 d3 d4 d5 d6} { $w.text tag bind $tag "$w.text tag configure $tag $normal" } # Main widget program sets variable tk_demoDirectory -$w.text tag bind d1 {source [file join $tk_demoDirectory items.tcl]} -$w.text tag bind d2 {source [file join $tk_demoDirectory plot.tcl]} -$w.text tag bind d3 {source [file join $tk_demoDirectory ctext.tcl]} -$w.text tag bind d4 {source [file join $tk_demoDirectory arrow.tcl]} -$w.text tag bind d5 {source [file join $tk_demoDirectory ruler.tcl]} -$w.text tag bind d6 {source [file join $tk_demoDirectory cscroll.tcl]} +$w.text tag bind d1 {source -encoding utf-8 [file join $tk_demoDirectory items.tcl]} +$w.text tag bind d2 {source -encoding utf-8 [file join $tk_demoDirectory plot.tcl]} +$w.text tag bind d3 {source -encoding utf-8 [file join $tk_demoDirectory ctext.tcl]} +$w.text tag bind d4 {source -encoding utf-8 [file join $tk_demoDirectory arrow.tcl]} +$w.text tag bind d5 {source -encoding utf-8 [file join $tk_demoDirectory ruler.tcl]} +$w.text tag bind d6 {source -encoding utf-8 [file join $tk_demoDirectory cscroll.tcl]} $w.text mark set insert 0.0 $w.text configure -state disabled diff --git a/library/demos/tclIndex b/library/demos/tclIndex index 86a72e2..cdb2f2c 100644 --- a/library/demos/tclIndex +++ b/library/demos/tclIndex @@ -6,62 +6,62 @@ # element name is the name of a command and the value is # a script that loads the command. -set auto_index(arrowSetup) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove1) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove2) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove3) [list source [file join $dir arrow.tcl]] -set auto_index(textLoadFile) [list source [file join $dir search.tcl]] -set auto_index(textSearch) [list source [file join $dir search.tcl]] -set auto_index(textToggle) [list source [file join $dir search.tcl]] -set auto_index(itemEnter) [list source [file join $dir items.tcl]] -set auto_index(itemLeave) [list source [file join $dir items.tcl]] -set auto_index(itemMark) [list source [file join $dir items.tcl]] -set auto_index(itemStroke) [list source [file join $dir items.tcl]] -set auto_index(itemsUnderArea) [list source [file join $dir items.tcl]] -set auto_index(itemStartDrag) [list source [file join $dir items.tcl]] -set auto_index(itemDrag) [list source [file join $dir items.tcl]] -set auto_index(butPress) [list source [file join $dir items.tcl]] -set auto_index(loadDir) [list source [file join $dir image2.tcl]] -set auto_index(loadImage) [list source [file join $dir image2.tcl]] -set auto_index(rulerMkTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerNewTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerSelectTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerMoveTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerReleaseTab) [list source [file join $dir ruler.tcl]] -set auto_index(mkTextConfig) [list source [file join $dir ctext.tcl]] -set auto_index(textEnter) [list source [file join $dir ctext.tcl]] -set auto_index(textInsert) [list source [file join $dir ctext.tcl]] -set auto_index(textPaste) [list source [file join $dir ctext.tcl]] -set auto_index(textB1Press) [list source [file join $dir ctext.tcl]] -set auto_index(textB1Move) [list source [file join $dir ctext.tcl]] -set auto_index(textBs) [list source [file join $dir ctext.tcl]] -set auto_index(textDel) [list source [file join $dir ctext.tcl]] -set auto_index(bitmapRow) [list source [file join $dir bitmap.tcl]] -set auto_index(scrollEnter) [list source [file join $dir cscroll.tcl]] -set auto_index(scrollLeave) [list source [file join $dir cscroll.tcl]] -set auto_index(scrollButton) [list source [file join $dir cscroll.tcl]] -set auto_index(textWindOn) [list source [file join $dir twind.tcl]] -set auto_index(textWindOff) [list source [file join $dir twind.tcl]] -set auto_index(textWindPlot) [list source [file join $dir twind.tcl]] -set auto_index(embPlotDown) [list source [file join $dir twind.tcl]] -set auto_index(embPlotMove) [list source [file join $dir twind.tcl]] -set auto_index(textWindDel) [list source [file join $dir twind.tcl]] -set auto_index(embDefBg) [list source [file join $dir twind.tcl]] -set auto_index(floorDisplay) [list source [file join $dir floor.tcl]] -set auto_index(newRoom) [list source [file join $dir floor.tcl]] -set auto_index(roomChanged) [list source [file join $dir floor.tcl]] -set auto_index(bg1) [list source [file join $dir floor.tcl]] -set auto_index(bg2) [list source [file join $dir floor.tcl]] -set auto_index(bg3) [list source [file join $dir floor.tcl]] -set auto_index(fg1) [list source [file join $dir floor.tcl]] -set auto_index(fg2) [list source [file join $dir floor.tcl]] -set auto_index(fg3) [list source [file join $dir floor.tcl]] -set auto_index(setWidth) [list source [file join $dir hscale.tcl]] -set auto_index(plotDown) [list source [file join $dir plot.tcl]] -set auto_index(plotMove) [list source [file join $dir plot.tcl]] -set auto_index(puzzleSwitch) [list source [file join $dir puzzle.tcl]] -set auto_index(setHeight) [list source [file join $dir vscale.tcl]] -set auto_index(showMessageBox) [list source [file join $dir msgbox.tcl]] -set auto_index(setColor) [list source [file join $dir clrpick.tcl]] -set auto_index(setColor_helper) [list source [file join $dir clrpick.tcl]] -set auto_index(fileDialog) [list source [file join $dir filebox.tcl]] +set auto_index(arrowSetup) [list source -encoding utf-8 [file join $dir arrow.tcl]] +set auto_index(arrowMove1) [list source -encoding utf-8 [file join $dir arrow.tcl]] +set auto_index(arrowMove2) [list source -encoding utf-8 [file join $dir arrow.tcl]] +set auto_index(arrowMove3) [list source -encoding utf-8 [file join $dir arrow.tcl]] +set auto_index(textLoadFile) [list source -encoding utf-8 [file join $dir search.tcl]] +set auto_index(textSearch) [list source -encoding utf-8 [file join $dir search.tcl]] +set auto_index(textToggle) [list source -encoding utf-8 [file join $dir search.tcl]] +set auto_index(itemEnter) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemLeave) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemMark) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemStroke) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemsUnderArea) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemStartDrag) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(itemDrag) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(butPress) [list source -encoding utf-8 [file join $dir items.tcl]] +set auto_index(loadDir) [list source -encoding utf-8 [file join $dir image2.tcl]] +set auto_index(loadImage) [list source -encoding utf-8 [file join $dir image2.tcl]] +set auto_index(rulerMkTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(rulerNewTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(rulerSelectTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(rulerMoveTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(rulerReleaseTab) [list source -encoding utf-8 [file join $dir ruler.tcl]] +set auto_index(mkTextConfig) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textEnter) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textInsert) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textPaste) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textB1Press) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textB1Move) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textBs) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(textDel) [list source -encoding utf-8 [file join $dir ctext.tcl]] +set auto_index(bitmapRow) [list source -encoding utf-8 [file join $dir bitmap.tcl]] +set auto_index(scrollEnter) [list source -encoding utf-8 [file join $dir cscroll.tcl]] +set auto_index(scrollLeave) [list source -encoding utf-8 [file join $dir cscroll.tcl]] +set auto_index(scrollButton) [list source -encoding utf-8 [file join $dir cscroll.tcl]] +set auto_index(textWindOn) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(textWindOff) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(textWindPlot) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(embPlotDown) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(embPlotMove) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(textWindDel) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(embDefBg) [list source -encoding utf-8 [file join $dir twind.tcl]] +set auto_index(floorDisplay) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(newRoom) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(roomChanged) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(bg1) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(bg2) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(bg3) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(fg1) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(fg2) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(fg3) [list source -encoding utf-8 [file join $dir floor.tcl]] +set auto_index(setWidth) [list source -encoding utf-8 [file join $dir hscale.tcl]] +set auto_index(plotDown) [list source -encoding utf-8 [file join $dir plot.tcl]] +set auto_index(plotMove) [list source -encoding utf-8 [file join $dir plot.tcl]] +set auto_index(puzzleSwitch) [list source -encoding utf-8 [file join $dir puzzle.tcl]] +set auto_index(setHeight) [list source -encoding utf-8 [file join $dir vscale.tcl]] +set auto_index(showMessageBox) [list source -encoding utf-8 [file join $dir msgbox.tcl]] +set auto_index(setColor) [list source -encoding utf-8 [file join $dir clrpick.tcl]] +set auto_index(setColor_helper) [list source -encoding utf-8 [file join $dir clrpick.tcl]] +set auto_index(fileDialog) [list source -encoding utf-8 [file join $dir filebox.tcl]] -- cgit v0.12 From 0880b455913f559282daeb268693b8fb7a5b894c Mon Sep 17 00:00:00 2001 From: marc_culler Date: Thu, 22 Oct 2020 14:13:14 +0000 Subject: Remove an unneeded echo command in GNUmakefile. --- macosx/GNUmakefile | 1 - 1 file changed, 1 deletion(-) diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index c2e1b77..ff028b5 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -290,7 +290,6 @@ else fix_install_id Frameworks/Tcl.framework/Tcl Tcl && fix_install_id Frameworks/Tk.framework/Tk Tk && \ fix_install_name MacOS/Wish Tcl && fix_install_name MacOS/Wish Tk ifeq (${INSTALL_BUILD},1) - echo removing frameworks @cd "${TOP_DIR}" && rm -rf "./${FMWK_DIR}"/T{cl,k}.framework && rmdir -p "./${FMWK_DIR}" 2>&- || true endif # install not subframework endif # embedded -- cgit v0.12 From 33ba7348673118b491542cd4ba2e50f04ef249c9 Mon Sep 17 00:00:00 2001 From: culler Date: Thu, 22 Oct 2020 19:50:59 +0000 Subject: Aqua: small change to showOpenSavePanel which might prevent some API warnings. --- macosx/tkMacOSXDialog.c | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/macosx/tkMacOSXDialog.c b/macosx/tkMacOSXDialog.c index 42cb4a5..ba6fabd 100644 --- a/macosx/tkMacOSXDialog.c +++ b/macosx/tkMacOSXDialog.c @@ -346,23 +346,25 @@ static NSInteger showOpenSavePanel( NSWindow *parent, FilePanelCallbackInfo *callbackInfo) { - NSInteger modalReturnCode; + __block NSInteger modalReturnCode = modalOther; if (parent && ![parent attachedSheet]) { [panel beginSheetModalForWindow:parent - completionHandler:^(NSModalResponse returnCode) { - [NSApp tkFilePanelDidEnd:panel - returnCode:returnCode - contextInfo:callbackInfo ]; + completionHandler:^(NSModalResponse result) { + [NSApp tkFilePanelDidEnd:panel + returnCode:result + contextInfo:callbackInfo ]; + modalReturnCode = result; }]; - - modalReturnCode = callbackInfo->cmdObj ? modalOther : - [panel runModal]; } else { - modalReturnCode = [panel runModal]; - [NSApp tkFilePanelDidEnd:panel returnCode:modalReturnCode - contextInfo:callbackInfo]; + [panel beginWithCompletionHandler:^(NSModalResponse result) { + [NSApp tkFilePanelDidEnd:panel + returnCode:result + contextInfo:callbackInfo ]; + modalReturnCode = result; + }]; } + [panel runModal]; return modalReturnCode; } -- cgit v0.12 From 5164db768ac805564630f25daae0357dad688b0c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 23 Oct 2020 08:10:17 +0000 Subject: Fix bug in TIP #474 implementation: Wrong bindings for Mousewheel in text widgets --- library/text.tcl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/library/text.tcl b/library/text.tcl index e4f00d1..5d41dc3 100644 --- a/library/text.tcl +++ b/library/text.tcl @@ -442,16 +442,16 @@ bind Text { set ::tk::Priv(prevPos) {} bind Text { - tk::MouseWheel y %D -3.0 pixels + tk::MouseWheel %W y %D -3.0 pixels } bind Text { - tk::MouseWheel y %D -0.3 pixels + tk::MouseWheel %W y %D -0.3 pixels } bind Text { - tk::MouseWheel x %D -3.0 pixels + tk::MouseWheel %W x %D -3.0 pixels } bind Text { - tk::MouseWheel x %D -0.3 pixels + tk::MouseWheel %W x %D -0.3 pixels } # ::tk::TextClosestGap -- -- cgit v0.12