[mcclim-cvs] CVS mcclim

[tmoore]

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