source: release/1.4/source/cocoa-ide/builder-utilities.lisp @ 13049

Last change on this file since 13049 was 13049, checked in by rme, 10 years ago

Merge trunk changes r13033 through 13035, r13048.

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  ;; certain values are required
236  (assert (or ls-item-content-types extensions mime-types ostypes)
237          ()
238          "You must supply a list of strings as the value for one of the keywords :ls-item-content-types, :extensions, :mime-types, or :ostypes")
239  (assert type-name () "You must supply a string as a value for the keyword :type-name")
240  (assert role () 
241          "You must supply one of the strings \"Editor\", \"Viewer\", \"Shell\", or \"None\" as a value for the keyword :role")
242  (assert document-class ()
243          "You must supply the name of an NSDocument subclass (as a string) as the value of the keyword :document-class")
244  )
245
246;;; READ-INFO-PLIST info-path
247;;; ------------------------------------------------------------------------
248;;; returns a newly-created NSDictionary with the contents
249;;; of the plist file at INFO-PATH
250(defun read-info-plist (info-path)
251  (let* ((info-path (pathname info-path)) ; make sure it's a pathname to start
252         (verified-path (probe-file info-path)))
253    (assert (and verified-path
254                 (string-equal (pathname-type verified-path) "plist"))
255            (info-path)
256            "The input path for READ-INFO-PLIST must be the name of a valid 'plist' file.")
257    (let* ((info-path-str (%temp-nsstring (namestring info-path))))
258      (#/dictionaryWithContentsOfFile: ns:ns-mutable-dictionary 
259                                       info-path-str))))
260
261;;; WRITE-INFO-PLIST info-plist path name package-type bundle-signature
262;;; ------------------------------------------------------------------------
263;;; sets the name, package-type, and bundle-signature of the
264;;; info-plist from the inputs; writes the changed dictionary to a new
265;;; Info.plist file at PATH.
266
267(defun write-info-plist (info-dict out-path name package-type bundle-signature
268                         &key main-nib-name)
269  ;; change the fields needed, write the results to PATH
270  (assert (or (null main-nib-name)
271              (stringp main-nib-name))
272          (main-nib-name)
273          "The main-nib-name must be a string or NIL, not ~S" main-nib-name)
274  (with-autorelease-pool
275    (let* ((bundle-name-str (%make-nsstring name))
276           (type-str (%make-nsstring package-type))
277           (sig-str (%make-nsstring bundle-signature))
278           (app-name-str (%make-nsstring (bundle-executable-name name)))
279           (app-plist-path-str (%make-nsstring (namestring out-path))))
280      (#/setValue:forKey: info-dict bundle-name-str $cfbundle-bundle-name-key)
281      (#/setValue:forKey: info-dict app-name-str $cfbundle-executable-key)
282      (#/setValue:forKey: info-dict type-str $cfbundle-bundle-package-type-key)
283      (#/setValue:forKey: info-dict sig-str $cfbundle-bundle-signature-key)
284      (when main-nib-name
285        (#/setValue:forKey: info-dict 
286                            (%make-nsstring main-nib-name)
287                            $ns-main-nib-file-key))
288      (#/writeToFile:atomically: info-dict app-plist-path-str #$YES))))
289
290;;; GET-IDE-BUNDLE-PATH
291;;; ------------------------------------------------------------------------
292;;; Returns the llisp pathname of the running IDE bundle
293
294(defun get-ide-bundle-path ()
295  (let* ((ide-bundle (#/mainBundle ns:ns-bundle))
296         (ide-bundle-path-nsstring (#/bundlePath ide-bundle)))
297    (pathname 
298     (ensure-directory-pathname 
299      (lisp-string-from-nsstring ide-bundle-path-nsstring)))))
300
301;;; GET-IDE-BUNDLE-INFO-PLIST
302;;; ------------------------------------------------------------------------
303;;; Returns an NSDictionary instance created by reading the Info.plist
304;;; file from the running IDE's application bundle
305
306(defun get-ide-bundle-info-plist ()
307  (let* ((ide-bundle (#/mainBundle ns:ns-bundle))
308         (ide-bundle-path-nsstring (#/bundlePath ide-bundle))
309         (ide-bundle-path (ensure-directory-pathname 
310                           (lisp-string-from-nsstring ide-bundle-path-nsstring)))
311         (ide-plist-path-str (namestring (path ide-bundle-path 
312                                               "Contents" "Info.plist"))))
313    (read-info-plist ide-plist-path-str)))
314
315;;; BUNNDLE-EXECUTABLE-PATH app-path
316;;; ------------------------------------------------------------------------
317;;; Returns the pathname of the executable directory given the pathname of
318;;; an application bundle
319(defun bundle-executable-path (app-path)
320  (path app-path "Contents" 
321        #-windows-target (ensure-directory-pathname "MacOS")
322        #+windows-target (ensure-directory-pathname "Windows")))
323
324;;; BUNNDLE-EXECUTABLE-NAME name
325;;; ------------------------------------------------------------------------
326;;; Returns the name of the executable file for an application bundle
327(defun bundle-executable-name (name)
328  #-windows-target name
329  #+windows-target (concatenate 'string name ".exe"))
330
331;;; MAKE-APPLICATION-BUNDLE name package-type bundle-signature project-path
332;;; ------------------------------------------------------------------------
333;;; Build the directory structure of a Cocoa application bundle and
334;;; populate it with the required PkgInfo and Info.plist files.
335(defun make-application-bundle (&key 
336                                (name $default-application-bundle-name)
337                                (project-path (current-directory)))
338  (let* ((app-bundle (path project-path 
339                           (ensure-directory-pathname (concatenate 'string name ".app"))))
340         (contents-dir (path app-bundle (ensure-directory-pathname "Contents")))
341         (executable-dir (bundle-executable-path app-bundle))
342         (rsrc-dir (path contents-dir  "Resources" 
343                         (ensure-directory-pathname "English.lproj"))))
344    (ensure-directories-exist executable-dir)
345    (ensure-directories-exist rsrc-dir)
346    app-bundle))
347
348;;; BUNDLE-FRAMEWORKS-PATH app-path
349;;; ------------------------------------------------------------------------
350;;; Returns the pathname of the frameworks directory given the pathname of
351;;; an application bundle
352(defun bundle-frameworks-path (app-path)
353  (path app-path "Contents"
354        #-windows-target (ensure-directory-pathname "Frameworks")
355        #+windows-target (ensure-directory-pathname "Windows")))
356
357;;; FIND-FRAMEWORK-EXECUTABLE framework-path
358;;; ------------------------------------------------------------------------
359;;; Returns the pathname of the framework's executable file given the
360;;; pathname of a framework
361(defun find-framework-executable (framework-path)
362  (let* ((raw-framework-name (car (last (pathname-directory framework-path))))
363         (framework-name (subseq raw-framework-name 0 (- (length raw-framework-name)
364                                                         #.(length ".framework"))))
365         (executable-wildcard (path framework-path
366                                    (concatenate 'string framework-name "*.dll")))
367         (executables (directory executable-wildcard)))
368    (when executables
369      (truename (first executables)))))
370
371;;; COPY-PRIVATE-FRAMEWORKS private-frameworks app-path
372;;; ------------------------------------------------------------------------
373;;; Copy any private frameworks into the bundle taking into account the
374;;; different directory structures used by Cocoa and Cocotron (Windows).
375(defun copy-private-frameworks (private-frameworks app-path)
376  (let ((private-frameworks #+windows-target (append *cocoa-application-frameworks*
377                                                     private-frameworks)
378                            #-windows-target private-frameworks)
379        (frameworks-dir (bundle-frameworks-path app-path)))
380    #+windows-target
381    (dolist (lib *cocoa-application-libraries*)
382      (copy-file lib frameworks-dir :preserve-attributes t :if-exists :supersede))
383    (when private-frameworks
384      (flet ((subdir (framework target)
385               (ensure-directory-pathname
386                (make-pathname :name (car (last (pathname-directory framework)))
387                               :defaults target))))
388        (dolist (framework private-frameworks)
389          (recursive-copy-directory framework (subdir framework frameworks-dir)
390                                    :test #'not-vc-control-file
391                                    :if-exists :overwrite)
392          #+windows-target
393          (let ((executable (find-framework-executable framework)))
394            (when executable
395              (copy-file executable frameworks-dir 
396                         :preserve-attributes t :if-exists :supersede))))))))
Note: See TracBrowser for help on using the repository browser.