Update of /project/mcclim/cvsroot/mcclim In directory common-lisp:/tmp/cvs-serv15419

Modified Files: frames.lisp package.lisp Log Message:

Implemented destroy-frame and map-over-frames.

Implemented find-application-frame from the Franz User Manual. CLIM Launcher folks might want to take a look at it.

--- /project/mcclim/cvsroot/mcclim/frames.lisp 2005/11/28 13:51:05 1.110 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/01/28 00:38:04 1.111 @@ -198,7 +198,7 @@ (user-supplied-geometry :initform nil :initarg :user-supplied-geometry :documentation "plist of defaulted :left, :top, :bottom, :right, :width and :height options.") - (process :reader frame-process :initform (current-process)) + (process :accessor frame-process :initform nil) (client-settings :accessor client-settings :initform nil)))

(defmethod frame-geometry ((frame application-frame)) @@ -465,10 +465,12 @@

(defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys) - (handler-case - (funcall (frame-top-level-lambda frame) frame) - (frame-exit () - nil))) + (letf (((frame-process frame) (current-process))) + (handler-case + (funcall (frame-top-level-lambda frame) frame) + (frame-exit () + nil)))) +

(defmethod run-frame-top-level :around ((frame application-frame) &key) (let ((*application-frame* frame) @@ -686,6 +688,7 @@

(defgeneric enable-frame (frame)) (defgeneric disable-frame (frame)) +(defgeneric destroy-frame (frame))

(defgeneric note-frame-enabled (frame-manager frame)) (defgeneric note-frame-disbled (frame-manager frame)) @@ -700,6 +703,11 @@ (setf (slot-value frame 'state) :disabled) (note-frame-disabled (frame-manager frame) frame))

+(defmethod destroy-frame ((frame application-frame)) + (when (eq (frame-state frame) :enabled) + (disable-frame frame)) + (disown-frame (frame-manager frame) frame)) + (defmethod note-frame-enabled ((fm frame-manager) frame) (declare (ignore frame)) t) @@ -708,6 +716,15 @@ (declare (ignore frame)) t)

+(defun map-over-frames (function &key port frame-manager) + (cond (frame-manager + (mapc function (frame-manager-frames frame-manager))) + (port + (loop for manager in (frame-managers port) + do (map-over-frames function :frame-manager manager))) + (t (loop for p in *all-ports* + do (map-over-frames function :port p))))) + (defvar *pane-realizer* nil)

(defmacro with-look-and-feel-realization ((frame-manager frame) &body body) @@ -929,6 +946,7 @@ (with-keywords-removed (options (:pretty-name :frame-manager :enable :state :left :top :right :bottom :width :height :save-under :frame-class)) + (declare (ignorable frame-class)) (let ((frame (apply #'make-instance frame-class :name frame-name :pretty-name pretty-name @@ -948,6 +966,39 @@ (warn ":state ~S not supported yet." state))) frame)))

+;;; From Franz Users Guide + +(defun find-application-frame (frame-name &rest initargs + &key (create t) (activate t) + (own-process *multiprocessing-p*) port + frame-manager frame-class + &allow-other-keys) + (let ((frame (unless (eq create :force) + (block + found-frame + (map-over-frames + #'(lambda (frame) + (when (eq (frame-name frame) frame-name) + (return-from found-frame frame))) + :port port + :frame-manager frame-manager))))) + (unless (or frame create) + (return-from find-application-frame nil)) + (unless frame + (with-keywords-removed (initargs (:create :activate :own-process)) + (setq frame (apply #'make-application-frame frame-name initargs)))) + (when (and frame activate) + (cond ((frame-process frame) + #-(and)(raise-frame frame)) ; not yet + (own-process + (clim-sys:make-process #'(lambda () + (run-frame-top-level frame)) + :name (format nil "~A" frame-name))) + (t (run-frame-top-level frame)))) + frame)) + + + ;;; Menu frame class

(defclass menu-frame () --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/01/11 08:30:55 1.51 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/01/28 00:38:04 1.52 @@ -691,6 +691,7 @@ #:extended-output-stream-p ;predicate #:filling-output ;macro #:find-applicable-translators ;function + #:find-application-frame ;function (in Franz User's Guide) #:find-cached-output-record ;generic function #:find-child-output-record ;generic function #:find-command-from-command-line-name ;function