[Cl-darcs-cvs] r43 - cl-darcs/trunk

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Fri Oct  6 13:07:36 2006
New Revision: 43

Modified:
   cl-darcs/trunk/util.lisp
Log:
Add copy-directory.


Modified: cl-darcs/trunk/util.lisp
==============================================================================
--- cl-darcs/trunk/util.lisp	(original)
+++ cl-darcs/trunk/util.lisp	Fri Oct  6 13:07:36 2006
@@ -215,3 +215,31 @@
   #+sbcl  (sb-posix:rmdir pathname)
   #-(or clisp sbcl)
   (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type)))
+
+(defun copy-directory (source target &key excluding)
+  "Copy all files and directories in SOURCE to TARGET.
+SOURCE and TARGET are pathnames designating directories, both of
+which must exist.  EXCLUDING is a list of files and directories
+to exclude.
+
+Symlinks will confuse the function."
+  (setq excluding (mapcar #'truename excluding))
+  (let* ((wild (make-pathname :directory '(:relative :wild-inferiors)
+			      :name :wild
+			      :type :wild
+			      :version :wild))
+	 (source-wild (merge-pathnames wild source))
+	 (target-wild (merge-pathnames wild target))
+
+	 (files (fad:list-directory (truename source))))
+    (dolist (source-file files)
+      (let ((target-file (translate-pathname source-file source-wild target-wild)))
+	(cond
+	  ((member source-file excluding :test #'equal)
+	   ;; File excluded - do nothing.
+	   )
+	  ((fad:directory-pathname-p source-file)
+	   (make-dir target-file)
+	   (copy-directory source-file target-file))
+	  (t
+	   (fad:copy-file source-file target-file)))))))