source: trunk/source/cocoa-ide/builder-utilities.lisp @ 15350

Last change on this file since 15350 was 15350, checked in by rme, 7 years ago

Rename "cocoa-application" to "cocoa-ide" in numerous places.

File size: 19.9 KB
Line 
1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*-
2;;;; ***********************************************************************
3;;;; FILE IDENTIFICATION
4;;;;
5;;;; Name:          builder-utilities.lisp
6;;;; Version:       0.9
7;;;; Project:       bosco - Cocoa application builder
8;;;; Purpose:       utilities used by both batch and interactive builders
9;;;;
10;;;; ***********************************************************************
11
12(in-package :ccl)
13
14;;; ABOUT
15;;; ------------------------------------------------------------------------
16;;; Builder-utilities contains several functions used by OpenMCL
17;;; application-building tools for building and copying bundles,
18;;; resource directories, and magic files used by OSX applications.
19
20(defun %temp-nsstring (s) (#/autorelease (%make-nsstring s)))
21
22;;; Info Defaults
23;;; Some useful values for use when creating application bundles
24
25(defparameter $default-application-bundle-name "MyApplication")
26(defparameter $default-application-type-string "APPL")
27(defparameter $default-application-creator-string "OMCL")
28(defparameter $default-application-version-number "1.0")
29
30;;; defaults related to Info.plist files
31(defparameter $cfbundle-development-region-key #@"CFBundleDevelopmentRegion")
32(defparameter $default-info-plist-development-region "English")
33
34(defparameter $cfbundle-executable-key #@"CFBundleExecutable")
35(defparameter $default-info-plist-executable $default-application-bundle-name)
36
37(defparameter $cfbundle-getinfo-string-key #@"CFBundleGetInfoString")
38(defparameter $default-info-plist-getInfo-string "\"1.0 Copyright © 2008\"")
39
40(defparameter $cfbundle-help-book-folder-key #@"CFBundleHelpBookFolder")
41(defparameter $default-info-plist-help-book-folder "MyApplicationHelp")
42
43(defparameter $cfbundle-help-book-name-key #@"CFBundleHelpBookName")
44(defparameter $default-info-plist-help-book-name "\"MyApplication Help\"")
45
46(defparameter $cfbundle-icon-file-key #@"CFBundleIconFile")
47(defparameter $default-info-plist-icon-file "\"MyApplication.icns\"")
48
49(defparameter $cfbundle-bundle-identifier-key #@"CFBundleIdentifier")
50(defparameter $default-info-plist-bundle-identifier "\"com.clozure.apps.myapplication\"")
51
52(defparameter $cfbundle-dictionary-version-key #@"CFBundleInfoDictionaryVersion")
53(defparameter $default-info-dictionary-version "\"6.0\"")
54
55(defparameter $cfbundle-bundle-name-key #@"CFBundleName")
56(defparameter $default-info-plist-bundle-name "MyApplication")
57
58(defparameter $cfbundle-bundle-package-type-key #@"CFBundlePackageType")
59(defparameter $default-info-plist-bundle-package-type "APPL")
60
61(defparameter $cfbundle-short-version-string-key #@"CFBundleShortVersionString")
62(defparameter $default-info-plist-short-version-string "\"1.0\"")
63
64(defparameter $cfbundle-bundle-signature-key #@"CFBundleSignature")
65(defparameter $default-info-plist-bundle-signature "OMCL")
66
67(defparameter $cfbundle-version-key #@"CFBundleVersion")
68(defparameter $default-info-plist-version "\"1.0\"")
69
70(defparameter $ls-has-localized-display-name-key #@"LSHasLocalizedDisplayName")
71(defparameter $default-info-plist-has-localized-display-name "0")
72
73(defparameter $ls-minimum-system-version-key #@"LSMinimumSystemVersion")
74(defparameter $default-info-plist-minimum-system-version "\"10.5\"")
75
76(defparameter $ns-main-nib-file-key #@"NSMainNibFile")
77(defparameter $default-info-plist-main-nib-file "MainMenu")
78
79(defparameter $ns-principal-class-key #@"NSPrincipalClass")
80(defparameter $default-info-plist-principal-class "LispApplication")
81
82;;; keys for document-types dicts
83(defparameter $cfbundle-type-extensions-key #@"CFBundleTypeExtensions")
84(defparameter $cfbundle-type-icon-file-key #@"CFBundleTypeIconFile")
85(defparameter $cfbundle-type-mime-types-key #@"CFBundleTypeMIMETypes")
86(defparameter $cfbundle-type-name-key #@"CFBundleTypeName")
87(defparameter $cfbundle-type-ostypes-key #@"CFBundleTypeOSTypes")
88(defparameter $cfbundle-type-role-key #@"CFBundleTypeRole")
89(defparameter $ls-item-content-types-key #@"LSItemContentTypes")
90(defparameter $ls-type-is-package-key #@"LSTypeIsPackage")
91(defparameter $ns-document-class-key #@"NSDocumentClass")
92(defparameter $ns-exportable-as-key #@"NSExportableAs")
93
94;;; NOT-VC-CONTROL-FILE (path)
95;;; ------------------------------------------------------------------------
96;;; Returns T if the specified file (or directory) is not part of a version
97;;; control system's control data
98
99(defun not-vc-control-file (path)
100  (let ((vc-directories '(".svn" "CVS"))
101        (vc-files '("svn-commit.tmp" "svn-commit.tmp~"
102                    "svn-prop.tmp" "svn-prop.tmp~"
103                    ".cvsignore")))
104    (not (or (member (car (last (pathname-directory path))) vc-directories :test #'equalp)
105             (member (file-namestring path) vc-files :test #'equalp)))))
106
107;;; COPY-NIBFILE (srcnib dest-directory &key (if-exists :overwrite))
108;;; ------------------------------------------------------------------------
109;;; Copies a nibfile (which may in fact be a directory) to the
110;;; destination path (which may already exist, and may need to
111;;; be overwritten
112
113(defun copy-nibfile (srcnib dest-directory &key (if-exists :overwrite))
114  (setq if-exists (require-type if-exists '(member :overwrite :error)))
115  (let* ((basename (basename srcnib))
116         (dest (path dest-directory basename)))
117    (if (probe-file dest)
118        (case if-exists
119          (:overwrite (progn
120                        (if (directoryp dest)
121                            (recursive-delete-directory dest)
122                            (delete-file dest))))
123          (:error (error "The nibfile '~A' already exists" dest))))
124    (if (directoryp srcnib)
125        (recursive-copy-directory srcnib dest :test #'not-vc-control-file)
126        (copy-file srcnib dest))))
127
128;;; BASENAME path
129;;; ------------------------------------------------------------------------
130;;; returns the final component of a pathname--that is, the
131;;; filename (with type extension) if it names a file, or the
132;;; last directory name if it names a directory
133
134(defun basename (path)
135  ;; first probe to see whether the path exists.  if it does, then
136  ;; PROBE-FILE returns a canonical pathname for it which, among other
137  ;; things, ensures the pathame represents a directory if it's really
138  ;; a directory, and a file if it's really a file
139  (let* ((path (or (probe-file path)
140                   path))
141         (dir (pathname-directory path))
142         (name (pathname-name path))
143         (type (pathname-type path)))
144    (if name
145        (if type
146            (make-pathname :name name :type type)
147            (make-pathname :name name))
148        ;; it's possible to have a pathname with a type but no name
149        ;; e.g. "/Users/foo/.emacs"
150        (if type
151            (make-pathname :type type)
152            (make-pathname :directory (first (last dir)))))))
153
154;;; PATH (&rest components)
155;;; ------------------------------------------------------------------------
156;;; returns a pathname. The input COMPONENTS are treated as
157;;; directory names, each contained in the one to the left, except
158;;; for the last. The last is treated as a directory if it ends
159;;; with a path separator, and a file if it doesn't
160(defun path (&rest components)
161  (if (null components)
162      (pathname "")
163      (if (null (cdr components))
164          (pathname (car components))
165          (merge-pathnames (apply #'path (cdr components))
166                           (ensure-directory-pathname (car components))))))
167
168
169;;; WRITE-PKGINFO path package-type bundle-signature
170;;; ------------------------------------------------------------------------
171;;; Writes a PkgInfo file of the sort used by Cocoa applications
172;;; to identify their package types and signatures. Writes
173;;; PACKAGE-TYPE and BUNDLE-SIGNATURE to the file at PATH,
174;;; clobbering it if it already exists.
175(defun write-pkginfo (path package-type bundle-signature)
176  (with-open-file (out path
177                       :direction :output
178                       :if-does-not-exist :create
179                       :if-exists :supersede)
180    (format out "~A~A" package-type bundle-signature)))
181
182;;; MAKE-INFO-DICT
183;;; ------------------------------------------------------------------------
184;;; returns a newly-created NSDictionary with contents
185;;; specified by the input parameters
186(defun make-info-dict (&key
187                       (development-region $default-info-plist-development-region)
188                       (executable $default-info-plist-executable)
189                       (getinfo-string $default-info-plist-getinfo-string)
190                       (help-book-folder $default-info-plist-help-book-folder)
191                       (help-book-name $default-info-plist-help-book-name)
192                       (icon-file $default-info-plist-icon-file)
193                       (bundle-identifier $default-info-plist-bundle-identifier)
194                       (dictionary-version $default-info-dictionary-version)
195                       (bundle-name $default-info-plist-bundle-name)
196                       (bundle-package-type $default-info-plist-bundle-package-type)
197                       (short-version-string $default-info-plist-short-version-string)
198                       (bundle-signature $default-info-plist-bundle-signature)
199                       (version $default-info-plist-version)
200                       (has-localized-display-name $default-info-plist-has-localized-display-name)
201                       (minimum-system-version $default-info-plist-minimum-system-version)
202                       (main-nib-file $default-info-plist-main-nib-file)
203                       (principal-class $default-info-plist-principal-class))
204  (#/dictionaryWithObjectsAndKeys: ns:ns-mutable-dictionary
205                                   (%temp-nsstring development-region) $cfbundle-development-region-key
206                                   (%temp-nsstring executable) $cfbundle-executable-key
207                                   (%temp-nsstring getinfo-string) $cfbundle-getinfo-string-key
208                                   (%temp-nsstring help-book-folder) $cfbundle-help-book-folder-key
209                                   (%temp-nsstring help-book-name) $cfbundle-help-book-name-key
210                                   (%temp-nsstring icon-file) $cfbundle-icon-file-key
211                                   (%temp-nsstring bundle-identifier) $cfbundle-bundle-identifier-key
212                                   (%temp-nsstring dictionary-version) $cfbundle-dictionary-version-key
213                                   (%temp-nsstring bundle-name) $cfbundle-bundle-name-key
214                                   (%temp-nsstring bundle-package-type) $cfbundle-bundle-package-type-key
215                                   (%temp-nsstring short-version-string) $cfbundle-short-version-string-key
216                                   (%temp-nsstring bundle-signature) $cfbundle-bundle-signature-key
217                                   (%temp-nsstring version) $cfbundle-version-key
218                                   (%temp-nsstring has-localized-display-name) $ls-has-localized-display-name-key
219                                   (%temp-nsstring minimum-system-version) $ls-minimum-system-version-key
220                                   (%temp-nsstring main-nib-file) $ns-main-nib-file-key
221                                   (%temp-nsstring principal-class) $ns-principal-class-key
222                                   +null-ptr+))
223
224(defun make-doctype-dict (&key
225                          (extensions nil)
226                          (icon-file "Icons.icns")
227                          (mime-types nil)
228                          (type-name nil)
229                          (ostypes nil)
230                          (role nil)
231                          (ls-item-content-types nil)
232                          (bundlep nil)
233                          (document-class nil)
234                          (exportable-as nil))
235  (declare (ignorable bundlep exportable-as icon-file))
236  ;; certain values are required
237  (assert (or ls-item-content-types extensions mime-types ostypes)
238          ()
239          "You must supply a list of strings as the value for one of the keywords :ls-item-content-types, :extensions, :mime-types, or :ostypes")
240  (assert type-name () "You must supply a string as a value for the keyword :type-name")
241  (assert role () 
242          "You must supply one of the strings \"Editor\", \"Viewer\", \"Shell\", or \"None\" as a value for the keyword :role")
243  (assert document-class ()
244          "You must supply the name of an NSDocument subclass (as a string) as the value of the keyword :document-class")
245  )
246
247;;; READ-INFO-PLIST info-path
248;;; ------------------------------------------------------------------------
249;;; returns a newly-created NSDictionary with the contents
250;;; of the plist file at INFO-PATH
251(defun read-info-plist (info-path)
252  (let* ((info-path (pathname info-path)) ; make sure it's a pathname to start
253         (verified-path (probe-file info-path)))
254    (assert (and verified-path
255                 (string-equal (pathname-type verified-path) "plist"))
256            (info-path)
257            "The input path for READ-INFO-PLIST must be the name of a valid 'plist' file.")
258    (let* ((info-path-str (%temp-nsstring (namestring info-path))))
259      (#/dictionaryWithContentsOfFile: ns:ns-mutable-dictionary 
260                                       info-path-str))))
261
262;;; WRITE-INFO-PLIST info-plist path name package-type bundle-signature
263;;; ------------------------------------------------------------------------
264;;; sets the name, package-type, and bundle-signature of the
265;;; info-plist from the inputs; writes the changed dictionary to a new
266;;; Info.plist file at PATH.
267
268(defun write-info-plist (info-dict out-path name package-type bundle-signature
269                         &key main-nib-name)
270  ;; change the fields needed, write the results to PATH
271  (assert (or (null main-nib-name)
272              (stringp main-nib-name))
273          (main-nib-name)
274          "The main-nib-name must be a string or NIL, not ~S" main-nib-name)
275  (with-autorelease-pool
276    (let* ((bundle-name-str (%make-nsstring name))
277           (type-str (%make-nsstring package-type))
278           (sig-str (%make-nsstring bundle-signature))
279           (app-name-str (%make-nsstring (bundle-executable-name name)))
280           (app-plist-path-str (%make-nsstring (namestring out-path))))
281      (#/setValue:forKey: info-dict bundle-name-str $cfbundle-bundle-name-key)
282      (#/setValue:forKey: info-dict app-name-str $cfbundle-executable-key)
283      (#/setValue:forKey: info-dict type-str $cfbundle-bundle-package-type-key)
284      (#/setValue:forKey: info-dict sig-str $cfbundle-bundle-signature-key)
285      (when main-nib-name
286        (#/setValue:forKey: info-dict 
287                            (%make-nsstring main-nib-name)
288                            $ns-main-nib-file-key))
289      (#/writeToFile:atomically: info-dict app-plist-path-str #$YES))))
290
291;;; GET-IDE-BUNDLE-PATH
292;;; ------------------------------------------------------------------------
293;;; Returns the llisp pathname of the running IDE bundle
294
295(defun get-ide-bundle-path ()
296  (let* ((ide-bundle (#/mainBundle ns:ns-bundle))
297         (ide-bundle-path-nsstring (#/bundlePath ide-bundle)))
298    (pathname 
299     (ensure-directory-pathname 
300      (lisp-string-from-nsstring ide-bundle-path-nsstring)))))
301
302;;; GET-IDE-BUNDLE-INFO-PLIST
303;;; ------------------------------------------------------------------------
304;;; Returns an NSDictionary instance created by reading the Info.plist
305;;; file from the running IDE's application bundle
306
307(defun get-ide-bundle-info-plist ()
308  (let* ((ide-bundle (#/mainBundle ns:ns-bundle))
309         (ide-bundle-path-nsstring (#/bundlePath ide-bundle))
310         (ide-bundle-path (ensure-directory-pathname 
311                           (lisp-string-from-nsstring ide-bundle-path-nsstring)))
312         (ide-plist-path-str (namestring (path ide-bundle-path 
313                                               "Contents" "Info.plist"))))
314    (read-info-plist ide-plist-path-str)))
315
316;;; BUNNDLE-EXECUTABLE-PATH app-path
317;;; ------------------------------------------------------------------------
318;;; Returns the pathname of the executable directory given the pathname of
319;;; an application bundle
320(defun bundle-executable-path (app-path)
321  (path app-path "Contents" 
322        #-windows-target (ensure-directory-pathname "MacOS")
323        #+windows-target (ensure-directory-pathname "Windows")))
324
325;;; BUNNDLE-EXECUTABLE-NAME name
326;;; ------------------------------------------------------------------------
327;;; Returns the name of the executable file for an application bundle
328(defun bundle-executable-name (name)
329  #-windows-target name
330  #+windows-target (concatenate 'string name ".exe"))
331
332;;; MAKE-APPLICATION-BUNDLE name package-type bundle-signature project-path
333;;; ------------------------------------------------------------------------
334;;; Build the directory structure of a Cocoa application bundle and
335;;; populate it with the required PkgInfo and Info.plist files.
336(defun make-application-bundle (&key 
337                                (name $default-application-bundle-name)
338                                (project-path (current-directory)))
339  (let* ((app-bundle (path project-path 
340                           (ensure-directory-pathname (concatenate 'string name ".app"))))
341         (contents-dir (path app-bundle (ensure-directory-pathname "Contents")))
342         (executable-dir (bundle-executable-path app-bundle))
343         (rsrc-dir (path contents-dir  "Resources" 
344                         (ensure-directory-pathname "English.lproj"))))
345    (ensure-directories-exist executable-dir)
346    (ensure-directories-exist rsrc-dir)
347    app-bundle))
348
349;;; BUNDLE-FRAMEWORKS-PATH app-path
350;;; ------------------------------------------------------------------------
351;;; Returns the pathname of the frameworks directory given the pathname of
352;;; an application bundle
353(defun bundle-frameworks-path (app-path)
354  (path app-path "Contents"
355        #-windows-target (ensure-directory-pathname "Frameworks")
356        #+windows-target (ensure-directory-pathname "Windows")))
357
358;;; FIND-FRAMEWORK-EXECUTABLE framework-path
359;;; ------------------------------------------------------------------------
360;;; Returns the pathname of the framework's executable file given the
361;;; pathname of a framework
362(defun find-framework-executable (framework-path)
363  (let* ((raw-framework-name (car (last (pathname-directory framework-path))))
364         (framework-name (subseq raw-framework-name 0 (- (length raw-framework-name)
365                                                         #.(length ".framework"))))
366         (executable-wildcard (path framework-path
367                                    (concatenate 'string framework-name "*.dll")))
368         (executables (directory executable-wildcard)))
369    (when executables
370      (truename (first executables)))))
371
372;;; COPY-PRIVATE-FRAMEWORKS private-frameworks app-path
373;;; ------------------------------------------------------------------------
374;;; Copy any private frameworks into the bundle taking into account the
375;;; different directory structures used by Cocoa and Cocotron (Windows).
376(defun copy-private-frameworks (private-frameworks app-path)
377  (let ((private-frameworks #+windows-target (append *cocoa-ide-frameworks*
378                                                     private-frameworks)
379                            #-windows-target private-frameworks)
380        (frameworks-dir (bundle-frameworks-path app-path)))
381    #+windows-target
382    (dolist (lib *cocoa-ide-libraries*)
383      (copy-file lib frameworks-dir :preserve-attributes t :if-exists :supersede))
384    (when private-frameworks
385      (flet ((subdir (framework target)
386               (ensure-directory-pathname
387                (make-pathname :name (car (last (pathname-directory framework)))
388                               :defaults target))))
389        (dolist (framework private-frameworks)
390          (recursive-copy-directory framework (subdir framework frameworks-dir)
391                                    :test #'not-vc-control-file
392                                    :if-exists :overwrite)
393          #+windows-target
394          (let ((executable (find-framework-executable framework)))
395            (when executable
396              (copy-file executable frameworks-dir 
397                         :preserve-attributes t :if-exists :supersede))))))))
Note: See TracBrowser for help on using the repository browser.