source: release/1.10/cocoa-ide-contrib/krueger/InterfaceProjects/Cocoa Dev/lisp-app-doc.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: 57.7 KB
RevLine 
[14585]1;; lisp-app-doc.lisp
2
3#|
4The MIT license.
5
[15808]6Copyright (c) 2013 Paul L. Krueger
[14585]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
[15808]17THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,EXPRESS OR IMPLIED, INCLUDING BUT NOT
[14585]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
25(eval-when (:compile-toplevel :load-toplevel :execute)
[15808]26 (require :objc-initialize)
[14585]27 (require :ccl-additions-for-cocoa-tools)
[15808]28 ;;(require :builder-utilities)
29 (let* ((ccl:*default-file-character-encoding* :iso-8859-1))
30 (require :builder-utilities))
[14585]31 (require :file-monitor)
32 (require :lisp-controller)
33 (require :class-convert)
34 (require :ide-bundle)
35 (require :lisp-app-delegate)
36 (require :lisp-document)
37 (require :lisp-doc-controller)
38 (require :lisp-app-win-controller)
[15808]39 (require :custom-app-init)
[14585]40 (require :menu-utils)
41 (require :open-panel)
42 (require :utility)
[15808]43 (require :thread-safe-queue)
[14585]44 (require :alert)
45 (require :class-convert)
46 (require :interactive-app))
47
48(in-package :ad)
49
50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[15808]51;; Utility functions used here and called by interface objects
[14585]52
53(defvar *doc-role-strings* (list "Editor" "Viewer" "Shell" "None"))
54
55(defstatic *ccl-ide-proto-plist*
56 (probe-file "ccl:contrib;cocoa-ide;krueger;InterfaceProjects;Cocoa Dev;CCL IDE Add In Proto.plist"))
57
58(defun find-app-classes ()
[15808]59 (mapcar #'(lambda (cls)
60 (string-downcase (class-name-string cls)))
61 (cons ns:ns-application (recursive-map #'class-direct-subclasses ns:ns-application))))
[14585]62
[15808]63(defun find-app-delegate-classes ()
[14585]64 (let ((c1 (find-class 'gui::lisp-application-delegate nil))
65 (c2 (find-class 'simple-lisp-app-delegate nil)))
66 (nconc
[15808]67 (mapcar #'(lambda (cls)
68 (string-downcase (class-name-string cls)))
69 (cons c1 (recursive-map #'class-direct-subclasses c1)))
70 (mapcar #'(lambda (cls)
71 (string-downcase (class-name-string cls)))
72 (cons c2 (recursive-map #'class-direct-subclasses c2))))))
[14585]73
74(defun find-document-classes ()
[15808]75 (mapcar #'(lambda (cls)
76 (string-downcase (class-name-string cls)))
77 (cons ns:ns-document
78 (recursive-map #'class-direct-subclasses ns:ns-document))))
[14585]79
80(defun uti-extension (uti)
81 ;; a uti is in the form: com.<something>. ... .<extension> so we just extract the extension
82 (when uti
83 (let* ((str (string uti))
84 (last-dot-pos (position #\. str :test #'char= :from-end t)))
85 (subseq str (if last-dot-pos (1+ last-dot-pos) 0)))))
86
87(defun make-empty-adjustable-array ()
88 (make-array '(8) :adjustable t :fill-pointer 0))
89
90(defun string-first (str)
91 ;; returns first element of a string as a string
92 (if (stringp str)
93 (let ((sp-pos (position #\space str)))
94 (if sp-pos
95 (subseq str 0 sp-pos)
96 str))
97 ""))
98
99(defun array-to-string (arr)
100 ;; arr should be an array of strings
101 (format nil "~{~a~^ ~}" (coerce arr 'list)))
102
103(defun make-string-array (str)
104 ;; take a string that is a set of space-delimited items and
105 ;; turn it into an array of strings, where each string is
106 ;; formed from one of the items.
107 (do* ((st str
108 (unless (<= (length st) (length next-str))
109 (subseq st (1+ (length next-str)))))
110 (next-str (string-first st)
111 (string-first st))
112 (res (make-empty-adjustable-array)))
113 ((string= next-str "") res)
114 (vector-push-extend next-str res)))
115
116(defun base-name (file-str)
117 (let ((last-slash (position #\/ file-str :from-end t)))
118 (if last-slash
119 (subseq file-str (1+ last-slash))
120 file-str)))
121
[15808]122(defun app-name-from-path (bundle-path)
123 (let* ((str (first (last (pathname-directory bundle-path))))
124 (dot-pos (position #\. str)))
125 (if dot-pos
126 (subseq str 0 dot-pos)
127 str)))
128
129(defun module-name (file-str)
130 (let* ((base-name (base-name file-str))
131 (last-dot (position #\. base-name :from-end t))
132 (str (if last-dot
133 (subseq base-name 0 last-dot)
134 base-name)))
135 (string-upcase str)))
136
[14585]137(defun objc-class-name-from-class-string (cl-str)
138 ;; cl-str is a string that includes a package qualifier
139 (let ((pos (position #\: cl-str :from-end t)))
140 (if pos
[15808]141 (ccl::compute-objc-classname (string-upcase (subseq cl-str (1+ pos))))
[14585]142 cl-str)))
143
144;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[15808]145;; Constants for plist files
[14585]146
147#|
148(defconstant *plist-keys*
149 (list "CCLDelegateClass" ;; The class of the app object's delegate (unless set when
150 ;; NSPrincipalClass object is created)
151 "CFBundleDevelopmentRegion" ;; e.g. English
152 "CFBundleDisplayName" ;; localized app name usually in InfoPlist.strings files
153 ;; in language-specific resource dirs
154 "CFBundleDocumentTypes" ;; Array of dictionaries defining document types supported
155 "CFBundleExecutable" ;; Name of executable file in bundle
156 "CFBundleHelpBookFolder" ;; Directory where help book resides
157 "CFBundleHelpBookName" ;; Name of help book
158 "CFBundleIconFile" ;; name of single icons file
159 "CFBundleIconFiles" ;; array of strings that identifies icon files used by app
160 "CFBundleIdentifier" ;; e.g. com.clozure.appName, reverse-DNS UTI string
161 "CFBundleInfoDictionaryVersion" ;; e.g. 6.0 ??
162 "CFBundleName" ;; short name of bundle, usually app name
163 "CFBundlePackageType" ;; "APPL" for app bundles
164 "CFBundleShortVersionString" ;; string with 3 period-separated integers - version of app
165 "CFBundleSignature" ;; Four-character bundle (Application) identifier
166 "CFBundleURLTypes" ;; array of dictionaries?
167 "CFBundleVersion" ;; app-specific version string
168 "LSMinimumSystemVersion" ;; minimum version of Mac OSX required to run app; e.g. "10.6.4"
169 "NSAppleScriptEnabled" ;; Boolean value
170 "NSHumanReadableCopyright" ;; copyright notice; can be localized as for CFBundleDisplayName
171 "NSMainNibFile" ;; base name (i.e. no .nib extension) of main nib file
172 "NSPrincipalClass" ;; some subclass of NSApplication; likely LispApplication or some subclass
173 "UTExportedTypeDeclarations" ;;
174 ))
175|#
176
177;; the following two functions are used to serialize fields that are hash tables
178;; with the constraint that values are either embedded hash-tables that are
179;; also serialized or values that can be printed to and read from strings.
180;; Keys in the hash-tables are always strings.
181
182(defun ht-to-assoc (ht)
183 (when (hash-table-p ht)
184 (let ((res nil))
185 (maphash #'(lambda (k v)
186 (when (typep v 'hash-table)
187 (setf v (ht-to-assoc v)))
188 (setf res (acons k v res)))
189 ht)
190 res)))
191
192(defun assoc-to-ht (alst)
193 (let ((ht (make-hash-table :test #'equal)))
194 (dolist (pair alst ht)
195 (setf (gethash (car pair) ht)
196 (if (listp (cdr pair))
197 (assoc-to-ht (cdr pair))
198 (cdr pair))))))
199
200;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[15808]201;; lisp-doc-type
202;;
203;; Contains information about a single document type supported by the application
204
205(defclass lisp-doc-type ()
206 ((dt-doc :accessor dt-doc
207 :initarg :doc)
208 (dt-doc-type :accessor dt-doc-type
209 :initform "New Doc Type"
210 :kvo "dtDocType"
211 :undo "set document type")
212 (dt-doc-class :accessor dt-doc-class
213 :initform ""
214 :kvo "dtDocClass"
215 :undo "set document class")
216 (dt-file-ext :accessor dt-file-ext
217 :initform ""
218 :kvo "dtFileExt"
219 :undo "set document extention")
220 (dt-export-uti :accessor dt-export-uti
221 :initform nil
222 :kvo "dtExportUTI"
223 :undo "set Export UTI")
224 (dt-uti :accessor dt-uti
225 :initform ""
226 :kvo "dtUTI"
227 :undo "set document UTI")
228 (dt-doc-role :accessor dt-doc-role
229 :initform ""
230 :kvo "dtDocRole"
231 :undo "set application role for document")
232 (dt-icon-full-path :accessor dt-icon-full-path
233 :initform nil)
234 (dt-icon-file :accessor dt-icon-file
235 :initform ""
236 :kvo "dtIconFile")
237 (dt-owner-for-doc :accessor dt-owner-for-doc
238 :initform nil
239 :kvo "dtOwnerForDoc"
240 :undo "change to App is Owner for Doc Type"))
241 (:default-initargs
242 :doc nil))
243
244(defmethod undo-target ((self lisp-doc-type))
245 (dt-doc self))
246
247;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[14585]248;; lisp-app-doc
249;;
250;; Contains all the parameter values required to build a particular application.
251;; Serves as a data source for bindings made from the application build window.
252
253(defclass lisp-app-doc (lisp-document)
254 ((app-name :accessor app-name
255 :initform "My Application"
256 :kvo "appName"
257 :undo "set application name")
258 (app-exec :accessor app-exec
259 :initform "myapp"
260 :kvo "appExec"
261 :undo "set executable name")
262 (app-bundle-id :accessor app-bundle-id
263 :initform "com.clozure.apps.myapplication"
264 :kvo "appBundleID"
265 :undo "set bundle ID")
266 (app-bundle-sig :accessor app-bundle-sig
267 :initform "MyAp"
268 :kvo "appBundleSig"
269 :undo "set bundle signature")
270 (app-version :accessor app-version
271 :initform "1.0"
272 :kvo "appVersion"
273 :undo "set application version")
[15808]274 (app-min-os :accessor app-min-os
275 :initform "10.7"
276 :kvo "appMinOS"
277 :undo "set minimum OS")
[14585]278 (app-directory :accessor app-directory
279 :initform nil
280 :kvo "appDirectory"
281 :undo "set application directory")
282 (app-class :accessor app-class
283 :initform ""
284 :kvo "appClass"
285 :undo "set application class")
286 (app-delegate-class :accessor app-delegate-class
287 :initform ""
288 :kvo "appDelegateClass"
289 :undo "set app delegate class")
[15808]290 (app-source-full-path :accessor app-source-full-path
291 :initform nil)
292 (app-source-abbrev-path :accessor app-source-abbrev-path
293 :initform ""
294 :kvo "appAbbrevSrc")
295 (app-source-module :accessor app-source-module
296 :initform nil)
297 (app-icon-full-path :accessor app-icon-full-path
298 :initform nil)
299 (app-icon-file :accessor app-icon-file
300 :initform ""
301 :kvo "appIconFile")
302 (app-init-func :accessor app-init-func
303 :initform ""
304 :kvo "appInitFunc"
305 :undo "set app init function")
306 (app-doc-types :accessor app-doc-types
307 :initform (make-empty-adjustable-array)
308 :kvo "docTypes")
[14585]309 (app-info-plist :accessor app-info-plist
310 :initform (make-hash-table :test #'equal))
311 (app-info-plist-imported :accessor app-info-plist-imported
312 :initform nil)
313 (app-info-plist-date :accessor app-info-plist-date
314 :initform 0)
315 (app-bundle-path :accessor app-bundle-path
316 :initform nil
317 :kvo "appBundlePath"
318 :undo "set bundle path")
319 ;; some lists of possible values for various fields in the window
320 (app-classes :accessor app-classes
[15808]321 :initform nil
[14585]322 :kvo "appClasses")
323 (app-delegate-classes :accessor app-delegate-classes
[15808]324 :initform nil
[14585]325 :kvo "appDelegateClasses")
326 (doc-classes :accessor doc-classes
[15808]327 :initform nil
[14585]328 :kvo "appDocClasses")
329 (doc-roles :accessor doc-roles
330 :initform *doc-role-strings*
331 :kvo "appDocRoles")
[15808]332 (doc-controller :accessor doc-controller
333 :initform nil)
334 (win-controller :accessor win-controller
335 :initform nil)
336 (task-queue :accessor task-queue
337 :initform (make-instance 'ts-queue))
338 (task-process :accessor task-process
339 :initform nil)
340 (update-lock :accessor update-lock :initform (make-lock)))
[14585]341 (:metaclass ns:+ns-object))
342
[15808]343(objc:defmethod (#/close :void)
344 ((self lisp-app-doc))
345 (when (task-process self)
346 ;; tell process to quit
347 (queue-task self nil))
348 (call-next-method))
349
[14585]350;; Methods to lock when necessary
351
352(defmethod (setf app-info-plist) :around (new-val (self lisp-app-doc))
353 (declare (ignore new-val))
354 (with-lock-grabbed ((update-lock self))
355 (call-next-method)))
356
[15808]357;; Methods to support doing some tasks in a separate thread
[14585]358
[15808]359(defmethod queue-task ((self lisp-app-doc) task-func)
360 ;; If task-func is not a function, the process will quit
361 (with-slots (task-queue task-process) self
362 (unless task-process
363 (setf task-process (process-run-function "lisp app doc tasks" #'run-app-doc-tasks self)))
364 (push-ts-queue task-queue task-func)))
[14585]365
[15808]366(defmethod run-app-doc-tasks ((self lisp-app-doc))
367 (let ((q (task-queue self)))
368 (do ((new-task (pop-ts-queue q)
369 (pop-ts-queue q)))
370 ((not (functionp new-task)) nil)
371 (funcall new-task))))
372
[14585]373;; Notification functions
374
[15808]375(defmethod bound-slot-modified ((self lisp-app-doc) (slot-name (eql 'app-bundle-sig)))
376 (with-slots (app-bundle-sig) self
377 (when (> (length app-bundle-sig) 4)
378 (alert :text (format nil "Signature ~s should be 4 characters or less, only the first 4 will be used" app-bundle-sig))
379 (setf app-bundle-sig (subseq app-bundle-sig 0 3)))))
380
381(defmethod bound-slot-modified ((self lisp-app-doc) (slot-name (eql 'app-name)))
[14585]382 ;; called when the app-name slot is modified. Check to see if we should
383 ;; rename the bundle.
[15808]384 (with-slots (app-bundle-path app-name) self
385 (when (and (non-empty-string app-name)
386 app-bundle-path
387 (not (string= (app-name-from-path app-bundle-path) app-name))
388 (probe-file app-bundle-path))
389 (let ((new-app-bundle-path (make-pathname :directory (append (butlast (pathname-directory app-bundle-path))
390 (list (concatenate 'string app-name ".app"))))))
391 (unless (equal app-bundle-path new-app-bundle-path)
392 (if (probe-file new-app-bundle-path)
393 (let ((res (alert :text (format nil
394 "~a already exists. Continuing rename will remove existing file."
395 (pathname new-app-bundle-path))
396 :right "Cancel Rename"
397 :left "Continue with Rename")))
398 (when (eq res :left)
399 (rename-file app-bundle-path new-app-bundle-path :if-exists :overwrite)))
400 (rename-file app-bundle-path new-app-bundle-path))
401 (setf app-bundle-path new-app-bundle-path)
402 (save-info-plist self))))))
[14585]403
404;; Methods to manage windows
405
[15808]406(defmethod window-build-funcs ((self lisp-app-doc))
407 (list #'make-app-doc-window))
[14585]408
409(defmethod document-window-controller-classes ((self lisp-app-doc))
410 (list (find-class 'lisp-app-win-controller)))
411
412;; lisp-app-doc Methods
413
414(defmethod archive-slots ((self lisp-app-doc))
415 ;; we want to save everything except for the doc-controller, win-controller, and update-lock slots
416 ;; also don't save app-info-plist since we'll read if from the bundle if it exists. That way
417 ;; it can be edited externally and those values will be preserved when the doc is opened.
418 (let ((default-slots (call-next-method)))
[15808]419 (set-difference default-slots '(doc-controller win-controller update-lock app-info-plist
420 app-classes app-delegate-classes doc-classes doc-roles
421 task-queue task-process))))
[14585]422
423(defmethod init-bundle ((self lisp-app-doc))
424 (setf (app-bundle-path self) nil)
425 (setf (app-info-plist self) (make-hash-table :test #'equal))
426 (setf (app-info-plist-imported self) nil)
427 (reinit-bundle self))
428
429(defmethod reinit-bundle ((self lisp-app-doc))
[15808]430 (with-slots (app-name app-bundle-path app-creator-string app-icon-file app-icon-full-path
431 app-source-full-path app-bundle-sig app-info-plist app-doc-types
432 app-info-plist-imported app-delegate-class app-exec) self
[14585]433 (let* ((bpath (and app-bundle-path (probe-file app-bundle-path)))
434 (bundle-dir (unless bpath
[15808]435 (iu:open-panel :choose-dirs t
436 :choose-files nil
437 :prompt "Create App Bundle Here"))))
438 ;; (set-defined-objc-classes self)
[14585]439 (when bundle-dir
440 ;; Create a new .app bundle
441 (setf bpath (ccl::make-application-bundle :name app-name
442 :project-path bundle-dir))
[14632]443 (setf app-bundle-path bpath)
444 (#/updateChangeCount: self #$NSChangeDone))
[14585]445
446 (when bpath
447 ;; Create a pkginfo file
448 ;; This isn't absolutely needed, but is a good idea
449 (ccl::write-pkginfo (ccl::path app-bundle-path "Contents" "PkgInfo") "APPL" app-bundle-sig)
[15808]450
451 ;; Copy any specified icon files into the bundle resource directory
452 (let ((res-path (ccl::path bpath "Contents" "Resources" app-icon-file)))
453 (when (and (non-empty-string app-icon-full-path)
454 (not (equal app-icon-full-path res-path)))
455 (copy-file app-icon-full-path res-path :if-exists :overwrite)))
456 (do-sequence (dt app-doc-types)
457 (let ((res-path (ccl::path bpath "Contents" "Resources" (dt-icon-file dt))))
458 (when (and (non-empty-string (dt-icon-full-path dt))
459 (not (equal (dt-icon-full-path dt) res-path)))
460 (copy-file (dt-icon-full-path dt) res-path :if-exists :overwrite))))
461
[14585]462 ;; Put Info.plist to the bundle
463 (save-info-plist self)
[15808]464
[14585]465 ;; Make sure the OS knows that the bundle was modified. Othewise it will use old
466 ;; cached information from the bundle.
467 (ccl::touch bpath)))))
468
469(defmethod use-bundle ((self lisp-app-doc))
470 ;; Associate an existing bundle with this document. Perhaps most commonly used when
471 ;; a developer copies an existing bundle to use as a starting point and then creates
472 ;; a new document and wants to associate the copied bundle with it.
[15808]473 (let ((new-bundle-file (open-panel :prompt "Select bundle"
474 :types '("bundle" "app" "bndl"))))
[14585]475 (when new-bundle-file
476 (with-slots (app-bundle-path) self
477 ;; unfortunately what comes back isn't recognized as a directory so we have
478 ;; to slightly patch the name
479 (setf app-bundle-path (pathname (concatenate 'string new-bundle-file "/")))
[15808]480 (read-info-plist self))
481 (#/updateChangeCount: self #$NSChangeDone))))
[14585]482
[15808]483(defmethod doc-type-string ((self lisp-app-doc))
484 (with-slots (app-doc-types app-name) self
485 (when (plusp (length app-doc-types))
486 (let ((dt (or (find t app-doc-types :key #'dt-owner-for-doc)
487 (elt app-doc-types 0))))
488 (if dt
489 (or (non-empty-string (dt-doc-type dt))
490 (non-empty-string (dt-file-ext dt)))
491 (concatenate 'string app-name " Document"))))))
[14585]492
[15808]493(defmethod primary-doc-class ((self lisp-app-doc))
494 (with-slots (app-doc-types) self
495 (when (plusp (length app-doc-types))
496 (dt-doc-class (or (find t app-doc-types :key #'dt-owner-for-doc)
497 (elt app-doc-types 0))))))
[14585]498
[15808]499(defmethod doc-file-extension ((self lisp-app-doc))
500 ;; Either use the first extension specified in the document window or the default "LDOC"
501 (with-slots (app-doc-types app-name) self
502 (let ((dt (when (plusp (length app-doc-types))
503 (or (find t app-doc-types :key #'dt-owner-for-doc)
504 (elt app-doc-types 0)))))
505 (or (and dt (non-empty-string (dt-file-ext dt)))
506 "LDOC"))))
[14585]507
508(defmethod assure-source-loaded ((self lisp-app-doc))
[15808]509 (with-slots (#|app-main-source-res |# app-source-full-path app-source-module #| app-source-files |#) self
510 (when app-source-module
511 (unless (member app-source-module *modules* :test #'string-equal)
512 (with-errors-alerted
513 (require app-source-module
514 (pathname app-source-full-path)))))))
[14585]515
516(defmethod load-lisp-app ((self lisp-app-doc))
[15808]517 (with-slots (app-bundle-path #| app-main-nib |# app-init-func #| app-doc-class app-include-source |#
518 #| app-source-files app-doc-types |# doc-controller #| app-main-source-res |# app-delegate-class) self
[14585]519 ;; first make sure the bundle is physically sync'ed with all the values in the lisp-app-doc
520 (when doc-controller
521 (#/release doc-controller)
522 (setf doc-controller nil))
523 (reinit-bundle self)
524 (unless app-bundle-path
525 ;; must have cancelled out of creating a new bundle, so just exit
526 (return-from load-lisp-app nil))
[15808]527 (let ((app-doc-class (primary-doc-class self))
528 ;;(bndl (lisp-bundle-with-path app-bundle-path))
[14585]529 (did-something nil))
[15808]530 (setf did-something (assure-source-loaded self))
[14585]531
532 ;; Next we do different things depending on the current state of the bundle:
533 ;;
534 ;; If the bundle has an application class defined for it, but does not have a main menu
535 ;; then create an instance of lisp-doc-controller that creates and adds some standard
536 ;; menu items for that class.
537 ;;
[15808]538 ;; If the bundle has an application class and also an app-init-func,
539 ;; then create an instance of lisp-doc-controller that will create the main menu from
540 ;; the function and also arrange to save the current menu items so that the user can
[14585]541 ;; toggle back and forth between the app menu-items and lisp menu-items
[15808]542 (if (non-empty-string app-init-func)
543 ;; Make an instance of lisp-doc-controller to be owner of any objects created by the app-init-func
544 ;; It will act as if it were an NSApplication with respect to global menu items that are created.
[14585]545 (progn
546 (setf doc-controller
547 (make-doc-controller app-doc-class
548 app-delegate-class
[15808]549 (doc-type-string self)
[14585]550 (doc-file-extension self)
551 app-bundle-path))
552 (show-dev-menu)
553 (set-toggle-states)
554 (setf did-something t))
555 (when (non-empty-string app-doc-class)
[15808]556 ;; otherwise make an instance of lisp-doc-controller that sets up pseudo menu-items
[14585]557 ;; for this document
558 (if (find-class (read-from-string app-doc-class) nil)
559 (progn
560 (setf doc-controller
561 (make-doc-controller app-doc-class
562 app-delegate-class
563 (doc-type-string self)
564 (doc-file-extension self)
565 app-bundle-path))
566 (setf did-something t))
567 (alert :text (format nil "Specified Document Class: ~a does not exist" app-doc-class)))))
568 (unless did-something
569 (alert
[15808]570 :text "No source files to be loaded, no app initialization function specified, no Document Class specifed, so nothing was done.")))))
[14585]571
572(defmethod unload-lisp-app ((self lisp-app-doc))
573 ;; As much as possible, remove what was loaded
574 ;; Open documents for this app are left alone, but menus on which they may depend will be gone.
575 ;; They can still be saved and closed, but no new ones can be opened or created.
576
577 ;; Release the doc-controller and set it to nil. Releasing will result in any menuitems that were
[15808]578 ;; added by the controller (either directly or via main-menu creation) being removed.
579 (when (doc-controller self)
580 (#/release (doc-controller self))
581 (setf (doc-controller self) nil)))
[14585]582
[15808]583(defmethod current-executable-path ()
584 ;; finds the path (string) to the executable for the Lisp IDE currently running
585 ;; This executable will be copied into the app bundle and renamed as needed.
586 (first (coerce-obj (#/arguments (#/processInfo ns:ns-process-info)) 'list)))
587
588(defmethod install-exec-sub-task ((self lisp-app-doc))
589 (with-slots (app-exec app-class app-bundle-path app-include-source app-doc-types
590 app-source-full-path app-source-module) self
591 ;; start a subordinate lisp to install the executable
592 (with-ccl-stream (other-ccl)
593 (with-stream-window (strm "Installation Progress")
594 (let ((exec-path (namestring (ccl::path (ccl::bundle-executable-path app-bundle-path)
[14585]595 (ccl::bundle-executable-name app-exec))))
596 (remote-result nil))
[14632]597 ;;(start-trace other-ccl)
[15808]598 (format strm "Beginning to install executable in ~s at ~a" app-bundle-path (time-string (now)))
599 (format strm "~%Starting Remote Lisp and requiring :cocoa-without-ide-init")
600 (setf remote-result (in-subordinate-ccl (other-ccl) (require :cocoa-without-ide-init)))
601 (if (eq :cocoa-without-ide-init remote-result)
[14585]602 (progn
[15808]603 (format strm "~%Starting Remote Lisp and requiring :cocoa-without-ide-init successful")
604 (format strm "~%Requiring :install-executable in remote lisp")
605 (setf remote-result (in-subordinate-ccl (other-ccl) (require :install-executable))))
606 (progn
607 (alert :text (format nil "Remote (require :cocoa-without-ide-init) failed. ~s returned" remote-result))
608 (return-from install-exec-sub-task nil)))
[14585]609 (if (eq :install-executable remote-result)
610 (progn
[15808]611 (format strm "~%Requiring :install-executable in remote lisp successful")
612 (format strm "~%Requiring ~s in remote lisp" app-source-module)
613 (setf remote-result (remote-let (other-ccl)
614 ((require-source app-source-module)
615 (require-path app-source-full-path))
616 (when require-path
617 (require require-source require-path))
618 ;; a non-null result will indicate an error occurred
619 nil)))
620 (progn
[14585]621 (alert :text (format nil "Remote (require :install-executable) failed. ~s returned" remote-result))
[15808]622 (return-from install-exec-sub-task nil)))
623
[14585]624 (cond ((stringp remote-result)
625 (alert :text remote-result))
626 ((null remote-result)
[15808]627 (format strm "~%Requiring ~s in remote lisp successful" app-source-module)
628 (format strm "~%Last step: Saving app from remote lisp")
629 ;; we don't expect the following to return since the subordinate CCL will terminate
[14585]630 (remote-let (other-ccl)
631 ((bpath app-bundle-path)
[15808]632 (app-name (ccl::bundle-executable-name app-exec)))
633 (gui::save-app bpath app-name))
[14585]634 (shell-command (format nil "touch ~s" app-bundle-path))
[15808]635 (if (probe-file exec-path)
636 (format strm "~%App creation successful")
[14585]637 (alert :text (format nil "After saving, executable not found at ~s" exec-path))))
638 (t
639 ;; something weird here
[15808]640 ;;(alert :text (format nil "Unknown error trying to make-default-type-method remotely: ~s returned" remote-result))
641 (alert :text (format nil "Unknown error trying to load app source remotely: ~s returned" remote-result))))
[14632]642 #|(trace-output other-ccl)|#)))))
[14585]643
[15808]644(defmethod install-executable ((self lisp-app-doc))
645 (when (app-bundle-path self)
646 (reinit-bundle self)
647 ;; running the following as a sub-task permits event processing to continue so that progress can
648 ;; be shown in a separate window.
649 (queue-task self #'(lambda ()
650 (install-exec-sub-task self)))))
651
[14585]652(defmethod run-standalone-app ((self lisp-app-doc))
653 (run-program "open"
654 (list (namestring (app-bundle-path self)))
655 :wait nil))
656
[15808]657(defmethod set-dt-icon-paths ((self lisp-doc-type) full-path)
658 ;; set the dt-icon-full-path and dt-icon-file slots using the full-path
659 (let ((current-val (dt-icon-full-path self)))
660 (set-undo self
661 #'(lambda ()
662 (set-dt-icon-paths self current-val))
663 "set doc type icon file"))
664 (setf (dt-icon-full-path self) full-path)
665 (setf (dt-icon-file self) (base-name full-path)))
666
667(defmethod select-icon-file ((self lisp-app-doc) (dt lisp-doc-type))
[14585]668 ;; Use open-panel to allow user to select an icon file
669 (let ((new-icon-file (open-panel :prompt "Select")))
670 (when new-icon-file
[15808]671 (set-dt-icon-paths dt new-icon-file))))
[14585]672
[15808]673(defmethod bound-slot-modified ((self lisp-doc-type) (slot-name (eql 'dt-icon-file)))
674 ;; User typed in a (hopefully) full pathname
675 (unless (probe-file (dt-icon-file self))
676 (alert :title "Warning" :text (format nil "File ~s does not currently exist." (dt-icon-file self))))
677 (set-dt-icon-paths self (dt-icon-file self)))
[14585]678
[15808]679(defmethod set-app-icon-paths ((self lisp-app-doc) full-path)
680 ;; set the app-icon-full-path and app-icon-file slots using the full-path
681 (let ((current-val (app-icon-full-path self)))
682 (set-undo self
683 #'(lambda ()
684 (set-app-icon-paths self current-val))
685 "set app icon file"))
686 (setf (app-icon-full-path self) full-path)
687 (setf (app-icon-file self) (base-name full-path)))
[14585]688
[15808]689(defmethod select-app-icon-file ((self lisp-app-doc))
690 ;; Use open-panel to allow user to select an icon file
691 (let ((new-icon-file (open-panel :prompt "Select")))
692 (when new-icon-file
693 (set-app-icon-paths self new-icon-file))))
694
695(defmethod bound-slot-modified ((self lisp-app-doc) (slot-name (eql 'app-icon-file)))
696 ;; User typed in a (hopefully) full pathname
697 (unless (probe-file (app-icon-file self))
698 (alert :title "Warning" :text (format nil "File ~s does not currently exist." (app-icon-file self))))
699 (set-app-icon-paths self (app-icon-file self)))
700
701(defmethod set-source-paths ((self lisp-app-doc) full-path)
702 ;; set the app-source-full-path, app-source-abbrev-path, and app-source-module slots using the full-path
703 (let ((current-val (app-source-full-path self)))
704 (set-undo self
705 #'(lambda ()
706 (set-source-paths self current-val))
707 "set required source file"))
708 (setf (app-source-full-path self) full-path)
709 (setf (app-source-abbrev-path self) (base-name full-path))
710 (setf (app-source-module self) (module-name full-path)))
711
712(defmethod select-src-file ((self lisp-app-doc))
713 ;; Use open-panel to allow user to select a source file
714 (let ((new-src-file (open-panel :prompt "Select")))
715 (when new-src-file
716 (set-source-paths self new-src-file))))
717
718(defmethod bound-slot-modified ((self lisp-app-doc) (slot-name (eql 'app-source-abbrev-path)))
719 ;; User typed in a (hopefully) full pathname
720 (unless (probe-file (app-source-abbrev-path self))
721 (alert :title "Warning" :text (format nil "File ~s does not currently exist." (app-source-abbrev-path self))))
722 (set-source-paths self (app-source-abbrev-path self)))
723
724(defmethod doc-type-added ((self lisp-app-doc) controller root parent new-child)
725 (declare (ignore controller root parent))
726 ;; make sure the new doc type has its dt-doc slot set so that undo works
727 (setf (dt-doc new-child) self))
728
[14585]729(defmethod update-available-classes ((self lisp-app-doc))
730 (setf (app-classes self) (find-app-classes))
[15808]731 (setf (app-delegate-classes self) (find-app-delegate-classes))
732 ;; (setf (ctrl-classes self) (find-ctrl-classes))
[14585]733 (setf (doc-classes self) (find-document-classes)))
734
735(defmethod document-did-open ((self lisp-app-doc))
736 ;; Reload the Info.plist from whatever is in the bundle, if it exists
[15808]737 (read-info-plist self))
[14585]738
739(defmethod window-will-close ((self lisp-app-doc))
740 (with-slots (doc-controller) self
741 (when doc-controller
742 (when (open-documents doc-controller)
743 (if (and (#/isRunning #$NSApp)
744 (eql :left (alert :text (format nil "Close open ~a documents?" (doc-type-string self))
745 :left "YES"
746 :right "NO")))
747 (close-open-documents doc-controller)))
748 (#/release doc-controller)
749 (setf doc-controller nil))))
750
751
752;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[15808]753;;; Resource functions
754
755(defmethod add-resource ((self lisp-app-doc) resource-path)
756 (let* ((bpath (app-bundle-path self))
757 (res-path (and bpath (ccl::path bpath "Contents" "Resources"))))
758 (when (probe-file resource-path)
759 (copy-file resource-path (ccl::path res-path (base-name resource-path))))))
760
761(defmethod remove-resource ((self lisp-app-doc) resource-base-name)
762 (unless (string= resource-base-name "")
763 (let* ((bpath (app-bundle-path self))
764 (res-path (and bpath (ccl::path bpath "Contents" "Resources" resource-base-name))))
765 (when (probe-file res-path)
766 (delete-file res-path)))))
767
768(defmethod has-resource ((self lisp-app-doc) resource-base-name)
769 (let* ((bpath (app-bundle-path self))
770 (res-path (and bpath (ccl::path bpath "Contents" "Resources" resource-base-name))))
771 (probe-file res-path)))
772
773;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[14585]774;;; Info.plist functions
775
776(defmethod merge-vals-into-plist ((self lisp-app-doc))
777 ;; Take values from the fields in the lisp-app window set by the user and make sure
778 ;; anything that needs to be reflected in the info.plist is
[15808]779 (with-slots (app-info-plist app-name app-version app-min-os app-directory app-class app-main-source
780 app-delegate-class app-doc-types #| app-doc-role
781 app-doc-class app-file-ext app-uti |# app-exec app-export-uti
782 app-icon-file #| app-owner-for-doc app-main-nib |# app-bundle-id
783 app-bundle-sig app-include-source #| app-source-classes |#
784 app-main-source-res app-init-func) self
[14585]785 (setf (gethash "CFBundleName" app-info-plist) app-name)
786 (setf (gethash "CFBundleIdentifier" app-info-plist) app-bundle-id)
787 (setf (gethash "CFBundleVersion" app-info-plist) app-version)
[15808]788 (setf (gethash "LSMinimumSystemVersion" app-info-plist) app-min-os)
[14585]789 (setf (gethash "CFBundleSignature" app-info-plist) app-bundle-sig)
790 (setf (gethash "CFBundleExecutable" app-info-plist) app-exec)
[15808]791 (if app-init-func
792 (setf (gethash "CLMainFunc" app-info-plist) app-init-func)
793 (remhash "CLMainFunc" app-info-plist))
[14585]794 (setf (gethash "NSPrincipalClass" app-info-plist)
795 (if (non-empty-string app-class)
796 (objc-class-name-from-class-string app-class)
797 "LispApplication"))
798 (setf (gethash "CFBundlePackageType" app-info-plist) "APPL")
[15808]799 (if (non-empty-string app-icon-file)
800 (setf (gethash "CFBundleIconFile" app-info-plist)
801 app-icon-file)
802 (remhash "CFBundlePackageType" app-info-plist))
[14585]803 (if (non-empty-string app-delegate-class)
804 (setf (gethash "CCLDelegateClass" app-info-plist)
805 (objc-class-name-from-class-string app-delegate-class))
806 (remhash "CCLDelegateClass" app-info-plist))
[15808]807
808 ;; If user has specified info for one or more application documents, make sure
809 ;; that there are correponding entries in the CFBundleDocumentTypes list
[14585]810 ;; for that info. If you are not also including ide resources, then there
811 ;; should also be an entry in the UTExportedTypeDeclarations list.
[15808]812 (let* ((doc-type-list (coerce (gethash "CFBundleDocumentTypes" app-info-plist) 'list))
813 (export-list (coerce (gethash "UTExportedTypeDeclarations" app-info-plist) 'list)))
814 (do-sequence (dt app-doc-types)
815 (with-slots (dt-doc-type dt-doc-class dt-file-ext dt-doc-role dt-icon-file dt-uti dt-export-uti dt-owner-for-doc) dt
816 (when (or (non-empty-string dt-doc-type)
817 (non-empty-string dt-doc-class)
818 (non-empty-string dt-file-ext)
819 (non-empty-string dt-doc-role)
820 (non-empty-string dt-icon-file)
821 (non-empty-string dt-uti))
822 (let ((dt-ht (find-if #'(lambda (ht)
823 (string= dt-doc-type (gethash "CFBundleTypeName" ht)))
824 doc-type-list))
825 (export-ht (find-if #'(lambda (ht)
826 (string= dt-uti (gethash "UTTypeIdentifier" ht)))
827 export-list)))
828 (unless dt-ht
829 (setf dt-ht (make-hash-table :test #'equal))
830 (setf doc-type-list (nconc doc-type-list (list dt-ht))))
831 (if (non-empty-string dt-doc-type)
832 (setf (gethash "CFBundleTypeName" dt-ht) dt-doc-type)
833 (remhash "CFBundleTypeName" dt-ht))
834 (if (non-empty-string dt-icon-file)
835 (setf (gethash "CFBundleTypeIconFile" dt-ht) dt-icon-file)
836 (remhash "CFBundleTypeIconFile" dt-ht))
837 (when (string= dt-doc-role "")
838 (setf dt-doc-role "Editor"))
839 (when (non-empty-string dt-doc-role)
840 (setf (gethash "CFBundleTypeRole" dt-ht) dt-doc-role))
841 (if (non-empty-string dt-file-ext)
842 (setf (gethash "CFBundleTypeExtensions" dt-ht) (make-string-array dt-file-ext))
843 (remhash "CFBundleTypeExtensions" dt-ht))
844 (if (non-empty-string dt-uti)
845 (progn
846 ;; specify what UTIs can be used to read in to represent this type of document
847 (setf (gethash "LSItemContentTypes" dt-ht) (make-string-array dt-uti))
848 ;; specify what UTIs can be used to write out this type of document
849 (setf (gethash "NSExportableTypes" dt-ht) (make-string-array dt-uti)))
850 (progn
851 (remhash "LSItemContentTypes" dt-ht)
852 (remhash "NSExportableTypes" dt-ht)))
853 (setf (gethash "LSHandlerRank" dt-ht)
854 (if dt-owner-for-doc "Owner" "Alternate"))
855 (setf (gethash "NSDocumentClass" dt-ht)
856 (if (non-empty-string dt-doc-class)
857 (objc-class-name-from-class-string dt-doc-class)
858 "LispDocument"))
859 (when (non-empty-string dt-uti)
860 (if dt-export-uti
861 (progn
862 (unless export-ht
863 ;; create an entry for our uti
864 (setf export-ht (make-hash-table :test #'equal))
865 (setf export-list (cons export-ht export-list))
866 (setf (gethash "UTExportedTypeDeclarations" app-info-plist) (coerce export-list 'simple-vector)))
867 ;; identify what UTIs this bundle is exporting to the world
868 (setf (gethash "UTTypeIdentifier" export-ht) dt-uti)
869 ;; bit of a kludge below, but if user really wants to set this they can edit info.plist
870 (setf (gethash "UTTypeConformsTo" export-ht) (coerce (list #$kUTTypeData #$kUTTypeContent) 'simple-vector))
871 (when (non-empty-string dt-doc-type)
872 (setf (gethash "UTTypeDescription" export-ht) dt-doc-type))
873 (let ((tts-hash (gethash "UTTypeTagSpecification" export-ht)))
874 (unless tts-hash
875 (setf tts-hash (make-hash-table :test #'equal))
876 (setf (gethash "UTTypeTagSpecification" export-ht) tts-hash))
877 (setf (gethash "public.filename-extension" tts-hash) (coerce (list dt-file-ext) 'simple-vector))))
878 (when export-ht
879 ;; remove the UTI export entry if it already exists
880 (setf export-list (delete export-ht export-list))
881 (if (null export-list)
882 (remhash "UTExportedTypeDeclarations" app-info-plist)
883 (setf (gethash "UTExportedTypeDeclarations" app-info-plist) (coerce export-list 'simple-vector))))))))))
884 (if doc-type-list
885 (setf (gethash "CFBundleDocumentTypes" app-info-plist) (coerce doc-type-list 'simple-vector))
886 (remhash "CFBundleDocumentTypes" app-info-plist)))))
[14585]887
888(defmethod info-plist-to-doc-vals ((self lisp-app-doc))
889 ;; Take values from the info-plist and move them into appropriate fields in the document so that
890 ;; they will be accurately displayed in the window. Typically this will be done after the user
891 ;; edits the plist (by using the "Edit Info.plist" menu command which opens the document's
892 ;; info-plist in Apple's Property List Editor) and subsequently saves it.
[15808]893 (with-slots (app-name app-bundle-id app-version app-min-os app-bundle-sig app-exec app-bundle-path app-icon-file
894 app-icon-full-path app-init-func app-doc-types
895 app-info-plist #| app-main-nib app-doc-class |# app-class app-delegate-class #|app-uti|# ) self
[14585]896 (setf app-name (gethash "CFBundleName" app-info-plist ""))
897 (setf app-bundle-id (gethash "CFBundleIdentifier" app-info-plist ""))
[15808]898 (setf app-version (gethash "CFBundleVersion" app-info-plist "1.0"))
899 (setf app-min-os (gethash "LSMinimumSystemVersion" app-info-plist "10.7"))
[14585]900 (setf app-bundle-sig (gethash "CFBundleSignature" app-info-plist ""))
901 (setf app-exec (gethash "CFBundleExecutable" app-info-plist ""))
[15808]902 (setf app-init-func (gethash "CLMainFunc" app-info-plist ""))
903 (let* ((new-icon-file (gethash "CFBundleIconFile" app-info-plist ""))
904 (bundle-path (has-resource self new-icon-file)))
905 (if bundle-path
906 (unless (string= new-icon-file app-icon-file)
907 (remove-resource self app-icon-file)
908 (setf app-icon-file new-icon-file)
909 (setf app-icon-full-path bundle-path))
910 (alert :text (format nil
911 "Ignoring new info.plist value for CFBundleIconFile because ~s is not a bundle resource"
912 new-icon-file))))
913 (setf app-class (string-downcase (ns-to-lisp-classname (gethash "NSPrincipalClass" app-info-plist nil) app-class)))
914 (setf app-delegate-class (string-downcase (ns-to-lisp-classname (gethash "CCLDelegateClass" app-info-plist nil) app-delegate-class)))
[14585]915
[15808]916 ;; Process all the doc types in the info.plist
917 (let* ((doc-types (coerce-obj (gethash "CFBundleDocumentTypes" app-info-plist nil) 'list))
918 (export-list (coerce (gethash "UTExportedTypeDeclarations" app-info-plist) 'list)))
919 (dolist (dt-ht doc-types)
920 (let* ((type-name (gethash "CFBundleTypeName" dt-ht ""))
921 (old-dt (find type-name app-doc-types :key #'dt-doc-type :test #'string=))
922 (dt (or old-dt (make-instance 'lisp-doc-type :doc self))))
923 (unless old-dt
924 (vector-push-extend dt app-doc-types))
925 (with-slots (dt-doc-type dt-doc-class dt-file-ext dt-doc-role dt-icon-file
926 dt-icon-full-path dt-uti dt-export-uti dt-owner-for-doc) dt
927 ;; we leave existing values in window/document if there isn't anything in the Info.plist that overrides it
928 (setf dt-doc-type (gethash "CFBundleTypeName" dt-ht ""))
929 (let* ((new-icon-file (gethash "CFBundleTypeIconFile" dt-ht ""))
930 (bundle-path (has-resource self new-icon-file)))
931 (if bundle-path
932 (unless (string= new-icon-file dt-icon-file)
933 (remove-resource self dt-icon-file)
934 (setf dt-icon-file new-icon-file)
935 (setf dt-icon-full-path bundle-path))
936 (alert :text (format nil
937 "Ignoring new info.plist value for CFBundleTypeIconFile because ~s is not a bundle resource"
938 new-icon-file))))
939 (setf dt-doc-role (gethash "CFBundleTypeRole" dt-ht ""))
940 (let ((types (gethash "LSItemContentTypes" dt-ht nil)))
941 (when types
942 (setf dt-uti (array-to-string types))))
943 (let ((exts (gethash "CFBundleTypeExtensions" dt-ht nil)))
944 (when exts
945 (setf dt-file-ext (array-to-string exts))))
[16203]946 (setf dt-owner-for-doc (if (string= (gethash "LSHandlerRank" dt-ht "") "Owner") t nil))
[15808]947 (setf dt-doc-class (string-downcase (ns-to-lisp-classname (gethash "NSDocumentClass" dt-ht nil) dt-doc-class)))
[14585]948
[15808]949 ;; check to see if UTI was exported
950 (if (find-if #'(lambda (ht)
951 (string= dt-uti (gethash "UTTypeIdentifier" ht)))
952 export-list)
953 (setf dt-export-uti t)
954 (setf dt-export-uti nil))))))))
[14585]955
956(defmethod save-info-plist ((self lisp-app-doc))
957 (with-slots (app-bundle-path) self
958 (let* ((bpath (and app-bundle-path (probe-file app-bundle-path)))
959 (ip-path (and bpath (namestring (ccl::path bpath "Contents" "Info.plist")))))
960 (flet ((save-it ()
961 (merge-vals-into-plist self)
962 ;; Don't want to detect this as an external modification of the Info.plist and
963 ;; re-merge the values, so we'll suspend any monitoring of the file that might exist.
964 ;; It wouldn't hurt anything, but is a waste of time and would show up in UNDO.
965 (suspend-monitoring ip-path)
[16179]966 (unless (#/writeToFile:atomically: (lisp-to-ns-plist-dict (app-info-plist self))
[14585]967 (lisp-to-temp-nsstring ip-path)
968 #$YES)
969 (ns-log (format nil
970 "Unknown error while trying to write ~s"
971 (namestring (ccl::path bpath "Contents" "Info.plist")))))
972 (setf (app-info-plist-date self) (file-write-date (ccl::path bpath "Contents" "Info.plist")))
973 (resume-monitoring ip-path)))
974 (if bpath
975 (progn
976 (if (and (probe-file ip-path) (> (file-write-date ip-path) (app-info-plist-date self)))
977 (case (alert :right "Cancel"
978 :left "Overwrite"
979 :middle "Import"
980 :text "Info.plist changed on disk by another application since last written.")
981 (:right (return-from save-info-plist nil))
982 (:middle (read-info-plist self))
983 (:left (save-it)))
984 (save-it)))
985 (reinit-bundle self))))))
986
987(defmethod read-info-plist ((self lisp-app-doc) &key (undo nil))
988 (let ((bpath (when (app-bundle-path self)
989 (or (probe-file (app-bundle-path self))
990 (setf (app-bundle-path self) nil))))
991 (aip (app-info-plist self)))
992 (when bpath
993 (when undo
994 (set-undo self
995 #'(lambda ()
996 (setf (app-info-plist self) aip)
997 (info-plist-to-doc-vals self))
998 "set values from edited Info.plist"))
999 (set-info-plist-from-file self (ccl::path bpath "Contents" "Info.plist"))
1000 (info-plist-to-doc-vals self))))
1001
1002(defmethod set-info-plist-from-file ((self lisp-app-doc) path)
1003 ;; While this sets the app-info-plist value it does not set any individual variables
1004 ;; so that later when we update the app-info-plist from those variables we may augment
1005 ;; and/or replace values that are there. Effectively this makes what we are reading
1006 ;; here a default set of values that may be overridden by what the user enters in
1007 ;; the application window.
1008 (let* ((pl-path (lisp-to-temp-nsstring (namestring path)))
1009 (ns-plist (#/dictionaryWithContentsOfFile: ns:ns-mutable-dictionary pl-path)))
1010 (setf (app-info-plist self)
[16203]1011 (ns-to-lisp-hash-table ns-plist :test 'equal))
[14585]1012 (setf (app-info-plist-date self) (file-write-date path))))
1013
1014(defmethod edit-plist ((self lisp-app-doc))
1015 ;; Edit plist with Apple's Property List Editor application.
1016 ;; When user does a "save" there, the plist will automatically be reloaded and re-displayed.
1017 (with-slots (app-bundle-path) self
1018 (save-info-plist self)
1019 ;; set up a file monitor that will restore the plist when it is modified
1020 ;; check for updates once per second
1021 (monitor-file (ccl::path app-bundle-path "Contents" "Info.plist")
1022 #'(lambda (plist-path)
1023 (declare (ignore plist-path))
1024 (read-info-plist self :undo t))
1025 :wait-secs 1)
1026 ;; open the plist in the default app, which is normally the Property List Editor
1027 (run-program "open"
1028 (list (namestring (ccl::path app-bundle-path
1029 "Contents"
1030 "Info.plist")))
1031 :wait nil)))
1032
1033(defun install-lisp-app-tools ()
1034 ;; This is meant to be executed in the lisp listener, so we make sure that everything is
1035 ;; done on the main thread.
[15808]1036 (on-main-thread
1037 (let* ((bundle-path (probe-file (first (directory "ccl:contrib;**;lisp-app-doc.bundle"
1038 :directories t
1039 :files nil))))
1040 (bundle-namestring (and bundle-path (namestring bundle-path))))
1041 (make-doc-controller 'lisp-app-doc
1042 nil
1043 "Lisp Application"
1044 "lapp"
1045 bundle-namestring))))
[14585]1046
1047;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[15808]1048;; Define a delegate for lisp-doc objects.
[14585]1049;; This object will end up as the delegate of the lisp-app-controller object that handles
1050;; lisp-app-doc instances.
1051
[15808]1052(defclass lisp-doc-app-delegate (lisp-IDE-app-delegate)
1053 ((lisp-doc-controller :accessor lisp-doc-controller)
1054 ;; (objc-classes :accessor objc-classes :initform nil)
1055 (ccl-menuitem :accessor ccl-menuitem
1056 :initarg :ccl-menuitem)
1057 (app-menuitem :accessor app-menuitem
1058 :initarg :app-menuitem)
1059 (dev-menu :accessor dev-menu
1060 :initarg :dev-menu)
1061 (menu-key :accessor menu-key :initform (gensym)))
1062 (:default-initargs
1063 :dev-menu (%null-ptr)
1064 :ccl-menuitem (%null-ptr)
1065 :app-menuitem (%null-ptr))
[14585]1066 (:metaclass ns:+ns-object))
1067
1068(objc:defmethod (#/applicationWillFinishLaunching: :void)
[15808]1069 ((self lisp-doc-app-delegate) notification)
[14585]1070 (declare (ignore notification))
1071 ;; In this method do things that need to be done before the event loop
1072 ;; of the app is started. These things are also done if the app is
1073 ;; loaded under the IDE. Here we explicitly call application-will-finish-launching.
1074 (application-will-finish-launching self))
1075
1076(let ((*dev-menu-key* nil)
1077 (*ccl-menuitem* nil)
1078 (*app-menuitem* nil))
1079
1080 (defun set-toggle-states ()
1081 ;; we need a way to set the state of the menu-toggle items in the DEV menu
1082 ;; after we load a new mainmenu from an application bundle. This will be
1083 ;; called to do that.
1084 (when *ccl-menuitem*
1085 (#/setState: *ccl-menuitem* #$NSOffState))
1086 (when *app-menuitem*
1087 (#/setState: *app-menuitem* #$NSOnState)))
1088
1089 (defun show-dev-menu ()
1090 (when *dev-menu-key*
1091 (add-to-main-menu *dev-menu-key*)))
1092
[15808]1093 (defmethod application-will-finish-launching ((self lisp-doc-app-delegate))
[14585]1094 ;; Add the Dev menu to the existing set of menus in the menubar
1095 ;; But do so in such a way that it never goes away as CCL and app
1096 ;; menus are toggled on and off.
1097 (with-slots (dev-menu menu-key ccl-menuitem app-menuitem) self
1098 (when (not (eql dev-menu (%null-ptr)))
1099 ;; the Dev menu is a disembodied (i.e. not Main) menu so we need to create a
1100 ;; menuitem and make it the submenu. Then add it to the saved menu hash table
1101 ;; and finally add it to the currently displayed main menu at a specified location.
[15808]1102 (let ((new-mi (make-instance ns:ns-menu-item
1103 :submenu dev-menu
1104 :title (#/title dev-menu))))
[14585]1105 (save-mi-list-with-key (list new-mi) menu-key)
1106 (setf *ccl-menuitem* ccl-menuitem)
1107 (setf *app-menuitem* app-menuitem)
1108 (setf *dev-menu-key* menu-key)
1109 (show-dev-menu)))))
1110)
1111
1112(objc:defmethod (#/toggleCCLMenus: :void)
[15808]1113 ((self lisp-doc-app-delegate) sender)
[14585]1114 (if (eql #$NSOnState (#/state sender))
1115 (progn
1116 (remove-from-main-menu (starting-menu))
1117 (#/setState: sender #$NSOffState))
1118 (progn
1119 (add-to-main-menu (starting-menu) 0)
1120 (#/setState: sender #$NSOnState))))
1121
[15808]1122(objc:defmethod (#/toggleAppMenus: :void)
1123 ((self lisp-doc-app-delegate) (sender :id))
1124 (if (eql #$NSOnState (#/state sender))
1125 (progn
1126 (remove-from-main-menu (app-menu))
1127 (#/setState: sender #$NSOffState))
1128 (progn
1129 (add-to-main-menu (app-menu) "Dev")
1130 (#/setState: sender #$NSOnState))))
[14585]1131
[15808]1132(objc:defmethod (#/validateMenuItem: #>BOOL)
1133 ((self lisp-doc-app-delegate) (item :id))
1134 (let* ((action (#/action item)))
1135 (if (eql action (ccl::@selector "toggleAppMenus:"))
1136 (if (app-menu)
1137 #$YES
1138 #$NO)
1139 (call-next-method item))))
[14585]1140
[15808]1141(defun make-dev-app (app-object)
1142 ;; This is called when the lisp-app-doc bundle is loaded by the lisp-doc-controller object created when
1143 ;; install-lisp-app-tools is called. The info.plist in that bundle contains "ad::make-dev-app" as the
1144 ;; value of the CLMainFunc key. The app-object will be the lisp-doc-controller instance. For stand-alone
1145 ;; apps the app-object argument would be the ns-application object for the app.
1146 (let* ((mi1 (make-instance ns:ns-menu-item
1147 :title "New Bundle"
1148 :action "initBundle:"
1149 :key-equivalent "b"
1150 :key-equivalent-modifier-mask :option))
1151 (mi2 (make-instance ns:ns-menu-item
1152 :title "Initialize Bundle"
1153 :action "reinitBundle:"
1154 :key-equivalent "i"
1155 :key-equivalent-modifier-mask :option))
1156 (mi3 (make-instance ns:ns-menu-item
1157 :title "Use Bundle
"
1158 :action "useBundle:"
1159 :key-equivalent "u"
1160 :key-equivalent-modifier-mask :option))
1161 (mi4 (make-instance ns:ns-menu-item
1162 :title "Edit Info.plist
"
1163 :action "editPlist:"
1164 :key-equivalent "p"
1165 :key-equivalent-modifier-mask :option))
1166 (mi5 (make-instance ns:ns-menu-item
1167 :title "Install Executable"
1168 :action "installExec:"
1169 :key-equivalent "e"
1170 :key-equivalent-modifier-mask :option))
1171 (mi6 (menu-item-for-key :sep))
1172 (mi7 (make-instance ns:ns-menu-item
1173 :title "Load App Under IDE"
1174 :action "loadLispApp:"
1175 :key-equivalent "l"
1176 :key-equivalent-modifier-mask :option))
1177 (mi8 (make-instance ns:ns-menu-item
1178 :title "Unload App from IDE"
1179 :action "unloadLispApp:"
1180 :key-equivalent "L"
1181 :key-equivalent-modifier-mask :option))
1182 (mi9 (make-instance ns:ns-menu-item
1183 :title "Run App Stand-Alone"
1184 :action "runStandAlone:"
1185 :key-equivalent "r"
1186 :key-equivalent-modifier-mask :option))
1187 (mi10 (menu-item-for-key :sep))
1188 (mi11 (make-instance ns:ns-menu-item
1189 :title "CCL Menus"
1190 :action "toggleCCLMenus:"
1191 :key-equivalent "c"
1192 :state #$NSOnState
1193 :key-equivalent-modifier-mask :option))
1194 (mi12 (make-instance ns:ns-menu-item
1195 :title "App Menus"
1196 :action "toggleAppMenus:"
1197 :state #$NSOffState
1198 :key-equivalent "a"
1199 :key-equivalent-modifier-mask :option))
1200 (dev-menu (make-instance ns:ns-menu
1201 :title "Dev"
1202 :menu-items (list mi1 mi2 mi3 mi4 mi5 mi6 mi7 mi8 mi9 mi10 mi11 mi12)))
1203 (del (make-instance 'lisp-doc-app-delegate
1204 :dev-menu dev-menu
1205 :ccl-menuitem mi11
1206 :app-menuitem mi12)))
1207 ;; Menu toggling is a function of the lisp-doc-controller delegate (lisp-doc-app-delegate instance)
1208 ;; so set the target for those menu items to the delegate.
1209 (#/setTarget: mi11 del)
1210 (#/setTarget: mi12 del)
[14585]1211
[15808]1212 (#/setDelegate: app-object del)
1213 (list dev-menu del)))
[14585]1214
1215(provide :lisp-app-doc)
1216
Note: See TracBrowser for help on using the repository browser.