[Gd-chatter] r11563 - branches/opendylan-melange/gtk branches/opendylan-melange/gtk-c-ffi branches/opendylan-melange/gtk-duim branches/opendylan-melange/registry/generic branches/opendylan-melange/registry/x86-linux branches/opendylan-melange/registry/x86-win32 trunk/archive/stuff-from-fundev/gnu trunk/archive/stuff-from-fundev/gtk-2 trunk/archive/stuff-from-fundev/x11 trunk/fundev/sources/duim/gtk trunk/fundev/sources/gnu trunk/fundev/sources/gtk trunk/fundev/sources/gtk-2 trunk/fundev/sources/gtk/gtk-c-ffi trunk/fundev/sources/gtk/gtk-glue trunk/fundev/sources/registry/generic trunk/fundev/sources/registry/x86-linux trunk/fundev/sources/registry/x86-win32 trunk/fundev/sources/x11
hannes at gwydiondylan.org
hannes at gwydiondylan.org
Wed Dec 19 02:52:16 CET 2007
Author: hannes
Date: Wed Dec 19 02:52:11 2007
New Revision: 11563
Added:
trunk/archive/stuff-from-fundev/gnu/
- copied from r11561, trunk/fundev/sources/gnu/
trunk/archive/stuff-from-fundev/gtk-2/
- copied from r11561, trunk/fundev/sources/gtk-2/
trunk/archive/stuff-from-fundev/x11/
- copied from r11561, trunk/fundev/sources/x11/
trunk/fundev/sources/duim/gtk/gtk-layout.dylan
- copied unchanged from r11562, branches/opendylan-melange/gtk-duim/gtk-layout.dylan
trunk/fundev/sources/gtk/
trunk/fundev/sources/gtk/gtk-c-ffi/
- copied from r11561, branches/opendylan-melange/gtk-c-ffi/
trunk/fundev/sources/gtk/gtk-glue/
- copied from r11561, branches/opendylan-melange/gtk/
trunk/fundev/sources/registry/generic/gtk-duim (props changed)
- copied unchanged from r11561, trunk/fundev/sources/registry/x86-win32/gtk-duim
trunk/fundev/sources/registry/x86-linux/gtk (contents, props changed)
trunk/fundev/sources/registry/x86-linux/gtk-c-ffi (contents, props changed)
trunk/fundev/sources/registry/x86-win32/gtk (contents, props changed)
trunk/fundev/sources/registry/x86-win32/gtk-c-ffi (contents, props changed)
Removed:
branches/opendylan-melange/gtk/
branches/opendylan-melange/gtk-c-ffi/
branches/opendylan-melange/gtk-duim/
branches/opendylan-melange/registry/generic/duim
branches/opendylan-melange/registry/generic/gtk-duim
branches/opendylan-melange/registry/x86-linux/gtk
branches/opendylan-melange/registry/x86-linux/gtk-c-ffi
branches/opendylan-melange/registry/x86-win32/gtk
branches/opendylan-melange/registry/x86-win32/gtk-c-ffi
trunk/fundev/sources/gnu/
trunk/fundev/sources/gtk-2/
trunk/fundev/sources/registry/generic/atk
trunk/fundev/sources/registry/generic/gdk-2
trunk/fundev/sources/registry/generic/gdk-pixbuf-2
trunk/fundev/sources/registry/generic/glib-2
trunk/fundev/sources/registry/generic/gobject-2
trunk/fundev/sources/registry/generic/gtk-2
trunk/fundev/sources/registry/generic/pango
trunk/fundev/sources/registry/x86-linux/gtk-duim
trunk/fundev/sources/registry/x86-linux/gtk-duim-gadget-panes
trunk/fundev/sources/registry/x86-linux/xlib
trunk/fundev/sources/registry/x86-linux/xt
trunk/fundev/sources/registry/x86-win32/gdk
trunk/fundev/sources/registry/x86-win32/glib
trunk/fundev/sources/registry/x86-win32/gtk-common
trunk/fundev/sources/registry/x86-win32/gtk-duim
trunk/fundev/sources/registry/x86-win32/gtk-hello-world
trunk/fundev/sources/registry/x86-win32/gtk-scribble
trunk/fundev/sources/registry/x86-win32/gtk-widgets
trunk/fundev/sources/x11/
Modified:
trunk/fundev/sources/duim/gtk/duim.lid
trunk/fundev/sources/duim/gtk/gtk-colors.dylan
trunk/fundev/sources/duim/gtk/gtk-debug.dylan
trunk/fundev/sources/duim/gtk/gtk-dialogs.dylan
trunk/fundev/sources/duim/gtk/gtk-display.dylan
trunk/fundev/sources/duim/gtk/gtk-draw.dylan
trunk/fundev/sources/duim/gtk/gtk-duim-debug.lid
trunk/fundev/sources/duim/gtk/gtk-duim.lid
trunk/fundev/sources/duim/gtk/gtk-events.dylan
trunk/fundev/sources/duim/gtk/gtk-fonts.dylan
trunk/fundev/sources/duim/gtk/gtk-framem.dylan
trunk/fundev/sources/duim/gtk/gtk-gadgets.dylan
trunk/fundev/sources/duim/gtk/gtk-keyboard.dylan
trunk/fundev/sources/duim/gtk/gtk-medium.dylan
trunk/fundev/sources/duim/gtk/gtk-menus.dylan
trunk/fundev/sources/duim/gtk/gtk-mirror.dylan
trunk/fundev/sources/duim/gtk/gtk-pixmaps.dylan
trunk/fundev/sources/duim/gtk/gtk-port.dylan
trunk/fundev/sources/duim/gtk/gtk-top.dylan
trunk/fundev/sources/duim/gtk/gtk-utils.dylan
trunk/fundev/sources/duim/gtk/library.dylan
trunk/fundev/sources/duim/gtk/module.dylan
trunk/fundev/sources/gtk/gtk-glue/gtk-linux.hdp (props changed)
trunk/fundev/sources/gtk/gtk-glue/gtk-win32.hdp (props changed)
trunk/fundev/sources/gtk/gtk-glue/gtk.dylan (props changed)
trunk/fundev/sources/gtk/gtk-glue/library.dylan (props changed)
trunk/fundev/sources/gtk/gtk-glue/module.dylan (props changed)
Log:
Job: fd
merge opendylan-melange/gtk-duim, opendylan-melange/gtk and opendylan-melange/gtk-c-ffi to trunk
move gtk-2, x11 and gnu from trunk to archive
update registries
Modified: trunk/fundev/sources/duim/gtk/duim.lid
==============================================================================
--- trunk/fundev/sources/duim/gtk/duim.lid (original)
+++ trunk/fundev/sources/duim/gtk/duim.lid Wed Dec 19 02:52:11 2007
@@ -4,7 +4,6 @@
Files: duim-library
Major-version: 2
Minor-version: 1
-Executable: DxDUIM
Base-address: 0x65c00000
Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
All rights reserved.
Modified: trunk/fundev/sources/duim/gtk/gtk-colors.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-colors.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-colors.dylan Wed Dec 19 02:52:11 2007
@@ -8,7 +8,7 @@
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
/// Palettes
-// /*---*** No palettes for now...
+/*---*** No palettes for now...
//--- How much more do we need to flesh out palettes?
define sealed class <gtk-palette> (<basic-palette>)
sealed slot port :: false-or(<port>),
@@ -18,7 +18,7 @@
required-init-keyword: colormap:;
sealed slot %default-drawable,
init-keyword: drawable:;
- sealed slot %gcontext :: false-or(<GdkGC*>) = #f;
+ sealed slot %gcontext :: false-or(<GdkGC>) = #f;
sealed constant slot %gc-cache :: <object-table> = make(<table>);
sealed constant slot %color-cache :: <object-table> = make(<table>);
sealed constant slot %pattern-cache :: <object-table> = make(<table>);
@@ -216,7 +216,7 @@
=> (pixel :: <integer>)
//--- Handle colormap resource exhaustion
let (plane-masks, pixels)
- = x/XAllocColorCells(x-display, x-colormap, #f, 0, 1)
+ = x/XAllocColorCells(x-display, x-colormap, #f, 0, 1);
ignore(plane-masks);
let pixel = pixels[0];
set-x-read-write-color(pixel, red, green, blue, x-display, x-colormap);
@@ -235,4 +235,4 @@
x/XStoreColor(x-display, x-colormap, x-color)
end
end method set-x-read-write-color;
-// */
+*/
Modified: trunk/fundev/sources/duim/gtk/gtk-debug.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-debug.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-debug.dylan Wed Dec 19 02:52:11 2007
@@ -7,4 +7,9 @@
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
- *debug-duim-function* := debug-message;
+
+define function dbg (message, #rest args)
+ apply(format-out, concatenate(message, "\n"), args);
+end;
+
+*debug-duim-function* := dbg;
Modified: trunk/fundev/sources/duim/gtk/gtk-dialogs.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-dialogs.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-dialogs.dylan Wed Dec 19 02:52:11 2007
@@ -29,8 +29,7 @@
define sealed method make-top-level-mirror
(sheet :: <top-level-sheet>, frame :: <dialog-frame>)
=> (mirror :: <top-level-mirror>)
-// let widget = GTK-WINDOW(gtk-window-new($GTK-WINDOW-DIALOG));
- let widget = GTK-WINDOW(gtk-dialog-new());
+ let widget = gtk-window-new($GTK-WINDOW-TOPLEVEL);
let owner = frame-owner(frame);
make(<dialog-mirror>,
widget: widget,
@@ -333,87 +332,48 @@
/// Choose file
-/*---
define sealed method do-choose-file
(framem :: <gtk-frame-manager>, owner :: <sheet>,
direction :: one-of(#"input", #"output"),
#key title :: false-or(<string>), documentation :: false-or(<string>), exit-boxes,
if-exists, if-does-not-exist = #"ask",
default :: false-or(<string>), default-type = $unsupplied,
- filters, default-filter,
+ filters, default-filter, selection-mode,
#all-keys)
=> (locator :: false-or(<string>), filter :: false-or(<integer>))
ignore(if-exists);
let _port = port(owner);
- let x-display = _port.%display;
let parent-widget = mirror-widget(sheet-mirror(owner));
- let (visual, colormap, depth) = xt/widget-visual-specs(parent-widget);
- let (directory, pattern) = gtk-directory-and-pattern(default, default-type);
- let shell-resources
- = vector(visual:, visual,
- colormap:, colormap,
- depth:, depth);
- let resources
- = vector(directory:, directory,
- pattern:, pattern,
- dialog-title:, title,
- dialog-style:, xm/$XmDIALOG-FULL-APPLICATION-MODAL,
- default-position:, #f);
-
- when (file-label)
- resources
- := concatenate!(resources, vector(file-list-label-string:, file-label))
- end;
- when (directory-label)
- resources
- := concatenate!(resources, vector(dir-list-label-string:, directory-label))
- end;
- let (x, y)
- = begin
- let (x, y) = sheet-size(owner);
- let (x, y) = values(floor/(x, 2), floor/(y, 2));
- with-device-coordinates (sheet-device-transform(owner), x, y)
- values(x, y)
- end
+ let (mtitle, action, second-name)
+ = if (direction == #"output")
+ values("Save File", $GTK-FILE-CHOOSER-ACTION-SAVE, $GTK-STOCK-SAVE)
+ else
+ values("Open File", $GTK-FILE-CHOOSER-ACTION-OPEN, $GTK-STOCK-OPEN);
end;
- let shell = #f;
- let dialog = #f;
- let result = #f;
- let client-data = #f;
- block ()
- local method waiter () result end method,
- method setter (value) result := value end method;
- shell := xt/XtCreatePopupShell("ChooseFileShell", xm/<dialog-shell>, parent-widget,
- resources: shell-resources);
- dialog := xm/XmCreateFileSelectionBox(shell, "ChooseFile",
- resources: resources);
- client-data := make(<callback-client-data>,
- owner-widget: parent-widget,
- x-display: x-display,
- pointer-x: x,
- pointer-y: y,
- setter: setter);
- xt/XtAddCallback(dialog, "okCallback", choose-file-button-press-callback, client-data);
- xt/XtAddCallback(dialog, "cancelCallback", choose-file-button-press-callback, client-data)
- xt/XtUnmanageChild(xm/XmFileSelectionBoxGetChild(dialog, xm/$XmDIALOG-HELP-BUTTON))
- xt/XtAddCallback(dialog, "mapCallback", notifier-map-callback, client-data);
- xm/XmAddWmProtocolCallback(xt/XtParent(dialog), "wmDeleteWindow", notifier-delete-window-callback, setter);
- xt/XtManageChild(dialog);
- //---*** CLIM does this: '(mp:process-wait "Waiting for CLIM:SELECT-FILE" #'waiter)'
- if (result == #"cancel")
- values(#f, #f)
+ with-gdk-lock
+ let dialog
+ = gtk-file-chooser-dialog-new (title | mtitle, parent-widget, action,
+ null-pointer(<gchar*>));
+ gtk-dialog-add-button(dialog, $GTK-STOCK-CANCEL, $GTK-RESPONSE-CANCEL);
+ gtk-dialog-add-button(dialog, second-name, $GTK-RESPONSE-ACCEPT);
+ if (default)
+ gtk-file-chooser-set-filename(dialog, default)
+ end;
+ let filename =
+ if (gtk-dialog-run (dialog) == $GTK-RESPONSE-ACCEPT)
+ gtk-file-chooser-get-filename(dialog); // FIXME: leaks the filename C string
+ end;
+ gtk-widget-destroy(dialog);
+ if (filename)
+ values(as(<byte-string>, filename), #f)
else
- values(result, #f)
- end
- cleanup
- when (dialog)
- x/XSync(x-display, #f);
- xt/XtUnmanageChild(dialog);
- xt/XtDestroyWidget(shell)
+ values(#f, #f);
end;
- end
+ end;
end method do-choose-file;
+
+/*---
define xm/xm-callback-function choose-file-button-press-callback
(widget, client-data :: <callback-client-data>, call-data :: xm/<XmFileSelectionBoxCallbackStruct>)
ignore(widget);
Modified: trunk/fundev/sources/duim/gtk/gtk-display.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-display.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-display.dylan Wed Dec 19 02:52:11 2007
@@ -53,7 +53,7 @@
(parent :: <display-mirror>, child :: <top-level-mirror>,
x :: <integer>, y :: <integer>)
=> ()
- let widget = GTK-WIDGET(mirror-widget(child));
+ let widget = mirror-widget(child);
//---*** This causes problems!
// gtk-widget-set-uposition(widget, x, y)
end method move-mirror;
@@ -62,8 +62,8 @@
(parent :: <display-mirror>, child :: <top-level-mirror>,
width :: <integer>, height :: <integer>)
=> ()
- let widget = GTK-WIDGET(mirror-widget(child));
+ let widget = mirror-widget(child);
//--- This may not work after the sheet is mapped...
//---*** This causes the window to grow and grow...
- // gtk-window-set-default-size(widget, width, height)
+ gtk-window-set-default-size(widget, width, height)
end method size-mirror;
Modified: trunk/fundev/sources/duim/gtk/gtk-draw.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-draw.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-draw.dylan Wed Dec 19 02:52:11 2007
@@ -14,49 +14,53 @@
define sealed method draw-point
(medium :: <gtk-medium>, x, y) => (record)
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium);
let transform = medium-device-transform(medium);
with-device-coordinates (transform, x, y)
let thickness = pen-width(medium-pen(medium));
- if (thickness < 2)
- gdk-draw-point(drawable, gcontext, x, y)
- else
- let thickness/2 = truncate/(thickness, 2);
- gdk-draw-arc(drawable, gcontext, $true,
- x - thickness/2, y - thickness/2, thickness, thickness,
- 0, $2pi-in-64ths-of-degree)
- end
+ with-gdk-lock
+ if (thickness < 2)
+ gdk-draw-point(drawable, gcontext, x, y)
+ else
+ let thickness/2 = truncate/(thickness, 2);
+ gdk-draw-arc(drawable, gcontext, $true,
+ x - thickness/2, y - thickness/2, thickness, thickness,
+ 0, $2pi-in-64ths-of-degree)
+ end
+ end;
end;
#f
end method draw-point;
define sealed method draw-points
(medium :: <gtk-medium>, coord-seq :: <coordinate-sequence>) => (record)
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium);
let transform = medium-device-transform(medium);
let thickness = pen-width(medium-pen(medium));
- if (thickness < 2)
- do-coordinates
- (method (x, y)
- with-device-coordinates (transform, x, y)
+ with-gdk-lock
+ if (thickness < 2)
+ do-coordinates
+ (method (x, y)
+ with-device-coordinates (transform, x, y)
//---*** Use gdk-draw-points
- gdk-draw-point(drawable, gcontext, x, y)
- end
- end,
- coord-seq)
- else
- let thickness/2 = truncate/(thickness, 2);
- do-coordinates
- (method (x, y)
- with-device-coordinates (transform, x, y)
- gdk-draw-arc(drawable, gcontext, $true,
- x - thickness/2, y - thickness/2, thickness, thickness,
- 0, $2pi-in-64ths-of-degree)
- end
- end,
- coord-seq)
+ gdk-draw-point(drawable, gcontext, x, y)
+ end
+ end,
+ coord-seq)
+ else
+ let thickness/2 = truncate/(thickness, 2);
+ do-coordinates
+ (method (x, y)
+ with-device-coordinates (transform, x, y)
+ gdk-draw-arc(drawable, gcontext, $true,
+ x - thickness/2, y - thickness/2, thickness, thickness,
+ 0, $2pi-in-64ths-of-degree)
+ end
+ end,
+ coord-seq)
+ end;
end;
#f
end method draw-points;
@@ -87,28 +91,32 @@
define sealed method draw-line
(medium :: <gtk-medium>, x1, y1, x2, y2) => (record)
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium, pen: medium-pen(medium));
let transform = medium-device-transform(medium);
with-device-coordinates (transform, x1, y1, x2, y2)
- gdk-draw-line(drawable, gcontext, x1, y1, x2, y2)
+ with-gdk-lock
+ gdk-draw-line(drawable, gcontext, x1, y1, x2, y2)
+ end;
end;
#f
end method draw-line;
define sealed method draw-lines
(medium :: <gtk-medium>, coord-seq :: <coordinate-sequence>) => (record)
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium, pen: medium-pen(medium));
let transform = medium-device-transform(medium);
//---*** Use gdk-draw-segments
- do-endpoint-coordinates
- (method (x1, y1, x2, y2)
- with-device-coordinates (transform, x1, y1, x2, y2)
- gdk-draw-line(drawable, gcontext, x1, y1, x2, y2)
- end
- end,
- coord-seq);
+ with-gdk-lock
+ do-endpoint-coordinates
+ (method (x1, y1, x2, y2)
+ with-device-coordinates (transform, x1, y1, x2, y2)
+ gdk-draw-line(drawable, gcontext, x1, y1, x2, y2)
+ end
+ end,
+ coord-seq);
+ end;
#f
end method draw-lines;
@@ -121,13 +129,15 @@
draw-polygon(medium, coords, filled?: filled?, closed?: #t)
end
else
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium, pen: ~filled? & medium-pen(medium));
//---*** Might need to use 'gdk-gc-set-ts-origin' to set tile/stipple origin to x1/y1
with-device-coordinates (transform, x1, y1, x2, y2)
- gdk-draw-rectangle(drawable, gcontext,
- if (filled?) $true else $false end,
- x1, y1, x2 - x1, y2 - y1)
+ with-gdk-lock
+ gdk-draw-rectangle(drawable, gcontext,
+ if (filled?) $true else $false end,
+ x1, y1, x2 - x1, y2 - y1)
+ end
end
end;
#f
@@ -140,15 +150,17 @@
if (~rectilinear-transform?(transform))
draw-transformed-rectangles(medium, coord-seq, filled?: filled?)
else
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium, pen: ~filled? & medium-pen(medium));
let transform = medium-device-transform(medium);
do-endpoint-coordinates
(method (x1, y1, x2, y2)
with-device-coordinates (transform, x1, y1, x2, y2)
- gdk-draw-rectangle(drawable, gcontext,
- if (filled?) $true else $false end,
- x1, y1, x2 - x1, y2 - y1)
+ with-gdk-lock
+ gdk-draw-rectangle(drawable, gcontext,
+ if (filled?) $true else $false end,
+ x1, y1, x2 - x1, y2 - y1)
+ end
end
end,
coord-seq);
@@ -182,7 +194,7 @@
define sealed method draw-rounded-rectangle
(medium :: <gtk-medium>, x1, y1, x2, y2,
#key filled? = #t, radius) => (record)
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium, pen: ~filled? & medium-pen(medium));
let transform = medium-device-transform(medium);
with-device-coordinates (transform, x1, y1, x2, y2)
@@ -200,13 +212,13 @@
define sealed method draw-polygon
(medium :: <gtk-medium>, coord-seq :: <coordinate-sequence>,
#key closed? = #t, filled? = #t) => (record)
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium, pen: ~filled? & medium-pen(medium));
let transform = medium-device-transform(medium);
let scoords :: <integer> = size(coord-seq);
let ncoords :: <integer> = size(coord-seq);
let npoints :: <integer> = floor/(ncoords, 2) + if (closed? & ~filled?) 1 else 0 end;
- with-stack-structure (points :: <GdkPoint*>, element-count: npoints)
+ with-stack-structure (points :: <GdkPoint>, element-count: npoints)
//--- Can't use without-bounds-checks until it works on FFI 'element-setter' calls
// without-bounds-checks
for (i :: <integer> from 0 below ncoords by 2,
@@ -233,11 +245,12 @@
end
end;
// end;
- if (filled?)
- gdk-draw-polygon(drawable, gcontext,
- $true,
- points, npoints)
- else
+ with-gdk-lock
+ if (filled?)
+ gdk-draw-polygon(drawable, gcontext,
+ $true,
+ points, npoints)
+ else
// ---*** gdk-draw-lines doesn't work on Win32 for some reason so use kludge instead.
// ---*** Kludge draws each line in turn after frigging the gcontext so that
// ---*** the line ends don't go over the start of the next line.
@@ -245,37 +258,38 @@
// ---*** (I tried both Dylan stack allocated and gdk-gc-new gcontexts)
// ---*** so the code has to frig a potentially shared gcontext (= not good).
// gdk-draw-lines(drawable, gcontext, points, npoints)
- with-stack-structure (gcontext-values :: <GdkGCValues*>)
- let old-cap-style = #f;
- block ()
- gdk-gc-get-values(gcontext, gcontext-values);
- old-cap-style := gcontext-values.GdkGCValues-cap-style;
- gdk-gc-set-line-attributes(gcontext,
- gcontext-values.GdkGCValues-line-width,
- gcontext-values.GdkGCValues-line-style,
- $gdk-cap-butt, // NB short lines for better joins
- gcontext-values.GdkGCValues-join-style);
- let previous-p = pointer-value-address(points, index: 0);
- for (i from 1 below npoints)
- let previous-x :: <integer> = previous-p.GdkPoint-x;
- let previous-y :: <integer> = previous-p.GdkPoint-y;
- let p = pointer-value-address(points, index: i);
- let x = p.GdkPoint-x;
- let y = p.GdkPoint-y;
- gdk-draw-line(drawable, gcontext, previous-x, previous-y, x, y);
- previous-p := p;
- end;
- cleanup
- if (old-cap-style)
+ with-stack-structure (gcontext-values :: <GdkGCValues>)
+ let old-cap-style = #f;
+ block ()
+ gdk-gc-get-values(gcontext, gcontext-values);
+ old-cap-style := gcontext-values.GdkGCValues-cap-style;
gdk-gc-set-line-attributes(gcontext,
gcontext-values.GdkGCValues-line-width,
gcontext-values.GdkGCValues-line-style,
- old-cap-style,
+ $gdk-cap-butt, // NB short lines for better joins
gcontext-values.GdkGCValues-join-style);
- end;
- end block;
- end with-stack-structure;
- end
+ let previous-p = pointer-value-address(points, index: 0);
+ for (i from 1 below npoints)
+ let previous-x :: <integer> = previous-p.GdkPoint-x;
+ let previous-y :: <integer> = previous-p.GdkPoint-y;
+ let p = pointer-value-address(points, index: i);
+ let x = p.GdkPoint-x;
+ let y = p.GdkPoint-y;
+ gdk-draw-line(drawable, gcontext, previous-x, previous-y, x, y);
+ previous-p := p;
+ end;
+ cleanup
+ if (old-cap-style)
+ gdk-gc-set-line-attributes(gcontext,
+ gcontext-values.GdkGCValues-line-width,
+ gcontext-values.GdkGCValues-line-style,
+ old-cap-style,
+ gcontext-values.GdkGCValues-join-style);
+ end;
+ end block;
+ end with-stack-structure;
+ end if;
+ end with-gdk-lock;
end;
#f
end method draw-polygon;
@@ -284,7 +298,7 @@
(medium :: <gtk-medium>, center-x, center-y,
radius-1-dx, radius-1-dy, radius-2-dx, radius-2-dy,
#key start-angle, end-angle, filled? = #t) => (record)
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium, pen: ~filled? & medium-pen(medium));
let transform = medium-device-transform(medium);
with-device-coordinates (transform, center-x, center-y)
@@ -308,10 +322,12 @@
end;
x-radius := abs(x-radius);
y-radius := abs(y-radius);
- gdk-draw-arc(drawable, gcontext,
- if (filled?) $true else $false end,
- center-x - x-radius, center-y - y-radius,
- x-radius * 2, y-radius * 2, angle, delta-angle)
+ with-gdk-lock
+ gdk-draw-arc(drawable, gcontext,
+ if (filled?) $true else $false end,
+ center-x - x-radius, center-y - y-radius,
+ x-radius * 2, y-radius * 2, angle, delta-angle)
+ end
else
ignoring("draw-ellipse for tilted ellipses");
#f
@@ -325,7 +341,7 @@
// GTK bitmaps and icons are handled separately
define sealed method draw-image
(medium :: <gtk-medium>, image :: <image>, x, y) => (record)
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
= update-drawing-state(medium);
let transform = medium-device-transform(medium);
with-device-coordinates (transform, x, y)
@@ -424,13 +440,25 @@
define sealed method clear-box
(medium :: <gtk-medium>, left, top, right, bottom) => ()
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
- = get-gcontext(medium);
- let sheet = medium-sheet(medium);
- let transform = sheet-device-transform(sheet);
- with-device-coordinates (transform, left, top, right, bottom)
- gdk-window-clear-area(drawable, left, top, right - left, bottom - top)
- end
+ with-gdk-lock
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
+ = get-gcontext(medium);
+ let colormap = gdk-gc-get-colormap(gcontext);
+ with-stack-structure (color :: <GdkColor>)
+ gdk-color-white(colormap, color);
+ gdk-gc-set-foreground(gcontext, color);
+ end;
+ let sheet = medium-sheet(medium);
+ let transform = sheet-device-transform(sheet);
+ with-device-coordinates (transform, left, top, right, bottom)
+ //gdk-window-clear-area(drawable, left, top, right - left, bottom - top)
+ gdk-draw-rectangle(drawable, gcontext, $true, left, top, right - left, bottom - top);
+ end;
+ with-stack-structure (color :: <GdkColor>)
+ gdk-color-black(colormap, color);
+ gdk-gc-set-foreground(gcontext, color);
+ end;
+ end;
end method clear-box;
@@ -454,56 +482,69 @@
#key start: _start :: <integer> = 0, end: _end :: <integer> = size(string),
align-x = #"left", align-y = #"baseline", do-tabs? = #f,
towards-x, towards-y, transform-glyphs?) => (record)
- let text-style :: <text-style> = medium-merged-text-style(medium);
- let font :: <gtk-font> = text-style-mapping(port(medium), text-style);
- let length :: <integer> = size(string);
- let (drawable :: <GdkDrawable*>, gcontext :: <GdkGC*>)
- = update-drawing-state(medium, font: font);
- let transform = medium-device-transform(medium);
- with-device-coordinates (transform, x, y)
- when (towards-x & towards-y)
- convert-to-device-coordinates!(transform, towards-x, towards-y)
- end;
- //---*** What about x and y alignment?
- if (do-tabs?)
- ignoring("draw-text with do-tabs?: #t");
- /*---*** Not yet implemented!
- let tab-width = text-size(medium, " ") * 8;
- let tab-origin = if (do-tabs? == #t) x else do-tabs? end;
- let x = 0;
- let s = _start;
- block (break)
- while (#t)
- let e = position(string, '\t', start: s, end: _end);
- //---*** It would be great if 'with-c-string' took start & end!
- let substring = copy-sequence(string, start: s, end: e);
- with-c-string (c-string = substring)
- gdk-draw-text(drawable, font, gcontext,
- tab-origin + x, y, string, e - s)
- end;
- if (e = _end)
- break()
- else
- let (x1, y1, x2, y2) = GET-STRING-EXTENT(drawable, string, font, s, e);
- ignore(x1, y1, y2);
- x := floor/(x + x2 + tab-width, tab-width) * tab-width;
- s := min(e + 1, _end)
- end
- end
- end
- */
- else
- ignoring("draw-text");
- /*---*** Fonts not working yet!
- //---*** It would be great if 'with-c-string' took start & end!
- let substring
- = if (_start = 0 & _end = length) string
- else copy-sequence(string, start: _start, end: _end) end;
- with-c-string (c-string = substring)
- gdk-draw-string(drawable, font, gcontext,
- x, y, c-string)
+ with-gdk-lock
+ let text-style :: <text-style> = medium-merged-text-style(medium);
+ let font :: <gtk-font> = text-style-mapping(port(medium), text-style);
+ let length :: <integer> = size(string);
+ let (drawable :: <GdkDrawable>, gcontext :: <GdkGC>)
+ = update-drawing-state(medium, font: font);
+ let screen = gdk-drawable-get-screen(drawable);
+ // let renderer = gdk-pango-renderer-get-default(screen);
+ // gdk-pango-renderer-set-gc(renderer, gcontext);
+ let context = gdk-pango-context-get-for-screen(screen);
+ let (_font, _width, _height, ascent) = gtk-font-metrics(font, context);
+ let layout = pango-layout-new(context);
+ pango-layout-set-font-description(layout, font.%font-description);
+ let transform = medium-device-transform(medium);
+ with-device-coordinates (transform, x, y)
+ when (towards-x & towards-y)
+ convert-to-device-coordinates!(transform, towards-x, towards-y)
+ end;
+ //---*** What about x and y alignment?
+ if (do-tabs?)
+ let tab-width = text-size(medium, " ") * 8;
+ let tab-origin = if (do-tabs? == #t) x else do-tabs? end;
+ let x = 0;
+ let s = _start;
+ block (break)
+ while (#t)
+ let e = position(string, '\t', start: s, end: _end) | _end;
+ let substring = copy-sequence(string, start: s, end: e);
+ pango-layout-set-text(layout, substring, e - s);
+ // pango-layout-context-changed(layout);
+ // pango-renderer-draw-layout(renderer, layout, tab-origin + x, y);
+ gdk-draw-layout(drawable, gcontext, tab-origin + x, y - ascent, layout);
+ if (e = _end)
+ break()
+ else
+ with-stack-structure (rectangle :: <PangoRectangle>)
+ pango-layout-get-pixel-extents(layout, null-pointer(<PangoRectangle>), rectangle);
+ x := floor/(x + rectangle.PangoRectangle-x + rectangle.PangoRectangle-width
+ + tab-width, tab-width) * tab-width;
+ s := min(e + 1, _end)
+ end;
+ end
+ end
+ end
+ else
+ let substring
+ = if (_start = 0 & _end = length)
+ string
+ else
+ copy-sequence(string, start: _start, end: _end)
+ end;
+ pango-layout-set-text(layout, substring, -1);
+ //pango-layout-context-changed(layout);
+ //pango-renderer-draw-layout(renderer, layout, x, y);
+ gdk-draw-layout(drawable, gcontext, x, y - ascent, layout);
end
- */
end
end
end method draw-text;
+
+
+
+
+
+
+
Modified: trunk/fundev/sources/duim/gtk/gtk-duim-debug.lid
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-duim-debug.lid (original)
+++ trunk/fundev/sources/duim/gtk/gtk-duim-debug.lid Wed Dec 19 02:52:11 2007
@@ -17,6 +17,7 @@
gtk-pixmaps
gtk-top
gtk-gadgets
+ gtk-layout
gtk-menus
gtk-dialogs
gtk-help
Modified: trunk/fundev/sources/duim/gtk/gtk-duim.lid
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-duim.lid (original)
+++ trunk/fundev/sources/duim/gtk/gtk-duim.lid Wed Dec 19 02:52:11 2007
@@ -17,6 +17,7 @@
gtk-pixmaps
gtk-top
gtk-gadgets
+ gtk-layout
gtk-menus
gtk-dialogs
gtk-help
Modified: trunk/fundev/sources/duim/gtk/gtk-events.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-events.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-events.dylan Wed Dec 19 02:52:11 2007
@@ -7,198 +7,6 @@
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-/// GTK signals
-
-define constant $signal-handlers = make(<object-table>);
-
-define class <signal-handler> (<sealed-constructor-mixin>)
- constant sealed slot handler-name :: <C-string>,
- required-init-keyword: name:;
- constant sealed slot handler-function :: <GtkSignalFunc>,
- required-init-keyword: function:;
-end class <signal-handler>;
-
-define function register-signal-handler
- (name :: <string>, function :: <GtkSignalFunc>,
- #key key = as(<symbol>, name)) => ()
- $signal-handlers[key]
- := make(<signal-handler>,
- name: as(<C-string>, name),
- function: function)
-end function register-signal-handler;
-
-define function fetch-signal-handler
- (name :: <symbol>) => (_handler :: <signal-handler>)
- element($signal-handlers, name, default: #f)
- | error("No GTK handler registered for '%s'", name)
-end function fetch-signal-handler;
-
-define function do-with-disabled-event-handler
- (function :: <function>, widget :: <GtkWidget*>, name :: <symbol>)
- => (#rest values)
- let _handler = handler-function(fetch-signal-handler(name));
- let object = GTK-OBJECT(widget);
- block ()
- gtk-signal-handler-block-by-func(object, _handler, $null-gpointer);
- function()
- cleanup
- gtk-signal-handler-unblock-by-func(object, _handler, $null-gpointer);
- end
-end function do-with-disabled-event-handler;
-
-define macro with-disabled-event-handler
- { with-disabled-event-handler (?widget:expression, ?name:expression)
- ?body:body
- end }
- => { do-with-disabled-event-handler(method () ?body end, GTK-WIDGET(?widget), ?name) }
-end macro with-disabled-event-handler;
-
-define macro event-handler-definer
- { define event-handler (?name:name, ?event-type:name)
- ?eq:token ?handler:name }
- => { define gtk-callback ("_gtk-" ## ?name ## "-callback", ?event-type)
- ?eq "handle_" ## ?name;
- register-signal-handler(as-lowercase(?"name"), "_gtk-" ## ?name ## "-callback");
- define open generic ?handler
- (sheet :: <abstract-sheet>, widget :: <GtkWidget*>,
- event :: ?event-type)
- => (handled? :: <boolean>);
- define function "handle_" ## ?name
- (widget :: <GtkWidget*>, event :: ?event-type)
- => (code :: <integer>)
- do-handle-gtk-signal
- (?handler, widget, ?"name", widget, event)
- end }
-end macro event-handler-definer;
-
-define event-handler (destroy, <GdkEventAny*>) = handle-gtk-destroy-event;
-define event-handler (delete_event, <GdkEventAny*>) = handle-gtk-delete-event;
-define event-handler (motion_notify_event, <GdkEventMotion*>) = handle-gtk-motion-event;
-define event-handler (button_press_event, <GdkEventButton*>) = handle-gtk-button-press-event;
-define event-handler (button_release_event, <GdkEventButton*>) = handle-gtk-button-release-event;
-define event-handler (key_press_event, <GdkEventKey*>) = handle-gtk-key-press-event;
-define event-handler (key_release_event, <GdkEventKey*>) = handle-gtk-key-release-event;
-define event-handler (configure_event, <GdkEventConfigure*>) = handle-gtk-configure-event;
-define event-handler (expose_event, <GdkEventExpose*>) = handle-gtk-expose-event;
-define event-handler (enter_event, <GdkEventCrossing*>) = handle-gtk-enter-event;
-define event-handler (leave_event, <GdkEventCrossing*>) = handle-gtk-leave-event;
-
-define event-handler (clicked, <GdkEventAny*>) = handle-gtk-clicked-event;
-define event-handler (select_row, <GdkEventAny*>) = handle-gtk-select-row-event;
-define event-handler (click_column, <GdkEventAny*>) = handle-gtk-click-column-event;
-define event-handler (resize_column, <GdkEventAny*>) = handle-gtk-resize-column-event;
-
-
-define inline function do-handle-gtk-signal
- (handler_ :: <function>, widget :: <GtkWidget*>, name :: <string>,
- #rest args)
- => (code :: <integer>)
- let mirror = widget-mirror(widget);
- debug-assert(mirror, "Unknown widget");
- let gadget = mirror-sheet(mirror);
- duim-debug-message("Handling %s for %=", name, gadget);
- let value = apply(handler_, gadget, args);
- duim-debug-message(" handled?: %=", value);
- if (instance?(value, <integer>))
- value
- elseif (value)
- $true
- else
- $false
- end
-end function do-handle-gtk-signal;
-
-/// Non-event signals
-
-define macro signal-handler-definer
- { define signal-handler ?:name (?args:*) ?eq:token ?handler:name }
- => { signal-handler-aux ?"name",
- ?handler (?args),
- "%gtk-" ## ?name ## "-signal-handler" (?args),
- "_gtk-" ## ?name ## "-signal-handler" (?args)
- end }
-end macro;
-define macro signal-handler-aux
- { signal-handler-aux ?signal:expression,
- ?handler:name (?args),
- ?%handler:name (?params:*),
- ?_handler:name (?c-params)
- end }
- => { define function ?%handler (widget :: <GtkWidget*>, ?params)
- do-handle-gtk-signal(?handler, widget, ?signal, ?args)
- end;
- define C-callable-wrapper ?_handler of ?%handler
- parameter widget :: <GtkWidget*>;
- ?c-params
- end;
- register-signal-handler(?signal, ?_handler)
- }
-c-params:
- { } => { }
- { ?:variable, ... } => { parameter ?variable; ... }
-args:
- { } => { }
- { ?arg:name :: ?:expression, ... } => { ?arg, ... }
-end macro;
-
-define signal-handler changed (user-data :: <gpointer>)
- = gtk-changed-signal-handler;
-define signal-handler activate (user-data :: <gpointer>)
- = gtk-activate-signal-handler;
-
-
-/// Adjustments
-define function %gtk-adjustment-value-changed-signal-handler
- (adj :: <GtkAdjustment*>, widget :: <GtkWidget*>)
- do-handle-gtk-signal(gtk-adjustment-value-changed-signal-handler,
- widget, "adjustment/value_changed", adj)
-end;
-define C-callable-wrapper _gtk-adjustment-value-changed-signal-handler
- of %gtk-adjustment-value-changed-signal-handler
- parameter adj :: <GtkAdjustment*>;
- parameter user-data :: <GtkWidget*>;
-end;
-register-signal-handler("value_changed",
- _gtk-adjustment-value-changed-signal-handler,
- key: #"adjustment/value_changed");
-
-define function install-named-handlers
- (mirror :: <gtk-mirror>, handlers :: <sequence>, #key adjustment) => ()
- let widget = mirror-widget(mirror);
- let object = GTK-OBJECT(widget);
- duim-debug-message("Installing handlers for %=: %=",
- mirror-sheet(mirror), handlers);
- for (key :: <symbol> in handlers)
- let handler_ = fetch-signal-handler(key);
- if (handler_)
- let name = as(<byte-string>, handler_.handler-name);
- let function = handler_.handler-function;
- let value = if (adjustment)
- g-signal-connect(adjustment, name, function, widget);
- else
- //--- Should we pass an object to help map back to a mirror?
- g-signal-connect(object, name, function, $null-gpointer);
- end;
- if (zero?(value))
- duim-debug-message("Unable to connect signal '%s'", name)
- end
- end
- end;
- gtk-widget-add-events(widget,
- logior($GDK-EXPOSURE-MASK, $GDK-LEAVE-NOTIFY-MASK,
- if (member?(#"motion_notify_event", handlers))
- logior($GDK-POINTER-MOTION-MASK, $GDK-POINTER-MOTION-HINT-MASK)
- else
- 0
- end,
- if (member?(#"button_press_event", handlers))
- logior($GDK-BUTTON-PRESS-MASK, $GDK-BUTTON-RELEASE-MASK)
- else
- 0
- end));
-end function install-named-handlers;
-
-
/// Install event handlers
define sealed method generate-trigger-event
@@ -215,7 +23,16 @@
=> (timed-out? :: <boolean>)
//--- We should do something with the timeout
ignore(timeout);
- gtk-main-iteration();
+ if ($os-name == #"win32")
+ with-gdk-lock
+ gtk-main-iteration();
+ end;
+ else
+ sleep(3);
+ with-gdk-lock
+ gtk-main();
+ end;
+ end;
#f;
end method process-next-event;
@@ -223,7 +40,7 @@
/// Event handlers
define method handle-gtk-destroy-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventAny*>)
+ (sheet :: <sheet>, widget :: <GtkWidget>, event :: <GdkEventAny>)
=> (handled? :: <boolean>)
ignoring("handle-gtk-destroy-event");
// frame-can-quit?...
@@ -231,10 +48,8 @@
end method handle-gtk-destroy-event;
define method handle-gtk-motion-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventMotion*>)
+ (sheet :: <sheet>, event :: <GdkEventMotion>)
=> (handled? :: <boolean>)
- let mirror = widget-mirror(widget);
- let sheet = mirror-sheet(mirror);
let _port = port(sheet);
when (_port)
ignoring("motion modifiers");
@@ -269,14 +84,14 @@
end method handle-gtk-motion-event;
define method handle-gtk-enter-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventCrossing*>)
+ (sheet :: <sheet>, widget :: <GtkWidget>, event :: <GdkEventCrossing>)
=> (handled? :: <boolean>)
ignore(widget);
handle-gtk-crossing-event(sheet, event, <pointer-enter-event>)
end method handle-gtk-enter-event;
define method handle-gtk-leave-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventCrossing*>)
+ (sheet :: <sheet>, widget :: <GtkWidget>, event :: <GdkEventCrossing>)
=> (handled? :: <boolean>)
ignore(widget);
handle-gtk-crossing-event(sheet, event, <pointer-exit-event>)
@@ -284,7 +99,7 @@
// Watch out, because leave events show up after window have been killed!
define sealed method handle-gtk-crossing-event
- (sheet :: <sheet>, event :: <GdkEventCrossing*>,
+ (sheet :: <sheet>, event :: <GdkEventCrossing>,
event-class :: subclass(<pointer-motion-event>))
=> (handled? :: <boolean>)
let _port = port(sheet);
@@ -318,20 +133,8 @@
end
end function gtk-detail->duim-crossing-kind;
-define method handle-gtk-button-press-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventButton*>)
- => (handled? :: <boolean>)
- handle-gtk-button-event(sheet, widget, event)
-end method handle-gtk-button-press-event;
-
-define method handle-gtk-button-release-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventButton*>)
- => (handled? :: <boolean>)
- handle-gtk-button-press-event(sheet, widget, event)
-end method handle-gtk-button-release-event;
-
define method handle-gtk-button-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventButton*>)
+ (sheet :: <sheet>, event :: <GdkEventButton>)
=> (handled? :: <boolean>)
let _port = port(sheet);
when (_port)
@@ -343,24 +146,25 @@
let modifiers = 0; //--- Do this!
let event-class
= select (type)
- $GDK-2BUTTON-PRESS => <double-click-event>;
- $GDK-BUTTON-PRESS => <button-press-event>;
- $GDK-BUTTON-RELEASE => <button-release-event>;
- otherwise => #f;
- end;
+ $GDK-2BUTTON-PRESS => <double-click-event>;
+ $GDK-BUTTON-PRESS => <button-press-event>;
+ $GDK-BUTTON-RELEASE => <button-release-event>;
+ otherwise => #f;
+ end;
if (event-class)
let (x, y)
- = untransform-position(sheet-native-transform(sheet), native-x, native-y);
+ = untransform-position(sheet-native-transform(sheet),
+ native-x, native-y);
port-modifier-state(_port) := modifiers;
let pointer = port-pointer(_port);
pointer-button-state(pointer) := button;
distribute-event(_port,
- make(event-class,
- sheet: sheet,
- pointer: pointer,
- button: button,
- modifier-state: modifiers,
- x: round(x), y: round(y)));
+ make(event-class,
+ sheet: sheet,
+ pointer: pointer,
+ button: button,
+ modifier-state: modifiers,
+ x: round(x), y: round(y)));
#t
end
end
@@ -376,7 +180,7 @@
end function gtk-button->duim-button;
define method handle-gtk-expose-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventExpose*>)
+ (sheet :: <sheet>, event :: <GdkEventExpose>)
=> (handled? :: <boolean>)
let _port = port(sheet);
when (_port)
@@ -485,9 +289,9 @@
*/
define method handle-gtk-configure-event
- (sheet :: <sheet>, widget :: <GtkWidget*>, event :: <GdkEventConfigure*>)
+ (sheet :: <sheet>, widget :: <GtkWidget>, event :: <GdkEventConfigure>)
=> (handled? :: <boolean>)
- let allocation = widget.GtkWidget-allocation;
+ let allocation = widget.gtk-widget-get-allocation;
let native-x = event.GdkEventConfigure-x;
let native-y = event.GdkEventConfigure-y;
let native-width = allocation.GdkRectangle-width;
Modified: trunk/fundev/sources/duim/gtk/gtk-fonts.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-fonts.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-fonts.dylan Wed Dec 19 02:52:11 2007
@@ -12,8 +12,8 @@
define sealed class <gtk-font> (<object>)
sealed slot %font-name :: <string>,
required-init-keyword: name:;
- sealed slot %font-id :: false-or(<GdkFont*>) = #f;
- sealed slot %font-struct = #f;
+ sealed slot %font-description :: <PangoFontDescription>,
+ required-init-keyword: description:;
end class <gtk-font>;
define sealed domain make (singleton(<gtk-font>));
@@ -51,13 +51,11 @@
/// Font mapping
-/*---*** Not used yet!
define constant $gtk-font-families :: <list>
- = #(#(#"fix", "courier"),
- #(#"sans-serif", "helvetica"),
- #(#"serif", "times", "charter", "new century schoolbook"),
+ = #(#(#"fix", "Monospace"),
+ #(#"sans-serif", "Sans"),
+ #(#"serif", "Serif"),
#(#"symbol", "symbol"));
-*/
//--- We should compute the numbers based on either device characteristics
//--- or some user option
@@ -70,7 +68,6 @@
#[#"tiny", 5],
#[#"huge", 18]];
-/*---*** Not used yet!
define method install-default-text-style-mappings
(_port :: <gtk-port>) => ()
ignoring("install-default-text-style-mappings");
@@ -89,24 +86,39 @@
=> (font-name :: <integer>)
not-yet-implemented("scaleable-font-name-at-size")
end method scaleable-font-name-at-size;
-*/
-
define sealed method do-text-style-mapping
(_port :: <gtk-port>, text-style :: <standard-text-style>, character-set)
=> (font :: <gtk-font>)
ignore(character-set);
- let text-style
- = standardize-text-style(_port, text-style,
- character-set: character-set);
- let table :: <object-table> = port-font-mapping-table(_port);
- let font = gethash(table, text-style);
- font
- | begin
- ignoring("do-text-style-mapping");
- //---*** This is not right!
- make(<gtk-font>, name: "fake")
- end
+ let table = port-font-mapping-table(_port);
+ let (font, found?) = gethash(table, text-style);
+ if (found?)
+ font
+ else
+ let size = if (instance?(text-style-size(text-style), <integer>))
+ text-style-size(text-style)
+ else
+ second(find-pair($gtk-logical-sizes, text-style-size(text-style)))
+ end;
+ let attributes = "";
+ if (text-style-weight(text-style) == #"bold")
+ attributes := concatenate(attributes, "bold ");
+ end;
+ if (text-style-slant(text-style) == #"italic")
+ attributes := concatenate(attributes, "italic ");
+ end;
+ let font-name
+ = format-to-string("%s %s%d",
+ second(find-pair($gtk-font-families, text-style-family(text-style))),
+ attributes,
+ size);
+ duim-debug-message("do-text-style-mapping: %s", font-name);
+ let font-description = with-gdk-lock pango-font-description-from-string(font-name) end;
+ let font = make(<gtk-font>, name: font-name, description: font-description);
+ table[text-style] := font;
+ font
+ end;
end method do-text-style-mapping;
//--- This approach seems unnecessarily clumsy; we might as well just have
@@ -180,12 +192,31 @@
gtk-font-metrics(font, _port)
end method font-metrics;
+define function gtk-get-pango-context-from-port (port :: <gtk-port>) => (context :: <pangocontext>)
+ let widget = port.port-displays.first.sheet-children.first.sheet-direct-mirror.mirror-widget; // YUCK!
+ gtk-widget-get-pango-context(widget);
+end;
+
+define sealed method gtk-font-metrics
+ (font :: <gtk-font>, pango-context :: <PangoContext>)
+ => (font :: <gtk-font>,
+ width :: <integer>, height :: <integer>, ascent :: <integer>, descent :: <integer>)
+ with-gdk-lock
+ let metrics = pango-context-get-metrics(pango-context, font.%font-description, pango-language-get-default());
+ values(font,
+ round/(pango-font-metrics-get-approximate-char-width(metrics), $PANGO-SCALE),
+ round/(pango-font-metrics-get-ascent(metrics) + pango-font-metrics-get-descent(metrics), $PANGO-SCALE),
+ round/(pango-font-metrics-get-ascent(metrics), $PANGO-SCALE),
+ round/(pango-font-metrics-get-descent(metrics), $PANGO-SCALE));
+ end;
+end;
+
define sealed method gtk-font-metrics
(font :: <gtk-font>, _port :: <gtk-port>)
=> (font :: <gtk-font>,
width :: <integer>, height :: <integer>, ascent :: <integer>, descent :: <integer>)
- ignoring("gtk-font-metrics");
- values(font, 100, 10, 8, 2)
+ let pango-context = gtk-get-pango-context-from-port(_port);
+ gtk-font-metrics(font, pango-context);
end method gtk-font-metrics;
@@ -220,8 +251,19 @@
_start :: <integer>, _end :: <integer>)
=> (x1 :: <integer>, y1 :: <integer>,
x2 :: <integer>, y2 :: <integer>)
- ignoring("measure-string");
- values(0, 0, 100, 10)
+ with-gdk-lock
+ let layout = pango-layout-new(gtk-get-pango-context-from-port(_port));
+ pango-layout-set-font-description(layout, font.%font-description);
+ pango-layout-set-text(layout,
+ copy-sequence(string, start: _start, end: _end),
+ _end - _start);
+ with-stack-structure (rectangle :: <PangoRectangle>)
+ pango-layout-get-pixel-extents(layout, null-pointer(<PangoRectangle>), rectangle);
+ values(rectangle.PangoRectangle-x, rectangle.PangoRectangle-y,
+ rectangle.PangoRectangle-x + rectangle.PangoRectangle-width,
+ rectangle.PangoRectangle-y + rectangle.PangoRectangle-height)
+ end;
+ end;
end method measure-string;
case
do-tabs? & do-newlines? =>
@@ -275,3 +317,9 @@
values(x2, y2 - y1, x2, y2 - y1, ascent);
end
end method text-size;
+
+
+
+
+
+
Modified: trunk/fundev/sources/duim/gtk/gtk-framem.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-framem.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-framem.dylan Wed Dec 19 02:52:11 2007
@@ -29,7 +29,7 @@
let sheet = top-level-sheet(frame);
let mirror = sheet & sheet-direct-mirror(sheet);
when (mirror)
- let widget = GTK-WINDOW(mirror-widget(mirror));
+ let widget = mirror-widget(mirror);
let title = frame-title(frame) | "";
with-c-string (c-string = title)
gtk-window-set-title(widget, c-string)
Modified: trunk/fundev/sources/duim/gtk/gtk-gadgets.dylan
==============================================================================
--- trunk/fundev/sources/duim/gtk/gtk-gadgets.dylan (original)
+++ trunk/fundev/sources/duim/gtk/gtk-gadgets.dylan Wed Dec 19 02:52:11 2007
@@ -89,10 +89,10 @@
define method do-compose-space
(gadget :: <gtk-gadget-mixin>, #key width, height)
=> (space-req :: <space-requirement>)
-// debug-message("do-compose-space(%= , %d, %d)", gadget, width, height);
+ debug-message("do-compose-space(%= , %d, %d)", gadget, width, height);
let mirror = sheet-direct-mirror(gadget);
if (mirror)
- let widget = GTK-WIDGET(mirror-widget(mirror));
+ let widget = mirror-widget(mirror);
gtk-space-requirements(gadget, widget)
else
gtk-debug("Composing space on an unmirrored gadget!");
@@ -102,7 +102,7 @@
// We take the values suggested by GTK as the default sizes
define method gtk-space-requirements
- (gadget :: <gtk-gadget-mixin>, widget :: <GtkWidget*>)
+ (gadget :: <gtk-gadget-mixin>, widget :: <GtkWidget>)
=> (space-req :: <space-requirement>)
let (width, height) = widget-size(widget);
let max-width = if (gadget.%gtk-fixed-width?) width else $fill end;
@@ -113,10 +113,16 @@
end method gtk-space-requirements;
define method widget-size
- (widget :: <GtkWidget*>)
+ (widget :: <GtkWidget>)
=> (width :: <integer>, height :: <integer>)
- with-stack-structure (request :: <GtkRequisition*>)
- gtk-widget-size-request(widget, request);
+ with-stack-structure (request :: <GtkRequisition>)
+ with-gdk-lock
+ gtk-widget-size-request(widget, request);
+ end;
+ duim-debug-message("widget-size for %= is %=x%=",
+ widget,
+ request.GtkRequisition-width,
+ request.GtkRequisition-height);
values(request.GtkRequisition-width, request.GtkRequisition-height)
end
end method widget-size;
@@ -172,16 +178,20 @@
(client, gadget :: <gtk-gadget-mixin>) => ()
ignore(client);
next-method();
- let widget = GTK-WIDGET(gadget-widget(gadget));
- gtk-widget-set-sensitive(widget, $true)
+ let widget = gadget-widget(gadget);
+ widget & with-gdk-lock
+ gtk-widget-set-sensitive(widget, $true)
+ end
end method note-gadget-enabled;
define sealed method note-gadget-disabled
(client, gadget :: <gtk-gadget-mixin>) => ()
ignore(client);
next-method();
- let widget = GTK-WIDGET(gadget-widget(gadget));
- gtk-widget-set-sensitive(widget, $false)
+ let widget = gadget-widget(gadget);
+ widget & with-gdk-lock
+ gtk-widget-set-sensitive(widget, $false)
+ end
end method note-gadget-disabled;
//---*** DO WE NEED THIS?
@@ -323,25 +333,26 @@
(gadget :: <gtk-label>)
=> (mirror :: <gadget-mirror>)
with-c-string (c-string = defaulted-gadget-label(gadget))
- let widget = GTK-LABEL(gtk-label-new(c-string));
- assert(~null-pointer?(widget), "gtk-label-new failed");
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget = gtk-label-new(c-string);
+ assert(~null-pointer?(widget), "gtk-label-new failed");
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end
end method make-gtk-mirror;
define sealed method update-mirror-label
(gadget :: <gtk-label>, mirror :: <gadget-mirror>) => ()
- with-c-string (c-string = defaulted-gadget-label(gadget))
- let widget = GTK-LABEL(mirror-widget(mirror));
- gtk-label-set-text(widget, c-string)
+ let widget = mirror-widget(mirror);
+ with-gdk-lock
+ gtk-label-set-text(widget, defaulted-gadget-label(gadget))
end
end method update-mirror-label;
/// Separators
-/*---*** Use the default separators
define sealed class <gtk-separator>
(<gtk-gadget-mixin>,
<separator>,
@@ -349,6 +360,24 @@
<sealed-constructor-mixin>)
end class <gtk-separator>;
+define method %gtk-fixed-width?
+ (gadget :: <gtk-separator>)
+ => (fixed? :: <boolean>)
+ select(gadget-orientation(gadget))
+ #"horizontal" => #f;
+ #"vertical" => #t;
+ end;
+end method;
+
+define method %gtk-fixed-height?
+ (gadget :: <gtk-separator>)
+ => (fixed? :: <boolean>)
+ select(gadget-orientation(gadget))
+ #"horizontal" => #t;
+ #"vertical" => #f;
+ end;
+end method;
+
define sealed method class-for-make-pane
(framem :: <gtk-frame-manager>, class == <separator>, #key)
=> (class :: <class>, options :: false-or(<sequence>))
@@ -358,34 +387,16 @@
define sealed method make-gtk-mirror
(gadget :: <gtk-separator>)
=> (mirror :: <gadget-mirror>)
- let parent = sheet-device-parent(gadget);
- let parent-widget = gadget-widget(parent);
- let (foreground, background, font) = widget-attributes(_port, gadget);
- ignore(font);
- let resources
- = vector(mapped-when-managed:, #f);
- let widget
- = xt/XtCreateManagedWidget("DUIMSeparator", xm/<XmSeparatorGadget>, parent-widget,
- resources:
- concatenate(resources, foreground, background));
- values(widget, #f)
-end method make-gtk-mirror;
-
-define sealed method do-compose-space
- (pane :: <gtk-separator>, #key width, height)
- => (space-requirement :: <space-requirement>)
- select (gadget-orientation(pane))
- #"horizontal" =>
- make(<space-requirement>,
- min-width: 1, width: width | 1, max-width: $fill,
- height: 2);
- #"vertical" =>
- make(<space-requirement>,
- width: 2,
- min-height: 1, height: height | 1, max-height: $fill);
+ with-gdk-lock
+ let widget = select(gadget-orientation(gadget))
+ #"horizontal" => gtk-hseparator-new();
+ #"vertical" => gtk-vseparator-new();
+ end;
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
end
-end method do-compose-space;
-*/
+end method make-gtk-mirror;
/// Buttons
@@ -396,12 +407,12 @@
define method install-event-handlers
(sheet :: <gtk-button-mixin>, mirror :: <gadget-mirror>) => ()
next-method();
- install-named-handlers(mirror, #[#"clicked"])
+ duim-g-signal-connect(sheet, #"clicked") (#rest args) handle-button-gadget-click(sheet) end;
end method install-event-handlers;
define sealed method handle-gtk-clicked-event
- (gadget :: <gtk-button-mixin>, widget :: <GtkWidget*>,
- event :: <GdkEventAny*>)
+ (gadget :: <gtk-button-mixin>, widget :: <GtkWidget>,
+ event :: <GdkEventAny>)
=> (handled? :: <boolean>)
gtk-debug("Clicked on button %=", gadget-label(gadget));
handle-button-gadget-click(gadget)
@@ -455,11 +466,13 @@
ignoring("image label")
end;
with-c-string (c-string = text)
- let widget = GTK-BUTTON(gtk-button-new-with-label(c-string));
- assert(~null-pointer?(widget), "gtk-button-new-with-label failed");
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget = gtk-button-new-with-label(c-string);
+ assert(~null-pointer?(widget), "gtk-button-new-with-label failed");
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end
end method make-gtk-mirror;
@@ -510,28 +523,31 @@
ignoring("image label")
end;
with-c-string (c-string = text)
- let widget
- = if (push-button-like?(gadget))
- GTK-TOGGLE-BUTTON(gtk-toggle-button-new-with-label(c-string))
- else
- GTK-RADIO-BUTTON(gtk-radio-button-new-with-label
- (null-pointer(<GSList*>), c-string))
- end;
- assert(~null-pointer?(widget), "gtk-toggle/radio-button-new-with-label failed");
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget
+ = if (push-button-like?(gadget))
+ gtk-toggle-button-new-with-label(c-string)
+ else
+ gtk-radio-button-new-with-label(null-pointer(<GSList>), c-string)
+ end;
+ assert(~null-pointer?(widget), "gtk-toggle/radio-button-new-with-label failed");
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end
end method make-gtk-mirror;
define method update-mirror-attributes
(gadget :: <gtk-radio-button>, mirror :: <gadget-mirror>) => ()
next-method();
- let widget = mirror.mirror-widget;
let selected? = gadget-value(gadget);
- with-disabled-event-handler (widget, #"clicked")
- gtk-toggle-button-set-active
- (widget, if (selected?) $true else $false end)
+ let widget = mirror-widget(mirror);
+ with-gdk-lock
+ with-disabled-event-handler (mirror, #"clicked")
+ gtk-toggle-button-set-active
+ (widget, if (selected?) $true else $false end)
+ end
end
end method update-mirror-attributes;
@@ -581,27 +597,31 @@
ignoring("image label")
end;
with-c-string (c-string = text)
- let widget
- = if (push-button-like?(gadget))
- GTK-TOGGLE-BUTTON(gtk-toggle-button-new-with-label(c-string))
- else
- GTK-CHECK-BUTTON(gtk-check-button-new-with-label(c-string))
- end;
- assert(~null-pointer?(widget), "gtk-toggle/radio-button-new-with-label failed");
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget
+ = if (push-button-like?(gadget))
+ gtk-toggle-button-new-with-label(c-string)
+ else
+ gtk-check-button-new-with-label(c-string)
+ end;
+ assert(~null-pointer?(widget), "gtk-toggle/radio-button-new-with-label failed");
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end
end method make-gtk-mirror;
define method update-mirror-attributes
(gadget :: <gtk-check-button>, mirror :: <gadget-mirror>) => ()
next-method();
- let widget = mirror.mirror-widget;
let selected? = gadget-value(gadget);
- with-disabled-event-handler (widget, #"clicked")
- gtk-toggle-button-set-active
- (widget, if (selected?) $true else $false end)
+ let widget = mirror-widget(mirror);
+ with-gdk-lock
+ with-disabled-event-handler (mirror, #"clicked")
+ gtk-toggle-button-set-active
+ (widget, if (selected?) $true else $false end)
+ end
end
end method update-mirror-attributes;
@@ -615,10 +635,6 @@
/// Text gadgets
-define gtk-type-cast-function GTK-EDITABLE => <GtkEditable*>;
-
-// --- TODO: should this be unicode?
-define gtk-type-cast-function GTK-STRING => <c-string>;
define method gtk-copy-text (text :: <c-string>) => (str :: <string>)
// Convert to gc'able string.
as(<byte-string>, text)
@@ -637,23 +653,10 @@
define method install-event-handlers
(sheet :: <gtk-text-gadget-mixin>, mirror :: <gadget-mirror>) => ()
next-method();
- install-named-handlers(mirror, #[#"changed", #"activate"]);
+ duim-g-signal-connect(sheet, #"activate") (#rest args) activate-gtk-gadget(sheet) end;
+ duim-g-signal-connect(sheet, #"changed") (#rest args) handle-text-gadget-changing(sheet) end;
end method install-event-handlers;
-// #"activate" signal
-define method gtk-activate-signal-handler (gadget :: <gtk-text-gadget-mixin>,
- user-data :: <gpointer>)
- ignore(user-data);
- activate-gtk-gadget(gadget);
-end;
-
-// #"changed" signal
-define method gtk-changed-signal-handler (gadget :: <gtk-text-gadget-mixin>,
- user-data :: <gpointer>)
- ignore(user-data);
- handle-text-gadget-changing(gadget);
-end;
-
define sealed method update-mirror-attributes
(gadget :: <gtk-text-gadget-mixin>, mirror :: <gadget-mirror>) => ()
next-method();
@@ -674,16 +677,18 @@
(gadget :: <gtk-text-gadget-mixin>) => ()
gtk-debug("handle-text-gadget-changing");
let old-text = gadget.gadget-text-buffer;
- let widget = GTK-EDITABLE(gadget-widget(gadget));
+ let widget = gadget-widget(gadget);
// --- TODO: use a stretchy buffer to avoid copying on each character?
- let chars = GTK-STRING(gtk-editable-get-chars(widget, 0, -1));
- let new-text = unless (old-text = chars)
- gadget.gadget-text-buffer := gtk-copy-text(chars);
- end;
- g-free(chars);
- when (new-text)
- gadget.%changed? := #t;
- distribute-text-changing-callback(gadget, new-text)
+ with-gdk-lock
+ let chars = gtk-editable-get-chars(widget, 0, -1);
+ let new-text = unless (old-text = chars)
+ gadget.gadget-text-buffer := gtk-copy-text(chars);
+ end;
+ g-free(chars);
+ when (new-text)
+ gadget.%changed? := #t;
+ distribute-text-changing-callback(gadget, new-text)
+ end;
end;
end method handle-text-gadget-changing;
@@ -699,7 +704,7 @@
define sealed method text-selection
(gadget :: <gtk-text-gadget-mixin>) => (range :: type-union(<text-range>, one-of(#f)))
- let widget = GTK-EDITABLE(gadget-widget(gadget));
+ let widget = gadget-widget(gadget);
let start-pos = widget.selection-start-pos-value;
let end-pos = widget.selection-end-pos-value;
when (start-pos < end-pos)
@@ -709,7 +714,7 @@
define sealed method selected-text
(gadget :: <gtk-text-gadget-mixin>) => (string :: false-or(<string>))
- let widget = GTK-EDITABLE(gadget-widget(gadget));
+ let widget = gadget-widget(gadget);
let start-pos = widget.selection-start-pos-value;
let end-pos = widget.selection-end-pos-value;
if (start-pos >= end-pos)
@@ -717,10 +722,12 @@
elseif (start-pos = 0 & end-pos = gadget.gadget-text-buffer.size)
gadget.gadget-text-buffer
else
- let chars = GTK-STRING(gtk-editable-get-chars(widget, start-pos, end-pos));
- let string = gtk-copy-text(chars);
- g-free(chars);
- string
+ with-gdk-lock
+ let chars = gtk-editable-get-chars(widget, start-pos, end-pos);
+ let string = gtk-copy-text(chars);
+ g-free(chars);
+ string
+ end
end;
end method selected-text;
@@ -731,7 +738,7 @@
define method widget-range-bounds (widget, range == #f)
=> (start-pos :: <integer>, end-pos :: <integer>)
- let pos = gtk-editable-get-position(widget);
+ let pos = with-gdk-lock gtk-editable-get-position(widget) end;
values(pos, pos)
end method widget-range-bounds;
@@ -750,25 +757,31 @@
(range :: type-union(<text-range>, one-of(#t, #f)),
gadget :: <gtk-text-gadget-mixin>)
=> (range :: type-union(<text-range>, one-of(#t, #f)))
- let widget = GTK-EDITABLE(gadget-widget(gadget));
+ let widget = gadget-widget(gadget);
let (start-pos, end-pos) = widget-range-bounds(widget, range);
- gtk-editable-select-region(widget, start-pos, end-pos);
+ with-gdk-lock
+ gtk-editable-select-region(widget, start-pos, end-pos);
+ end;
range
end method text-selection-setter;
define sealed method text-caret-position
(gadget :: <gtk-text-gadget-mixin>)
=> (position :: <integer>)
- let widget = GTK-EDITABLE(gadget-widget(gadget));
- gtk-editable-get-position(widget);
+ let widget = gadget-widget(gadget);
+ with-gdk-lock
+ gtk-editable-get-position(widget);
+ end
end method text-caret-position;
define sealed method text-caret-position-setter
(position :: false-or(<integer>), gadget :: <gtk-text-gadget-mixin>)
=> (position :: false-or(<integer>))
if (position)
- let widget = GTK-EDITABLE(gadget-widget(gadget));
- gtk-editable-set-position(widget, position);
+ let widget = gadget-widget(gadget);
+ with-gdk-lock
+ gtk-editable-get-position(widget, position);
+ end;
position
end;
end method text-caret-position-setter;
@@ -799,38 +812,42 @@
define sealed method make-gtk-mirror
(gadget :: <gtk-text-field-mixin>)
=> (mirror :: <gadget-mirror>)
- let max = text-field-maximum-size(gadget);
- let text = gadget-text-buffer(gadget);
- let visibility = %gtk-text-visibility(gadget);
- let widget = if (max)
- GTK-ENTRY(gtk-entry-new-with-max-length(max))
- else
- GTK-ENTRY(gtk-entry-new());
- end;
- assert(~null-pointer?(widget), "gtk-entry-new failed");
- // Note that this is happening before install-event-handlers, so don't
- // need to disable events.
- gtk-entry-set-visibility(widget, if (visibility) 1 else 0 end);
- unless (empty?(text))
- with-c-string (c-text = text)
- gtk-entry-set-text(widget, c-text);
+ with-gdk-lock
+ let max = text-field-maximum-size(gadget);
+ let text = gadget-text-buffer(gadget);
+ let visibility = %gtk-text-visibility(gadget);
+ let widget = if (max)
+ gtk-entry-new-with-max-length(max)
+ else
+ gtk-entry-new();
+ end;
+ assert(~null-pointer?(widget), "gtk-entry-new failed");
+ // Note that this is happening before install-event-handlers, so don't
+ // need to disable events.
+ gtk-entry-set-visibility(widget, if (visibility) 1 else 0 end);
+ unless (empty?(text))
+ with-c-string (c-text = text)
+ gtk-entry-set-text(widget, c-text);
+ end;
end;
- end;
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end method make-gtk-mirror;
// Updates the GTK text field from the DUIM gadget
define sealed method update-gadget-text
(gadget :: <gtk-text-field-mixin>, mirror :: <gadget-mirror>) => ()
ignore(mirror);
- let widget = GTK-ENTRY(gadget-widget(gadget));
+ let widget = gadget-widget(gadget);
let new-text = gadget-text-buffer(gadget);
- with-disabled-event-handler (widget, #"changed")
- with-c-string (c-text = new-text)
- gtk-entry-set-text(widget, c-text);
- end;
+ with-gdk-lock
+ with-disabled-event-handler (mirror, #"changed")
+ with-c-string (c-text = new-text)
+ gtk-entry-set-text(widget, c-text);
+ end;
+ end
end;
end method update-gadget-text;
@@ -882,7 +899,7 @@
/// Text editors
define sealed class <gtk-text-editor>
- (<gtk-text-gadget-mixin>,
+ (<gtk-gadget-mixin>,
<text-editor>,
<leaf-pane>,
<sealed-constructor-mixin>)
@@ -901,53 +918,52 @@
let columns = gadget-columns(gadget);
let word-wrap? = text-field-word-wrap?(gadget);
let text = gadget-text-buffer(gadget);
- let widget = GTK-TEXT(gtk-text-new(null-pointer(<GtkAdjustment*>),
- null-pointer(<GtkAdjustment*>)));
- assert(~null-pointer?(widget), "gtk-text-new failed");
- // Note that this is happening before install-event-handlers, so don't
- // need to disable events.
- when (lines | columns)
- ignoring("lines:/columns:")
- end;
- gtk-text-set-word-wrap(widget, if (word-wrap?) $true else $false end);
- set-text-widget-text(widget, text);
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget = gtk-text-view-new();
+ assert(~null-pointer?(widget), "gtk-text-new failed");
+ // Note that this is happening before install-event-handlers, so don't
+ // need to disable events.
+ when (lines | columns)
+ ignoring("lines:/columns:")
+ end;
+ if (word-wrap?)
+ widget. at wrap-mode := $GTK-WRAP-WORD-CHAR;
+ end;
+ let buffer = gtk-text-view-get-buffer(widget);
+ //duim-debug-message("Setting text to %=", text);
+ gtk-text-buffer-set-text(buffer, text, -1);
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end method make-gtk-mirror;
define sealed method update-gadget-text
(gadget :: <gtk-text-editor>, mirror :: <gadget-mirror>) => ()
+ //duim-debug-message("Updating text-editors text");
ignore(mirror);
- let widget = GTK-TEXT(gadget-widget(gadget));
- when (widget)
- let new-text = gadget-text-buffer(gadget);
- let old-text = GTK-STRING(gtk-editable-get-chars(widget, 0, -1));
- let update? = old-text ~= new-text;
- g-free(old-text);
- when (update?)
- block ()
- gtk-text-freeze(widget);
- with-disabled-event-handler (widget, #"changed")
- set-text-widget-text(widget, new-text);
- end;
- cleanup
- gtk-text-thaw(widget);
- end
- end;
- end;
+ note-gadget-text-changed(gadget);
end method update-gadget-text;
-define method set-text-widget-text (widget, text :: <string>)
- with-c-string (c-text = text)
- with-stack-structure (position :: <c-int*>)
- gtk-editable-delete-text(widget, 0, -1);
- pointer-value(position) := 0;
- gtk-editable-insert-text(widget, c-text, text.size,
- pointer-cast(<gint*>, position));
- end;
+define method note-gadget-text-changed
+ (gadget :: <gtk-text-editor>) => ()
+ let widget = gadget-widget(gadget);
+ when (widget)
+ with-gdk-lock
+ let buffer = gtk-text-view-get-buffer(widget);
+ let new-text = gadget-text-buffer(gadget);
+ gtk-text-buffer-set-text(buffer, new-text, size(new-text));
+ end
end;
-end set-text-widget-text;
+end;
+
+define method gadget-text-setter
+ (text :: <string>, gadget :: <gtk-text-editor>, #key do-callback? = #f)
+ => (text :: <string>)
+ gadget-text-buffer(gadget) := text;
+ note-gadget-text-changed(gadget);
+ text;
+end;
/// Scroll bars
@@ -1009,20 +1025,20 @@
define method scroll-bar-adjusted-contents
(gadget :: <gtk-scroll-bar>)
- => (value :: <single-float>,
- lower :: <single-float>, upper :: <single-float>,
- step-increment :: <single-float>, page-increment :: <single-float>,
- page-size :: <single-float>)
+ => (value :: <double-float>,
+ lower :: <double-float>, upper :: <double-float>,
+ step-increment :: <double-float>, page-increment :: <double-float>,
+ page-size :: <double-float>)
let range-value = gadget-value(gadget);
let (range-start, range-end, range-step) = gadget-range-values(gadget);
let slug-size = gadget-slug-size(gadget);
- let lower = as(<single-float>, range-start);
- let page-size = as(<single-float>, slug-size);
- let step-increment = as(<single-float>, range-step);
+ let lower = as(<double-float>, range-start);
+ let page-size = as(<double-float>, slug-size);
+ let step-increment = as(<double-float>, range-step);
let page-increment = max(page-size, step-increment);
- let upper = as(<single-float>, range-end); // this inclues page size.
- let value = as(<single-float>, range-value);
+ let upper = as(<double-float>, range-end); // this inclues page size.
+ let value = as(<double-float>, range-value);
values(value, lower, upper, step-increment, page-increment, page-size)
end scroll-bar-adjusted-contents;
@@ -1030,37 +1046,39 @@
define sealed method make-gtk-mirror
(gadget :: <gtk-scroll-bar>)
=> (mirror :: <gadget-mirror>)
- let (value, lower, upper, step-inc, page-inc, page-size)
- = scroll-bar-adjusted-contents(gadget);
- let adj = GTK-ADJUSTMENT(gtk-adjustment-new(value,
- lower,
- upper,
- step-inc,
- page-inc,
- page-size));
- let widget = select(gadget-orientation(gadget))
- #"horizontal" => GTK-HSCROLLBAR(gtk-hscrollbar-new(adj));
- #"vertical" => GTK-VSCROLLBAR(gtk-vscrollbar-new(adj));
- end;
- assert(~null-pointer?(widget), "gtk-h/vscrollbar-new failed");
- // --- Does DUIM have anything to select/deselect smooth scrolling?
- // gtk-range-set-update-policy(widget, $gtk-update-discontinuous);
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let (value, lower, upper, step-inc, page-inc, page-size)
+ = scroll-bar-adjusted-contents(gadget);
+ let adj = gtk-adjustment-new(value,
+ lower,
+ upper,
+ step-inc,
+ page-inc,
+ page-size);
+ let widget = select(gadget-orientation(gadget))
+ #"horizontal" => gtk-hscrollbar-new(adj);
+ #"vertical" => gtk-vscrollbar-new(adj);
+ end;
+ assert(~null-pointer?(widget), "gtk-h/vscrollbar-new failed");
+ // --- Does DUIM have anything to select/deselect smooth scrolling?
+ // gtk-range-set-update-policy(widget, $gtk-update-discontinuous);
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end method make-gtk-mirror;
define method install-event-handlers
(sheet :: <gtk-scroll-bar>, mirror :: <gadget-mirror>) => ()
next-method();
- let adj = gtk-range-get-adjustment(mirror-widget(mirror));
- install-named-handlers(mirror, #[#"adjustment/value_changed"],
- adjustment: adj);
+ let widget = mirror-widget(mirror);
+ duim-g-signal-connect(sheet, #"value-changed") (adjustment, #rest args) gtk-adjustment-value-changed-signal-handler(sheet, widget) end;
end method install-event-handlers;
define method gtk-adjustment-value-changed-signal-handler
- (gadget :: <gtk-scroll-bar>, adjustment :: <GtkAdjustment*>) => ()
- let value = adjustment.value-value;
+ (gadget :: <gtk-scroll-bar>, widget :: <GtkWidget>) => ()
+ let adj = gtk-range-get-adjustment(widget);
+ let value = adj.gtk-adjustment-get-value;
scroll-to-position(gadget, value);
end;
@@ -1092,19 +1110,21 @@
(gadget :: <gtk-scroll-bar>) => ()
let widget = gadget-widget(gadget);
when (widget)
- let (value, lower, upper, step-inc, page-inc, page-size)
- = scroll-bar-adjusted-contents(gadget);
- let adjustment :: <GtkAdjustment*> = gtk-range-get-adjustment(widget);
- adjustment.GtkAdjustment-lower := lower;
- adjustment.GtkAdjustment-upper := upper;
- adjustment.GtkAdjustment-value := value;
- adjustment.GtkAdjustment-step-increment := step-inc;
- adjustment.GtkAdjustment-page-increment := page-inc;
- adjustment.GtkAdjustment-page-size := page-size;
- // --- TODO: cache gtk-signal-lookup
- with-c-string (name = "changed")
- gtk-signal-emitv-by-name(adjustment, name, null-pointer(<GtkArg*>));
- end;
+ with-gdk-lock
+ let (value, lower, upper, step-inc, page-inc, page-size)
+ = scroll-bar-adjusted-contents(gadget);
+ let adjustment :: <GtkAdjustment> = gtk-range-get-adjustment(widget);
+ adjustment. at lower := lower;
+ adjustment. at upper := upper;
+ adjustment. at value := value;
+ adjustment. at step-increment := step-inc;
+ adjustment. at page-increment := page-inc;
+ adjustment. at page-size := page-size;
+ // --- TODO: cache gtk-signal-lookup
+ with-c-string (name = "changed")
+ gtk-signal-emitv-by-name(adjustment, name, null-pointer(<GtkArg>));
+ end;
+ end
end;
end method note-scroll-bar-changed;
@@ -1115,90 +1135,126 @@
(<gtk-gadget-mixin>,
<collection-gadget>,
<sealed-constructor-mixin>)
+ slot store-model :: false-or(<GtkTreeModel>) = #f;
end class <gtk-list-control-mixin>;
+define sealed class <gtk-tree-view-control-mixin>
+ (<gtk-list-control-mixin>)
+end;
+
define method update-mirror-attributes
- (gadget :: <gtk-list-control-mixin>, mirror :: <gadget-mirror>) => ()
+ (gadget :: <gtk-tree-view-control-mixin>, mirror :: <gadget-mirror>) => ()
next-method();
- let widget = GTK-CLIST(mirror.mirror-widget);
- gtk-clist-set-selection-mode
- (widget,
- select (gadget-selection-mode(gadget))
- #"none" => $GTK-SELECTION-BROWSE;
- #"single" => $GTK-SELECTION-SINGLE;
- #"multiple" => $GTK-SELECTION-EXTENDED;
- end);
- gtk-clist-set-shadow-type(widget, $GTK-SHADOW-IN);
- if (instance?(gadget, <table-control>))
- gtk-clist-column-titles-show(widget)
- else
- gtk-clist-column-titles-hide(widget);
- //---*** How should we decide this?
- gtk-clist-set-column-width(widget, 0, 500)
+ with-gdk-lock
+ let widget = mirror.mirror-widget;
+ let selection = gtk-tree-view-get-selection(widget);
+ gtk-tree-selection-set-mode
+ (selection,
+ select (gadget-selection-mode(gadget))
+ #"none" => $GTK-SELECTION-NONE;
+ #"single" => $GTK-SELECTION-BROWSE;
+ #"multiple" => $GTK-SELECTION-MULTIPLE;
+ end);
+ if (instance?(gadget, <table-control>))
+ widget. at headers-visible := #t;
+ else
+ widget. at headers-visible := #f;
+ end;
end;
- update-list-control-items(gadget, mirror)
end method update-mirror-attributes;
define method install-event-handlers
- (sheet :: <gtk-list-control-mixin>, mirror :: <gadget-mirror>) => ()
+ (sheet :: <gtk-tree-view-control-mixin>, mirror :: <gadget-mirror>) => ()
next-method();
- install-named-handlers(mirror,
- #[#"select_row", #"button_press_event"])
+ let widget = mirror-widget(mirror);
+ let selection = with-gdk-lock gtk-tree-view-get-selection(widget) end;
+ g-signal-connect(selection, "changed", method (#rest args) handle-gtk-select-row-event(sheet) end);
+ duim-g-signal-connect(sheet, #"button-press-event") (widget, event, #rest args) handle-gtk-button-press-event(sheet, event) end;
+ with-gdk-lock
+ gtk-widget-add-events(widget, $GDK-BUTTON-PRESS-MASK);
+ end
end method install-event-handlers;
define sealed method handle-gtk-select-row-event
- (gadget :: <gtk-list-control-mixin>, widget :: <GtkWidget*>,
- event :: <GdkEventAny*>)
+ (gadget :: <gtk-tree-view-control-mixin>)
=> (handled? :: <boolean>)
- gtk-debug("Clicked on list control!");
- let selection = list-selection(gadget, sheet-direct-mirror(gadget));
- gtk-debug(" Selection now %=", selection);
- distribute-selection-changed-callback(gadget, selection);
+ gtk-debug("Selected list control item!");
+ let mirror = gadget.sheet-direct-mirror;
+ let widget = mirror-widget(mirror);
+ let selection = gtk-tree-view-get-selection(widget);
+ let new-selection = make(<stretchy-vector>);
+
+ with-stack-structure (model :: <GtkTreeModel*>)
+ let selected-paths
+ = glist-to-vector
+ (gtk-tree-selection-get-selected-rows(selection, model),
+ <GtkTreePath>);
+
+ for (path in selected-paths)
+ with-stack-structure (iter :: <GtkTreeIter>)
+ gtk-tree-model-get-iter(model[0], iter, path);
+ with-stack-structure (value :: <GValue>)
+ g-value-nullify(value);
+ gtk-tree-model-get-value(model[0], iter, 0, value);
+ add!(new-selection, g-value-to-dylan(value));
+ end;
+ end;
+ end;
+ end;
+
+ gtk-debug(" Selection now %=", new-selection);
+ distribute-selection-changed-callback(gadget, new-selection);
#t
end method handle-gtk-select-row-event;
define sealed method handle-gtk-button-press-event
- (gadget :: <gtk-list-control-mixin>, widget :: <GtkWidget*>,
- event :: <GdkEventButton*>)
+ (gadget :: <gtk-list-control-mixin>, event :: <GdkEventButton>)
=> (handled? :: <boolean>)
gtk-debug("Pressed button %=, type %=",
- event.GdkEventButton-button,
- select (event.GdkEventButton-type)
- $GDK-BUTTON-PRESS => "button press";
- $GDK-2BUTTON-PRESS => "double click";
- $GDK-3BUTTON-PRESS => "treble click";
- otherwise => event.GdkEventButton-type;
- end);
+ event.GdkEventButton-button,
+ select (event.GdkEventButton-type)
+ $GDK-BUTTON-PRESS => "button press";
+ $GDK-2BUTTON-PRESS => "double click";
+ $GDK-3BUTTON-PRESS => "treble click";
+ otherwise => event.GdkEventButton-type;
+ end);
if (event.GdkEventButton-type == $GDK-2BUTTON-PRESS)
gtk-debug("Double clicked on list control!");
when (gadget-activate-callback(gadget))
distribute-activate-callback(gadget);
end;
#t
+ elseif ((event.GdkEventButton-type == $GDK-BUTTON-PRESS) & (event.GdkEventButton-button == 3)) //right click
+ gtk-debug("right clicked on list control!");
+ when (gadget-popup-menu-callback(gadget))
+ gtk-set-button-time(event);
+ handle-event(gadget,
+ make(<popup-menu-gadget-event>,
+ gadget: gadget,
+ target: 0,
+ x: round(event.GdkEventButton-x),
+ y: round(event.GdkEventButton-y)));
+ //XXX: fix this when there is some spare time
+ //distribute-popup-menu-callback(gadget, 0,
+ // x: round(event.GdkEventButton-x),
+ // y: round(event.GdkEventButton-y));
+ end;
+ #t
end
end method handle-gtk-button-press-event;
-define method list-selection
- (gadget :: <gtk-list-control-mixin>, mirror :: <gadget-mirror>)
- => (vector :: <vector>)
-/* TODO: GtkCList is deprecated in GTK2 */
- let widget = GTK-CLIST(mirror.mirror-widget);
- let selection = widget.selection-value;
- glist-to-vector(selection, <integer>)
-end method list-selection;
-
define method glist-to-vector
- (GList :: <GList*>, type :: <type>)
+ (GList :: <GList>, type :: <type>)
=> (vector :: <stretchy-object-vector>)
let vector = make(<stretchy-object-vector>);
local method process-list
- (GList :: <GList*>)
+ (GList :: <GList>)
case
null-pointer?(GList) =>
#f;
otherwise =>
- add!(vector, c-type-cast(type, glist.data-value));
- process-list(glist.next-value);
+ add!(vector, c-type-cast(type, glist.GList-data));
+ process-list(glist.GList-next);
end
end;
process-list(GList);
@@ -1219,24 +1275,52 @@
mirror & update-list-control-items(gadget, mirror)
end method update-gadget;
+define function generate-list-model () => (res :: <GtkTreeModel>)
+ with-gdk-lock
+ let type-vector = make(<GType*>, element-count: 2);
+ type-vector[0] := $G-TYPE-INT;
+ type-vector[1] := $G-TYPE-STRING;
+ gtk-list-store-newv(2, type-vector);
+ end;
+end;
+
define sealed method update-list-control-items
(gadget :: <gtk-list-control-mixin>, mirror :: <gadget-mirror>)
=> ()
- let widget = GTK-CLIST(mirror.mirror-widget);
+ let widget = mirror.mirror-widget;
let items = gadget-items(gadget);
let label-function = gadget-label-key(gadget);
- gtk-clist-clear(widget);
- with-stack-structure(string* :: <C-string*>)
- for (item in items)
- let label = label-function(item);
- with-c-string (string = label)
- string*[0] := string;
- gtk-clist-append(widget, pointer-cast(<gchar**>, string*))
+ let model = gadget.store-model
+ | begin
+ gadget.store-model := generate-list-model();
+ with-gdk-lock widget. at model := gadget.store-model end;
+ gadget.store-model;
end;
+ with-gdk-lock
+ gtk-list-store-clear(model);
+ with-stack-structure(iter :: <GtkTreeIter>)
+ for (item in items, i from 0)
+ let label = label-function(item);
+ gtk-list-store-append(model, iter);
+ with-stack-structure (gvalue :: <GValue>)
+ g-value-nullify(gvalue);
+ g-value-set-value(gvalue, i);
+ gtk-list-store-set-value(model, iter, 0, gvalue);
+ g-value-nullify(gvalue);
+ g-value-set-value(gvalue, label);
+ gtk-list-store-set-value(model, iter, 1, gvalue);
+ end;
+ end
end;
end
end method update-list-control-items;
+define method update-mirror-attributes
+ (gadget :: <gtk-list-control-mixin>, mirror :: <gadget-mirror>) => ()
+ next-method();
+ update-list-control-items(gadget, mirror);
+end;
+
define sealed method update-gadget-selection
(gadget :: <gtk-list-control-mixin>) => ()
select (gadget-selection-mode(gadget))
@@ -1272,7 +1356,7 @@
// List boxes
define sealed class <gtk-list-box>
- (<gtk-list-control-mixin>,
+ (<gtk-tree-view-control-mixin>,
<list-box>,
<leaf-pane>)
end class <gtk-list-box>;
@@ -1286,11 +1370,17 @@
define sealed method make-gtk-mirror
(gadget :: <gtk-list-box>)
=> (mirror :: <gadget-mirror>)
- let widget = GTK-CLIST(gtk-clist-new(1));
- assert(~null-pointer?(widget), "gtk-clist-new failed");
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget = gtk-tree-view-new();
+ let renderer = gtk-cell-renderer-text-new();
+ let column = gtk-tree-view-column-new();
+ gtk-tree-view-column-pack-start(column, renderer, 0);
+ gtk-tree-view-column-add-attribute(column, renderer, "text", 1);
+ gtk-tree-view-append-column(widget, column);
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end method make-gtk-mirror;
@@ -1298,7 +1388,7 @@
//---*** Need to implement add-item etc...
define sealed class <gtk-list-control>
- (<gtk-list-control-mixin>,
+ (<gtk-tree-view-control-mixin>,
<list-control>,
<leaf-pane>)
end class <gtk-list-control>;
@@ -1312,18 +1402,85 @@
define sealed method make-gtk-mirror
(gadget :: <gtk-list-control>)
=> (mirror :: <gadget-mirror>)
- let widget = GTK-CLIST(gtk-clist-new(1));
- assert(~null-pointer?(widget), "gtk-clist-new failed");
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget = gtk-tree-view-new();
+ let renderer = gtk-cell-renderer-text-new();
+ let column = gtk-tree-view-column-new();
+ gtk-tree-view-column-pack-start(column, renderer, 0);
+ gtk-tree-view-column-add-attribute(column, renderer, "text", 1);
+ gtk-tree-view-append-column(widget, column);
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end method make-gtk-mirror;
+// Scrolled mixins
+define sealed class <scrolled-mixin>
+ (<gtk-gadget-mixin>)
+end;
+
+define sealed class <scrolled-mirror> (<gadget-mirror>)
+ constant slot scrolled-window, required-init-keyword: scrolled-window:;
+end;
+
+define method set-mirror-parent
+ (child :: <scrolled-mirror>, parent :: <widget-mirror>)
+ => ()
+ with-gdk-lock
+ gtk-container-add(parent.mirror-widget, child.scrolled-window);
+ end;
+end;
+
+define method set-mirror-size
+ (mirror :: <scrolled-mirror>, width :: <integer>, height :: <integer>)
+ => ()
+ set-widget-size(mirror, mirror.scrolled-window, width, height);
+end;
+
+define method do-compose-space
+ (gadget :: <scrolled-mixin>, #key width, height)
+ => (space-req :: <space-requirement>)
+ debug-message("do-compose-space(%= , %d, %d)", gadget, width, height);
+ let mirror = sheet-direct-mirror(gadget);
+ if (mirror)
+ let widget = scrolled-window(mirror);
+ gtk-space-requirements(gadget, widget)
+ else
+ gtk-debug("Composing space on an unmirrored gadget!");
+ default-space-requirement(gadget, width: width, height: height)
+ end
+end method do-compose-space;
+
+define method init-scrolled-window
+ (widget :: <GtkWidget>, gadget :: <scrolled-mixin>)
+ with-gdk-lock
+ let scrolled-win
+ = gtk-scrolled-window-new(null-pointer(<GtkAdjustment>),
+ null-pointer(<GtkAdjustment>));
+ gtk-container-add(scrolled-win, widget);
+ let (#rest policies)
+ = select (gadget-scroll-bars(gadget))
+ #f, #"none" => values($GTK-POLICY-NEVER, $GTK-POLICY-NEVER);
+ #t, #"dynamic" => values($GTK-POLICY-AUTOMATIC, $GTK-POLICY-AUTOMATIC);
+ #"both" => values($GTK-POLICY-ALWAYS, $GTK-POLICY-ALWAYS);
+ //#"both" => values($GTK-POLICY-AUTOMATIC, $GTK-POLICY-AUTOMATIC);
+ #"horizontal" => values($GTK-POLICY-ALWAYS, $GTK-POLICY-AUTOMATIC);
+ #"vertical" => values($GTK-POLICY-AUTOMATIC, $GTK-POLICY-ALWAYS);
+ end;
+ //duim-debug-message("scroll-bar %=", gadget-scroll-bars(gadget));
+ apply(gtk-scrolled-window-set-policy, scrolled-win, policies);
+ gtk-widget-show(scrolled-win);
+ scrolled-win;
+ end;
+end;
+
+
// Table controls
-/*---*** Use the fake ones for now...
define sealed class <gtk-table-control>
- (<gtk-list-control-mixin>,
+ (<scrolled-mixin>,
+ <gtk-tree-view-control-mixin>,
<table-control>,
<leaf-pane>)
end class <gtk-table-control>;
@@ -1338,37 +1495,90 @@
(gadget :: <gtk-table-control>)
=> (mirror :: <gadget-mirror>)
let columns = table-control-columns(gadget);
- let widget = GTK-CLIST(gtk-clist-new(columns.size));
- assert(~null-pointer?(widget), "gtk-clist-new failed");
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget = gtk-tree-view-new();
+ let columns = table-control-columns(gadget);
+ for (c in columns, i from 1)
+ let renderer = gtk-cell-renderer-text-new();
+ let column = gtk-tree-view-column-new();
+ gtk-tree-view-column-pack-start(column, renderer, 0);
+ gtk-tree-view-column-add-attribute(column, renderer, "text", i);
+ //gtk-tree-view-column-set-resizable(column, 1);
+ gtk-tree-view-append-column(widget, column);
+ end;
+ gtk-tree-view-set-fixed-height-mode(widget, 1);
+ let scrolled-win
+ = init-scrolled-window(widget, gadget);
+ make(<scrolled-mirror>,
+ widget: widget,
+ scrolled-window: scrolled-win,
+ sheet: gadget);
+ end;
end method make-gtk-mirror;
define method update-mirror-attributes
(gadget :: <gtk-table-control>, mirror :: <gadget-mirror>) => ()
next-method();
- let widget = GTK-CLIST(mirror.mirror-widget);
- gtk-clist-column-titles-active(widget);
- for (i :: <integer> from 0,
- column :: <table-column> in table-control-columns(gadget))
- let heading = table-column-heading(column);
- let width = table-column-width(column);
- let alignment = table-column-alignment(column);
- with-c-string (c-string = heading)
- gtk-clist-set-column-title(widget, i, c-string)
- end;
- gtk-clist-set-column-width(widget, i, width);
- gtk-clist-set-column-justification
- (widget, i,
- select (alignment)
- #"left" => $GTK-JUSTIFY-LEFT;
- #"right" => $GTK-JUSTIFY-RIGHT;
- #"center" => $GTK-JUSTIFY-CENTER;
- end)
- end
+ let widget = mirror.mirror-widget;
+ let columns = table-control-columns(gadget);
+ with-gdk-lock
+ for (c in columns, i from 0)
+ let column = gtk-tree-view-get-column(widget, i);
+ column. at title := c.table-column-heading;
+ column. at alignment
+ := select (c.table-column-alignment)
+ #"left" => $GTK-JUSTIFY-LEFT;
+ #"right" => $GTK-JUSTIFY-RIGHT;
+ #"center" => $GTK-JUSTIFY-CENTER;
+ end;
+ column. at fixed-width := c.table-column-width;
+ end;
+ end;
+ //gtk-clist-column-titles-active(widget);
end method update-mirror-attributes;
+define sealed class <gtk-table-item> (<table-item>)
+ sealed slot %table :: false-or(<table-control>) = #f;
+end;
+
+define sealed domain make (singleton(<gtk-table-item>));
+define sealed domain initialize(<gtk-table-item>);
+
+define sealed method do-make-item
+ (pane :: <gtk-table-control>, class == <table-item>, #key object)
+ => (item :: <gtk-table-item>)
+ make(<gtk-table-item>, object: object);
+end;
+
+define sealed method do-add-item
+ (gadget :: <gtk-table-control>, item :: <gtk-table-item>, #key after) => ()
+ let mirror = sheet-direct-mirror(gadget);
+ let columns = table-control-columns(gadget);
+ let model = gadget.store-model;
+ let item = item-object(item);
+ mirror & with-gdk-lock
+ with-stack-structure (iter :: <GtkTreeIter>)
+ gtk-list-store-append(model, iter);
+ with-stack-structure (gvalue :: <GValue>)
+ g-value-nullify(gvalue);
+ g-value-set-value(gvalue, gadget-items(gadget).size - 1);
+ gtk-list-store-set-value(model, iter, 0, gvalue);
+ for (c in columns, j from 1)
+ let generator = table-column-generator(c);
+ let label = gadget-item-label(gadget, generator(item));
+ unless (instance?(label, <string>))
+ label := format-to-string("%=", label);
+ end;
+ g-value-nullify(gvalue);
+ g-value-set-value(gvalue, label);
+ gtk-list-store-set-value(model, iter, j, gvalue);
+ end;
+ end;
+ end;
+ end;
+end;
+
+/*
define method install-event-handlers
(sheet :: <gtk-table-control>, mirror :: <gadget-mirror>) => ()
next-method();
@@ -1376,53 +1586,272 @@
end method install-event-handlers;
define sealed method handle-gtk-click-column-event
- (gadget :: <gtk-table-control>, widget :: <GtkWidget*>,
- event :: <GdkEventAny*>)
+ (gadget :: <gtk-table-control>, widget :: <GtkWidget>,
+ event :: <GdkEventAny>)
=> (handled? :: <boolean>)
gtk-debug("Clicked on column!");
#t
end method handle-gtk-click-column-event;
define sealed method handle-gtk-resize-column-event
- (gadget :: <gtk-list-control-mixin>, widget :: <GtkWidget*>,
- event :: <GdkEventAny*>)
+ (gadget :: <gtk-list-control-mixin>, widget :: <GtkWidget>,
+ event :: <GdkEventAny>)
=> (handled? :: <boolean>)
gtk-debug("Resized column!");
#t
end method handle-gtk-resize-column-event;
+*/
+
+define function generate-table-model (no-of-columns :: <integer>)
+ => (res :: <GtkTreeModel>)
+ with-gdk-lock
+ let type-vector = make(<GType*>, element-count: 1 + no-of-columns);
+ type-vector[0] := $G-TYPE-INT;
+ for (i from 1 to no-of-columns)
+ type-vector[i] := $G-TYPE-STRING;
+ end;
+ gtk-list-store-newv(no-of-columns + 1, type-vector);
+ end;
+end;
define sealed method update-list-control-items
(gadget :: <gtk-table-control>, mirror :: <gadget-mirror>)
=> ()
- let widget = GTK-CLIST(mirror.mirror-widget);
+ let widget = mirror.mirror-widget;
let items = gadget-items(gadget);
- let label-function = gadget-label-key(gadget);
let columns = table-control-columns(gadget);
let no-of-columns = columns.size;
- gtk-clist-clear(widget);
- for (item in items)
- let label = label-function(item);
- let object = item-object(item);
- let string* = make(<C-string*>, element-count: no-of-columns);
- for (index :: <integer> from 0 below no-of-columns,
- column :: <table-column> in columns)
- let generator = table-column-generator(column);
- let label = label-function(generator(object));
- string*[index] := as(<C-string>, label)
- end;
- block ()
- gtk-clist-append(widget, string*);
- cleanup
- map(destroy, string*)
- end
- end
+ let model = gadget.store-model |
+ begin
+ gadget.store-model := generate-table-model(no-of-columns);
+ widget. at model := with-gdk-lock gadget.store-model end;
+ gadget.store-model;
+ end;
+ with-gdk-lock
+ gtk-list-store-clear(model);
+ with-stack-structure(iter :: <GtkTreeIter>)
+ for (item in items, i from 0)
+ gtk-list-store-append(model, iter);
+ with-stack-structure (gvalue :: <GValue>)
+ g-value-nullify(gvalue);
+ g-value-set-value(gvalue, i);
+ gtk-list-store-set-value(model, iter, 0, gvalue);
+ for (c in columns, j from 1)
+ let generator = table-column-generator(c);
+ let label = gadget-item-label(gadget, generator(item));
+ unless (instance?(label, <string>))
+ label := format-to-string("%=", label);
+ end;
+ g-value-nullify(gvalue);
+ g-value-set-value(gvalue, label);
+ gtk-list-store-set-value(model, iter, j, gvalue);
+ end;
+ end;
+ end;
+ end;
+ //gtk-tree-view-columns-autosize(widget);
+ end;
end method update-list-control-items;
-*/
+
+// Tree control
+
+define sealed class <gtk-tree-control>
+ (<scrolled-mixin>,
+ <gtk-tree-view-control-mixin>,
+ <tree-control>,
+ <leaf-pane>)
+end;
+
+define sealed method class-for-make-pane
+ (framem :: <gtk-frame-manager>, class == <tree-control>, #key)
+ => (class :: <class>, options :: false-or(<sequence>))
+ values(<gtk-tree-control>, #f);
+end;
+
+define sealed method make-gtk-mirror
+ (gadget :: <gtk-tree-control>) => (mirror :: <gadget-mirror>)
+ with-gdk-lock
+ let widget = gtk-tree-view-new();
+ let renderer = gtk-cell-renderer-text-new();
+ let column = gtk-tree-view-column-new();
+ gtk-tree-view-column-pack-start(column, renderer, 0);
+ gtk-tree-view-column-add-attribute(column, renderer, "text", 1);
+ gtk-tree-view-append-column(widget, column);
+ let type-vector = make(<GType*>, element-count: 2);
+ type-vector[0] := $G-TYPE-INT;
+ type-vector[1] := $G-TYPE-STRING;
+ let model = gtk-tree-store-newv(2, type-vector);
+ gadget.store-model := model;
+ widget. at model := model;
+ let scrolled-win = init-scrolled-window(widget, gadget);
+ make(<scrolled-mirror>,
+ widget: widget,
+ scrolled-window: scrolled-win,
+ sheet: gadget);
+ end;
+end;
+
+define sealed class <gtk-tree-node> (<tree-node>)
+ sealed slot gtk-iter :: false-or(<GtkTreeIter>) = #f,
+ init-keyword: gtk-iter:;
+end;
+
+define sealed domain make (singleton(<gtk-tree-node>));
+define sealed domain initialize (<gtk-tree-node>);
+
+define sealed method do-make-node
+ (pane :: <gtk-tree-control>, class == <tree-node>, #rest rest, #key, #all-keys )
+ => (item :: <gtk-tree-node>)
+ apply(make, <gtk-tree-node>, rest);
+end;
+
+define sealed method do-add-node
+ (pane :: <gtk-tree-control>, parent, item :: <gtk-tree-node>, #key after) => ()
+ let mirror = sheet-direct-mirror(pane);
+ when (mirror)
+ //insert into tree control and gadget-items
+ //remember index into gadget-items (for selection)
+ let index = gadget-items(pane).size - 1;
+ let np = null-pointer(<GtkTreeIter>);
+ let gtk-parent = ((node-generation(item) > 0) & gtk-iter(parent)) | np;
+ let children? = tree-control-children-predicate(pane);
+ with-gdk-lock
+ with-stack-structure (iter :: <GtkTreeIter>)
+ let model = pane.store-model;
+ gtk-tree-store-insert-before(model, iter, gtk-parent, np);
+ with-stack-structure (data :: <GValue>)
+ g-value-nullify(data);
+ g-value-set-value(data, index);
+ gtk-tree-store-set-value(model, iter, 0, data);
+ let label = pane.gadget-label-key(item.node-object);
+ unless (instance?(label, <string>))
+ label := format-to-string("%=", label);
+ end;
+ g-value-nullify(data);
+ g-value-set-value(data, label);
+ gtk-tree-store-set-value(model, iter, 1, data);
+ if (children?(item.node-object))
+ with-stack-structure (dummy :: <GtkTreeIter>)
+ with-stack-structure (dummy-value :: <GValue>)
+ gtk-tree-store-insert-before(model, dummy, iter, np);
+ g-value-nullify(dummy-value);
+ g-value-set-value(dummy-value, "this is just a dummy");
+ gtk-tree-store-set-value(model, dummy, 1, dummy-value);
+ g-value-nullify(dummy-value);
+ g-value-set-value(dummy-value, -1);
+ gtk-tree-store-set-value(model, dummy, 0, dummy-value);
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+end;
+
+define sealed method do-add-nodes
+ (pane :: <gtk-tree-control>, parent, nodes :: <sequence>, #key after) => ()
+ //let selected-nodes = gadget-selected-nodes(pane);
+ //gadget-selection(pane) := #[];
+ for (node in nodes)
+ add-node(pane, parent, node, after: after)
+ end;
+ //gadget-selection(pane) := compute-gadget-selection(pane, selected-nodes)
+end method do-add-nodes;
+
+define sealed method do-expand-node
+ (pane :: <gtk-tree-control>, node :: <gtk-tree-node>) => ()
+ with-gdk-lock
+ let path = gtk-tree-model-get-path(pane.store-model, node.gtk-iter);
+ gtk-tree-view-expand-row(pane.sheet-direct-mirror.mirror-widget , path, $false)
+ end;
+end method do-expand-node;
+
+define sealed method update-list-control-items
+ (gadget :: <gtk-tree-control>, mirror :: <gadget-mirror>)
+ => ()
+ let model = gadget.store-model;
+ let roots = tree-control-roots(gadget);
+ with-gdk-lock
+ gtk-tree-store-clear(model);
+ end;
+ gadget-selection(gadget) := #[];
+ gadget-items(gadget).size := 0;
+ tree-control-root-nodes(gadget) := make(<stretchy-vector>);
+ for (tln in roots)
+ let node = make-node(gadget, tln);
+ add-node(gadget, gadget, node, setting-roots?: #t);
+ end;
+end;
+
+define method install-event-handlers
+ (sheet :: <gtk-tree-control>, mirror :: <gadget-mirror>) => ()
+ next-method();
+ duim-g-signal-connect(sheet, #"row-expanded")
+ (treeview, treeiter, treepath, #rest args)
+ handle-row-expanded(sheet, treeiter, treepath) end;
+end;
+
+define function find-node-list
+ (gadget :: <gtk-tree-control>, indices :: <collection>)
+ => (res :: false-or(<tree-node>))
+ let roots = tree-control-root-nodes(gadget);
+ let node = roots[indices[0]];
+ for (i from 1 below indices.size)
+ node := node.node-children[indices[i]];
+ end;
+ node;
+end;
+
+define sealed method note-tree-control-roots-changed
+ (pane :: <gtk-tree-control>, #key value = $unsupplied) => ()
+ //change root nodes!
+ //clear store and gadget-items
+ update-list-control-items(pane, sheet-direct-mirror(pane))
+end;
+
+define method handle-row-expanded
+ (sheet :: <gtk-tree-control>, iter :: <GtkTreeIter>, path :: <GtkTreePath>)
+ //duim-debug-message("handling row expansion signal");
+ let model = sheet.store-model;
+ let path = map(string-to-integer,
+ split(as(<byte-string>, gtk-tree-path-to-string(path)),
+ ':'));
+ let node = find-node-list(sheet, path);
+ node.gtk-iter := iter;
+ let tree = sheet;
+ unless (node-state(node))
+ with-busy-cursor (tree)
+ // If no items have ever been added, do it now
+ let children-predicate = tree-control-children-predicate(tree);
+ when (children-predicate(node-object(node)))
+ let children-generator = tree-control-children-generator(tree);
+ let objects = children-generator(node-object(node));
+ let nodes = map-as(<simple-vector>,
+ method (object) make-node(tree, object) end, objects);
+ do-add-nodes(tree, node, nodes)
+ end;
+ node-state(node) := #"expanded"
+ end
+ end;
+
+ with-stack-structure (iter2 :: <GtkTreeIter>)
+ //remove the dummy entry
+ let res = gtk-tree-model-iter-children(model, iter2, iter);
+ with-stack-structure (value :: <GValue>)
+ g-value-nullify(value);
+ gtk-tree-model-get-value(model, iter2, 0, value);
+ if (g-value-to-dylan(value) == -1)
+ gtk-tree-store-remove(model, iter2);
+ end;
+ end;
+ end;
+ #t;
+end;
/// Option boxes
-// A fake...
define sealed class <gtk-option-box>
(<gtk-list-control-mixin>,
<option-box>,
@@ -1439,8 +1868,8 @@
define sealed method make-gtk-mirror
(gadget :: <gtk-option-box>)
=> (mirror :: <gadget-mirror>)
- let widget = GTK-CLIST(gtk-clist-new(1));
- assert(~null-pointer?(widget), "gtk-clist-new failed");
+ let widget = with-gdk-lock gtk-combo-box-new() end;
+ assert(~null-pointer?(widget), "gtk-combo-box-new failed");
make(<gadget-mirror>,
widget: widget,
sheet: gadget)
@@ -1466,7 +1895,6 @@
/// Combo boxes
-// A fake...
define sealed class <gtk-combo-box>
(<gtk-list-control-mixin>,
<combo-box>,
@@ -1474,6 +1902,10 @@
<sealed-constructor-mixin>)
end class <gtk-combo-box>;
+define method %gtk-fixed-height? (obj :: <gtk-combo-box>) => (res :: <boolean>)
+ #t;
+end;
+
define sealed method class-for-make-pane
(framem :: <gtk-frame-manager>, class == <combo-box>, #key)
=> (class :: <class>, options :: false-or(<sequence>))
@@ -1483,204 +1915,60 @@
define sealed method make-gtk-mirror
(gadget :: <gtk-combo-box>)
=> (mirror :: <gadget-mirror>)
- let widget = GTK-CLIST(gtk-clist-new(1));
- assert(~null-pointer?(widget), "gtk-clist-new failed");
- make(<gadget-mirror>,
- widget: widget,
- sheet: gadget)
+ with-gdk-lock
+ let widget = gtk-combo-box-entry-new();
+ make(<gadget-mirror>,
+ widget: widget,
+ sheet: gadget)
+ end
end method make-gtk-mirror;
-/*---*** No combo boxes for now...
-define sealed class <gtk-combo-box>
- (<gtk-gadget-mixin>,
- <combo-box>,
- <leaf-pane>,
- <sealed-constructor-mixin>)
- sealed slot %changed? :: <boolean> = #f;
-end class <gtk-combo-box>;
-
-//--- If <gtk-combo-box> was a <text-field>, we would not need this
-define sealed method activate-gtk-gadget
- (gadget :: <combo-box>) => (activated? :: <boolean>)
- handle-text-gadget-changed(gadget);
- next-method()
-end method activate-gtk-gadget;
-
-define sealed class <gtk-combo-box-text-field>
- (<gtk-subgadget-mixin>,
- <gtk-text-field>)
-end class <gtk-combo-box-text-field>;
-
-define sealed method class-for-make-pane
- (framem :: <gtk-frame-manager>, class == <combo-box>, #key)
- => (class :: <class>, options :: false-or(<sequence>))
- values(<gtk-combo-box>, #f)
-end method class-for-make-pane;
-
-define sealed method make-gadget-control
- (gadget :: <gtk-combo-box>, parent :: <HWND>, options :: <options-type>,
- #key x, y, width, height)
- => (handle :: <HWND>)
- let ext-style = if (border-type(gadget) == #"none") 0 else $WS-EX-CLIENTEDGE end;
- let handle :: <HWND>
- = CreateWindowEx(ext-style,
- "COMBOBOX",
- "",
- %logior(options,
- $WS-GROUP, $WS-TABSTOP,
- $CBS-AUTOHSCROLL, $CBS-HASSTRINGS,
- $CBS-DROPDOWN),
- x, y, width, height,
- parent,
- $null-hMenu,
- application-instance-handle(),
- $NULL-VOID);
- check-result("CreateWindowEx (COMBOBOX)", handle);
- subclass-combo-box-text-field(gadget, handle);
- handle
-end method make-gadget-control;
-
-define sealed method update-mirror-attributes
+define method update-mirror-attributes
(gadget :: <gtk-combo-box>, mirror :: <gadget-mirror>) => ()
next-method();
- note-gadget-items-changed(gadget)
-end method update-mirror-attributes;
+ gtk-combo-box-entry-set-text-column(mirror.mirror-widget, 1);
+end;
-// This is a bizarre hack to subclass the text field which is
-// a child of the combo box.
-define function subclass-combo-box-text-field
- (gadget :: <gtk-combo-box>, handle :: <HWND>) => ()
- let edit-control = GetWindow(handle, $GW-CHILD);
- check-result("Finding the combo box's edit control", edit-control);
- // This is odd, but making this gadget actually does all the work
- // to mirror and attach everything correctly.
- make(<gtk-combo-box-text-field>,
- owner: gadget, handle: edit-control);
-end function subclass-combo-box-text-field;
+define method install-event-handlers
+ (sheet :: <gtk-combo-box>, mirror :: <gadget-mirror>) => ()
+ next-method();
+ duim-g-signal-connect (sheet, #"changed") (#rest args) handle-changing-selection(sheet) end;
+ let gtkentry = with-gdk-lock gtk-bin-get-child(mirror.mirror-widget) end;
+ g-signal-connect(gtkentry, "activate", method(#rest args) handle-changed-selection(sheet) end);
+end;
-define sealed method do-compose-space
- (gadget :: <gtk-combo-box>, #key width, height)
- => (space-req :: <space-requirement>)
- ignore(height);
- let _port = port(gadget);
- let text-style = get-default-text-style(_port, gadget);
- let min-width = $minimum-visible-characters * font-width(text-style, _port);
- let width = constrain-size(width | min-width, min-width, $fill);
- //---*** How should we really calculate the constant below?
- let height = font-height(text-style, _port) + $option-box-extra-height;
- make(<space-requirement>,
- width: max(width, min-width), min-width: min-width, max-width: $fill,
- height: height)
-end method do-compose-space;
+define method handle-changed-selection (gadget :: <gtk-combo-box>) => (handled? :: <boolean>)
+ let widget = mirror-widget(sheet-direct-mirror(gadget));
+ let text = as(<byte-string>, gtk-combo-box-get-active-text(widget));
+ distribute-text-changed-callback(gadget, text);
+ #t
+end;
-define sealed method gtk-combo-box-height
- (gadget :: <gtk-combo-box>) => (height :: <integer>)
- let _port = port(gadget);
- let text-style = get-default-text-style(_port, gadget);
- let n-items :: <integer> = size(gadget-items(gadget));
- let line-height = font-height(text-style, _port);
- let vsp = $default-vertical-spacing;
- let nlines = max(n-items, 1);
- //---*** How can we compute this for real?
- line-height + $option-box-extra-height + 4
- + min($option-box-maximum-popup-height,
- nlines * line-height + (nlines - 1) * vsp)
-end method gtk-combo-box-height;
+define method handle-changing-selection (gadget :: <gtk-combo-box>) => (handled? :: <boolean>)
+ let widget = mirror-widget(sheet-direct-mirror(gadget));
+ let row = gtk-combo-box-get-active(widget);
+ let text =
+ if (row = -1)
+ as(<byte-string>, gtk-combo-box-get-active-text(widget));
+ else
+ let gtkentry = gtk-bin-get-child(widget);
+ gtk-entry-set-text(gtkentry, gadget-items(gadget)[row]);
+ gtk-widget-grab-focus(gtkentry);
+ gadget-items(gadget)[row]
+ end;
+ distribute-text-changing-callback(gadget, text);
+ #t
+end;
define sealed method note-gadget-items-changed
(gadget :: <gtk-combo-box>) => ()
next-method();
let mirror = sheet-direct-mirror(gadget);
when (mirror)
- update-gadget-items(gadget, $CB-RESETCONTENT, $CB-ADDSTRING);
- update-gadget-text(gadget, mirror);
- // Call 'set-mirror-edges' to make sure that the drop-down menu
- // is the correct size.
- let _port = port(gadget);
- let (left, top, right, bottom) = mirror-edges(_port, gadget, mirror);
- set-mirror-edges(_port, gadget, mirror, left, top, right, bottom)
+ update-list-control-items(gadget, mirror);
end
end method note-gadget-items-changed;
-define sealed method note-gadget-text-changed
- (gadget :: <gtk-combo-box>) => ()
- next-method();
- let mirror = sheet-direct-mirror(gadget);
- mirror & update-gadget-text(gadget, mirror)
-end method note-gadget-text-changed;
-
-define sealed method note-gadget-value-changed
- (gadget :: <gtk-combo-box>) => ()
- next-method();
- let mirror = sheet-direct-mirror(gadget);
- mirror & update-gadget-text(gadget, mirror)
-end method note-gadget-value-changed;
-
-define sealed method handle-selection-changed
- (gadget :: <gtk-combo-box>) => (handled? :: <boolean>)
- let handle = window-handle(gadget);
- let selection = SendMessage(handle, $CB-GETCURSEL, 0, 0);
- unless (selection = $CB-ERR)
- let item = gadget-items(gadget)[selection];
- let text = collection-gadget-item-label(gadget, item);
- distribute-text-changed-callback(gadget, text);
- #t
- end
-end method handle-selection-changed;
-
-define sealed method handle-command
- (gadget :: <gtk-combo-box>, mirror :: <gadget-mirror>,
- id :: <integer>, event :: <integer>)
- => (handled? :: <boolean>)
- ignore(mirror, id);
- select (event)
- $CBN-EDITCHANGE => handle-text-gadget-changing(gadget);
- $CBN-SELENDOK => handle-selection-changed(gadget);
-//---*** This doesn't seem to work, and also messes up
-//---*** the SELENDOK so I've taken it out for now.
-// $EN-KILLFOCUS => handle-text-gadget-changed(gadget);
- otherwise => next-method();
- end
-end method handle-command;
-
-//--- This is a hack to wrestle the magic keys from the combo-box so
-//--- that we can correctly handle hitting return, escape or tab.
-define sealed method handle-control-message
- (text-field :: <gtk-combo-box-text-field>, message :: <message-type>,
- wParam :: <wparam-type>, lParam :: <lparam-type>)
- => (handled? :: <boolean>)
- let gadget = subgadget-owner(text-field);
- duim-debug-message("Handling message #x%x for subclassed %=",
- message, gadget);
- when (message = $WM-KEYUP | message = $WM-CHAR | message = $WM-KEYDOWN)
- let key-name = virtual-key->keysym(wParam);
- duim-debug-message("Handling key-name %= for subclassed %=",
- key-name, gadget);
- select (key-name)
- #"return", #"escape" =>
- message = $WM-KEYDOWN & handle-command-for-id(gadget, $IDOK);
- #t;
- #"tab" =>
- //---*** We need to handle Tab and shift-Tab somehow, since
- //---*** combo boxes won't do it for us.
- duim-debug-message("Dropping Tab on the floor for %=!", gadget);
- #t;
- otherwise =>
- #f;
- end
- end
-end method handle-control-message;
-
-define sealed method cancel-gadget
- (gadget :: <gtk-combo-box>) => (handled? :: <boolean>)
- let handle = window-handle(gadget);
- when (handle & (SendMessage(handle, $CB-GETDROPPEDSTATE, 0, 0) = $true))
- SendMessage(handle, $CB-SHOWDROPDOWN, $false, 0);
- #t
- end
-end method cancel-gadget;
-*/
-
/// Viewports
@@ -1698,17 +1986,17 @@
values(<gtk-viewport>, #f)
end method class-for-make-pane;
-// ---*** make viewports drawing areas for now so that we can see some content
define method make-gtk-mirror
(sheet :: <gtk-viewport>)
=> (mirror :: <widget-mirror>)
-// let widget = GTK-DRAWING-AREA(gtk-drawing-area-new());
- let widget = GTK-WIDGET(gtk-drawing-area-new());
-// gtk-drawing-area-size(widget, 200, 200);
- gtk-widget-set-size-requ