/[meta-cvs]/meta-cvs/F-FA1826D235E55390A70DEBE51DC3234B.lisp
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Sat Jul 6 17:15:02 2002 UTC (11 years, 9 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-20, symlink-branch~branch-point, mcvs-0-21, mcvs-0-19, mcvs-0-18
Branch point for: symlink-branch
Changes since 1.2: +8 -6 lines
Merging from partial-sandbox-branch.
1 kaz 1.1 ;;; This source file is part of the Meta-CVS program,
2     ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5     (require "dirwalk")
6     (require "mapping")
7     (provide "remap")
8    
9     (defun mcvs-remap ()
10     (in-sandbox-root-dir
11 kaz 1.3 (let* ((old-mapping (mapping-read *mcvs-map-local*))
12     (cvs-mapping (mapping-read *mcvs-map*))
13     (inode-hash (make-hash-table :test #'eql))
14     (new-mapping (remove-if #'real-path-exists
15     old-mapping :key #'second)))
16 kaz 1.2 (restart-case
17     (when (not (equal old-mapping cvs-mapping))
18     (error "mcvs-remap: local and repository mappings differ."))
19     (ignore () :report "remap anyway, clobbering repository mapping"))
20 kaz 1.1 (dolist (entry old-mapping)
21     (let ((file-info (stat (first entry))))
22     (setf (gethash (inode file-info) inode-hash) (first entry))))
23     (for-each-file-info (fi ".")
24 kaz 1.3 (let* ((path (canonicalize-path (file-name fi)))
25     (abs-path (real-to-abstract-path path)))
26 kaz 1.1 (cond
27     ((regular-p fi)
28     (let ((f-file (gethash (inode fi) inode-hash)))
29     (when f-file
30 kaz 1.3 (push (list f-file abs-path) new-mapping)
31 kaz 1.1 (setf (gethash (inode fi) inode-hash) nil))))
32     ((directory-p fi)
33     (when (path-equal path *mcvs-dir*)
34     (skip))))))
35     (mapping-write new-mapping *mcvs-map-local* :sort-map t)
36     (mapping-write new-mapping *mcvs-map* :sort-map t))))
37    
38     (defun mcvs-remap-wrapper (global-options command-options args)
39     (declare (ignore global-options command-options))
40     (when args
41     (error "mcvs-remap: command takes no arguments."))
42     (mcvs-remap))

  ViewVC Help
Powered by ViewVC 1.1.5