X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/6bb2385148c2ff5f4f5daa87b508ae6c985b451b..43e8a182b5a4b41d3b5bb063cecb15d12ae3964b:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index f7c6184..b76bff5 100644 --- a/gtk/gtk.lisp +++ b/gtk/gtk.lisp @@ -15,7 +15,7 @@ ;; 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.18 2004-11-19 13:09:00 espen Exp $ +;; $Id: gtk.lisp,v 1.27 2004-12-26 11:51:21 espen Exp $ (in-package "GTK") @@ -321,19 +321,18 @@ (defmethod shared-initialize ((combo-box-entry combo-box-entry) names &key model ;;;; Dialog -(defmethod shared-initialize ((dialog dialog) names &rest initargs &key button) - (declare (ignore button)) - (call-next-method) - (dolist (button-definition (get-all initargs :button)) - (apply #'dialog-add-button dialog (mklist button-definition)))) +(defmethod shared-initialize ((dialog dialog) names &rest initargs + &key button buttons) + (declare (ignore button buttons)) + (prog1 + (call-next-method) + (initial-apply-add dialog #'dialog-add-button initargs :button :buttons))) -(defvar %*response-id-key* (gensym)) - (defun %dialog-find-response-id-num (dialog id &optional create-p error-p) (or (cadr (assoc id (rest (type-expand-1 'response-type)))) - (let ((response-ids (object-data dialog %*response-id-key*))) + (let ((response-ids (object-data dialog 'response-id-key))) (cond ((and response-ids (position id response-ids :test #'equal))) (create-p @@ -343,7 +342,7 @@ (defun %dialog-find-response-id-num (dialog id &optional create-p error-p) (1- (length response-ids))) (t (setf - (object-data dialog %*response-id-key*) + (object-data dialog 'response-id-key) (make-array 1 :adjustable t :fill-pointer t :initial-element id)) 0))) (error-p @@ -355,7 +354,7 @@ (defun %dialog-find-response-id (dialog response-id-num) (rassoc (list response-id-num) (rest (type-expand-1 'response-type)) :test #'equal)) - (aref (object-data dialog %*response-id-key*) response-id-num ))) + (aref (object-data dialog 'response-id-key) response-id-num ))) (defmethod signal-connect ((dialog dialog) signal function &key object after) @@ -389,8 +388,7 @@ (defbinding %dialog-add-button () button (defun dialog-add-button (dialog label &optional (response label) &key default object after) - "Adds a button to the dialog. If no response is given, then label - will be used." + "Adds a button to the dialog." (let* ((id (if (functionp response) label response)) @@ -435,8 +433,20 @@ (defbinding dialog-set-response-sensitive (dialog response-id sensitive) nil ((%dialog-find-response-id-num dialog response-id nil t) int) (sensitive boolean)) +#+gtk2.6 +(defbinding alternative-dialog-button-order-p(&optional screen) + (screen (or null screen))) + +#+gtk2.6 +(defbinding (dialog-set-alternative-button-order + "gtk_dialog_set_alternative_button_order_from_array") + (dialog new-order) + (dialog dialog) + ((length new-order) int) + ((map 'vector #'(lambda (id) + (%dialog-find-response-id-num dialog id nil t)) + new-order) (vector int))) -;; Addition dialog functions (defmethod container-add ((dialog dialog) (child widget) &rest args) (apply #'container-add (dialog-vbox dialog) child args)) @@ -452,12 +462,17 @@ (defmethod (setf container-children) (children (dialog dialog)) -;;; Drawing area -- no functions +;;; Drawing area + +(defbinding drawing-area-get-size () nil + (drawing-area drawing-area) + (width int :out) + (height int :out)) ;;; Entry -(defbinding entry-get-layout () (copy-of pango:layout) +(defbinding entry-get-layout () pango:layout (entry entry)) (defbinding entry-get-layout-offsets () nil @@ -466,6 +481,39 @@ (defbinding entry-get-layout-offsets () nil (y int :out)) +;;; Entry Completion + +(def-callback-marshal %entry-completion-match-func + (boolean entry-completion string (copy-of tree-iter))) + +(defbinding entry-completion-set-match-func (completion function) nil + (completion entry-completion) + ((callback %entry-completion-match-func) pointer) + ((register-callback-function function) unsigned-int) + ((callback %destroy-user-data) pointer)) + +(defbinding entry-completion-complete () nil + (completion entry-completion)) + +#+gtk2.6 +(defbinding entry-completion-insert-prefix () nil + (completion entry-completion)) + +(defbinding entry-completion-insert-action-text () nil + (completion entry-completion) + (index int) + (text string)) + +(defbinding entry-completion-insert-action-markup () nil + (completion entry-completion) + (index int) + (markup string)) + +(defbinding entry-completion-delete-action () nil + (completion entry-completion) + (index int)) + + ;;; Image (defbinding image-set-from-file () nil @@ -524,7 +572,7 @@ (defbinding label-select-region () nil (defbinding label-get-text () string (label label)) -(defbinding label-get-layout () (copy-of pango:layout) +(defbinding label-get-layout () pango:layout (label label)) (defbinding label-get-selection-bounds () boolean @@ -617,6 +665,48 @@ (defbinding menu-item-toggle-size-allocate () nil (allocation int)) +;;; Message dialog + +(defmethod initialize-instance ((dialog message-dialog) &rest initargs + &key (type :info) (buttons :close) ; or :ok? + flags message parent) + (remf initargs :parent) + (setf + (slot-value dialog 'location) + (%message-dialog-new parent flags type buttons nil)) + (message-dialog-set-markup dialog message) + (apply #'call-next-method dialog initargs)) + + +(defbinding %message-dialog-new () pointer + (parent (or null window)) + (flags dialog-flags) + (type message-type) + (buttons buttons-type) + (message (or null string))) + +(defbinding %message-dialog-new-with-markup () pointer + (parent (or null window)) + (flags dialog-flags) + (type message-type) + (buttons buttons-type) + (message string)) + +(defbinding message-dialog-set-markup () nil + (message-dialog message-dialog) + (markup string)) + +#+gtk2.6 +(defbinding message-dialog-format-secondary-text () nil + (message-dialog message-dialog) + (text string)) + +#+gtk2.6 +(defbinding message-dialog-format-secondary-markup () nil + (message-dialog message-dialog) + (markup string)) + + ;;; Radio menu item @@ -650,6 +740,15 @@ (defbinding toggle-button-toggled () nil ;;; Window +(defmethod initialize-instance ((window window) &rest initargs + &key accel-group accel-groups) + (declare (ignore accel-group accel-groups)) + (prog1 + (call-next-method) + (initial-add window #'window-add-accel-group + initargs :accel-group :accel-groups))) + + (defbinding window-set-wmclass () nil (window window) (wmclass-name string) @@ -674,9 +773,44 @@ (defbinding window-set-default-size (window width height) int ((or width -1) int) ((or height -1) int)) -;(defbinding window-set-geometry-hints) - -(defbinding window-list-toplevels () (glist window)) +(defbinding %window-set-geometry-hints () nil + (window window) + (geometry gdk:geometry) + (geometry-mask gdk:window-hints)) + +(defun window-set-geometry-hints (window &key min-width min-height + max-width max-height base-width base-height + width-inc height-inc min-aspect max-aspect + (gravity nil gravity-p) min-size max-size) + (let ((geometry (make-instance 'gdk:geometry + :min-width (or min-width -1) + :min-height (or min-height -1) + :max-width (or max-width -1) + :max-height (or max-height -1) + :base-width (or base-width 0) + :base-height (or base-height 0) + :width-inc (or width-inc 0) + :height-inc (or height-inc 0) + :min-aspect (or min-aspect 0) + :max-aspect (or max-aspect 0) + :gravity gravity)) + (mask ())) + (when (or min-size min-width min-height) + (push :min-size mask)) + (when (or max-size max-width max-height) + (push :max-size mask)) + (when (or base-width base-height) + (push :base-size mask)) + (when (or width-inc height-inc) + (push :resize-inc mask)) + (when (or min-aspect max-aspect) + (push :aspect mask)) + (when gravity-p + (push :win-gravity mask)) + (%window-set-geometry-hints window geometry mask))) + +(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) @@ -693,6 +827,14 @@ (defbinding window-mnemonic-activate (window key modifier) nil ((gdk:keyval-from-name key) unsigned-int) (modifier gdk:modifier-type)) +(defbinding window-activate-key () boolean + (window window) + (event gdk:key-event)) + +(defbinding window-propagate-key-event () boolean + (window window) + (event gdk:key-event)) + (defbinding window-present () nil (window window)) @@ -714,6 +856,20 @@ (defbinding window-maximize () nil (defbinding window-unmaximize () nil (window window)) +(defbinding window-fullscreen () nil + (window window)) + +(defbinding window-unfullscreen () nil + (window window)) + +(defbinding window-set-keep-above () nil + (window window) + (setting boolean)) + +(defbinding window-set-keep-below () nil + (window window) + (setting boolean)) + (defbinding window-begin-resize-drag () nil (window window) (edge gdk:window-edge) @@ -732,9 +888,6 @@ (defbinding window-set-frame-dimensions () nil (window window) (left int) (top int) (rigth int) (bottom int)) -(defbinding (window-default-icons "gtk_window_get_default_icon_list") - () (glist gdk:pixbuf)) - (defbinding %window-get-default-size () nil (window window) (width int :out) @@ -751,12 +904,6 @@ (defbinding window-get-frame-dimensions () nil (defbinding %window-get-icon-list () (glist gdk:pixbuf) (window window)) -(defmethod window-icon ((window window)) - (let ((icon-list (%window-get-icon-list window))) - (if (endp (rest icon-list)) - (first icon-list) - icon-list))) - (defbinding window-get-position () nil (window window) (root-x int :out) @@ -784,19 +931,86 @@ (defbinding window-resize () nil (width int) (heigth int)) -(defbinding %window-set-icon-list () nil +(defbinding (window-default-icon-list "gtk_window_get_default_icon_list") + () (glist gdk:pixbuf)) + +(defun window-default-icon () + (first (window-default-icon-list))) + +(defbinding %window-set-default-icon-list () nil + (icons (glist gdk:pixbuf))) + +(defun (setf window-default-icon-list) (icons) + (%window-set-default-icon-list icons) + icons) + +(defbinding %window-set-default-icon () nil + (icons (glist gdk:pixbuf))) + +(defmethod (setf window-default-icon) ((icon gdk:pixbuf)) + (%window-set-default-icon icon) + icon) + +(defmethod (setf window-group) ((group window-group) (window window)) + (window-group-add-window group window) + group) + +(defbinding %window-set-default-icon-from-file () boolean + (filename pathname) + (nil null)) + +(defmethod (setf window-default-icon) ((icon-file pathname)) + (%window-set-default-icon-from-file icon-file) + icon-file) + +(defbinding %window-set-icon-from-file () boolean + (window window) + (filename pathname) + (nil null)) + +(defmethod (setf window-icon) ((icon-file pathname) (window window)) + (%window-set-icon-from-file window icon-file) + icon-file) + +(defbinding window-set-auto-startup-notification () nil + (setting boolean)) + +(defbinding decorated-window-init () nil + (window window)) + +(defbinding decorated-window-calculate-frame-size () nil + (window window)) + +(defbinding decorated-window-set-title () nil (window window) - (icon-list (glist gdk:pixbuf))) + (title string)) -(defmethod (setf window-icon) (icon (window window)) - (%window-set-icon-list window (mklist icon))) +(defbinding decorated-window-move-resize-window () nil + (window window) + (x int) + (y int) + (width int) + (heigth int)) +;;; Window group +(defmethod initialize-instance ((window-group window-group) &rest initargs + &key window windows) + (declare (ignore window windows)) + (prog1 + (call-next-method) + (initial-add window-group #'window-group-add-window + initargs :window :windows))) -;;; File chooser +(defbinding window-group-add-window () nil + (window-group window-group) + (window window)) +(defbinding window-group-remove-window () nil + (window-group window-group) + (window window)) ;;; Scrolled window @@ -1027,27 +1241,6 @@ (defbinding paned-pack2 () nil (resize boolean) (shrink boolean)) -(defun (setf paned-child1) (child paned) - (paned-pack1 paned child nil t) - child) - -(defun (setf paned-child2) (child paned) - (paned-pack2 paned child t t) - child) - -;; Defined in gtkglue.c -(defbinding paned-child1 () widget - (paned paned) - (resize boolean :out) - (shrink boolean :out)) - -;; Defined in gtkglue.c -(defbinding paned-child2 () widget - (paned paned) - (resize boolean :out) - (shrink boolean :out)) - - ;;; Layout @@ -1170,17 +1363,16 @@ (defbinding table-resize () nil (columns unsigned-int)) (defbinding table-attach (table child left right top bottom - &key (x-options '(:expand :fill)) - (y-options '(:expand :fill)) - (x-padding 0) (y-padding 0)) nil + &key options x-options y-options + (x-padding 0) (y-padding 0)) nil (table table) (child widget) (left unsigned-int) (right unsigned-int) (top unsigned-int) (bottom unsigned-int) - (x-options attach-options) - (y-options attach-options) + ((append (mklist options) (mklist x-options)) attach-options) + ((append (mklist options) (mklist y-options)) attach-options) (x-padding unsigned-int) (y-padding unsigned-int)) @@ -1494,14 +1686,57 @@ (defbinding progress-bar-pulse () nil (progress-bar progress-bar)) +;;; Size group + +(defmethod initialize-instance ((size-group size-group) &rest initargs + &key widget widgets) + (declare (ignore widget widgets)) + (prog1 + (call-next-method) + (initial-add size-group #'size-group-add-widget + initargs :widget :widgets))) + + +(defbinding size-group-add-widget () nil + (size-group size-group) + (widget widget)) + +(defbinding size-group-remove-widget () nil + (size-group size-group) + (widget widget)) + ;;; Stock items -(defbinding stock-lookup () boolean +(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) - ((make-instance 'stock-item) stock-item :return)) - + (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 @@ -1548,22 +1783,6 @@ (defbinding rc-get-style () style ;;; Accelerator Groups #| -(defbinding accel-group-get-default () accel-group) - -(deftype-method alien-ref accel-group (type-spec) - (declare (ignore type-spec)) - '%accel-group-ref) - -(deftype-method alien-unref accel-group (type-spec) - (declare (ignore type-spec)) - '%accel-group-unref) - -(defbinding %accel-group-ref () accel-group - (accel-group (or accel-group pointer))) - -(defbinding %accel-group-unref () nil - (accel-group (or accel-group pointer))) - (defbinding accel-group-activate (accel-group key modifiers) boolean (accel-group accel-group) ((gdk:keyval-from-name key) unsigned-int)