/[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.13 - (show annotations)
Tue Nov 28 07:47:22 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.12: +5 -5 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

* code/mapping.lisp (*mcvs-dir*): Renamed to *admin-dir*.
(*mcvs-map-name*): Renamed to *map-file*.
(*mcvs-map-local-name*): Renamed to *map-local-file*.
(*mcvs-displaced-name*): Renamed to *displaced-file*.
(*mcvs-map*): Renamed to *map-path*.
(*mcvs-map-local*): Renamed to *map-local-path*.
(*mcvs-displaced*): Renamed to *displaced-path*.
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 (in-package :meta-cvs)
6
7 (defun remap ()
8 (in-sandbox-root-dir
9 (let* ((old-mapping (mapping-read *map-local-path*))
10 (cvs-mapping (mapping-read *map-path*))
11 (inode-hash (make-hash-table :test #'eql))
12 (new-mapping (remove-if #'(lambda (entry)
13 (with-slots (path kind) entry
14 (and (eq kind :file)
15 (real-path-exists path))))
16 old-mapping)))
17 (restart-case
18 (when (not (equal-filemaps old-mapping cvs-mapping))
19 (error "local and repository mappings differ."))
20 (continue () :report "remap anyway, clobbering repository mapping"))
21 (dolist (entry old-mapping)
22 (with-slots (id kind) entry
23 (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 ".")
32 (let* ((path (canonicalize-path (file-name fi)))
33 (abs-path (real-to-abstract-path path)))
34 (cond
35 ((regular-p fi)
36 (let ((entry (gethash (inode fi) inode-hash)))
37 (when entry
38 (let ((new-entry (copy-mapping-entry entry)))
39 (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)
47 (when (path-equal path *admin-dir*)
48 (skip))))))
49 (mapping-write new-mapping *map-local-path* :sort-map t)
50 (mapping-write new-mapping *map-path* :sort-map t))))
51
52 (defun remap-wrapper (global-options command-options args)
53 (declare (ignore global-options command-options))
54 (when args
55 (error "command takes no arguments."))
56 (remap))

  ViewVC Help
Powered by ViewVC 1.1.5