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 | ;;; PATHNAME-SEPARATOR |
---|
21 | ;;; returns the character used to separate elements of a pathname |
---|
22 | ;;; on this platform. |
---|
23 | ;;; TODO: add conditional compiles to support platforms where |
---|
24 | ;;; the path separator is not "/" (if we ever care about that) |
---|
25 | (defun pathname-separator () #\/) |
---|
26 | |
---|
27 | ;;; ENSURE-DIRECTORY-PATHNAME p |
---|
28 | ;;; Returns the input pathname P, but ensures that it ends with a |
---|
29 | ;;; path separator, so that it will be parsed as a directory |
---|
30 | (defmethod ensure-directory-pathname ((p string)) |
---|
31 | (let ((pstr (namestring p))) |
---|
32 | (if (char= (pathname-separator) |
---|
33 | (elt pstr (1- (length pstr)))) |
---|
34 | p |
---|
35 | (pathname (concatenate 'string p (string (pathname-separator))))))) |
---|
36 | |
---|
37 | (defmethod ensure-directory-pathname ((p pathname)) |
---|
38 | (ensure-directory-pathname (namestring p))) |
---|
39 | |
---|
40 | ;;; BASENAME path |
---|
41 | ;;; returns the final component of a pathname--that is, the |
---|
42 | ;;; filename (with type extension) if it names a file, or the |
---|
43 | ;;; last directory name if it names a directory |
---|
44 | ;;; TODO: perhaps BASENAME should check the file or directory |
---|
45 | ;;; named by PATH and ensure that, if the named file |
---|
46 | ;;; or directory exists, then the choice of returning |
---|
47 | ;;; a file or directory is based on what the actual target |
---|
48 | ;;; is, rather than on what the text of PATH suggests? |
---|
49 | |
---|
50 | (defun basename (path) |
---|
51 | (let* ((dir (pathname-directory path)) |
---|
52 | (name (pathname-name path)) |
---|
53 | (type (pathname-type path))) |
---|
54 | (if name |
---|
55 | (if type |
---|
56 | (make-pathname :name name :type type) |
---|
57 | (make-pathname :name name)) |
---|
58 | (make-pathname :directory (first (last dir)))))) |
---|
59 | |
---|
60 | ;;; PATH (&rest components) |
---|
61 | ;;; returns a pathname. The input COMPONENTS are treated as |
---|
62 | ;;; directory names, each contained in the one to the left, except |
---|
63 | ;;; for the last. The last is treated as a directory if it ends |
---|
64 | ;;; with a path separator, and a file if it doesn't |
---|
65 | (defun path (&rest components) |
---|
66 | (if (null components) |
---|
67 | (pathname "") |
---|
68 | (if (null (cdr components)) |
---|
69 | (pathname (car components)) |
---|
70 | (merge-pathnames (apply #'path (cdr components)) |
---|
71 | (ensure-directory-pathname (car components)))))) |
---|
72 | |
---|
73 | |
---|
74 | ;;; RECURSIVE-COPY-DIRECTORY source-path dest-path |
---|
75 | ;;; Copies the contents of the SOURCE-PATH to the DEST-PATH. |
---|
76 | ;;; |
---|
77 | ;;; TODO: - add an ignore-list ability, so I can prevent |
---|
78 | ;;; this function from copying CVS and .svn directories |
---|
79 | ;;; - add some flags to control what do do if the dest |
---|
80 | ;;; already exists, and that sort of thing. Currently, |
---|
81 | ;;; this function just clobbers naything that is already |
---|
82 | ;;; in DEST-PATH |
---|
83 | (defun recursive-copy-directory (source-path dest-path) |
---|
84 | (ensure-directories-exist (ensure-directory-pathname dest-path)) |
---|
85 | (let ((files (directory (path source-path "*.*") :directories nil :files t)) |
---|
86 | (subdirs (directory (path source-path "*.*") :directories t :files nil))) |
---|
87 | ; (format t "~%files = ~S" files) |
---|
88 | ; (format t "~%subdirs = ~S~%" subdirs) |
---|
89 | (dolist (f files) |
---|
90 | (let* ((src-name (file-namestring f)) |
---|
91 | (dest-file (path dest-path src-name))) |
---|
92 | (ccl:copy-file f dest-file |
---|
93 | :if-exists :supersede |
---|
94 | :preserve-attributes t))) |
---|
95 | (dolist (d subdirs) |
---|
96 | (let* ((subdir-name (first (last (pathname-directory d)))) |
---|
97 | (dest-dir (ensure-directory-pathname (path dest-path subdir-name)))) |
---|
98 | (recursive-copy-directory d dest-dir))) |
---|
99 | dest-path |
---|
100 | )) |
---|
101 | |
---|
102 | ;;; WRITE-PKGINFO path package-type bundle-signature |
---|
103 | ;;; Writes a PkgInfo file of the sort used by Cocoa applications |
---|
104 | ;;; to identify their package types and signatures. Writes |
---|
105 | ;;; PACKAGE-TYPE and BUNDLE-SIGNATURE to the file at PATH, |
---|
106 | ;;; clobbering it if it already exists. |
---|
107 | (defun write-pkginfo (path package-type bundle-signature) |
---|
108 | (with-open-file (out path |
---|
109 | :direction :output |
---|
110 | :if-does-not-exist :create |
---|
111 | :if-exists :supersede) |
---|
112 | (format out "~A~A" package-type bundle-signature))) |
---|
113 | |
---|
114 | ;;; WRITE-INFO-PLIST path name package-type bundle-signature |
---|
115 | ;;; Reads the Info.plist file of the running IDE application |
---|
116 | ;;; into an NSMutableDictionary; sets the name, package-type, |
---|
117 | ;;; and bundle-signature from the inputs; writes the changed |
---|
118 | ;;; dictionary to a new Info.plist file at PATH. |
---|
119 | ;;; |
---|
120 | ;;; TODO: this function is extremely specialized to the case |
---|
121 | ;;; of writing an Info.plist for an app bundle that is |
---|
122 | ;;; copied from the IDE. Should separate the IDE-specific |
---|
123 | ;;; behavior from more general behavior that can be used |
---|
124 | ;;; by the batch builder, which does not depend on the IDE. |
---|
125 | (defun write-info-plist (path name package-type bundle-signature |
---|
126 | &key main-nib-name) |
---|
127 | ;; read the Info.plist of the IDE app, change |
---|
128 | ;; the fields needed, write the results to PATH |
---|
129 | (assert (or (null main-nib-name) |
---|
130 | (stringp main-nib-name)) |
---|
131 | (main-nib-name) |
---|
132 | "The main-nib-name must be a string or NIL, not ~S" main-nib-name) |
---|
133 | (with-autorelease-pool |
---|
134 | (let* ((bundle-name-key (%make-nsstring "CFBundleName")) |
---|
135 | (bundle-name-str (%make-nsstring name)) |
---|
136 | (type-key (%make-nsstring "CFBundlePackageType")) |
---|
137 | (type-str (%make-nsstring package-type)) |
---|
138 | (sig-key (%make-nsstring "CFBundleSignature")) |
---|
139 | (sig-str (%make-nsstring bundle-signature)) |
---|
140 | (ide-bundle (#/mainBundle ns:ns-bundle)) |
---|
141 | (ide-bundle-path-nsstring (#/bundlePath ide-bundle)) |
---|
142 | (ide-bundle-path (pathname |
---|
143 | (ensure-directory-pathname |
---|
144 | (lisp-string-from-nsstring ide-bundle-path-nsstring)))) |
---|
145 | (ide-plist-path-str (namestring (path ide-bundle-path |
---|
146 | "Contents" "Info.plist"))) |
---|
147 | (info-dict (#/dictionaryWithContentsOfFile: ns:ns-mutable-dictionary |
---|
148 | ide-plist-path-str)) |
---|
149 | (app-name-key (%make-nsstring "CFBundleExecutable")) |
---|
150 | (app-name-str (%make-nsstring name)) |
---|
151 | (app-plist-path-str (%make-nsstring (namestring path)))) |
---|
152 | (#/setValue:forKey: info-dict bundle-name-str bundle-name-key) |
---|
153 | (#/setValue:forKey: info-dict app-name-str app-name-key) |
---|
154 | (#/setValue:forKey: info-dict type-str type-key) |
---|
155 | (#/setValue:forKey: info-dict sig-str sig-key) |
---|
156 | (when main-nib-name |
---|
157 | (#/setValue:forKey: info-dict |
---|
158 | (%make-nsstring main-nib-name) |
---|
159 | #@"NSMainNibFile")) |
---|
160 | (#/writeToFile:atomically: info-dict app-plist-path-str #$YES)))) |
---|
161 | |
---|
162 | ;;; MAKE-APPLICATION-BUNDLE name package-type bundle-signature project-path |
---|
163 | ;;; Build the directory structure of a Cocoa application bundle and |
---|
164 | ;;; populate it with the required PkgInfo and Info.plist files. |
---|
165 | (defun make-application-bundle (name package-type bundle-signature project-path |
---|
166 | &key main-nib-name) |
---|
167 | (let* ((app-bundle (path project-path |
---|
168 | (ensure-directory-pathname (concatenate 'string name ".app")))) |
---|
169 | (contents-dir (path app-bundle (ensure-directory-pathname "Contents"))) |
---|
170 | (macos-dir (path contents-dir (ensure-directory-pathname "MacOS"))) |
---|
171 | (rsrc-dir (path contents-dir "Resources" |
---|
172 | (ensure-directory-pathname "English.lproj")))) |
---|
173 | (ensure-directories-exist macos-dir) |
---|
174 | (ensure-directories-exist rsrc-dir) |
---|
175 | (write-info-plist (path app-bundle "Contents" "Info.plist") |
---|
176 | name package-type bundle-signature :main-nib-name main-nib-name) |
---|
177 | (write-pkginfo (path app-bundle "Contents" "PkgInfo") |
---|
178 | package-type bundle-signature) |
---|
179 | app-bundle)) |
---|