Skip to content
Snippets Groups Projects
Commit 997bd37e authored by kaz's avatar kaz
Browse files

* code/grab.lisp (move-candidates): Function renamed to

determine-moved-files.
(determine-moved-symlinks): New function, doesn't do anything
yet.
(mcvs-grab): Updated to process symlinks and use new
mapping-entry structure.
parent a40e5e5e
No related merge requests found
2002-08-31 Kaz Kylheku <kaz@ashi.footprints.net>
* code/grab.lisp (move-candidates): Function renamed to
determine-moved-files.
(determine-moved-symlinks): New function, doesn't do anything
yet.
(mcvs-grab): Updated to process symlinks and use new
mapping-entry structure.
2002-08-26 Kaz Kylheku <kaz@ashi.footprints.net>
* code/remap.lisp (mcvs-remap): Use new mapping entry structure.
......
......@@ -106,7 +106,7 @@
(remhash key (second file)))))
(second file))))
(defun move-candidates (added-files removed-files)
(defun determine-moved-files (added-files removed-files)
(let (pairs candidates taken-added taken-removed)
(dolist (added added-files)
(dolist (removed removed-files)
......@@ -128,6 +128,10 @@
(set-difference added-files taken-added :test #'eq)
(set-difference removed-files taken-removed :test #'eq))))
(defun determine-moved-symlinks (added-symlinks removed-symlinks moved-files)
(declare (ignore moved-files))
(values nil added-symlinks removed-symlinks))
(defun mcvs-grab (global-options command-options module subdir)
(find-bind (:test #'string= :key #'first)
((branch "r") (trunk "A"))
......@@ -140,38 +144,54 @@
`(("d" ,*this-dir*) ,@(if branch (list branch)))
:no-generate t)
(in-sandbox-root-dir
(let ((old-paths (mapping-read *mcvs-map*))
invisible-old-paths new-paths added-files removed-files stable-files)
(let ((mapping (mapping-read *mcvs-map*))
invisible-old-paths old-paths
old-file-paths new-file-paths
old-symlink-paths new-symlink-paths
added-files removed-files stable-files
added-symlinks removed-symlinks stable-symlinks)
(chatter-info "Scanning directory structure.~%")
(multiple-value-setq (old-paths invisible-old-paths)
(separate-if #'real-path-exists old-paths
:key #'second))
(setf old-paths (mapcar #'(lambda (entry)
(destructuring-bind (object name &rest stuff)
entry
(list* object (abstract-to-real-path name)
stuff))) old-paths))
(separate-if #'real-path-exists mapping
:key #'mapping-entry-path))
(dolist (entry old-paths)
(with-slots (path) entry
(setf path (abstract-to-real-path path))))
(multiple-value-setq (old-file-paths old-symlink-paths)
(separate :file old-paths
:test #'eq
:key #'mapping-entry-kind))
(for-each-file-info (fi *this-dir*)
(let* ((path (canonicalize-path (file-name fi))))
(cond
((regular-p fi)
(push path new-paths))
(push path new-file-paths))
((symlink-p fi)
(push path new-symlink-paths))
((directory-p fi)
(when (path-equal path *mcvs-dir*)
(skip))))))
(multiple-value-setq (stable-files removed-files added-files)
(intersection-difference old-paths new-paths
:key1 #'second
(intersection-difference old-file-paths
new-file-paths
:key1 #'mapping-entry-path
:test #'equal))
(multiple-value-setq (stable-symlinks removed-symlinks added-symlinks)
(intersection-difference old-symlink-paths
new-symlink-paths
:key1 #'mapping-entry-path
:test #'equal))
(cond
((or (null added-files) (null removed-files))
(setf added-files (mapcar #'(lambda (name) (list name)) added-files))
(setf removed-files (mapcar #'(lambda (map-entry)
(destructuring-bind (f-file path)
map-entry
(list path nil f-file)))
(setf removed-files (mapcar #'(lambda (entry)
(with-slots (id path) entry
(list path nil id)))
removed-files)))
(t (chatter-terse "Analyzing ~a added files.~%" (length added-files))
(setf added-files (mapcar #'(lambda (name)
......@@ -179,12 +199,10 @@
added-files))
(chatter-terse "Analyzing ~a removed files.~%" (length removed-files))
(setf removed-files (mapcar #'(lambda (map-entry)
(destructuring-bind (f-file path)
map-entry
(list path
(word-hash-file f-file)
f-file)))
(setf removed-files (mapcar #'(lambda (entry)
(with-slots (id path) entry
(list path
(word-hash-file id) id)))
removed-files))
(let ((common-word-hash (make-hash-table :test #'equalp)))
(determine-common-words common-word-hash added-files)
......@@ -194,44 +212,78 @@
(eliminate-common-words common-word-hash added-files threshold)
(eliminate-common-words common-word-hash removed-files threshold)))
(chatter-terse "Determining move candidates.~%")))
(multiple-value-bind (moved-files added-files removed-files)
(if (or (null added-files) (null removed-files))
(values nil added-files removed-files)
(move-candidates added-files removed-files))
(let ((mapping (mapping-read *mcvs-map*))
(f-hash (make-hash-table :test #'equal)))
(when moved-files
(dolist (pair moved-files)
(destructuring-bind ((target-name hash-2)
(source-name hash-1 f-file) confidence)
pair
(declare (ignore hash-1 hash-2))
(chatter-terse "moving ~a -> ~a (confidence ~a%)~%"
source-name target-name (round (* confidence 100)))
(setf (gethash f-file f-hash) target-name)))
(setf mapping
(mapcar #'(lambda (entry)
(let ((replacement (gethash (first entry)
f-hash)))
(if replacement
(list (first entry)
(real-to-abstract-path replacement))
entry)))
mapping))
(mapping-write mapping *mcvs-map*)
(dolist (entry mapping)
(when (gethash (first entry) f-hash)
(unlink (first entry))
(link (abstract-to-real-path (second entry)) (first entry)))))
(mapping-write mapping *mcvs-map-local*)
(dolist (entry stable-files)
(unlink (first entry))
(link (second entry) (first entry))))
(when removed-files
(mcvs-remove nil (mapcar #'first removed-files) :no-sync t))
(when added-files
(mcvs-add nil global-options nil (mapcar #'first added-files))))))))
(determine-moved-files added-files
removed-files))
(when added-symlinks
(chatter-terse "Reading ~a added symbolic links.~%"
(length added-symlinks))
(setf added-symlinks (mapcar #'(lambda (path)
(list path (readlink path)))
added-symlinks)))
(multiple-value-bind (moved-symlinks added-symlinks removed-symlinks)
(if (or (null added-symlinks)
(null removed-symlinks))
(values nil added-symlinks removed-symlinks)
(determine-moved-symlinks added-symlinks
removed-symlinks
moved-files))
(let ((f-hash (make-hash-table :test #'equal))
(mapping (mapping-read *mcvs-map*)))
(when (or moved-files moved-symlinks)
(dolist (pair moved-files)
(destructuring-bind ((target-name hash-2)
(source-name hash-1 f-file) confidence)
pair
(declare (ignore hash-1 hash-2))
(chatter-terse "moving ~a -> ~a (confidence ~a%)~%"
source-name target-name (round (* confidence 100)))
(setf (gethash f-file f-hash) target-name)))
(dolist (pair moved-symlinks)
(destructuring-bind ((target-name symlink-target)
source-entry) pair
(declare (ignore symlink-target))
(with-slots (id (source-name path)) source-entry
(chatter-terse "moving symlink ~a -> ~a~%"
source-name target-name)
(setf (gethash id f-hash) target-name))))
(mapc #'(lambda (entry)
(with-slots (id path) entry
(let ((replacement (gethash id f-hash)))
(if replacement
(setf path
(real-to-abstract-path replacement))))))
mapping)
(mapping-write mapping *mcvs-map*)
(dolist (entry mapping)
(with-slots (kind id path) entry
(when (and (gethash id f-hash) (eq kind :file))
(unlink id)
(link (abstract-to-real-path path) id))))
(mapping-write mapping *mcvs-map-local*))
(dolist (entry stable-files)
(with-slots (kind id path) entry
(when (eq kind :file)
(unlink id)
(link path id)))))
(when removed-files
(mcvs-remove nil (mapcar #'first removed-files) :no-sync t))
(when removed-symlinks
(mcvs-remove nil (mapcar #'mapping-entry-path removed-symlinks)
:no-sync t))
(when added-files
(mcvs-add nil global-options
nil (mapcar #'first added-files)))
(when added-symlinks
(mcvs-add nil global-options
nil (mapcar #'first added-symlinks)))))))))
(defun mcvs-grab-wrapper (global-options command-options args)
(flet ((error ()
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment