[Openmcl-cvs-notifications] r7494 - in /trunk/ccl: cocoa-ide/build-application.lisp cocoa-ide/builder-utilities.lisp level-1/l1-files.lisp lib/pathnames.lisp
gz at clozure.com
gz at clozure.com
Mon Oct 22 13:59:23 MDT 2007
Author: gz
Date: Mon Oct 22 15:59:23 2007
New Revision: 7494
Log:
Moved some non-cocoa pathname utilities out of cocoa-ide to core lisp:
ensure-directory-pathname converts a pathname to be directory-pathname-p
recursive-copy-directory copies directory and all subdirectories
Tweaked them some to make them more general, in particular made them work
on logical pathnames, made the latter accept a :test arg and a limited set
of :if-exists values. The default is now :if-exists :error.
Modified:
trunk/ccl/cocoa-ide/build-application.lisp
trunk/ccl/cocoa-ide/builder-utilities.lisp
trunk/ccl/level-1/l1-files.lisp
trunk/ccl/lib/pathnames.lisp
Modified: trunk/ccl/cocoa-ide/build-application.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/ccl/cocoa-ide/build-application.lisp (original)
+++ trunk/ccl/cocoa-ide/build-application.lisp Mon Oct 22 15:59:23 2007
@@ -69,7 +69,8 @@
=
;; copy IDE resources into the application bundle
(recursive-copy-directory (path ide-bundle-path "Contents" "Resources/=
")
- (path app-bundle "Contents" "Resources/"))
+ (path app-bundle "Contents" "Resources/")
+ :if-exists :overwrite)
;; copy user-supplied nibfiles into the bundle
(when nibfiles
(let ((nib-paths (mapcar #'pathname nibfiles)))
@@ -85,7 +86,7 @@
(let ((dest (path app-bundle "Contents" "Resources" "English.lp=
roj/" (namestring (basename n)))))
(if (probe-file dest)
(error "The destination nibfile '~A' already exists" dest)
- (recursive-copy-directory n dest))))))
+ (recursive-copy-directory n dest :if-exists :overwrite))))=
))
;; save the application image
(save-application image-path
:application-class application-class
Modified: trunk/ccl/cocoa-ide/builder-utilities.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/ccl/cocoa-ide/builder-utilities.lisp (original)
+++ trunk/ccl/cocoa-ide/builder-utilities.lisp Mon Oct 22 15:59:23 2007
@@ -27,26 +27,6 @@
main-nib-name
app)
app))
-
-;;; PATHNAME-SEPARATOR
-;;; returns the character used to separate elements of a pathname
-;;; on this platform. =
-;;; TODO: add conditional compiles to support platforms where
-;;; the path separator is not "/" (if we ever care about that) =
-(defun pathname-separator () #\/)
-
-;;; ENSURE-DIRECTORY-PATHNAME p
-;;; Returns the input pathname P, but ensures that it ends with a
-;;; path separator, so that it will be parsed as a directory
-(defmethod ensure-directory-pathname ((p string))
- (let ((pstr (namestring p)))
- (if (char=3D (pathname-separator)
- (elt pstr (1- (length pstr))))
- p
- (pathname (concatenate 'string p (string (pathname-separator)))))))
-
-(defmethod ensure-directory-pathname ((p pathname)) =
- (ensure-directory-pathname (namestring p)))
=
;;; BASENAME path
;;; returns the final component of a pathname--that is, the
@@ -81,34 +61,6 @@
(merge-pathnames (apply #'path (cdr components))
(ensure-directory-pathname (car components))))))
=
-
-;;; RECURSIVE-COPY-DIRECTORY source-path dest-path
-;;; Copies the contents of the SOURCE-PATH to the DEST-PATH.
-;;;
-;;; TODO: - add an ignore-list ability, so I can prevent
-;;; this function from copying CVS and .svn directories
-;;; - add some flags to control what do do if the dest
-;;; already exists, and that sort of thing. Currently,
-;;; this function just clobbers naything that is already
-;;; in DEST-PATH
-(defun recursive-copy-directory (source-path dest-path)
- (ensure-directories-exist (ensure-directory-pathname dest-path))
- (let ((files (directory (path source-path "*.*") :directories nil :files=
t))
- (subdirs (directory (path source-path "*.*") :directories t :files=
nil)))
-; (format t "~%files =3D ~S" files)
-; (format t "~%subdirs =3D ~S~%" subdirs)
- (dolist (f files)
- (let* ((src-name (file-namestring f))
- (dest-file (path dest-path src-name)))
- (ccl:copy-file f dest-file
- :if-exists :supersede
- :preserve-attributes t)))
- (dolist (d subdirs)
- (let* ((subdir-name (first (last (pathname-directory d))))
- (dest-dir (ensure-directory-pathname (path dest-path subdir-n=
ame))))
- (recursive-copy-directory d dest-dir)))
- dest-path
- ))
=
;;; WRITE-PKGINFO path package-type bundle-signature
;;; Writes a PkgInfo file of the sort used by Cocoa applications
@@ -150,9 +102,8 @@
(sig-str (%make-nsstring bundle-signature))
(ide-bundle (#/mainBundle ns:ns-bundle))
(ide-bundle-path-nsstring (#/bundlePath ide-bundle))
- (ide-bundle-path (pathname =
- (ensure-directory-pathname =
- (lisp-string-from-nsstring ide-bundle-path-n=
sstring))))
+ (ide-bundle-path (ensure-directory-pathname =
+ (lisp-string-from-nsstring ide-bundle-path-nsstring)))
(ide-plist-path-str (namestring (path ide-bundle-path =
"Contents" "Info.plist")))
(info-dict (#/dictionaryWithContentsOfFile: ns:ns-mutable-dicti=
onary =
Modified: trunk/ccl/level-1/l1-files.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/ccl/level-1/l1-files.lisp (original)
+++ trunk/ccl/level-1/l1-files.lisp Mon Oct 22 15:59:23 2007
@@ -311,11 +311,25 @@
(neq (pathname-host path) :unspecific)))
=
(defun ensure-directory-namestring (string)
- (let* ((len (length string)))
- (if (and (> len 1)
- (not (eql (char string (1- len)) #\/)))
- (concatenate 'string string "/")
- string)))
+ (namestring (ensure-directory-pathname string)))
+
+(defun ensure-directory-pathname (pathname)
+ (let ((path (pathname pathname)))
+ (if (directory-pathname-p path)
+ path
+ (cons-pathname (append (or (pathname-directory path)
+ ;; This makes sure "ccl:foo" maps to "ccl:foo;" (not
+ ;; "ccl:;foo;"), but "foo" maps to "foo/" (not "/foo/").
+ (if (eq (pathname-host path) :unspecific)
+ '(:relative)
+ '(:absolute)))
+ ;; Don't use file-namestring, because that
+ ;; includes the version for logical names.
+ (list (file-namestring-from-parts
+ (pathname-name path)
+ (pathname-type path)
+ nil)))
+ nil nil (pathname-host path)))))
=
(defun %directory-list-namestring (list &optional logical-p)
(if (null list)
Modified: trunk/ccl/lib/pathnames.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/ccl/lib/pathnames.lisp (original)
+++ trunk/ccl/lib/pathnames.lisp Mon Oct 22 15:59:23 2007
@@ -129,6 +129,31 @@
(error "Error copying ~s to ~s: ~a"
source-path dest-path (%strerror exit-code)))
(values new-name original (truename new-name))))))
+
+(defun recursive-copy-directory (source-path dest-path &key test (if-exist=
s :error))
+ ;; TODO: Support :if-exists :supersede to blow away any files not in sou=
rce dir
+ (setq if-exists (require-type if-exists '(member :overwrite :error)))
+ (setq dest-path (ensure-directory-pathname dest-path))
+ (when (eq if-exists :error)
+ (when (probe-file dest-path)
+ (if-exists if-exists dest-path))
+ ;; Skip the probe-file in recursive calls, already know ok.
+ (setq if-exists :overwrite))
+ (let* ((source-dir (ensure-directory-pathname source-path))
+ (pattern (make-pathname :name :wild :type :wild :defaults source-dir))
+ (source-files (directory pattern :test test :directories t :files t)))
+ (ensure-directories-exist dest-path)
+ (dolist (f source-files)
+ (when (or (null test) (funcall test f))
+ (if (directory-pathname-p f)
+ (let ((dest-file (make-pathname :name (first (last (pathname-director=
y f)))
+ :defaults dest-path)))
+ (recursive-copy-directory f dest-file :test test :if-exists if-exis=
ts))
+ (let* ((dest-file (make-pathname :name (pathname-name f)
+ :type (pathname-type f)
+ :defaults dest-path)))
+ (copy-file f dest-file :if-exists :supersede :preserve-attributes t=
)))))))
+
=
=
;;; It's not clear that we can support anything stronger than
More information about the Openmcl-cvs-notifications
mailing list