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

Last change on this file since 15536 was 15536, checked in by gb, 7 years ago

Support using the "coding" option in a file's file options line (a
line at the start of a text file that contains name:value pairs
separated by semicolons bracketed by -*- sequences) to determine a
file's character encoding. Specifically:

  • OPEN now allows an external-format of :INFERRED; previously, this was shorthand for an external-format whose line-termination was inferred and whose character encoding was based on *DEFAULT-FILE-CHARACTER-ENCODING*. When an input file whose external-format is specified as :INFERRED is opened, its file options are parsed and the value of the "coding" option is used if such an option is found (and if the value is something that CCL supports.) If a supported "coding" option isn't found, *DEFAULT-FILE-CHARACTER-ENCODING* is used as before.
  • In the Cocoa IDE, the Hemlock command "Ensure File Options Line" (bound to Control-Meta-M by default) ensures that the first line in the current buffer is a file options line and fills in some plausible values for the "Mode", "Package", and "Coding" options. The "Process File Options" command (Control-Meta-m) can be used to process the file options line after it's been edited. (The file options line is always processed when the file is first opened; changes to the "coding" option affect how the file will be saved.)

When a Lisp source file is opened in the IDE editor, the following
character encodings are tried in this order until one of them

  • if the "Open ..." panel was used to open the file and an encoding other than "Automatic" - which is now the default - is selected, that encoding is tried.
  • if a "coding" option is found, that encoding is tried.
  • the value of *DEFAULT-FILE-CHARACTER-ENCODING* is tried.
  • iso-8859-1 is tried. All files can be decoded in iso-8859-1.

This is all supposed to be what Emacs does and I think that it's
pretty close in practice.

A file that caused problems for Paul Krueger a few days ago
because its encoding (ISO-8859-1) wasn't guessed correctly
now has an explicit "coding" option and serves as a test case.

