[cells-gtk-cvs] CVS update: root/cells-gtk/textview.lisp

[Peter Denno]

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp.net:/tmp/cvs-serv7557/cells-gtk

Modified Files:
	textview.lisp 
Log Message:
Implementation of populate-popup signal handling.
Date: Sat Feb 26 23:29:23 2005
Author: pdenno

Index: root/cells-gtk/textview.lisp
diff -u root/cells-gtk/textview.lisp:1.2 root/cells-gtk/textview.lisp:1.3
--- root/cells-gtk/textview.lisp:1.2	Sun Dec  5 07:33:23 2004
+++ root/cells-gtk/textview.lisp	Sat Feb 26 23:29:23 2005
@@ -30,7 +30,10 @@
 			      -1))
 
 (def-widget text-view ()
-  ((buffer :accessor buffer :initarg :buffer :initform (mk-text-buffer)))
+  ((buffer :accessor buffer :initarg :buffer :initform (mk-text-buffer))
+   (populate-popup :accessor populate-popup :initarg :populate-popup :initform (c-in nil))
+   (depopulate-popup :accessor depopulate-popup :initarg :depopulate-popup :initform (c-in nil))
+   (old-popups :cell nil :accessor old-popups :initform nil))
   ()
   ()
   :kids (c? (when (buffer self) (list (buffer self))))
@@ -40,3 +43,64 @@
 (def-c-output buffer ((self text-view))
   (when new-value
     (gtk-text-view-set-buffer (id self) (id (buffer self)))))
+
+;;; --------Populate-add -------------------------------------------------
+;;; Menu-items that are appended to the existing textview popup menu on 
+;;; the populate-popup signal. They are made fresh from populate-adds.
+
+(defclass populate-adds ()
+  ((label :initarg :label :initform nil)
+   (on-activate :initarg :on-activate :initform nil)
+   (owner :initarg :owner :initform nil)
+   (kids :initarg :kids :initform nil)))
+
+;;; Returns a list of populate-adds objects. These contain the :on-activate closures, 
+;;; but do not create the menu-item, which must be made each time they are needed, 
+;;; in the handler.
+(defmacro def-populate-adds (&body menu-items)
+  `(list 
+    ,@(loop for (type . args) in menu-items 
+           when (eql type :menu-item)
+           collect `(funcall #'make-instance 'populate-adds , at args))))
+
+(ff-defun-callable :cdecl :void text-view-populate-popup-handler
+  ((widget :pointer-void) (signal :pointer-void) (data :pointer-void))
+  (declare (ignorable signal data))
+  (let ((popup-menu (gtk-adds-text-view-popup-menu widget)))
+    (bwhen (text-view (gtk-object-find widget))
+      (bwhen (cb (callback-recover text-view :populate-popup))
+        (funcall cb popup-menu))))
+  1)
+
+(def-c-output populate-popup ((self text-view))
+  (when new-value
+      (callback-register self :populate-popup (populate-popup-closure (reverse new-value) self))
+      (gtk-signal-connect (id self) "populate-popup"
+                          (ffx:ff-register-callable 'text-view-populate-popup-handler))))
+
+(defun populate-popup-closure (p-adds text-view)
+  (let (accum)
+    (labels ((do-padds (p-add)
+               (let ((item (with-slots (label on-activate owner kids) p-add
+                             (mk-menu-item :label label :owner owner :on-activate on-activate
+                                           :kids (mapcar #'do-padds kids)))))
+                 (push item accum)
+                 item)))
+      #'(lambda (popup-menu)
+          (loop for old in (old-popups text-view) do 
+               (bwhen (sub (submenu old)) 
+                 (gtk-object-forget (id sub) sub))
+               (gtk-object-forget (id old) old))
+          (let ((tops (mapcar #'do-padds p-adds)))
+            (setf (old-popups text-view) accum)
+            (mapc #'(lambda (i) (to-be i) (gtk-menu-shell-prepend popup-menu (id i))) tops))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(def-populate-adds populate-adds)))
+
+
+
+
+
+
+