/[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.6.2.1 - (hide annotations)
Tue Apr 22 05:53:42 2003 UTC (11 years ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-11, mcvs-1-0-10, mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-7
Changes since 1.6: +1 -1 lines
Slightly redesigned error handling protocol.

* code/update.lisp (mcvs-update): Change continue restart to bail.

* code/add.lisp (mcvs-add): Likewise.

* code/error.lisp (mcvs-error-handler): Specially recognize two
additional restart symbols, bail and info. A bail restart performs
any rolling back and cleanup and terminates. Continuation is now
properly reserved for actions that proceed boldly to finish
the job, possibly irretrievably clobbering precious data.
The info restart is now a standard way to indicate that more
details about the error can be obtained, so this does not have
to be represented as a special action with an ad-hoc restart.

* code/create.lisp (mcvs-create): Change show restart to info.

* code/remap.lisp (mcvs-remap): Change ignore restart to continue.

* code/mapping.lisp (mapping-update): Change ignore and do-clobber
restarts to continue, and print-clobbers restart to info.
Change continue restart to bail.
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.6.2.1 (continue () :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 kaz 1.6 (setf (gethash (inode file-info) inode-hash) entry)))))
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 kaz 1.6 (let ((entry (gethash (inode fi) inode-hash)))
34     (when entry
35     (let ((new-entry (copy-mapping-entry entry)))
36     (setf (mapping-entry-executable new-entry)
37     (executable-p fi))
38     (setf (mapping-entry-path new-entry) abs-path)
39     (push new-entry new-mapping)
40     (setf (gethash (inode fi) inode-hash) nil)))))
41 kaz 1.4 ((symlink-p fi)
42     (chatter-info "skipping symbolic link ~a.~%" path))
43 kaz 1.1 ((directory-p fi)
44     (when (path-equal path *mcvs-dir*)
45     (skip))))))
46     (mapping-write new-mapping *mcvs-map-local* :sort-map t)
47     (mapping-write new-mapping *mcvs-map* :sort-map t))))
48    
49     (defun mcvs-remap-wrapper (global-options command-options args)
50     (declare (ignore global-options command-options))
51     (when args
52 kaz 1.5 (error "command takes no arguments."))
53 kaz 1.1 (mcvs-remap))

  ViewVC Help
Powered by ViewVC 1.1.5