File size: 19.9 KB
[15536]1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user; coding:iso-8859-1; -*-
[7096]2;;;; ***********************************************************************
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
10;;;; ***********************************************************************
12(in-package :ccl)
[7098]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.
[9333]20(defun %temp-nsstring (s) (#/autorelease (%make-nsstring s)))
[9333]22;;; Info Defaults
23;;; Some useful values for use when creating application bundles
[9309]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")
30;;; defaults related to Info.plist files
[9333]31(defparameter $cfbundle-development-region-key #@"CFBundleDevelopmentRegion")
32(defparameter $default-info-plist-development-region "English")
[9333]34(defparameter $cfbundle-executable-key #@"CFBundleExecutable")
[9309]35(defparameter $default-info-plist-executable $default-application-bundle-name)
37(defparameter $cfbundle-getinfo-string-key #@"CFBundleGetInfoString")
38(defparameter $default-info-plist-getInfo-string "\"1.0 Copyright © 2008\"")
40(defparameter $cfbundle-help-book-folder-key #@"CFBundleHelpBookFolder")
41(defparameter $default-info-plist-help-book-folder "MyApplicationHelp")
43(defparameter $cfbundle-help-book-name-key #@"CFBundleHelpBookName")
44(defparameter $default-info-plist-help-book-name "\"MyApplication Help\"")
46(defparameter $cfbundle-icon-file-key #@"CFBundleIconFile")
47(defparameter $default-info-plist-icon-file "\"MyApplication.icns\"")
49(defparameter $cfbundle-bundle-identifier-key #@"CFBundleIdentifier")
50(defparameter $default-info-plist-bundle-identifier "\"com.clozure.apps.myapplication\"")
52(defparameter $cfbundle-dictionary-version-key #@"CFBundleInfoDictionaryVersion")
53(defparameter $default-info-dictionary-version "\"6.0\"")
55(defparameter $cfbundle-bundle-name-key #@"CFBundleName")
56(defparameter $default-info-plist-bundle-name "MyApplication")
58(defparameter $cfbundle-bundle-package-type-key #@"CFBundlePackageType")
[9309]59(defparameter $default-info-plist-bundle-package-type "APPL")
61(defparameter $cfbundle-short-version-string-key #@"CFBundleShortVersionString")
62(defparameter $default-info-plist-short-version-string "\"1.0\"")
64(defparameter $cfbundle-bundle-signature-key #@"CFBundleSignature")
[9309]65(defparameter $default-info-plist-bundle-signature "OMCL")
67(defparameter $cfbundle-version-key #@"CFBundleVersion")
68(defparameter $default-info-plist-version "\"1.0\"")
70(defparameter $ls-has-localized-display-name-key #@"LSHasLocalizedDisplayName")
71(defparameter $default-info-plist-has-localized-display-name "0")
73(defparameter $ls-minimum-system-version-key #@"LSMinimumSystemVersion")
74(defparameter $default-info-plist-minimum-system-version "\"10.5\"")
76(defparameter $ns-main-nib-file-key #@"NSMainNibFile")
[9309]77(defparameter $default-info-plist-main-nib-file "MainMenu")
79(defparameter $ns-principal-class-key #@"NSPrincipalClass")
[9309]80(defparameter $default-info-plist-principal-class "LispApplication")
[9827]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")
[13035]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
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)))))
[9309]107;;; COPY-NIBFILE (srcnib dest-directory &key (if-exists :overwrite))
[9348]108;;; ------------------------------------------------------------------------
[9309]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
[7804]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)
[13035]125        (recursive-copy-directory srcnib dest :test #'not-vc-control-file)
[7804]126        (copy-file srcnib dest))))
[7172]128;;; BASENAME path
[9348]129;;; ------------------------------------------------------------------------
[7172]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
[7120]134(defun basename (path)
[9283]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))
[7120]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))
[9283]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)))))))
[7096]154;;; PATH (&rest components)
[9348]155;;; ------------------------------------------------------------------------
[7096]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))))))
169;;; WRITE-PKGINFO path package-type bundle-signature
[9348]170;;; ------------------------------------------------------------------------
[7096]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)))
[9333]182;;; MAKE-INFO-DICT
[9348]183;;; ------------------------------------------------------------------------
[9309]184;;; returns a newly-created NSDictionary with contents
185;;; specified by the input parameters
[9333]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))
[9822]204  (#/dictionaryWithObjectsAndKeys: ns:ns-mutable-dictionary
[9333]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+))
[9827]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))
[15327]235  (declare (ignorable bundlep exportable-as icon-file))
[9827]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  )
[9285]247;;; READ-INFO-PLIST info-path
[9348]248;;; ------------------------------------------------------------------------
[9285]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.")
[11593]258    (let* ((info-path-str (%temp-nsstring (namestring info-path))))
[9285]259      (#/dictionaryWithContentsOfFile: ns:ns-mutable-dictionary 
260                                       info-path-str))))
[9333]262;;; WRITE-INFO-PLIST info-plist path name package-type bundle-signature
[9348]263;;; ------------------------------------------------------------------------
[9333]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.
268(defun write-info-plist (info-dict out-path name package-type bundle-signature
[7098]269                         &key main-nib-name)
[9333]270  ;; change the fields needed, write the results to PATH
[7098]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)
[7096]275  (with-autorelease-pool
[9333]276    (let* ((bundle-name-str (%make-nsstring name))
[7096]277           (type-str (%make-nsstring package-type))
278           (sig-str (%make-nsstring bundle-signature))
[12676]279           (app-name-str (%make-nsstring (bundle-executable-name name)))
[9284]280           (app-plist-path-str (%make-nsstring (namestring out-path))))
[9333]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)
[7098]285      (when main-nib-name
286        (#/setValue:forKey: info-dict 
287                            (%make-nsstring main-nib-name)
[9333]288                            $ns-main-nib-file-key))
[7096]289      (#/writeToFile:atomically: info-dict app-plist-path-str #$YES))))
[9348]291;;; GET-IDE-BUNDLE-PATH
292;;; ------------------------------------------------------------------------
293;;; Returns the llisp pathname of the running IDE bundle
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)))))
303;;; ------------------------------------------------------------------------
304;;; Returns an NSDictionary instance created by reading the Info.plist
305;;; file from the running IDE's application bundle
[9333]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)))
[12676]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")))
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"))
[7096]332;;; MAKE-APPLICATION-BUNDLE name package-type bundle-signature project-path
[9348]333;;; ------------------------------------------------------------------------
[7096]334;;; Build the directory structure of a Cocoa application bundle and
335;;; populate it with the required PkgInfo and Info.plist files.
[9333]336(defun make-application-bundle (&key 
337                                (name $default-application-bundle-name)
338                                (project-path (current-directory)))
[7096]339  (let* ((app-bundle (path project-path 
[9333]340                           (ensure-directory-pathname (concatenate 'string name ".app"))))
[7096]341         (contents-dir (path app-bundle (ensure-directory-pathname "Contents")))
[12676]342         (executable-dir (bundle-executable-path app-bundle))
[7096]343         (rsrc-dir (path contents-dir  "Resources" 
344                         (ensure-directory-pathname "English.lproj"))))
[12676]345    (ensure-directories-exist executable-dir)
[7096]346    (ensure-directories-exist rsrc-dir)
[12703]347    app-bundle))
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")))
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)))))
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)
[15350]377  (let ((private-frameworks #+windows-target (append *cocoa-ide-frameworks*
[12704]378                                                     private-frameworks)
379                            #-windows-target private-frameworks)
380        (frameworks-dir (bundle-frameworks-path app-path)))
381    #+windows-target
[15350]382    (dolist (lib *cocoa-ide-libraries*)
[12704]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)
[13035]391                                    :test #'not-vc-control-file
[12704]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.