ViewVC logotype

Diff of /meta-cvs/F-FA1826D235E55390A70DEBE51DC3234B.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision by kaz, Sat Jul 6 16:13:41 2002 UTC revision 1.13 by kaz, Tue Nov 28 07:47:22 2006 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
5  (require "dirwalk")  (in-package :meta-cvs)
 (require "mapping")  
 (provide "remap")  
7  (defun mcvs-remap ()  (defun remap ()
8    (in-sandbox-root-dir    (in-sandbox-root-dir
9      (let* ((old-mapping (mapping-read *mcvs-map-local*))      (let* ((old-mapping (mapping-read *map-local-path*))
10             (cvs-mapping (mapping-read *mcvs-map*))             (cvs-mapping (mapping-read *map-path*))
11             (inode-hash (make-hash-table :test #'eql))             (inode-hash (make-hash-table :test #'eql))
12             (new-mapping (remove-if #'real-path-exists             (new-mapping (remove-if #'(lambda (entry)
13                                     old-mapping :key #'second)))                                         (with-slots (path kind) entry
14                                             (and (eq kind :file)
15                                                  (real-path-exists path))))
16                                       old-mapping)))
17        (restart-case        (restart-case
18          (when (not (equal old-mapping cvs-mapping))          (when (not (equal-filemaps old-mapping cvs-mapping))
19            (error "mcvs-remap: local and repository mappings differ."))            (error "local and repository mappings differ."))
20          (ignore () :report "remap anyway, clobbering repository mapping"))          (continue () :report "remap anyway, clobbering repository mapping"))
21        (dolist (entry old-mapping)        (dolist (entry old-mapping)
22          (let ((file-info (stat (first entry))))          (with-slots (id kind) entry
23            (setf (gethash (inode file-info) inode-hash) (first entry))))            (when (eq kind :file)
24                (let ((file-info (no-existence-error (stat id))))
25                  (unless file-info
26                    (restart-case
27                      (error "~a does not exist." id)
28                      (continue () :report "Remove it from the map.")))
29                  (when file-info
30                    (setf (gethash (inode file-info) inode-hash) entry))))))
31        (for-each-file-info (fi ".")        (for-each-file-info (fi ".")
32          (let* ((path (canonicalize-path (file-name fi)))          (let* ((path (canonicalize-path (file-name fi)))
33                 (abs-path (real-to-abstract-path path)))                 (abs-path (real-to-abstract-path path)))
34            (cond            (cond
35              ((regular-p fi)              ((regular-p fi)
36                (let ((f-file (gethash (inode fi) inode-hash)))                (let ((entry (gethash (inode fi) inode-hash)))
37                  (when f-file                  (when entry
38                    (push (list f-file abs-path) new-mapping)                    (let ((new-entry (copy-mapping-entry entry)))
39                    (setf (gethash (inode fi) inode-hash) nil))))                      (setf (mapping-entry-executable new-entry)
40                              (executable-p fi))
41                        (setf (mapping-entry-path new-entry) abs-path)
42                        (push new-entry new-mapping)
43                        (setf (gethash (inode fi) inode-hash) nil)))))
44                ((symlink-p fi)
45                  (chatter-info "skipping symbolic link ~a.~%" path))
46              ((directory-p fi)              ((directory-p fi)
47                (when (path-equal path *mcvs-dir*)                (when (path-equal path *admin-dir*)
48                  (skip))))))                  (skip))))))
49        (mapping-write new-mapping *mcvs-map-local* :sort-map t)        (mapping-write new-mapping *map-local-path* :sort-map t)
50        (mapping-write new-mapping *mcvs-map* :sort-map t))))        (mapping-write new-mapping *map-path* :sort-map t))))
52  (defun mcvs-remap-wrapper (global-options command-options args)  (defun remap-wrapper (global-options command-options args)
53    (declare (ignore global-options command-options))    (declare (ignore global-options command-options))
54    (when args    (when args
55      (error "mcvs-remap: command takes no arguments."))      (error "command takes no arguments."))
56    (mcvs-remap))    (remap))

Removed from v.  
changed lines
  Added in v.1.13

  ViewVC Help
Powered by ViewVC 1.1.5