copy-directory.lisp

(defpackage #:snippets/copy-directory
  (:use #:cl)
  (:import-from #:alexandria
                #:copy-file)
  (:import-from #:cl-fad
                #:walk-directory
                #:pathname-as-directory))

(in-package #:snippets/copy-directory)

;;
;; What about:
;;
;; - symbolic links? ;
;; - empty directories? ;
;; - helpful restarts? ;
;; - generalizing the walk?
;;
(defun copy-directory (source-directory target-directory)
  "Copy all files in `source-directory' to `target-directory'; also
ensure `target-directory' exists before copying."
  (setf source-directory (pathname-as-directory source-directory)
        target-directory (pathname-as-directory target-directory))
  (labels ((directory-diff (base derivative)
             (let ((pos (mismatch base derivative :test #'equal)))
               (if pos (cons :relative (nthcdr pos derivative)) '())))
           (source->target (pathname)
             (merge-pathnames
              (make-pathname
               :name (pathname-name pathname)
               :type (pathname-type pathname)
               :directory (directory-diff
                           (pathname-directory source-directory)
                           (pathname-directory pathname)))
              target-directory)))
    (ensure-directories-exist target-directory)
    (walk-directory
     source-directory
     (lambda (source-pathname)
       (let ((target-pathname (source->target source-pathname)))
         (ensure-directories-exist target-pathname)
         (copy-file source-pathname target-pathname)))))
  (values))