source: release/1.10/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/lisp-doc-controller.lisp

Last change on this file was 16203, checked in by R. Matthew Emerson, 10 years ago

Merge from trunk (see r16202 in particular)
File size: 21.1 KB
RevLine 
[13390]1;; lisp-doc-controller.lisp
2
3#|
4The MIT license.
5
6Copyright (c) 2010 Paul L. Krueger
7
8Permission is hereby granted, free of charge, to any person obtaining a copy of this software
9and associated documentation files (the "Software"), to deal in the Software without restriction,
10including without limitation the rights to use, copy, modify, merge, publish, distribute,
11sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
12furnished to do so, subject to the following conditions:
13
14The above copyright notice and this permission notice shall be included in all copies or substantial
15portions of the Software.
16
17THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
18LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
19IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
20WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23|#
24
[13631]25(eval-when (:compile-toplevel :load-toplevel :execute)
[15808]26 (require :iu-classes)
[14585]27 (require :menu-utils)
28 (require :selector-utils)
29 (require :nslog-utils)
30 (require :lisp-bundle)
31 (require :lisp-document)
32 (require :lisp-app-delegate)
33 (require :doc-controller-hash)
34 (require :nib))
[13390]35
36(in-package :iu)
37
38;; lisp-doc-controller class
39;; This class does some of the same things that the shared NSDocumentController instance
40;; does for stand-alone application programs. We use it so that we don't have to mess
[15808]41;; with CCL's existing interfaces to or its NSApplication delegate objects. We will
[13390]42;; create specific menu-items that target an instance of this class to create new documents
43;; of a specified type that the CCL IDE knows nothing about. We will tell the shared
44;; NSDocumentController about our documents so that it can manage things like saving and
45;; closing them. This class will also handle opening files of a specified type.
46;; The creator of one of these objects can also specify a name to use for inserting
[14585]47;; "New <doc-type>" and "Open <doc-type>" menuitems which will target this instance.
[13390]48
[15808]49;; The class also has functionality that permits a developer to create a main-menu
50;; creation function and execute it within a CCL IDE environment. This would be done by
51;; invoking the "Load App Under IDE" command from the "Dev" menu.
[14585]52;; If the user also specifies a delegate class that is connected to the File Owner's delegate
[15808]53;; outlet, then any menu commands that are targeted to the File Owner will be passed
[14585]54;; to the delegate object, just as they would be passed by an NSApplication instance to its delegate
55;; in a stand-alone application. If there is no delegate specified or if the delegate cannot handle
56;; a message, then it is redirected to the IDE's application instance (i.e. the value of $&NSApp).
57
[15808]58#|
[13390]59(defclass lisp-doc-controller (ns:ns-object)
[15808]60 ((document-class :accessor document-class
61 :initform nil)
62 (doc-type-name :accessor doc-type-name
63 :initform nil)
64 (saved-menu-key :accessor saved-menu-key
65 :initform nil)
66 (file-ext :accessor file-ext
67 :initform nil)
68 (doc-ctrlr :accessor doc-ctrlr
69 :initform nil)
70 (ldc-open-pnl :accessor ldc-open-pnl
71 :initform nil)
72 (type-ns-str :accessor type-ns-str
73 :initform nil)
74 (ext-ns-str :accessor ext-ns-str
75 :initform nil)
76 (documents :accessor documents
77 :initform nil)
78 (installed-menuitems :accessor installed-menuitems
79 :initform nil)
80 (bundle-objects :accessor bundle-objects
81 :initform nil)
82 (delegate-class :accessor delegate-class
83 :initform nil)
84 (delegate :accessor delegate
85 :foreign-type :id))
[13390]86 (:metaclass ns:+ns-object))
[15808]87|#
[13390]88
[14585]89(let ((dc-hash (make-hash-table :test #'eql))
90 (doc-type-dc-hash (make-hash-table :test #'equal)))
[13390]91
[14585]92 (defmethod initialize-doc-controller ((self lisp-doc-controller)
93 &key
94 (doc-class nil)
95 (delegate-class nil)
96 (doc-type nil)
97 (file-ext nil)
98 (app-bundle nil))
99 (let ((starting-main-menu (#/mainMenu #&NSApp)))
100 (save-main-menu) ;; save the current main menu for future menu swapping
101 (setf (document-class self) doc-class)
102 (setf (delegate-class self) delegate-class)
103 (setf (doc-type-name self) doc-type)
104 (setf (gethash doc-type doc-type-dc-hash) self)
105 (setf (file-ext self) file-ext)
106 (setf (doc-ctrlr self) (#/sharedDocumentController ns:ns-document-controller))
[14828]107 (setf (ldc-open-pnl self) (#/retain (make-instance ns:ns-open-panel)))
[14585]108 (setf (ext-ns-str self) (when file-ext (ccl::%make-nsstring file-ext)))
109 (when (ext-ns-str self)
110 (#/setAllowedFileTypes: (ldc-open-pnl self)
111 (#/arrayWithObject: ns:ns-array (ext-ns-str self))))
112 (when app-bundle
[15808]113 ;; load the main nib from the bundle with this object as the "owner" of the nib OR
114 ;; run the app-init function specified in the info.plist
[14585]115 (let* ((dict (#/infoDictionary app-bundle))
116 (nib-name (if (not (eql (%null-ptr) dict))
[15808]117 (#/objectForKey: dict #@"NSMainNibFile")))
118 (main-func-name (if (not (eql (%null-ptr) dict))
119 (#/objectForKey: dict #@"CLMainFunc")))
120 (lisp-func-name (unless (eql main-func-name (%null-ptr))
121 (coerce-obj main-func-name 'string))))
122 (cond ((non-empty-string lisp-func-name)
123 (funcall (read-from-string lisp-func-name) self)
124 (#/awakeFromNib self))
125 ((and nib-name (not (eql nib-name (%null-ptr))))
126 ;; load the nib
127 (setf (bundle-objects self)
128 (load-nibfile nib-name
129 :nib-owner self
130 :retain-top-objs t
131 :bundle app-bundle))
132 (#/awakeFromNib self))
133 (t
134 ;; if there isn't a valid nib or main-func process, make sure there
135 ;; is a menu-name so that we create some default menu-items.
136 (if (and (null doc-type) doc-class)
137 (setf doc-type (symbol-name (class-name doc-class))))))
138 (let ((mm (#/mainMenu #&NSApp)))
139 (unless (eql mm starting-main-menu)
140 ;; loading the nib or running a main-func resulted in a new main menu,
141 ;; so capture it
142 (save-main-menu)
143 (setf (saved-menu-key self) mm)
144 (set-app-menu mm) ;; only 1 app main menu permitted at a time
145 (setf (gethash mm dc-hash) self)))))
[14585]146 (when (and doc-type (eql (#/mainMenu #&NSApp) starting-main-menu))
[15808]147 ;; Use the document type to create some additional menus if loading the bundle
148 ;; didn't already result in a new main menu.
[14585]149 (setf (type-ns-str self) (ccl::%make-nsstring doc-type))
150 (push (make-and-install-menuitems-after "File" "New"
151 (list (concatenate 'string "New " doc-type)
152 "newDocument"
153 nil
154 self))
155 (installed-menuitems self))
156 (push (make-and-install-menuitems-after "File" "Open..."
157 (list (concatenate 'string "Open " doc-type "...")
158 "openDocument"
159 nil
160 self))
161 (installed-menuitems self))
162 (push (make-and-install-menuitems-after "File" "Print..."
163 (list (concatenate 'string "Print " doc-type "...")
164 "printDocument:"
165 nil
166 self))
167 (installed-menuitems self)))))
[13390]168
[14585]169 (defun doc-controller-for-menu-item (menu-item)
170 (gethash (key-for-menuitem menu-item) dc-hash nil))
171
172 (defun doc-controller-for-doc-type (doc-type-str)
173 (gethash doc-type-str doc-type-dc-hash nil))
174
[16203]175 (defun controlled-doc-types ()
176 (let ((types nil))
177 (maphash #'(lambda (k v)
178 (declare (ignore v))
179 (push k types))
180 doc-type-dc-hash)
181 types))
182
[14585]183)
184
185(defun docs-of-type (doc-type-str)
186 (let ((dc (doc-controller-for-doc-type doc-type-str)))
187 (when dc
188 (open-documents dc))))
189
190;; Methods to create a doc-controller specific to a specified class
191;; This is called when the document is to be managed under the CCL IDE
192
193(defun make-doc-controller (doc-class-name delegate-class-name doc-type-string file-ext-string &optional (bundle-path nil))
[15808]194 (on-main-thread
195 (let ((cn (ensure-class-name doc-class-name))
196 (dcn (and delegate-class-name
197 (non-empty-string delegate-class-name)
198 (ensure-class-name delegate-class-name)))
199 (bundle (and bundle-path (lisp-bundle-with-path bundle-path)))
200 (ldc (make-instance 'lisp-doc-controller)))
201 (when bundle
202 ;; Required so that we can later find the correct bundle for the document class
203 ;; which in turn is needed when loading the nib for some document window
204 (load-bundle bundle))
205 (initialize-doc-controller ldc
206 :doc-class (or (find-class cn nil) (find-class 'lisp-document))
207 :delegate-class (and dcn (find-class dcn nil))
208 :doc-type doc-type-string
209 :file-ext file-ext-string
210 :app-bundle bundle)
211 (set-doc-controller-for-class cn ldc))))
[14585]212
213(defmethod open-documents ((self lisp-doc-controller))
214 ;; If objects in our documents slot have a reference count of 1, then
215 ;; they are no longer also owned by the shared-document-controller and
216 ;; must have been closed. We return what's left.
217 (setf (documents self)
218 (mapcan #'(lambda (doc)
219 (unless (eql (#_CFGetRetainCount doc) 1)
220 (list doc)))
221 (documents self))))
222
223(defmethod close-document ((self lisp-doc-controller) doc)
224 (when (find doc (open-documents self) :test #'eql)
225 (setf (documents self) (delete doc (documents self) :test #'eql))
[15808]226 (#/close doc)
227 (#/release doc)))
[14585]228
229(defmethod close-open-documents ((self lisp-doc-controller))
230 (dolist (doc (open-documents self))
231 (close-document self doc)))
232
[15808]233(defmethod watch-document ((self lisp-doc-controller) doc)
234 (#/addObserver:selector:name:object:
235 (#/defaultCenter ns:ns-notification-center)
236 self
237 (ccl::@selector "lispDocumentDidClose:")
238 (coerce-obj "LispDocumentDidClose" 'ns:ns-string)
239 doc))
240
241(objc:defmethod (#/lispDocumentDidClose: :void)
242 ((self lisp-doc-controller) (notif :id))
243 ;; remove doc from the list of documents
244 (let ((doc (#/object notif)))
245 (when (find doc (open-documents self) :test #'eql)
246 (#/release doc)
247 (setf (documents self) (delete doc (documents self) :test #'eql)))))
248
[14585]249(objc:defmethod (#/delegate :id)
[13390]250 ((self lisp-doc-controller))
[14585]251 (delegate self))
[13390]252
[14585]253(objc:defmethod (#/setDelegate: :void)
254 ((self lisp-doc-controller) (del :id))
255 (setf (delegate self) del))
256
257(objc:defmethod (#/dealloc :void)
[13390]258 ((self lisp-doc-controller))
[14585]259 ;; make sure that any menu items for docs of this type are removed.
260 (when (#/isRunning #$NSApp)
261 (add-to-main-menu (starting-menu) 0)
262 (delete-menu (saved-menu-key self))
[15808]263 (set-app-menu nil)
[14585]264 (setf (saved-menu-key self) nil) ;; just a precaution
265 (dolist (im (installed-menuitems self))
266 (remove-menuitems im))
267 (when (type-ns-str self)
268 (#/release (type-ns-str self)))
269 (when (ext-ns-str self)
270 (#/release (ext-ns-str self)))
271 (when (ldc-open-pnl self)
272 (#/release (ldc-open-pnl self)))
273 (dolist (obj (bundle-objects self))
274 (unless (typep obj 'ns:ns-menu)
275 (#/release obj)))
276 (dolist (doc (documents self))
277 ;; open documents should have been retained by the shared-document-controller
278 ;; so we can release them here without harm
[15808]279 (#/release doc))
280 (call-next-method)
281 (objc:remove-lisp-slots self)))
[14585]282
283(objc:defmethod (#/newDocument :void)
284 ((self lisp-doc-controller))
[15808]285 (when (document-class self)
286 (let ((new-doc (#/initWithType:error: (#/alloc (document-class self))
287 (lisp-to-temp-nsstring (doc-type-name self))
288 (%null-ptr))))
289 (when (obj-if-not-null new-doc)
290 (push new-doc (documents self))
291 (watch-document self new-doc)
292 ;; register the document with the shared controller so that things like
293 ;; "save" and "close" will work properly
294 (#/addDocument: (doc-ctrlr self) new-doc)
295 (#/makeWindowControllers new-doc)
296 (#/showWindows new-doc)))))
[14585]297
298(objc:defmethod (#/openDocument :void)
299 ((self lisp-doc-controller))
[15808]300 (when (document-class self)
301 (let ((result (#/runModal (ldc-open-pnl self))))
302 (when (eql result #$NSOKButton)
303 (let ((urls (#/URLs (ldc-open-pnl self))))
304 (dotimes (i (#/count urls))
305 (let ((doc (#/alloc (document-class self))))
306 (setf doc (#/initWithContentsOfURL:ofType:error:
307 doc
308 (#/objectAtIndex: urls i)
309 (lisp-to-temp-nsstring (doc-type-name self))
310 (%null-ptr)))
311 (if doc
312 (progn
313 (pushnew doc (documents self))
314 (watch-document self doc)
315 (#/addDocument: (doc-ctrlr self) doc)
316 (#/makeWindowControllers doc)
317 (#/showWindows doc))
318 (#_NSRunAlertPanel #@"ALERT"
319 #@"Could not open specified file ... ignoring it."
320 #@"OK"
321 (%null-ptr)
322 (%null-ptr))))))))))
323
[14585]324(objc:defmethod (#/validateMenuItem: #>BOOL)
325 ((self lisp-doc-controller) (item :id))
326 (let* ((action (#/action item))
[15808]327 (top-win (#/keyWindow #&NSApp))
328 (top-doc (and top-win
329 (#/document top-win))))
330 (cond ((eql action (ccl::@selector "printDocument:"))
331 (if (and top-doc (not (%null-ptr-p top-doc)) (eq (class-of top-doc) (document-class self)))
332 #$YES
333 #$NO))
334 ((or (eql action (ccl::@selector "openDocument:"))
335 (eql action (ccl::@selector "newDocument:")))
336 (if (document-class self)
337 #$YES
338 #$NO))
339 (t
340 (call-next-method item)))))
[14585]341
342(objc:defmethod (#/printDocument: :void)
343 ((self lisp-doc-controller) (sender :id))
344 ;; This gets printDocument messages that are directed here instead of to the first responder
345 ;; in order to avoid causing problems for CCL documents that don't implement everything needed
346 ;; to make this work.
347 ;; We just redirect back to the top document since we know if the menuitem was enabled
348 ;; that the top window must have been of the correct type.
349 (let ((top-doc (#/objectAtIndex: (#/orderedDocuments #&NSApp) 0)))
350 (#/printDocument: top-doc sender)))
351
352(objc:defmethod (#/awakeFromNib :void)
353 ((self lisp-doc-controller))
354 ;; called after we have loaded the nib for some application being loaded under the IDE
355 ;; First save off the main menu. If it was replaced by virtue of loading the NIB then
356 ;; we will now have both the original and new versions available for menu swapping.
357 (save-main-menu)
358 (when (and (eql (%null-ptr) (delegate self)) (delegate-class self))
359 ;; set our delegate to an instance of the specified class
360 (setf (delegate self) (make-instance (delegate-class self))))
361 (when (and (not (eql (%null-ptr) (delegate self)))
362 (#/respondsToSelector: (delegate self) (ccl::@selector "applicationWillFinishLaunching:")))
363 (#/applicationWillFinishLaunching: (delegate self)
364 (#/notificationWithName:object:
365 ns:ns-notification
366 #&NSApplicationWillFinishLaunchingNotification
367 self))))
368
369(objc:defmethod (#/methodSignatureForSelector: :id)
370 ((self lisp-doc-controller) (sel #>SEL))
371 (cond ((and (not (eql (%null-ptr) (delegate self)))
372 (#/respondsToSelector: (delegate self) sel))
373 (#/methodSignatureForSelector: (delegate self) sel))
374 ((#/respondsToSelector: #&NSApp sel)
375 (#/methodSignatureForSelector: #&NSApp sel))
376 (t
377 ;; shouldn't ever happen
378 (%null-ptr))))
379
380(objc:defmethod (#/forwardInvocation: :void)
381 ((self lisp-doc-controller) (inv :id))
382 (let ((sel (#/selector inv)))
383 (cond ((and (not (eql (%null-ptr) (delegate self)))
384 (#/respondsToSelector: (delegate self) sel))
385 ;;(ns-log (format nil "Forwarding ~s to ~s" (find-selector-match sel) (delegate self)))
386 (#/invokeWithTarget: inv (delegate self)))
387 ((#/respondsToSelector: #&NSApp sel)
388 ;; (ns-log (format nil "Forwarding ~s to ~s" (find-selector-match sel) #&NSApp))
389 (#/invokeWithTarget: inv #&NSApp))
390 (t
391 (#/doesNotRecognizeSelector: self sel)))))
392
393(objc:defmethod (#/forwardingTargetForSelector: :id)
394 ((self lisp-doc-controller) (sel #>SEL))
395 (cond ((and (not (eql (%null-ptr) (delegate self)))
396 (#/respondsToSelector: (delegate self) sel))
397 (delegate self))
398 ((#/respondsToSelector: #&NSApp sel)
399 #&NSApp)
400 ((#/respondsToSelector: (doc-ctrlr self) sel)
401 (doc-ctrlr self))
402 (t
403 (call-next-method sel))))
404
405(objc:defmethod (#/respondsToSelector: #>BOOL)
406 ((self lisp-doc-controller) (sel #>SEL))
407 ;; since we're going to forward anything we don't understand to the NSApp
408 ;; we can say that we respond to everything that it does.
409 (if (or (call-next-method sel)
410 (#/respondsToSelector: #$NSApp sel)
[15808]411 (and (not (eql (%null-ptr) (delegate self)))
412 (#/respondsToSelector: (delegate self) sel))
[14585]413 (member sel
414 (list (ccl::@selector "newDocument")
415 (ccl::@selector "openDocument")
416 (ccl::@selector "awakeFromNib"))
417 :test #'eql))
418 #$YES
419 #$NO))
420
421;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
422;; Additional method for lisp-documents used only when running them
423;; under the IDE. (which is why it is declared in this file).
424;; Overrides the method declared in lisp-document.lisp.
425
426(objc:defmethod (#/prepareSavePanel: #>BOOL)
427 ((self lisp-document) (panel :id))
428 (let* ((dc (doc-controller-for-class (class-name (class-of self))))
429 (typ (and dc (ext-ns-str dc))))
430 (when (obj-if-not-null typ)
431 (#/setRequiredFileType: panel typ)))
432 #$YES)
433
434;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
435;; Modifications to CCL functionality to permit loading apps under the CCL IDE
436
437;; Since
438;; 1. #/newDocument: and #/openDocument: are sent to the first responder, and
439;; 2. the Applications delegate is in the first responder chain before the
440;; sharedDocumentController, and
441;; 3. these methods are not already implemented in the default delegate for the CCL IDE,
442;; We can implement these as additional methods for the CCL IDE delegate and divert
443;; them to the appropriate lisp-doc-controller if needed.
444
445(objc:defmethod (#/newDocument: :void)
446 ((self gui::lisp-application-delegate) (sender :id))
447 ;; Check to see whether this came from one of our app menus. If so hand it to
448 ;; the lisp-doc-controller that handles that app. If not, hand it off to the
449 ;; sharedDocumentController, just as would have happened had we not intervened.
450 (let* ((dc (doc-controller-for-menu-item sender)))
451 (if dc
452 (#/newDocument dc)
453 (#/newDocument: (#/sharedDocumentController ns:ns-document-controller) sender))))
454
455(objc:defmethod (#/openDocument: :void)
456 ((self gui::lisp-application-delegate) (sender :id))
457 ;; Check to see whether this came from one of our app menus. If so hand it to
458 ;; the lisp-doc-controller that handles that app. If not, hand it off to the
459 ;; sharedDocumentController, just as would have happened had we not intervened.
460 (let ((dc (doc-controller-for-menu-item sender)))
461 (if dc
462 (#/openDocument dc)
463 (#/openDocument: (#/sharedDocumentController ns:ns-document-controller) sender))))
464
[13390]465(provide :lisp-doc-controller)
Note: See TracBrowser for help on using the repository browser.