Алгоритм простой:
- Если файл/директория есть в src но нет в dest - то он/она копируется в dest.
- Если файл/директория есть в dest но нет в src - то он/она удаляется из dest.
- Если файл есть в src и в dest, но размеры их не совпадают - то файл из src переписывает файл из dest.
- Алгоритм вызывается рекурсивно для всех поддиректорий.
Работает, я считаю, довольно шустро - у меня синхронизация папки 1.4 гб с 53 тыс файлов занимает примерно 10 минут.
;;;; Created on 2009-10-18 13:12:10
(load "F:/Lisp/cl-fad-0.6.3/load.lisp")
(defmacro my-with-gensyms ((&rest names) &body body)
`(let ,(loop for n in names collect `(,n (gensym)))
,@body))
(defmacro exec-time (executions (&body body))
(my-with-gensyms (start end time)
`(progn
(setf ,start (get-internal-real-time))
(loop for i from 1 to ,executions do ,body)
(setf ,end (get-internal-real-time))
(setf ,time (float (/ (- ,end ,start) internal-time-units-per-second)))
,time)
)
)
(defun path-to-str (path)
(format nil "~a" path))
(defun file-len (filepath)
(with-open-file (in filepath) (file-length in)))
(defun dirs-and-files (path)
(let* ((files-dirs (cl-fad:list-directory path))
(dirs (remove-if-not #'cl-fad:directory-pathname-p files-dirs))
(files (remove-if #'cl-fad:directory-pathname-p files-dirs)))
(values dirs files)))
(defun file-name (path)
(let ((ext (pathname-type path)))
(concatenate 'string (pathname-name path)
(if ext (concatenate 'string "." ext)))
))
(defun dir-name (path)
(car (last (pathname-directory path))))
(defun new-deleted-existed (dest-paths src-paths is-files)
(let* ((key-func (if is-files #'file-name #'dir-name))
(new (set-difference src-paths dest-paths
:key key-func :test #'string-equal))
(deleted (set-difference dest-paths src-paths
:key key-func :test #'string-equal))
(existed (intersection src-paths dest-paths
:key key-func :test #'string-equal)))
(values new deleted existed)))
(defun get-relative (base-path full-path)
(let ((base-path-str (path-to-str base-path))
(full-path-str (path-to-str full-path)))
(pathname (subseq full-path-str (length base-path-str)))
))
(defun full-dest-path (base-dest-path base-src-path full-src-path)
(let ((relative (get-relative base-src-path full-src-path)))
(merge-pathnames relative base-dest-path)
))
(defmacro sefe-progn (&body body)
`(handler-case (progn ,@body) (error (r) (format t "~a~%" r))))
(defun synchronize (dest src)
(let ((dest (pathname dest)) (src (pathname src))
(dirs-src nil) (files-src nil) (dirs-dest nil) (files-dest nil)
(new-files nil) (deleted-files nil) (existed-files nil)
(new-dirs nil) (deleted-dirs nil) (existed-dirs nil))
(setf (values dirs-src files-src) (dirs-and-files src))
(setf (values dirs-dest files-dest) (dirs-and-files dest))
(setf (values new-files deleted-files existed-files)
(new-deleted-existed files-dest files-src T))
(setf (values new-dirs deleted-dirs existed-dirs)
(new-deleted-existed dirs-dest dirs-src nil))
(loop for new in new-files
for new-dest = (full-dest-path dest src new)
do (sefe-progn
(format t "Copy FROM ~a TO ~a~%" new new-dest)
(cl-fad:copy-file new new-dest)))
(loop for deleted in deleted-files
do (sefe-progn
(format t "Delete file ~a~%" deleted)
(delete-file deleted)))
(loop for existed in existed-files
for existed-dest = (full-dest-path dest src existed)
do (sefe-progn
(if (/= (file-len existed) (file-len existed-dest))
(progn
(format t "Overwrite FROM ~a TO ~a~%" existed existed-dest)
(cl-fad:copy-file existed existed-dest :overwrite t)))))
(loop for new in new-dirs
for new-dest = (full-dest-path dest src new)
do (sefe-progn
(format t "Create directory ~a~%" new-dest)
(ensure-directories-exist new-dest)
(synchronize new-dest new)))
(loop for deleted in deleted-dirs
do (sefe-progn
(format t "Delete directory ~a~%" deleted)
(cl-fad:delete-directory-and-files deleted)))
(loop for existed in existed-dirs
for existed-dest = (full-dest-path dest src existed)
do (synchronize existed-dest existed))
))
(defun main (args)
(let ((src (if (= 3 (length args))
(nth 1 args) "F:/jFiles/workspaces/tests/file-sync/2"))
(dest (if (= 3 (length args))
(nth 2 args) "F:/jFiles/workspaces/tests/file-sync/1")))
(cl-fad:pathname-as-directory "F:/jFiles/workspaces/tests/file-sync/2")
(format t "Synchronize ~a ==> ~a~%" src dest)
(let ((time
(exec-time 1 (synchronize (cl-fad:pathname-as-directory dest)
(cl-fad:pathname-as-directory src)))))
(format t "Finished [execution time: ~as]" time))
))
(main *posix-argv*)
Теперь небольшая инструкция, как сделать так, чтобы программа заработала.
Для запуска вам понадобиться SBCL и библиотечка cl-fad которую я использовал для упрощения работы с файлами. В программе указан абсолютный путь к библиотеке "F:/Lisp/cl-fad-0.6.3/load.lisp" - необходимо будет заменить его на путь куда вы установите библиотеку. Сохранив код в файл, например sync.lisp, его можно запускать батником, например таким образом: call sbcl --script sync.lisp "F:/jFiles/" "O:/jFiles/". Возможна одна проблема - при запуске программа будет ругаться что библиотека cl-fad якобы откомпилирована более старой версией SBCL. Не пугайтесь - решается просто, надо пойти в директорию установки cl-fad и удалить файл packages.fasl. Тогда при повторном запуске cl-fad будет перекомпилирована.
Осталось добавить батник в планировщик заданий и радоваться жизни)
