X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/68f519e0e99a023834e3bc0db73ca3ae9e40d64a..a5522de52c8dcd65783339b80de07c3413d61ffa:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index af78c09..6d0c9ef 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.30 2005-01-12 13:38:18 espen Exp $ +;; $Id: gtk.lisp,v 1.41 2005-04-19 08:11:39 espen Exp $ (in-package "GTK") @@ -44,7 +44,7 @@ (defbinding get-default-language () (copy-of pango:language)) ;;;; Initalization -(defbinding (gtk-init "gtk_parse_args") () nil +(defbinding (gtk-init "gtk_parse_args") () boolean "Initializes the library without opening the display." (nil null) (nil null)) @@ -53,18 +53,130 @@ (defun clg-init (&optional display) "Initializes the system and starts the event handling" (unless (gdk:display-get-default) (gdk:gdk-init) - (gtk-init) + (unless (gtk-init) + (error "Initialization of GTK+ failed.")) (prog1 (gdk:display-open display) - (system:add-fd-handler - (gdk:display-connection-number) :input #'main-iterate-all) - (setq lisp::*periodic-polling-function* #'main-iterate-all) - (setq lisp::*max-event-to-sec* 0) - (setq lisp::*max-event-to-usec* 1000)))) + (add-fd-handler (gdk:display-connection-number) :input #'main-iterate-all) + (setq *periodic-polling-function* #'main-iterate-all) + (setq *max-event-to-sec* 0) + (setq *max-event-to-usec* 1000)))) + + +;;; Misc + +(defbinding grab-add () nil + (widget widget)) + +(defbinding grab-get-current () widget) + +(defbinding grab-remove () nil + (widget widget)) + + +;;; About dialog + +#+gtk2.6 +(progn + (def-callback-marshal %about-dialog-activate-link-func + (nil (dialog about-dialog) (link (copy-of string)))) + + (defbinding about-dialog-set-email-hook (function) nil + ((callback %about-dialog-activate-link-func) pointer) + ((register-callback-function function) unsigned-int) + ((callback user-data-destroy-func) pointer)) + + (defbinding about-dialog-set-url-hook (function) nil + ((callback %about-dialog-activate-link-func) pointer) + ((register-callback-function function) unsigned-int) + ((callback user-data-destroy-func) pointer))) ;;; Acccel group +(defbinding %accel-group-connect () nil + (accel-group accel-group) + (key unsigned-int) + (modifiers gdk:modifier-type) + (flags accel-flags) + (gclosure gclosure)) + +(defun accel-group-connect (group accelerator function &optional flags) + (multiple-value-bind (key modifiers) (accelerator-parse accelerator) + (let ((gclosure (make-callback-closure function))) + (%accel-group-connect group key modifiers flags gclosure) + gclosure))) + +(defbinding accel-group-connect-by-path (group path function) nil + (group accel-group) + (path string) + ((make-callback-closure function) gclosure :return)) + +(defbinding %accel-group-disconnect (group gclosure) boolean + (group accel-group) + (gclosure gclosure)) + +(defbinding %accel-group-disconnect-key () boolean + (group accel-group) + (key unsigned-int) + (modifiers gdk:modifier-type)) + +(defun accel-group-disconnect (group accelerator) + (etypecase accelerator + (gclosure (%accel-group-disconnect group accelerator)) + (string + (multiple-value-bind (key modifiers) (accelerator-parse accelerator) + (%accel-group-disconnect-key group key modifiers))))) + +(defbinding accel-group-lock () nil + (accel-group accel-group)) + +(defbinding accel-group-unlock () nil + (accel-group accel-group)) + +(defbinding %accel-groups-activate () boolean + (object gobject) + (key unsigned-int) + (modifiers gdk:modifier-type)) + +(defun accel-groups-activate (object accelerator) + (multiple-value-bind (key modifiers) (accelerator-parse accelerator) + (%accel-groups-activate object key modifiers))) + +(defbinding accel-groups-from-object () (gslist accel-groups) + (object gobject)) + +(defbinding accelerator-valid-p (key &optional modifiers) boolean + (key unsigned-int) + (modifiers gdk:modifier-type)) + +(defbinding %accelerator-parse () nil + (accelerator string) + (key unsigned-int :out) + (modifiers gdk:modifier-type :out)) + +(defun accelerator-parse (accelerator) + (multiple-value-bind (key modifiers) (%accelerator-parse accelerator) + (if (zerop key) + (error "Invalid accelerator: ~A" accelerator) + (values key modifiers)))) + +(defbinding accelerator-name () string + (key unsigned-int) + (modifiers gdk:modifier-type)) + +#+gtk2.6 +(defbinding accelerator-get-label () string + (key unsigned-int) + (modifiers gdk:modifier-type)) + +(defbinding %accelerator-set-default-mod-mask () nil + (default-modifiers gdk:modifier-type)) + +(defun (setf accelerator-default-modifier-mask) (default-modifiers) + (%accelerator-set-default-mod-mask default-modifiers)) + +(defbinding (accelerator-default-modifier-mask "gtk_accelerator_get_default_mod_mask") () gdk:modifier-type) ;;; Acccel label @@ -73,6 +185,50 @@ (defbinding accel-label-refetch () boolean (accel-label accel-label)) + +;;; Accel map + +;(defbinding (accel-map-init "_gtk_accel_map_init") () nil) + +(defbinding %accel-map-add-entry () nil + (path string) + (key unsigned-int) + (modifiers gdk:modifier-type)) + +(defun accel-map-add-entry (path accelerator) + (multiple-value-bind (key modifiers) (accelerator-parse accelerator) + (%accel-map-add-entry path key modifiers))) + +(defbinding accel-map-lookup-entry () boolean + (path string) + (key pointer)) ;accel-key)) + +(defbinding %accel-map-change-entry () boolean + (path string) + (key unsigned-int) + (modifiers gdk:modifier-type) + (replace boolean)) + +(defun accel-map-change-entry (path accelerator &optional replace) + (multiple-value-bind (key modifiers) (accelerator-parse accelerator) + (%accel-map-change-entry path key modifiers replace))) + +(defbinding accel-map-load () nil + (filename pathname)) + +(defbinding accel-map-save () nil + (filename pathname)) + +(defbinding accel-map-get () accel-map) + +(defbinding accel-map-lock-path () nil + (path string)) + +(defbinding accel-map-unlock-path () nil + (path string)) + + + ;;; Accessible (defbinding accessible-connect-widget-destroyed () nil @@ -137,8 +293,9 @@ (defun (setf bin-child) (child bin) (container-add bin child) child) -(defmethod create-callback-function ((bin bin) function arg1) - (if (eq arg1 :child) +(defmethod compute-signal-function ((bin bin) signal function object) + (declare (ignore signal)) + (if (eq object :child) #'(lambda (&rest args) (apply function (bin-child bin) (rest args))) (call-next-method))) @@ -254,10 +411,6 @@ (defbinding check-menu-item-toggled () nil (check-menu-item check-menu-item)) - -;;; Clipboard - - ;;; Color selection (defbinding (color-selection-is-adjusting-p @@ -340,113 +493,114 @@ (defmethod shared-initialize ((dialog dialog) names &rest initargs (initial-apply-add dialog #'dialog-add-button initargs :button :buttons))) -(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))) - (cond - ((and response-ids (position id response-ids :test #'equal))) - (create-p +(defun dialog-response-id (dialog response &optional create-p error-p) + "Returns a numeric response id" + (if (typep response 'response-type) + (response-type-to-int response) + (let ((responses (object-data dialog 'responses))) + (cond + ((and responses (position response responses :test #'equal))) + (create-p (cond - (response-ids - (vector-push-extend id response-ids) - (1- (length response-ids))) + (responses + (vector-push-extend response responses) + (1- (length responses))) (t (setf - (object-data dialog 'response-id-key) - (make-array 1 :adjustable t :fill-pointer t :initial-element id)) + (object-data dialog 'responses) + (make-array 1 :adjustable t :fill-pointer t + :initial-element response)) 0))) (error-p - (error "Invalid response: ~A" id)))))) - -(defun %dialog-find-response-id (dialog response-id-num) - (if (< response-id-num 0) - (car - (rassoc - (list response-id-num) - (rest (type-expand-1 'response-type)) :test #'equal)) - (aref (object-data dialog 'response-id-key) response-id-num ))) - - -(defmethod signal-connect ((dialog dialog) signal function &key object after) - (let ((response-id-num (%dialog-find-response-id-num dialog signal))) - (cond - (response-id-num - (call-next-method - dialog 'response - #'(lambda (dialog id) - (when (= id response-id-num) - (cond - ((eq object t) (funcall function dialog)) - (object (funcall function object)) - (t (funcall function))))) - :object t :after after)) - ((call-next-method))))) + (error "Invalid response: ~A" response)))))) + +(defun dialog-find-response (dialog id) + "Finds a symbolic response given a numeric id" + (if (< id 0) + (int-to-response-type id) + (aref (object-data dialog 'responses) id))) + + +(defmethod compute-signal-id ((dialog dialog) signal) + (if (dialog-response-id dialog signal) + (ensure-signal-id 'response dialog) + (call-next-method))) +(defmethod compute-signal-function ((dialog dialog) signal function object) + (declare (ignore function object)) + (let ((callback (call-next-method)) + (id (dialog-response-id dialog signal))) + (if id + #'(lambda (dialog response) + (when (= response id) + (funcall callback dialog))) + callback))) (defbinding dialog-run () nil (dialog dialog)) -(defbinding dialog-response (dialog response-id) nil +(defbinding dialog-response (dialog response) nil (dialog dialog) - ((%dialog-find-response-id-num dialog response-id nil t) int)) + ((dialog-response-id dialog response nil t) int)) (defbinding %dialog-add-button () button (dialog dialog) (text string) - (response-id-num int)) + (response-id int)) (defun dialog-add-button (dialog label &optional (response label) &key default object after) "Adds a button to the dialog." - (let* ((id (if (functionp response) - label - response)) - (id-num (%dialog-find-response-id-num dialog id t)) - (button (%dialog-add-button dialog label id-num))) + (let* ((signal (if (functionp response) + label + response)) + (id (dialog-response-id dialog signal t)) + (button (%dialog-add-button dialog label id))) (when (functionp response) - (signal-connect dialog id response :object object :after after)) + (signal-connect dialog signal response :object object :after after)) (when default - (%dialog-set-default-response dialog id-num)) + (%dialog-set-default-response dialog id)) button)) -(defbinding %dialog-add-action-widget () button +(defbinding %dialog-add-action-widget () nil (dialog dialog) (action-widget widget) - (response-id-num int)) + (response-id int)) (defun dialog-add-action-widget (dialog widget &optional (response widget) &key default object after) - (let* ((id (if (functionp response) - widget - response)) - (id-num (%dialog-find-response-id-num dialog id t))) - (%dialog-add-action-widget dialog widget id-num) + (let* ((signal (if (functionp response) + widget + response)) + (id (dialog-response-id dialog signal t))) + (unless (widget-hidden-p widget) + (widget-show widget)) + (%dialog-add-action-widget dialog widget id) (when (functionp response) - (signal-connect dialog id response :object object :after after)) + (signal-connect dialog signal response :object object :after after)) (when default - (%dialog-set-default-response dialog id-num)) + (%dialog-set-default-response dialog id)) widget)) (defbinding %dialog-set-default-response () nil (dialog dialog) - (response-id-num int)) + (response-id int)) -(defun dialog-set-default-response (dialog response-id) +(defun dialog-set-default-response (dialog response) (%dialog-set-default-response - dialog (%dialog-find-response-id-num dialog response-id nil t))) + dialog (dialog-response-id dialog response nil t))) -(defbinding dialog-set-response-sensitive (dialog response-id sensitive) nil +(defbinding dialog-set-response-sensitive (dialog response sensitive) nil (dialog dialog) - ((%dialog-find-response-id-num dialog response-id nil t) int) + ((dialog-response-id dialog response nil t) int) (sensitive boolean)) #+gtk2.6 -(defbinding alternative-dialog-button-order-p(&optional screen) - (screen (or null screen))) +(defbinding alternative-dialog-button-order-p (&optional screen) boolean + (screen (or null gdk:screen))) #+gtk2.6 (defbinding (dialog-set-alternative-button-order @@ -454,14 +608,15 @@ (defbinding (dialog-set-alternative-button-order (dialog new-order) (dialog dialog) ((length new-order) int) - ((map 'vector #'(lambda (id) - (%dialog-find-response-id-num dialog id nil t)) + ((map 'vector #'(lambda (response) + (dialog-response-id dialog response nil t)) new-order) (vector int))) (defmethod container-add ((dialog dialog) (child widget) &rest args) (apply #'container-add (dialog-vbox dialog) child args)) + (defmethod container-remove ((dialog dialog) (child widget)) (container-remove (dialog-vbox dialog) child)) @@ -497,7 +652,7 @@ (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)) + ((callback user-data-destroy-func) pointer)) (defbinding entry-completion-complete () nil (completion entry-completion)) @@ -632,17 +787,16 @@ (defbinding file-filter-add-pattern () nil #+gtk2.6 (defbinding file-filter-add-pixbuf-formats () nil - (filter file-filter) - (pattern string)) + (filter file-filter)) (def-callback-marshal %file-filter-func (boolean file-filter-info)) -(defbinding file-filter-add-custom () nil +(defbinding file-filter-add-custom (filter needed function) nil (filter file-filter) (needed file-filter-flags) ((callback %file-filter-func) pointer) ((register-callback-function function) unsigned-int) - ((callback %destroy-user-data) pointer)) + ((callback user-data-destroy-func) pointer)) (defbinding file-filter-get-needed () file-filter-flags (filter file-filter)) @@ -701,6 +855,12 @@ (defmethod (setf image-menu-item-image) (image (item image-menu-item)) ;;; Label +(defmethod shared-initialize ((label label) names &key pattern) + (declare (ignore names)) + (call-next-method) + (when pattern + (setf (label-pattern label) pattern))) + (defbinding label-get-layout-offsets () nil (label label) (x int :out) @@ -731,6 +891,25 @@ (defmethod add-to-radio-group ((button1 radio-button) (button2 radio-button)) "Add BUTTON1 to the group which BUTTON2 belongs to." (%radio-button-set-group button1 (%radio-button-get-group button2))) +(defun %add-activate-callback (widget signal function object after) + (if object + (signal-connect widget signal + #'(lambda (object) + (when (slot-value widget 'active) + (funcall function object (slot-value widget 'value)))) + :object object :after after) + (signal-connect widget signal + #'(lambda () + (when (slot-value widget 'active) + (funcall function (slot-value widget 'value)))) + :after after))) + +(defmethod activate-radio-widget ((button radio-button)) + (signal-emit button 'clicked)) + +(defmethod add-activate-callback ((button radio-button) function &key object after) + (%add-activate-callback button 'clicked function object after)) + (defmethod initialize-instance ((button radio-button) &key group) (prog1 (call-next-method) @@ -800,7 +979,7 @@ (defbinding menu-item-toggle-size-allocate () nil ;;; Menu tool button #+gtk2.6 -(defbinding menu-tool-button-set-arrow-tip () nil +(defbinding menu-tool-button-set-arrow-tooltip () nil (menu-tool-button menu-tool-button) (tooltips tooltips) (tip-text string) @@ -809,15 +988,19 @@ (defbinding menu-tool-button-set-arrow-tip () nil ;;; Message dialog -(defmethod initialize-instance ((dialog message-dialog) &rest initargs - &key (type :info) (buttons :close) ; or :ok? - flags message parent) - (remf initargs :parent) +(defmethod initialize-instance ((dialog message-dialog) + &key (message-type :info) (buttons :close) + flags text #+gtk 2.6 secondary-text + transient-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)) + (%message-dialog-new transient-parent flags message-type buttons)) + (when text + (message-dialog-set-markup dialog text)) + #+gtk2.6 + (when secondary-text + (message-dialog-format-secondary-markup dialog secondary-text)) + (call-next-method)) (defbinding %message-dialog-new () pointer @@ -825,14 +1008,7 @@ (defbinding %message-dialog-new () pointer (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)) + (nil null)) (defbinding message-dialog-set-markup () nil (message-dialog message-dialog) @@ -859,10 +1035,16 @@ (defbinding %radio-menu-item-set-group () nil (radio-menu-item radio-menu-item) (group pointer)) +(defmethod activate-radio-widget ((item radio-menu-item)) + (menu-item-activate item)) + (defmethod add-to-radio-group ((item1 radio-menu-item) (item2 radio-menu-item)) "Add ITEM1 to the group which ITEM2 belongs to." (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2))) +(defmethod add-activate-callback ((item radio-menu-item) function &key object after) + (%add-activate-callback item 'activate function object after)) + (defmethod initialize-instance ((item radio-menu-item) &key group) (prog1 (call-next-method) @@ -880,22 +1062,14 @@ (defbinding %radio-tool-button-set-group () nil (radio-tool-button radio-tool-button) (group pointer)) +(defmethod activate-radio-widget ((button radio-tool-button)) + (signal-emit button 'clicked)) + (defmethod add-to-radio-group ((button1 radio-tool-button) (button2 radio-tool-button)) "Add BUTTON1 to the group which BUTTON2 belongs to." (%radio-tool-button-set-group button1 (%radio-tool-button-get-group button2))) - -(defmethod add-activate-callback ((widget widget) function &key object after) - (if object - (signal-connect widget 'clicked - #'(lambda (object) - (when (slot-value widget 'active) - (funcall function object (slot-value widget 'value)))) - :object object :after after) - (signal-connect widget 'clicked - #'(lambda () - (when (slot-value widget 'active) - (funcall function (slot-value widget 'value)))) - :after after))) +(defmethod add-activate-callback ((button radio-tool-button) function &key object after) + (%add-activate-callback button 'clicked function object after)) (defmethod initialize-instance ((button radio-tool-button) &key group) (prog1 @@ -1196,12 +1370,12 @@ (defbinding scrolled-window-add-with-viewport () nil (scrolled-window scrolled-window) (child widget)) -(defmethod initialize-instance ((window scrolled-window) &rest initargs - &key policy) - (if policy - (apply #'call-next-method window - :vscrollbar-policy policy :hscrollbar-policy policy initargs) - (call-next-method))) +(defmethod shared-initialize ((window scrolled-window) names &key policy) + (declare (ignore names)) + (when policy + (setf (slot-value window 'hscrollbar-policy) policy) + (setf (slot-value window 'vscrollbar-policy) policy)) + (call-next-method)) ;;; Statusbar @@ -1746,7 +1920,7 @@ (defbinding editable-insert-text (editable text &optional (position 0)) nil (editable editable) (text string) ((length text) int) - (position position-type :in-out)) + (position position :in-out)) (defun editable-append-text (editable text) (editable-insert-text editable text nil)) @@ -1808,10 +1982,16 @@ (defbinding spin-button-get-range () nil (defun spin-button-value-as-int (spin-button) (round (spin-button-value spin-button))) -(defbinding spin-button-spin () nil +(defbinding %spin-button-spin () nil (spin-button spin-button) (direction spin-type) - (increment single-float)) + (increment double-float)) + +(defun spin-button-spin (spin-button value) + (etypecase value + (real (%spin-button-spin spin-button :spin-user-defined value)) + (spin-type (%spin-button-spin spin-button value 0)))) + (defbinding spin-button-update () nil (spin-button spin-button)) @@ -1986,84 +2166,3 @@ (defbinding rc-reparse-all () nil) (defbinding rc-get-style () style (widget widget)) - - - -;;; Accelerator Groups -#| -(defbinding accel-group-activate (accel-group key modifiers) boolean - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type)) - -(defbinding accel-groups-activate (object key modifiers) boolean - (object object) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type)) - -(defbinding accel-group-attach () nil - (accel-group accel-group) - (object object)) - -(defbinding accel-group-detach () nil - (accel-group accel-group) - (object object)) - -(defbinding accel-group-lock () nil - (accel-group accel-group)) - -(defbinding accel-group-unlock () nil - (accel-group accel-group)) - - -;;; Accelerator Groups Entries - -(defbinding accel-group-get-entry (accel-group key modifiers) accel-entry - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type)) - -(defbinding accel-group-lock-entry (accel-group key modifiers) nil - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type)) - -(defbinding accel-group-unlock-entry (accel-group key modifiers) nil - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type)) - -(defbinding accel-group-add - (accel-group key modifiers flags object signal) nil - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type) - (flags accel-flags) - (object object) - ((name-to-string signal) string)) - -(defbinding accel-group-add (accel-group key modifiers object) nil - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type) - (object object)) - - -;;; Accelerator Signals - -(defbinding accel-group-handle-add - (object signal-id accel-group key modifiers flags) nil - (object object) - (signal-id unsigned-int) - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type) - (flags accel-flags)) - -(defbinding accel-group-handle-remove - (object accel-group key modifiers) nil - (object object) - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type)) -|#