[clg] / gtk / gtkaction.lisp

;; Common Lisp bindings for GTK+ v2.x
;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net>
;;
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;; $Id: gtkaction.lisp,v 1.12 2008-03-10 18:51:13 espen Exp $


(in-package "GTK")

;;; Action

(defmethod initialize-instance ((action action) &key callback)
  (call-next-method)
  (when callback
    (apply #'signal-connect action 'activate (mklist callback))))

(defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean
  (action action))

(defbinding (action-is-visible-p "gtk_action_is_visible") () boolean
  (action action))

(defbinding action-activate () nil
  (action action))


;;; Action Group

(defmethod initialize-instance ((action-group action-group) &rest initargs 
				&key action actions)
  (declare (ignore action actions))
  (prog1
      (call-next-method)
    (initial-add action-group #'action-group-add-action
     initargs :action :actions)))

(defbinding action-group-get-action () action
  (action-group action-group)
  (name string))

(defbinding action-group-list-actions () (glist action)
  (action-group action-group))

(defbinding %action-group-add-action () nil
  (action-group action-group)
  (action action))

(defbinding %action-group-add-action-with-accel () nil
  (action-group action-group)
  (action action)
  (accelerator (or null string)))

(defun action-group-add-action (action-group action)
  (if (slot-boundp action 'accelerator)
      (%action-group-add-action-with-accel action-group action (action-accelerator action))
    (%action-group-add-action action-group action)))

(defbinding action-group-remove-action () nil
  (action-group action-group)
  (action action))


;;; Radio Action

(defmethod initialize-instance ((action radio-action) &key group)
  (call-next-method)
  (setf (slot-value action 'self) (pointer-address (foreign-location action)))
  (when group
    (add-to-radio-group action group)))

(defbinding %radio-action-get-group () pointer
  (radio-action radio-action))

(defbinding %radio-action-set-group () nil
  (radio-button radio-button)
  (group pointer))

(defmethod add-to-radio-group ((action1 radio-action) (action2 radio-action))
  "Add ACTION1 to the group which ACTION2 belongs to."
  (%radio-action-set-group action1 (%radio-action-get-group action2)))

(defmethod activate-radio-widget ((action radio-action))
  (action-activate action))

(defmethod add-activate-callback ((action radio-action) function &key object after)
  (%add-activate-callback action 'activate function object after))

(defbinding (radio-action-get-current "gtk_radio_action_get_current_value") 
    () radio-action
  "Returns the current active radio action in the group the give radio action belongs to."
  (radio-action radio-action))

(defun radio-action-get-current-value (action)
  (radio-action-value (radio-action-get-current action)))


;;; Toggle Action

(defmethod initialize-instance ((action toggle-action) &rest initargs &key callback #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")active)
  (remf initargs :callback)
  (apply #'call-next-method action initargs)
  (when callback
    (destructuring-bind (function &key object after) (mklist callback)
      (signal-connect action 'activate
       (if object 
	   #'(lambda (object)
	       (funcall function object (toggle-action-active-p action)))
	 #'(lambda ()
	     (funcall function (toggle-action-active-p action))))
       :object object :after after)))
  #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
  (when active
    (action-activate action)))

(defbinding toggle-action-toggled () nil
  (toggle-action toggle-action))


;;; UI Manager

(defmethod initialize-instance ((ui-manager ui-manager) &rest initargs 
				&key ui action-group)
  (declare (ignore ui action-group))
  (call-next-method)
  (mapc #'(lambda (action-group)
	    (ui-manager-insert-action-group ui-manager action-group))
	(get-all initargs :action-group))
  (mapc #'(lambda (ui)
	    (ui-manager-add-ui ui-manager ui))
	(get-all initargs :ui)))


(defbinding ui-manager-insert-action-group 
    (ui-manager action-group &optional (pos :end)) nil
  (ui-manager ui-manager)
  (action-group action-group)
  ((case pos
     (:first 0)
     (:end -1)
     (t pos)) int))

(defbinding ui-manager-remove-action-group () nil
  (ui-manager ui-manager)
  (action-group action-group))

(defbinding ui-manager-get-widget () widget
  (ui-manager ui-manager)
  (path string))

(defbinding ui-manager-get-toplevels () (glist widget)
  (ui-manager ui-manager)
  (types ui-manager-item-type))

(defbinding ui-manager-get-action () action
  (ui-manager ui-manager)
  (path string))

(defbinding %ui-manager-add-ui-from-string (ui-manager ui) int
  (ui-manager ui-manager)
  (ui string)
  ((length ui) int)
  (gerror gerror-signal :out))

(defgeneric ui-manager-add-ui (ui-manager ui-spec))

(defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string))
  (%ui-manager-add-ui-from-string ui-manager ui-spec))

(defbinding %ui-manager-add-ui-from-file () int
  (ui-manager ui-manager)
  (filename pathname)
  (gerror gerror-signal :out))

(defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname))
  (%ui-manager-add-ui-from-file ui-manager path))

(defbinding %ui-manager-new-merge-id () unsigned-int
  (ui-manager ui-manager))

(defbinding %ui-manager-add-ui () nil
  (ui-manager ui-manager)
  (merge-id unsigned-int)
  (path string)
  (name string)
  (action (or null string))
  (type ui-manager-item-type)
  (top boolean))

(defvar *valid-ui-elements*
  '((:ui :menubar :toolbar :popup :accelerator)
    (:menubar :menuitem :separator :placeholder :menu)
    (:menu :menuitem :separator :placeholder :menu)
    (:popup :menuitem :separator :placeholder :menu)
    (:toolbar :toolitem :separator :placeholder)
    (:placeholder :menuitem :toolitem :separator :placeholder :menu)
    (:menuitem)
    (:toolitem)
    (:separator)
    (:accelerator)))

(defvar *anonymous-element-counter* 0)
(internal *anonymous-element-counter*)

(defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list))
  (let ((id (%ui-manager-new-merge-id ui-manager)))
    (labels 
	((parse-ui-spec (path ui-spec element)
	   (loop
	    for definition in ui-spec
	    do (destructuring-bind (type &optional name &rest rest)
		   (mklist definition)
		 (cond
		  ((not (find type (cdr (assoc element *valid-ui-elements*))))
		   (ui-manager-remove-ui ui-manager id)
		   (error "~S not valid subelement in ~S" type element))
		  ((multiple-value-bind (action children)
		       (if (and rest (atom (first rest)) 
				(not (keywordp (first rest))))
			   (values (first rest) (rest rest))
			 (values name rest))
		     (%ui-manager-add-ui ui-manager 
		      id (or path "/") 
		      (or name (format nil "~A~D" 
			        (string-capitalize type) 
				(incf *anonymous-element-counter*)))
		      action type nil)
		     (when children
		       (parse-ui-spec (concatenate 'string path "/" name) 
				      children type)))))))))
      (parse-ui-spec nil ui-spec :ui))
    id))

