/[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.4 - (show annotations)
Sat Aug 31 20:53:13 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24, mcvs-0-22, mcvs-0-23, mcvs-0-95, mcvs-0-96
Changes since 1.3: +16 -6 lines
Merging symlink-branch to main trunk.
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 (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 #'(lambda (entry)
15 (with-slots (path kind) entry
16 (and (eq kind :file)
17 (real-path-exists path))))
18 old-mapping)))
19 (restart-case
20 (when (not (equal-filemaps old-mapping cvs-mapping))
21 (error "mcvs-remap: local and repository mappings differ."))
22 (ignore () :report "remap anyway, clobbering repository mapping"))
23 (dolist (entry old-mapping)
24 (with-slots (id kind) entry
25 (when (eq kind :file)
26 (let ((file-info (stat id)))
27 (setf (gethash (inode file-info) inode-hash) id)))))
28 (for-each-file-info (fi ".")
29 (let* ((path (canonicalize-path (file-name fi)))
30 (abs-path (real-to-abstract-path path)))
31 (cond
32 ((regular-p fi)
33 (let ((f-file (gethash (inode fi) inode-hash)))
34 (when f-file
35 (push (make-mapping-entry :kind :file
36 :id f-file
37 :path abs-path)
38 new-mapping)
39 (setf (gethash (inode fi) inode-hash) nil))))
40 ((symlink-p fi)
41 (chatter-info "skipping symbolic link ~a.~%" path))
42 ((directory-p fi)
43 (when (path-equal path *mcvs-dir*)
44 (skip))))))
45 (mapping-write new-mapping *mcvs-map-local* :sort-map t)
46 (mapping-write new-mapping *mcvs-map* :sort-map t))))
47
48 (defun mcvs-remap-wrapper (global-options command-options args)
49 (declare (ignore global-options command-options))
50 (when args
51 (error "mcvs-remap: command takes no arguments."))
52 (mcvs-remap))

  ViewVC Help
Powered by ViewVC 1.1.5