Commit 5657f989386ba494a8bac8ed618c141cc4bd6b87
2013-08-06T15:26:50
fix file-more-recent-p and copy-files
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
diff --git a/files.lisp b/files.lisp
index e0e8568..8141e4c 100644
--- a/files.lisp
+++ b/files.lisp
@@ -103,8 +103,9 @@
(defun file-more-recent-p (a b)
"Return T if A is more recent than B according to FILE-WRITE-DATE.
Return NIL otherwise."
- (when (cl-fad:file-exists-p a)
- (> (file-write-date a) (file-write-date b))))
+ (or (not (file-exists-p b))
+ (and (file-exists-p a)
+ (> (file-write-date a) (file-write-date b)))))
(defun directories (list)
(declare (type list list))
@@ -117,25 +118,32 @@ Return NIL otherwise."
(defun copy-files (from to &key replace update exclude rename)
(ensure-directories-exist to)
- (mapcan
- (lambda (src)
- (let* ((src (enough-namestring src))
- (name (make-pathname :name (pathname-name src)
- :type (pathname-type src))))
- (unless (etypecase exclude
- (sequence (member name exclude :test #'pathname-match-p))
- (function (funcall exclude name))
- (null nil))
- (let* ((renamed (etypecase rename
- (list (cdr (assoc name rename
- :test #'pathname-match-p)))
- (function (funcall rename (format nil "~A" name)))
- (null nil)))
- (dest (merge-pathnames (or renamed name) to)))
- (unless (and update (file-more-recent-p dest src))
- (cl-fad:copy-file src dest :overwrite replace))
- `(,dest)))))
- (directory from)))
+ (let (copied updated)
+ (dolist (src (directory from))
+ (let* ((src (enough-namestring src))
+ (name (make-pathname :name (pathname-name src)
+ :type (pathname-type src))))
+ (unless (etypecase exclude
+ (sequence (member name exclude :test #'pathname-match-p))
+ (function (funcall exclude name))
+ (null nil))
+ (let ((dest (if (pathname-name to)
+ to
+ (let ((renamed
+ (etypecase rename
+ (list (cdr
+ (assoc name rename
+ :test #'pathname-match-p)))
+ (function (funcall rename
+ (format nil "~A" name)))
+ (null nil))))
+ (merge-pathnames (or renamed name) to)))))
+ (unless (and update (not (file-more-recent-p src dest)))
+ (cl-fad:copy-file src dest :overwrite (or replace update))
+ (push dest updated))
+ (push dest copied)))))
+ (values (nreverse copied) (nreverse updated))))
+
;; Regex
diff --git a/lowh.triangle.files.asd b/lowh.triangle.files.asd
index bb9a8a1..a127334 100644
--- a/lowh.triangle.files.asd
+++ b/lowh.triangle.files.asd
@@ -27,6 +27,7 @@
:version "0.1"
:description "Pathname, files and streams utility library"
:depends-on ("alexandria"
- "cl-fad")
+ "cl-fad"
+ "cl-ppcre")
:components
((:file "files")))