(defbinding ui-manager-remove-ui () nil
  (ui-manager ui-manager)
  (merge-id unsigned-int))
  
(defbinding ui-manager-get-ui () string
  (ui-manager ui-manager))

(defbinding ui-manager-ensure-update () nil
  (ui-manager ui-manager))
Commit	Line	Data
112ac1d3	1	;; Common Lisp bindings for GTK+ v2.x
112ac1d3	2	;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net>
d9a443c9	3	;;
112ac1d3	4	;; Permission is hereby granted, free of charge, to any person obtaining
	5	;; a copy of this software and associated documentation files (the
	6	;; "Software"), to deal in the Software without restriction, including
	7	;; without limitation the rights to use, copy, modify, merge, publish,
	8	;; distribute, sublicense, and/or sell copies of the Software, and to
	9	;; permit persons to whom the Software is furnished to do so, subject to
	10	;; the following conditions:
d9a443c9	11	;;
112ac1d3	12	;; The above copyright notice and this permission notice shall be
112ac1d3	13	;; included in all copies or substantial portions of the Software.
d9a443c9	14	;;
112ac1d3	15	;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
	16	;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
	17	;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
	18	;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
	19	;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
	20	;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
	21	;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
d9a443c9	22
37e1312a	23	;; $Id: gtkaction.lisp,v 1.12 2008-03-10 18:51:13 espen Exp $
d9a443c9	24
	25
	26	(in-package "GTK")
	27
	28	;;; Action
	29
