/[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.5 - (hide annotations)
Sat Oct 5 18:09:48 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
Changes since 1.4: +2 -2 lines
Error messages no longer specify prefixes like "mcvs:" or
"mcvs-remove:".

When no restarts are available, the error handler now adds the "mcvs:"
prefix when dumping the error text to the standard error stream,
and also adds a terminating newline.

The inability to write to the MAP file is converted to a more
informative error message.

New --debug option is supported to set the chatter level to 3.
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 kaz 1.4 (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 kaz 1.2 (restart-case
20 kaz 1.4 (when (not (equal-filemaps old-mapping cvs-mapping))
21 kaz 1.5 (error "local and repository mappings differ."))
22 kaz 1.2 (ignore () :report "remap anyway, clobbering repository mapping"))
23 kaz 1.1 (dolist (entry old-mapping)
24 kaz 1.4 (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 kaz 1.1 (for-each-file-info (fi ".")
29 kaz 1.3 (let* ((path (canonicalize-path (file-name fi)))
30     (abs-path (real-to-abstract-path path)))
31 kaz 1.1 (cond
32     ((regular-p fi)
33     (let ((f-file (gethash (inode fi) inode-hash)))
34     (when f-file
35 kaz 1.4 (push (make-mapping-entry :kind :file
36     :id f-file
37     :path abs-path)
38     new-mapping)
39 kaz 1.1 (setf (gethash (inode fi) inode-hash) nil))))
40 kaz 1.4 ((symlink-p fi)
41     (chatter-info "skipping symbolic link ~a.~%" path))
42 kaz 1.1 ((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 kaz 1.5 (error "command takes no arguments."))
52 kaz 1.1 (mcvs-remap))

  ViewVC Help
Powered by ViewVC 1.1.5