Changeset 8174


Ignore:
Timestamp:
Jan 17, 2008, 3:07:06 PM (12 years ago)
Author:
gb
Message:

(Mikel ?)'s changes to RECURSIVE-COPY-DIRECTORY et al (from trunk.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/1.2/devel/source/lib/pathnames.lisp

    r7737 r8174  
    133133(defun recursive-copy-directory (source-path dest-path &key test (if-exists :error))
    134134  ;; TODO: Support :if-exists :supersede to blow away any files not in source dir
     135  (assert (directoryp source-path)(source-path)
     136          "source-path is not a directory in RECURSIVE-COPY-DIRECTORY")
    135137  (setq if-exists (require-type if-exists '(member :overwrite :error)))
    136138  (setq dest-path (ensure-directory-pathname dest-path))
     
    138140    (when (probe-file dest-path)
    139141      (if-exists if-exists dest-path))
    140     ;; Skip the probe-file in recursive calls, already know ok.
     142    ;; Skip the probe-file in recursive calls, we already know it's ok.
    141143    (setq if-exists :overwrite))
    142144  (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        (pattern (make-pathname :name :wild :type :wild :defaults source-dir))
     146        (source-files (directory pattern :test test :directories t :files t)))
    145147    (ensure-directories-exist dest-path)
    146148    (dolist (f source-files)
    147149      (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)))))))
     150        (if (directory-pathname-p f)
     151            (let ((dest-file (make-pathname :name (first (last (pathname-directory f)))
     152                                            :defaults dest-path)))
     153              (recursive-copy-directory f dest-file :test test :if-exists if-exists))
     154            (let* ((dest-file (make-pathname :name (pathname-name f)
     155                                             :type (pathname-type f)
     156                                             :defaults dest-path)))
     157              (copy-file f dest-file :if-exists :supersede :preserve-attributes t)))))))
    156158
    157159;;; use with caution!
Note: See TracChangeset for help on using the changeset viewer.