a5522de5	30	(defmethod initialize-instance ((action action) &key callback)
d9a443c9	31	(call-next-method)
a5522de5	32	(when callback
a5522de5	33	(apply #'signal-connect action 'activate (mklist callback))))
d9a443c9	34
d9a443c9	35	(defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean
	36	(action action))
	37
	38	(defbinding (action-is-visible-p "gtk_action_is_visible") () boolean
	39	(action action))
	40
	41	(defbinding action-activate () nil
	42	(action action))
	43
	44
	45	;;; Action Group
	46
	47	(defmethod initialize-instance ((action-group action-group) &rest initargs
	48	&key action actions)
	49	(declare (ignore action actions))
13955a62	50	(prog1
13955a62	51	(call-next-method)
a5522de5	52	(initial-add action-group #'action-group-add-action
13955a62	53	initargs :action :actions)))
d9a443c9	54
	55	(defbinding action-group-get-action () action
	56	(action-group action-group)
	57	(name string))
	58
	59	(defbinding action-group-list-actions () (glist action)
	60	(action-group action-group))
	61
	62	(defbinding %action-group-add-action () nil
	63	(action-group action-group)
	64	(action action))
	65
	66	(defbinding %action-group-add-action-with-accel () nil
	67	(action-group action-group)
	68	(action action)
	69	(accelerator (or null string)))
	70
	71	(defun action-group-add-action (action-group action)
a5522de5	72	(if (slot-boundp action 'accelerator)
	73	(%action-group-add-action-with-accel action-group action (action-accelerator action))
	74	(%action-group-add-action action-group action)))
d9a443c9	75
	76	(defbinding action-group-remove-action () nil
	77	(action-group action-group)
	78	(action action))
	79
	80
	81	;;; Radio Action
	82
a5522de5	83	(defmethod initialize-instance ((action radio-action) &key group)
d9a443c9	84	(call-next-method)
8ab0db90	85	(setf (slot-value action 'self) (pointer-address (foreign-location action)))
d9a443c9	86	(when group
a5522de5	87	(add-to-radio-group action group)))
d9a443c9	88
	89	(defbinding %radio-action-get-group () pointer
	90	(radio-action radio-action))
	91
	92	(defbinding %radio-action-set-group () nil
	93	(radio-button radio-button)
	94	(group pointer))
	95
a5522de5	96	(defmethod add-to-radio-group ((action1 radio-action) (action2 radio-action))
d9a443c9	97	"Add ACTION1 to the group which ACTION2 belongs to."
	98	(%radio-action-set-group action1 (%radio-action-get-group action2)))
	99
a5522de5	100	(defmethod activate-radio-widget ((action radio-action))
	101	(action-activate action))
	102
	103	(defmethod add-activate-callback ((action radio-action) function &key object after)
	104	(%add-activate-callback action 'activate function object after))
	105
d9a443c9	106	(defbinding (radio-action-get-current "gtk_radio_action_get_current_value")
d9a443c9	107	() radio-action
a5522de5	108	"Returns the current active radio action in the group the give radio action belongs to."
d9a443c9	109	(radio-action radio-action))
	110
	111	(defun radio-action-get-current-value (action)
8292a3d4	112	(radio-action-value (radio-action-get-current action)))
d9a443c9	113
	114
	115
	116	;;; Toggle Action
	117
4007604e	118	(defmethod initialize-instance ((action toggle-action) &rest initargs &key callback #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")active)
a5522de5	119	(remf initargs :callback)
	120	(apply #'call-next-method action initargs)
	121	(when callback
	122	(destructuring-bind (function &key object after) (mklist callback)
	123	(signal-connect action 'activate
	124	(if object
	125	#'(lambda (object)
	126	(funcall function object (toggle-action-active-p action)))
	127	#'(lambda ()
	128	(funcall function (toggle-action-active-p action))))
	129	:object object :after after)))
4007604e	130	#?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
0c9b7932	131	(when active
a5522de5	132	(action-activate action)))
a5522de5	133
d9a443c9	134	(defbinding toggle-action-toggled () nil
	135	(toggle-action toggle-action))
	136
	137
d9a443c9	138	;;; UI Manager
	139
	140	(defmethod initialize-instance ((ui-manager ui-manager) &rest initargs
	141	&key ui action-group)
	142	(declare (ignore ui action-group))
	143	(call-next-method)
	144	(mapc #'(lambda (action-group)
	145	(ui-manager-insert-action-group ui-manager action-group))
	146	(get-all initargs :action-group))
	147	(mapc #'(lambda (ui)
	148	(ui-manager-add-ui ui-manager ui))
	149	(get-all initargs :ui)))
	150
	151
	152	(defbinding ui-manager-insert-action-group
	153	(ui-manager action-group &optional (pos :end)) nil
	154	(ui-manager ui-manager)
	155	(action-group action-group)
	156	((case pos
	157	(:first 0)
	158	(:end -1)
	159	(t pos)) int))
	160
	161	(defbinding ui-manager-remove-action-group () nil
	162	(ui-manager ui-manager)
	163	(action-group action-group))
	164
	165	(defbinding ui-manager-get-widget () widget
	166	(ui-manager ui-manager)
	167	(path string))
	168
	169	(defbinding ui-manager-get-toplevels () (glist widget)
	170	(ui-manager ui-manager)
	171	(types ui-manager-item-type))
	172
	173	(defbinding ui-manager-get-action () action
	174	(ui-manager ui-manager)
	175	(path string))
	176
	177	(defbinding %ui-manager-add-ui-from-string (ui-manager ui) int
	178	(ui-manager ui-manager)
	179	(ui string)
	180	((length ui) int)
034ff042	181	(gerror gerror-signal :out))
	182
	183	(defgeneric ui-manager-add-ui (ui-manager ui-spec))
d9a443c9	184
d9a443c9	185	(defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string))
034ff042	186	(%ui-manager-add-ui-from-string ui-manager ui-spec))
d9a443c9	187
	188	(defbinding %ui-manager-add-ui-from-file () int
	189	(ui-manager ui-manager)
	190	(filename pathname)
034ff042	191	(gerror gerror-signal :out))
d9a443c9	192
d9a443c9	193	(defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname))
034ff042	194	(%ui-manager-add-ui-from-file ui-manager path))
d9a443c9	195
	196	(defbinding %ui-manager-new-merge-id () unsigned-int
	197	(ui-manager ui-manager))
	198
	199	(defbinding %ui-manager-add-ui () nil
	200	(ui-manager ui-manager)
	201	(merge-id unsigned-int)
	202	(path string)
	203	(name string)
	204	(action (or null string))
	205	(type ui-manager-item-type)
	206	(top boolean))
	207
	208	(defvar valid-ui-elements
	209	'((:ui :menubar :toolbar :popup :accelerator)
	210	(:menubar :menuitem :separator :placeholder :menu)
37e1312a	211	(:menu :menuitem :separator :placeholder :menu)
	212	(:popup :menuitem :separator :placeholder :menu)
	213	(:toolbar :toolitem :separator :placeholder)
d9a443c9	214	(:placeholder :menuitem :toolitem :separator :placeholder :menu)
	215	(:menuitem)
	216	(:toolitem)
	217	(:separator)
	218	(:accelerator)))
	219
a5522de5	220	(defvar anonymous-element-counter 0)
	221	(internal anonymous-element-counter)
	222
d9a443c9	223	(defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list))
	224	(let ((id (%ui-manager-new-merge-id ui-manager)))
	225	(labels
	226	((parse-ui-spec (path ui-spec element)
	227	(loop
	228	for definition in ui-spec
	229	do (destructuring-bind (type &optional name &rest rest)
	230	(mklist definition)
	231	(cond
	232	((not (find type (cdr (assoc element valid-ui-elements))))
	233	(ui-manager-remove-ui ui-manager id)
	234	(error "~S not valid subelement in ~S" type element))
	235	((multiple-value-bind (action children)
	236	(if (and rest (atom (first rest))
	237	(not (keywordp (first rest))))
	238	(values (first rest) (rest rest))
	239	(values name rest))
a5522de5	240	(%ui-manager-add-ui ui-manager
	241	id (or path "/")
	242	(or name (format nil "~A~D"
	243	(string-capitalize type)
	244	(incf anonymous-element-counter)))
	245	action type nil)
d9a443c9	246	(when children
	247	(parse-ui-spec (concatenate 'string path "/" name)
	248	children type)))))))))
	249	(parse-ui-spec nil ui-spec :ui))
	250	id))
	251
	252	(defbinding ui-manager-remove-ui () nil
	253	(ui-manager ui-manager)
	254	(merge-id unsigned-int))
	255
	256	(defbinding ui-manager-get-ui () string
	257	(ui-manager ui-manager))
	258
	259	(defbinding ui-manager-ensure-update () nil
	260	(ui-manager ui-manager))