Changeset 7494


Ignore:
Timestamp:
Oct 22, 2007, 7:59:23 PM (14 years ago)
Author:
gz
Message:

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.

Location:
trunk/ccl
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/cocoa-ide/build-application.lisp

    r7351 r7494  
    7070    ;; copy IDE resources into the application bundle
    7171    (recursive-copy-directory (path ide-bundle-path "Contents" "Resources/")
    72                               (path app-bundle  "Contents" "Resources/"))
     72                              (path app-bundle  "Contents" "Resources/")
     73                              :if-exists :overwrite)
    7374    ;; copy user-supplied nibfiles into the bundle
    7475    (when nibfiles
     
    8687            (if (probe-file dest)
    8788                (error "The destination nibfile '~A' already exists" dest)
    88                 (recursive-copy-directory n dest))))))
     89                (recursive-copy-directory n dest :if-exists :overwrite))))))
    8990    ;; save the application image
    9091    (save-application image-path
  • trunk/ccl/cocoa-ide/builder-utilities.lisp

    r7352 r7494  
    2828                   app)
    2929         app))
    30 
    31 ;;; PATHNAME-SEPARATOR
    32 ;;; returns the character used to separate elements of a pathname
    33 ;;; on this platform.
    34 ;;; TODO: add conditional compiles to support platforms where
    35 ;;;       the path separator is not "/" (if we ever care about that)
    36 (defun pathname-separator () #\/)
    37 
    38 ;;; ENSURE-DIRECTORY-PATHNAME p
    39 ;;; Returns the input pathname P, but ensures that it ends with a
    40 ;;; path separator, so that it will be parsed as a directory
    41 (defmethod ensure-directory-pathname ((p string))
    42   (let ((pstr (namestring p)))
    43     (if (char= (pathname-separator)
    44                (elt pstr (1- (length pstr))))
    45         p
    46         (pathname (concatenate 'string p (string (pathname-separator)))))))
    47 
    48 (defmethod ensure-directory-pathname ((p pathname))
    49   (ensure-directory-pathname (namestring p)))
    5030
    5131;;; BASENAME path
     
    8262                           (ensure-directory-pathname (car components))))))
    8363
    84 
    85 ;;; RECURSIVE-COPY-DIRECTORY source-path dest-path
    86 ;;; Copies the contents of the SOURCE-PATH to the DEST-PATH.
    87 ;;;
    88 ;;; TODO: - add an ignore-list ability, so I can prevent
    89 ;;;         this function from copying CVS and .svn directories
    90 ;;;       - add some flags to control what do do if the dest
    91 ;;;         already exists, and that sort of thing. Currently,
    92 ;;;         this function just clobbers naything that is already
    93 ;;;         in DEST-PATH
    94 (defun recursive-copy-directory (source-path dest-path)
    95   (ensure-directories-exist (ensure-directory-pathname dest-path))
    96   (let ((files (directory (path source-path "*.*") :directories nil :files t))
    97         (subdirs (directory (path source-path "*.*") :directories t :files nil)))
    98 ;    (format t "~%files = ~S" files)
    99 ;    (format t "~%subdirs = ~S~%" subdirs)
    100     (dolist (f files)
    101       (let* ((src-name (file-namestring f))
    102              (dest-file (path dest-path src-name)))
    103         (ccl:copy-file f dest-file
    104                        :if-exists :supersede
    105                        :preserve-attributes t)))
    106     (dolist (d subdirs)
    107       (let* ((subdir-name (first (last (pathname-directory d))))
    108              (dest-dir (ensure-directory-pathname (path dest-path subdir-name))))
    109         (recursive-copy-directory d dest-dir)))
    110     dest-path
    111     ))
    11264
    11365;;; WRITE-PKGINFO path package-type bundle-signature
     
    151103           (ide-bundle (#/mainBundle ns:ns-bundle))
    152104           (ide-bundle-path-nsstring (#/bundlePath ide-bundle))
    153            (ide-bundle-path (pathname
    154                              (ensure-directory-pathname
    155                               (lisp-string-from-nsstring ide-bundle-path-nsstring))))
     105           (ide-bundle-path (ensure-directory-pathname
     106                             (lisp-string-from-nsstring ide-bundle-path-nsstring)))
    156107           (ide-plist-path-str (namestring (path ide-bundle-path
    157108                                                 "Contents" "Info.plist")))
  • trunk/ccl/level-1/l1-files.lisp

    r7455 r7494  
    312312
    313313(defun ensure-directory-namestring (string)
    314   (let* ((len (length string)))
    315     (if (and (> len 1)
    316              (not (eql (char string (1- len)) #\/)))
    317       (concatenate 'string string "/")
    318       string)))
     314  (namestring (ensure-directory-pathname string)))
     315
     316(defun ensure-directory-pathname (pathname)
     317  (let ((path (pathname pathname)))
     318    (if (directory-pathname-p path)
     319        path
     320        (cons-pathname (append (or (pathname-directory path)
     321                                   ;; This makes sure "ccl:foo" maps to "ccl:foo;" (not
     322                                   ;; "ccl:;foo;"), but "foo" maps to "foo/" (not "/foo/").
     323                                   (if (eq (pathname-host path) :unspecific)
     324                                       '(:relative)
     325                                       '(:absolute)))
     326                               ;; Don't use file-namestring, because that
     327                               ;; includes the version for logical names.
     328                               (list (file-namestring-from-parts
     329                                      (pathname-name path)
     330                                      (pathname-type path)
     331                                      nil)))
     332                       nil nil (pathname-host path)))))
    319333
    320334(defun %directory-list-namestring (list &optional logical-p)
  • trunk/ccl/lib/pathnames.lisp

    r7272 r7494  
    130130                 source-path dest-path (%strerror exit-code)))
    131131        (values new-name original (truename new-name))))))
     132
     133(defun recursive-copy-directory (source-path dest-path &key test (if-exists :error))
     134  ;; TODO: Support :if-exists :supersede to blow away any files not in source dir
     135  (setq if-exists (require-type if-exists '(member :overwrite :error)))
     136  (setq dest-path (ensure-directory-pathname dest-path))
     137  (when (eq if-exists :error)
     138    (when (probe-file dest-path)
     139      (if-exists if-exists dest-path))
     140    ;; Skip the probe-file in recursive calls, already know ok.
     141    (setq if-exists :overwrite))
     142  (let* ((source-dir (ensure-directory-pathname source-path))
     143         (pattern (make-pathname :name :wild :type :wild :defaults source-dir))
     144         (source-files (directory pattern :test test :directories t :files t)))
     145    (ensure-directories-exist dest-path)
     146    (dolist (f source-files)
     147      (when (or (null test) (funcall test f))
     148        (if (directory-pathname-p f)
     149            (let ((dest-file (make-pathname :name (first (last (pathname-directory f)))
     150                                            :defaults dest-path)))
     151              (recursive-copy-directory f dest-file :test test :if-exists if-exists))
     152            (let* ((dest-file (make-pathname :name (pathname-name f)
     153                                             :type (pathname-type f)
     154                                             :defaults dest-path)))
     155              (copy-file f dest-file :if-exists :supersede :preserve-attributes t)))))))
     156
    132157
    133158
Note: See TracChangeset for help on using the changeset viewer.