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 ,@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))) + + + + + + +