X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/8755b1a5d37f2f4b853c01f0d8b121ab9ee4093a..73d58e01fa0bfd1eaa85bf893370e2f46d0debc4:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index a4451cf..88135b7 100644 --- a/gtk/gtk.lisp +++ b/gtk/gtk.lisp @@ -15,14 +15,14 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gtk.lisp,v 1.16 2004-11-07 01:23:38 espen Exp $ +;; $Id: gtk.lisp,v 1.20 2004-12-04 00:34:49 espen Exp $ (in-package "GTK") ;;; Gtk version -(defbinding check-version () string +(defbinding check-version () (copy-of string) (required-major unsigned-int) (required-minor unsigned-int) (required-micro unsigned-int)) @@ -39,7 +39,7 @@ (defun gtk-version () (format nil "Gtk+ v~A.~A" major minor) (format nil "Gtk+ v~A.~A.~A" major minor micro)))) -(defbinding get-default-language () string) +(defbinding get-default-language () (copy-of pango:language)) ;;;; Initalization @@ -132,8 +132,8 @@ (defbinding box-pack-end () nil (fill boolean) (padding unsigned-int)) -(defun box-pack (box child &key from-end expand fill (padding 0)) - (if from-end +(defun box-pack (box child &key end expand fill (padding 0)) + (if end (box-pack-end box child expand fill padding) (box-pack-start box child expand fill padding))) @@ -265,23 +265,59 @@ (defbinding (color-selection-is-adjusting-p -;;; Combo +;;;; Combo Box -(defmethod shared-initialize ((combo combo) names &rest initargs - &key popdown-strings) - (declare (ignore initargs)) - (call-next-method) - (when popdown-strings - (combo-set-popdown-strings combo popdown-strings))) - -(defbinding combo-set-popdown-strings () nil - (combo combo) - (strings (glist string))) +(defmethod shared-initialize ((combo-box combo-box) names &key model content) + (unless model + (setf + (combo-box-model combo-box) + (make-instance 'list-store :column-types '(string))) + (unless (typep combo-box 'combo-box-entry) + (let ((cell (make-instance 'cell-renderer-text))) + (cell-layout-pack combo-box cell :expand t) + (cell-layout-add-attribute combo-box cell :text 0))) + (when content + (map 'nil #'(lambda (text) + (combo-box-append-text combo-box text)) + content))) + (call-next-method)) + +;; (defmethod shared-initialize :after ((combo-box combo-box) names &key active) +;; (when active +;; (signal-emit combo-box 'changed))) + +(defbinding combo-box-append-text () nil + (combo-box combo-box) + (text string)) + +(defbinding combo-box-insert-text () nil + (combo-box combo-box) + (position int) + (text string)) + +(defbinding combo-box-prepend-text () nil + (combo-box combo-box) + (text string)) + +#+gtk2.6 +(defbinding combo-box-get-active-text () string + (combo-box combo-box)) + +(defbinding combo-box-popup () nil + (combo-box combo-box)) + +(defbinding combo-box-popdown () nil + (combo-box combo-box)) -(defbinding combo-disable-activate () nil - (combo combo)) +;;;; Combo Box Entry + +(defmethod shared-initialize ((combo-box-entry combo-box-entry) names &key model) + (call-next-method) + (unless model + (setf (combo-box-entry-text-column combo-box-entry) 0))) + ;;;; Dialog @@ -520,23 +556,6 @@ (defmethod initialize-instance ((button radio-button) (radio-button-add-to-group button group-with))) -;;; Option menu - -(defbinding %option-menu-set-menu () nil - (option-menu option-menu) - (menu widget)) - -(defbinding %option-menu-remove-menu () nil - (option-menu option-menu)) - -(defun (setf option-menu-menu) (menu option-menu) - (if (not menu) - (%option-menu-remove-menu option-menu) - (%option-menu-set-menu option-menu menu)) - menu) - - - ;;; Item (defbinding item-select () nil @@ -631,6 +650,14 @@ (defbinding toggle-button-toggled () nil ;;; Window +(defmethod initialize-instance ((window window) &rest initargs &key accel-group) + (declare (ignore accel-group)) + (call-next-method) + (mapc #'(lambda (accel-group) + (window-add-accel-group window accel-group)) + (get-all initargs :accel-group))) + + (defbinding window-set-wmclass () nil (window window) (wmclass-name string) @@ -657,7 +684,8 @@ (defbinding window-set-default-size (window width height) int ;(defbinding window-set-geometry-hints) -(defbinding window-list-toplevels () (glist window)) +(defbinding window-list-toplevels () (glist (copy-of window)) + "Returns a list of all existing toplevel windows.") (defbinding window-add-mnemonic (window key target) nil (window window) @@ -937,7 +965,7 @@ (defbinding (notebook-tab-label "gtk_notebook_get_tab_label") ((%notebook-child notebook page) widget)) (defbinding (notebook-tab-label-text "gtk_notebook_get_tab_label_text") - (notebook page) string + (notebook page) (copy-of string) (notebook notebook) ((%notebook-child notebook page) widget)) @@ -960,7 +988,7 @@ (defbinding (notebook-menu-label "gtk_notebook_get_menu_label") ((%notebook-child notebook page) widget)) (defbinding (notebook-menu-label-text "gtk_notebook_get_menu_label_text") - (notebook page) string + (notebook page) (copy-of string) (notebook notebook) ((%notebook-child notebook page) widget)) @@ -1110,13 +1138,10 @@ (defbinding %menu-popup () nil (defun menu-popup (menu button activate-time &key callback parent-menu-shell parent-menu-item) (if callback - (let ((callback-id (register-callback-function callback))) - (unwind-protect - (%menu-popup - menu parent-menu-shell parent-menu-item - (callback %menu-popup-callback) - callback-id button activate-time) - (destroy-user-data callback-id))) + (with-callback-function (id callback) + (%menu-popup + menu parent-menu-shell parent-menu-item + (callback %menu-popup-callback) id button activate-time)) (%menu-popup menu parent-menu-shell parent-menu-item nil 0 button activate-time))) @@ -1481,11 +1506,35 @@ (defbinding progress-bar-pulse () nil ;;; Stock items -(defbinding stock-lookup () boolean - (stock-id string) - (stock-item stock-item :out)) - +(defbinding %stock-item-copy () pointer + (location pointer)) + +(defbinding %stock-item-free () nil + (location pointer)) + +(defmethod reference-foreign ((class (eql (find-class 'stock-item))) location) + (%stock-item-copy location)) + +(defmethod unreference-foreign ((class (eql (find-class 'stock-item))) location) + (%stock-item-free location)) +(defbinding stock-add (stock-item) nil + (stock-item stock-item) + (1 unsigned-int)) + +(defbinding stock-list-ids () (gslist string)) + +(defbinding %stock-lookup () boolean + (stock-id string) + (location pointer)) + +(defun stock-lookup (stock-id) + (let ((location + (allocate-memory (proxy-instance-size (find-class 'stock-item))))) + (unwind-protect + (when (%stock-lookup stock-id location) + (ensure-proxy-instance 'stock-item (%stock-item-copy location))) + (deallocate-memory location)))) ;;; Tooltips