/[meta-cvs]/meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8
ViewVC logotype

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.61 - (hide annotations)
Tue Apr 22 06:28:16 2003 UTC (10 years, 11 months ago) by kaz
Branch: MAIN
Changes since 1.60: +4 -4 lines
Merging from mcvs-1-0-branch.

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.10 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.9 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "dirwalk")
6     (require "system")
7 kaz 1.54 (require "options")
8 kaz 1.1 (require "sync")
9     (require "chatter")
10     (require "restart")
11 kaz 1.38 (require "seqfuncs")
12 kaz 1.53 (require "mcvs-package")
13 kaz 1.1 (provide "mapping")
14    
15 kaz 1.53 (in-package "META-CVS")
16    
17 kaz 1.6 (eval-when (:compile-toplevel :load-toplevel :execute)
18 kaz 1.40 (defconstant *mcvs-dir* "MCVS")
19 kaz 1.20 (defconstant *mcvs-map-name* "MAP")
20 kaz 1.37 (defconstant *mcvs-map-local-name* "MAP-LOCAL")
21     (defconstant *mcvs-displaced-name* "DISPLACED"))
22 kaz 1.6
23     (eval-when (:compile-toplevel :load-toplevel :execute)
24 kaz 1.20 (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))
25 kaz 1.37 (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* *mcvs-map-local-name*))
26     (defconstant *mcvs-displaced* #.(path-cat *mcvs-dir* *mcvs-displaced-name*)))
27    
28     (defvar *displaced-path-prefix* nil)
29     (defvar *displaced-path-length* nil)
30 kaz 1.1
31     (defun mcvs-locate ()
32 kaz 1.58 (let ((current-dir (split-fields (getcwd) *path-sep*))
33     (escape-levels *nesting-escape-option*))
34 kaz 1.40 (dotimes (i (length current-dir) nil)
35     (let* ((path-components (butlast current-dir i))
36     (path-string (reduce #'path-cat path-components)))
37 kaz 1.58 (when (and (ignore-errors (stat (path-cat path-string *mcvs-dir*)))
38     (zerop (prog1 escape-levels (decf escape-levels))))
39     (when (> *nesting-escape-option* 0)
40     (chatter-info "using sandbox ~a~%" path-string))
41 kaz 1.40 (chdir path-string)
42     (return (if (zerop i)
43     "."
44     (reduce #'path-cat (last current-dir i)))))))))
45 kaz 1.1
46 kaz 1.57 (declaim (inline real-path-exists abstract-to-real-path
47     real-to-abstract-path))
48    
49 kaz 1.37 (defun real-path-exists (path)
50     (or (null *displaced-path-prefix*)
51     (path-prefix-equal *displaced-path-prefix* path)))
52    
53     (defun abstract-to-real-path (path)
54     (if *displaced-path-length*
55     (if (or (= (length path) (1- *displaced-path-length*))
56     (= (length path) *displaced-path-length*))
57     *this-dir*
58 kaz 1.53 (subseq path *displaced-path-length*))
59 kaz 1.37 path))
60    
61     (defun real-to-abstract-path (path)
62     (if *displaced-path-prefix*
63     (concatenate 'string *displaced-path-prefix* path)
64     path))
65    
66 kaz 1.4 (defmacro in-sandbox-root-dir (&body forms)
67     (let ((downpath-sym (gensym "DOWNPATH-")))
68     `(current-dir-restore
69     (let ((,downpath-sym (mcvs-locate)))
70     (when (not ,downpath-sym)
71 kaz 1.46 (error "could not locate ~a directory." *mcvs-dir*))
72 kaz 1.37 (let* ((*displaced-path-prefix* (displaced-path-read))
73     (*displaced-path-length* (if *displaced-path-prefix*
74     (length *displaced-path-prefix*))))
75     (flet ((sandbox-translate-path (in-path)
76     (multiple-value-bind (out-path out-of-bounds)
77     (canonicalize-path
78     (if (path-absolute-p in-path)
79     (path-cat *this-dir* in-path)
80     (path-cat ,downpath-sym in-path)))
81     (if out-of-bounds
82 kaz 1.46 (error "path ~a is not within sandbox." out-path)
83 kaz 1.37 out-path))))
84     (symbol-macrolet ((sandbox-down-path ,downpath-sym))
85     ,@forms)))))))
86 kaz 1.4
87 kaz 1.42 (defstruct mapping-entry
88     (kind :file)
89     (id "")
90     (path "")
91 kaz 1.43 (target "")
92 kaz 1.44 (executable nil)
93     (raw-plist nil))
94 kaz 1.42
95     (defun equal-mapping-entries (left right)
96     (and (eq (mapping-entry-kind left) (mapping-entry-kind right))
97     (string= (mapping-entry-id left) (mapping-entry-id right))
98     (path-equal (mapping-entry-path left) (mapping-entry-path right))
99     (equal (mapping-entry-target left) (mapping-entry-target right))))
100    
101     (defun equal-filemaps (left right)
102 kaz 1.48 (let ((same t))
103 kaz 1.42 (mapc #'(lambda (le re)
104     (setf same (and same (equal-mapping-entries le re))))
105 kaz 1.48 left right)
106     same))
107 kaz 1.42
108 kaz 1.44 (defun mapping-entry-parse-plist (entry)
109     (with-slots (executable raw-plist) entry
110 kaz 1.45 (destructuring-bind (&key exec &allow-other-keys)
111     raw-plist
112     (setf executable exec)))
113     (values))
114 kaz 1.43
115 kaz 1.42 (defun mapping-generate-id (&key no-dir (suffix "") (prefix "F-"))
116     (format nil "~a~a~32,'0X~a"
117     (if no-dir "" (concatenate 'string *mcvs-dir* *path-sep*))
118     prefix
119     (guid-gen)
120     (if (or (null suffix) (string= "" suffix))
121     ""
122     (concatenate 'string "." suffix))))
123    
124     (defun mapping-extract-kind (filemap kind)
125     (remove-if-not #'(lambda (entry-kind)
126     (eq entry-kind kind))
127     filemap
128     :key #'mapping-entry-kind))
129 kaz 1.1
130 kaz 1.57 (declaim (inline mapping-extract-paths))
131 kaz 1.12 (defun mapping-extract-paths (filemap)
132 kaz 1.42 (mapcar #'mapping-entry-path filemap))
133 kaz 1.4
134 kaz 1.12 (defun mapping-lookup (filemap path)
135 kaz 1.42 (find path filemap :test #'path-equal :key #'mapping-entry-path))
136 kaz 1.6
137 kaz 1.12 (defun mapping-prefix-lookup (filemap prefix)
138 kaz 1.6 (if (path-equal *this-dir* prefix)
139     (first filemap)
140 kaz 1.42 (find prefix filemap :test #'path-prefix-equal :key #'mapping-entry-path)))
141 kaz 1.1
142 kaz 1.12 (defun mapping-prefix-matches (filemap path)
143 kaz 1.2 (if (path-equal *this-dir* path)
144     filemap
145     (remove-if-not #'(lambda (entry)
146 kaz 1.42 (path-prefix-equal path (mapping-entry-path entry)))
147     filemap)))
148 kaz 1.2
149 kaz 1.42 (defun mapping-same-id-p (entry-one entry-two)
150     (string= (mapping-entry-id entry-one) (mapping-entry-id entry-two)))
151 kaz 1.1
152 kaz 1.12 (defun mapping-same-path-p (entry-one entry-two)
153 kaz 1.42 (path-equal (mapping-entry-path entry-one) (mapping-entry-path entry-two)))
154 kaz 1.1
155 kaz 1.12 (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
156 kaz 1.3 "Returns a new filemap, in which the pathames in the list file-list are edited
157     by replacing the old-prefix with the new-prefix. If any path thus created
158     matches an existing map entry, that map entry is removed. The sorting order
159     of the map is not preserved."
160 kaz 1.4 (flet ((combine (prefix path)
161     (if (string= path "")
162     prefix
163     (canonicalize-path (path-cat prefix path)))))
164     (let* ((op-len (length old-prefix))
165     (delete-map (mapcan #'(lambda (entry)
166 kaz 1.42 (with-slots (path) entry
167 kaz 1.4 (if (and (member path file-list
168     :test #'path-equal)
169     (path-prefix-equal old-prefix
170     path))
171     (list entry)))) filemap))
172     (replace-map (mapcan #'(lambda (entry)
173 kaz 1.42 (with-slots (path) entry
174     (let ((new-entry (copy-mapping-entry
175     entry)))
176     (setf (mapping-entry-path new-entry)
177     (combine new-prefix
178     (subseq path op-len)))
179     (list new-entry))))
180 kaz 1.4 delete-map)))
181 kaz 1.3 (append
182     (set-difference
183 kaz 1.12 (set-difference filemap delete-map :test #'mapping-same-path-p)
184     replace-map :test #'mapping-same-path-p)
185 kaz 1.4 replace-map))))
186 kaz 1.3
187 kaz 1.29 (defun malformed-map ()
188 kaz 1.46 (error "malformed map (merge conflicts?): correct and run mcvs update."))
189 kaz 1.29
190 kaz 1.13 (defun mapping-dupe-check (filemap)
191     "Signals an error condition if the filemap contains duplicate paths or
192 kaz 1.17 duplicate objects. Otherwise returns the filemap, sorted by path."
193 kaz 1.42 (let ((dupes)
194     (id-hash (make-hash-table :test #'equal))
195     (path-hash (make-hash-table :test #'equal)))
196     (dolist (entry filemap)
197     (if (gethash (mapping-entry-id entry) id-hash)
198     (push entry dupes)
199     (setf (gethash (mapping-entry-id entry) id-hash) entry))
200     (if (gethash (mapping-entry-path entry) path-hash)
201     (push entry dupes)
202     (setf (gethash (mapping-entry-path entry) path-hash) entry)))
203 kaz 1.13 (when dupes
204     (dolist (dupe dupes)
205 kaz 1.42 (chatter-terse "duplicate ~a -> ~a~%"
206     (mapping-entry-id dupe) (mapping-entry-path dupe)))
207 kaz 1.46 (error "duplicates in map: correct and run mcvs update.")))
208 kaz 1.13 filemap)
209 kaz 1.1
210 kaz 1.42 (defun mapping-convert-old-style-in (raw-filemap)
211     "Converts old-style Meta-CVS file mapping to a list of mapping-entry
212     structures."
213     (mapcar #'(lambda (item)
214     (when (or (not (consp item))
215     (not (and (stringp (first item))
216     (stringp (second item)))))
217     (malformed-map))
218     (make-mapping-entry :kind :file
219     :id (first item)
220     :path (second item)))
221     raw-filemap))
222    
223     (defun mapping-convert-in (raw-filemap)
224     "Converts a Meta-CVS filemap as read from a file into its internal
225     representation---a list of mapping-entry structures."
226     (mapcar #'(lambda (item)
227     (when (or (not (consp item))
228     (not (and (keywordp (first item))
229     (stringp (second item)))))
230     (malformed-map))
231     (case (first item)
232     ((:file)
233 kaz 1.43 (let ((entry (make-mapping-entry :kind :file
234     :id (second item)
235 kaz 1.44 :path (third item)
236     :raw-plist (fourth item))))
237 kaz 1.43 (when (fourth item)
238 kaz 1.44 (mapping-entry-parse-plist entry))
239 kaz 1.43 entry))
240 kaz 1.42 ((:symlink)
241     (when (not (third item))
242 kaz 1.46 (error "bad map: symlink ~a has no target."
243 kaz 1.42 (second item)))
244     (make-mapping-entry :kind :symlink
245     :id (second item)
246     :path (third item)
247 kaz 1.44 :target (fourth item)
248     :raw-plist (fifth item)))
249 kaz 1.46 (otherwise (error "bad type keyword ~s in map."
250 kaz 1.42 (first item)))))
251     raw-filemap))
252    
253     (defun mapping-convert-out (filemap)
254     "Converts the internal representation of a Meta-CVS mapping to
255     the external form that is written out to files."
256     (mapcar #'(lambda (entry)
257 kaz 1.44 (with-slots (kind id path target executable raw-plist) entry
258 kaz 1.49 (if executable
259     (setf (getf raw-plist :exec) t)
260     (remf raw-plist :exec))
261 kaz 1.42 (case kind
262 kaz 1.44 ((:file) (list* kind id path
263     (if raw-plist (list raw-plist))))
264     ((:symlink) (list* kind id path target
265     (if raw-plist (list raw-plist))))
266 kaz 1.42 (otherwise (error "unknown mapping entry type ~s." kind)))))
267     filemap))
268    
269 kaz 1.50 (defun mapping-read-raw-map (stream)
270 kaz 1.55 (let ((*read-eval* nil))
271     (let ((map (read stream nil :error)))
272     (if (or (eq map :error)
273     (and (not (consp map)) (not (null map))))
274     (malformed-map)
275     map))))
276 kaz 1.50
277     (defun mapping-read (source &key sanity-check)
278 kaz 1.42 "Reads a Meta-CVS from a file, optionally performing a check
279     for duplicate entries"
280 kaz 1.11 (let (filemap)
281 kaz 1.42 ;;
282     ;; Read the raw data, ensure that the file contains
283     ;; a Lisp object and that it's a list, or at least a cons.
284     ;;
285 kaz 1.50 (if (streamp source)
286     (setf filemap (mapping-read-raw-map source))
287 kaz 1.60 (restart-case
288     (with-open-file (stream source :direction :input)
289     (setf filemap (mapping-read-raw-map stream)))
290     (continue ()
291     :report "Pretend that an empty map was correctly read."
292     (setf filemap nil))))
293 kaz 1.42 ;;
294     ;; Distinguish between the old-style Meta-CVS map and
295     ;; the new one. The old one is a list of lists of strings.
296     ;; The new one is a list of lists having a keyword in
297     ;; the first position.
298     ;;
299     (setf filemap (if (or (null filemap) (keywordp (first (first filemap))))
300     (mapping-convert-in filemap)
301     (mapping-convert-old-style-in filemap)))
302    
303 kaz 1.11 (if sanity-check
304 kaz 1.14 (mapping-dupe-check filemap)
305 kaz 1.11 filemap)))
306    
307     (defun mapping-write (filemap filename &key sort-map)
308 kaz 1.54 (when *dry-run-option*
309     (chatter-debug "not writing to ~a because of -n global option.~%" filename)
310     (return-from mapping-write))
311 kaz 1.42 (when sort-map
312     (setf filemap (sort (copy-list filemap)
313     #'string< :key #'mapping-entry-id)))
314     (let ((raw-filemap (mapping-convert-out filemap)))
315 kaz 1.46 (handler-case
316     (with-open-file (file filename :direction :output)
317     (let ((*print-right-margin* 1))
318     (prin1 raw-filemap file)
319     (terpri file)))
320 kaz 1.47 (error (cond) (error "unable to write mapping file: ~a" cond)))))
321 kaz 1.11
322 kaz 1.60 (defun mapping-synchronize (&key filemap (direction :either))
323 kaz 1.1 "Synchronizes the contents of files in the sandbox, and their corresponding
324 kaz 1.10 CVS files in the Meta-CVS directory. This must be done before any CVS operation
325     such as commit or update, so that the Meta-CVS files have the correct contents
326 kaz 1.1 reflecting local changes. It must also be done after any CVS update operation,
327     to ensure that the newly incorporated changes are propagated to the sandbox"
328 kaz 1.56 (let ((filemap (or filemap (mapping-read *mcvs-map-local*))))
329 kaz 1.43 (dolist (entry filemap)
330 kaz 1.1 (can-restart-here ("Continue synchronizing files.")
331 kaz 1.43 (with-slots (kind id path target executable) entry
332 kaz 1.42 (when (real-path-exists path)
333     (case kind
334     ((:file)
335     (let ((left id) (right (abstract-to-real-path path)))
336 kaz 1.60 (case (synchronize-files left right executable
337     :direction direction)
338 kaz 1.42 ((:left)
339     (chatter-info "sync ~a -> ~a~%" left right))
340     ((:right)
341     (chatter-info "sync ~a <- ~a~%" left right))
342 kaz 1.60 ((:same :no-sync))
343 kaz 1.42 ((:dir)
344 kaz 1.46 (error "cannot sync, either ~a or ~a is a directory."
345 kaz 1.42 left right))
346     ((nil)
347 kaz 1.46 (error "cannot sync, neither ~a nor ~a exists."
348 kaz 1.42 left right)))))
349     ((:symlink)
350     (let* ((symlink (abstract-to-real-path path))
351     (linkdata (no-existence-error (readlink symlink))))
352     (when (or (not linkdata)
353     (not (string= linkdata target)))
354     (chatter-info "linking: ~a -> ~a~%"
355 kaz 1.54 symlink target)
356     (honor-dry-run (target symlink)
357     (no-existence-error (unlink symlink))
358     (ensure-directories-exist symlink)
359     (symlink target symlink))))))))))))
360 kaz 1.1
361 kaz 1.17 (defun mapping-difference (old-mapping new-mapping)
362     "Compute the difference between two mappings. Returns three values:
363 kaz 1.22 - a mapping containing only elements added by new-mapping;
364     - a mapping containing only elements removed by new-mapping; and
365     - a list of moved items, which contains pairs of elements from both, whose
366     object name matches, but path differs."
367 kaz 1.39 (multiple-value-bind (moved-pairs added-items removed-items)
368 kaz 1.38 (intersection-difference
369     new-mapping old-mapping
370 kaz 1.42 :key #'mapping-entry-id :test #'equal
371 kaz 1.38 :combine #'(lambda (new old)
372 kaz 1.42 (unless (string= (mapping-entry-path new)
373     (mapping-entry-path old))
374 kaz 1.39 (list old new)))
375     :squash-nil t)
376     (values added-items removed-items moved-pairs)))
377 kaz 1.17
378 kaz 1.35 (defun mapping-update (&key no-delete-removed)
379 kaz 1.1 #.(format nil
380 kaz 1.10 "Reads the Meta-CVS mapping files ~a and ~a, the local
381 kaz 1.1 mapping and repository mapping, respectively. It computes the difference
382     between them and then reorganizes the file structure of the sandbox as
383     necessary to make the mapping up to date. Then the local mapping file is
384     overwritten so it is identical to the repository one. This is necessary to
385 kaz 1.19 bring the local structure up to date after incorporating mapping changes
386     whether they came from the CVS repository, or from local operations."
387 kaz 1.1 *mcvs-map-local* *mcvs-map*)
388 kaz 1.11 (let ((old-filemap (mapping-read *mcvs-map-local*))
389 kaz 1.22 (new-filemap (mapping-read *mcvs-map* :sanity-check t))
390     rollback-remove-items rollback-restore-items)
391     (restart-case
392     (multiple-value-bind (added-items removed-items moved-pairs)
393     (mapping-difference old-filemap new-filemap)
394     ;; First remove what has to be removed. This way when we
395     ;; do sanity checks, we won't complain about clobbering things
396     ;; that are slated to disappear.
397 kaz 1.37 (dolist (item removed-items)
398 kaz 1.42 (when (real-path-exists (mapping-entry-path item))
399     (let ((real (abstract-to-real-path (mapping-entry-path item))))
400 kaz 1.37 (chatter-terse "removing ~a~%" real)
401     (unless no-delete-removed
402     (restart-case
403 kaz 1.54 (honor-dry-run (real)
404     (ensure-directories-gone real))
405 kaz 1.61 (continue () :report "Ignore file removal error."))
406 kaz 1.37 (push item rollback-restore-items)))))
407 kaz 1.22
408     (dolist (pair moved-pairs)
409     (let ((old-item (first pair)))
410 kaz 1.42 (with-slots (path) old-item
411     (when (real-path-exists path)
412 kaz 1.54 (honor-dry-run (path)
413     (ensure-directories-gone (abstract-to-real-path path)))
414 kaz 1.42 (push old-item rollback-restore-items)))))
415 kaz 1.22
416     ;; Now check sanity of adds and moves, to verify they don't
417     ;; clobber any local files.
418 kaz 1.23 (let (clobber-add-items clobber-move-pairs)
419     (dolist (item added-items)
420 kaz 1.42 (with-slots (kind id path target) item
421     (when (real-path-exists path)
422     (let* ((real-path (abstract-to-real-path path))
423     (file-info (exists real-path)))
424     (when (and file-info
425     (case kind
426     ((:file)
427     (not (same-file-p file-info (stat id))))
428     ((:symlink)
429     (not (string= (readlink real-path)
430     target)))
431     (otherwise t))
432     (not (mapping-lookup old-filemap path)))
433     (push item clobber-add-items))))))
434 kaz 1.23
435     (dolist (item moved-pairs)
436     (destructuring-bind (old-item new-item) item
437     (declare (ignore old-item))
438 kaz 1.42 (with-slots (path) new-item
439     (when (real-path-exists path)
440     (let ((file-info (exists (abstract-to-real-path path))))
441     (when (and file-info
442     (not (mapping-lookup old-filemap path)))
443     (push item clobber-move-pairs)))))))
444 kaz 1.23
445     (when (or clobber-add-items clobber-move-pairs)
446 kaz 1.59 (super-restart-case
447     (error "some moves or adds want to overwrite local files or directories.")
448 kaz 1.61 (info ()
449 kaz 1.59 :report "Print list of adds or moves which want to overwrite."
450     (dolist (item clobber-add-items)
451     (format t "add: ~a~%"
452     (abstract-to-real-path (mapping-entry-path item))))
453     (dolist (pair clobber-move-pairs)
454     (format t "move ~a -> ~a~%"
455     (abstract-to-real-path (mapping-entry-path
456     (first pair)))
457     (abstract-to-real-path (mapping-entry-path
458     (second pair))))))
459 kaz 1.61 (continue ()
460 kaz 1.59 :report "Go ahead and overwrite the target files."
461     (unwind)))))
462 kaz 1.19
463 kaz 1.22 ;; Sanity check passed, complete moves and adds.
464     (dolist (item moved-pairs)
465     (destructuring-bind (old-item new-item) item
466 kaz 1.42 (with-slots ((old-path path) (old-id id)) old-item
467 kaz 1.43 (with-slots ((new-path path) (new-id id) kind target executable)
468     new-item
469 kaz 1.42 (let ((real-old-exists (real-path-exists old-path))
470     (real-new-exists (real-path-exists new-path)))
471     (let ((real-old (and real-old-exists
472     (abstract-to-real-path old-path)))
473     (real-new (and real-new-exists
474     (abstract-to-real-path new-path))))
475     (cond
476     ((and real-old-exists real-new-exists)
477     (chatter-terse "moving ~a -> ~a~%" real-old real-new))
478     (real-new-exists
479     (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))
480     (real-old-exists
481     (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
482    
483     (when real-new-exists
484 kaz 1.54 (no-existence-error (honor-dry-run (real-new)
485     (unlink real-new)))
486 kaz 1.42 (case kind
487     ((:file)
488 kaz 1.60 (synchronize-files new-id real-new executable
489     :direction :right))
490 kaz 1.42 ((:symlink)
491 kaz 1.54 (honor-dry-run (target real-new)
492     (ensure-directories-exist real-new)
493     (symlink target real-new))))
494 kaz 1.42 (push new-item rollback-remove-items))))))))
495 kaz 1.1
496 kaz 1.22 (dolist (item added-items)
497 kaz 1.43 (with-slots (kind id path target executable) item
498 kaz 1.42 (when (real-path-exists path)
499     (let ((real (abstract-to-real-path path)))
500     (can-restart-here ("Continue updating file structure.")
501 kaz 1.54 (no-existence-error (honor-dry-run (real)
502     (unlink real)))
503 kaz 1.42 (case kind
504     ((:file)
505     (chatter-terse "adding ~a~%" real)
506 kaz 1.60 (synchronize-files id real executable
507     :direction :right))
508 kaz 1.42 ((:symlink)
509     (chatter-terse "linking ~a -> ~a~%" real target)
510 kaz 1.54 (honor-dry-run (real)
511     (ensure-directories-exist real)
512     (symlink target real))))
513 kaz 1.42 (push item rollback-remove-items)))))))
514 kaz 1.61 (bail ()
515 kaz 1.22 :report "Restore all restructuring done so far."
516 kaz 1.28 (chatter-debug "Restoring.~%")
517 kaz 1.22 (dolist (item rollback-remove-items)
518 kaz 1.42 (let ((real (abstract-to-real-path (mapping-entry-path item))))
519 kaz 1.37 (chatter-terse "removing ~a~%" real)
520 kaz 1.54 (honor-dry-run (real)
521     (ensure-directories-gone real))))
522 kaz 1.22 (dolist (item rollback-restore-items)
523 kaz 1.43 (with-slots (kind path id target executable) item
524 kaz 1.42 (let ((real (abstract-to-real-path path)))
525     (chatter-terse "restoring ~a~%" real)
526     (case kind
527     ((:file)
528 kaz 1.60 (synchronize-files id real executable :direction :right))
529 kaz 1.42 ((:symlink)
530 kaz 1.54 (honor-dry-run (real)
531     (ensure-directories-exist real)
532     (symlink target real)))))))
533 kaz 1.24 (return-from mapping-update nil)))
534 kaz 1.1
535 kaz 1.24 (mapping-write new-filemap *mcvs-map-local*))
536     t)
537 kaz 1.36
538     (defun mapping-removed-files (filemap)
539     (let ((to-be-removed ())
540     (f-hash (make-hash-table :test #'equal)))
541     (dolist (entry filemap)
542 kaz 1.42 (setf (gethash (mapping-entry-id entry) f-hash) entry))
543 kaz 1.36 (for-each-file-info (fi *mcvs-dir*)
544 kaz 1.51 (when (and (directory-p fi)
545     (path-equal (basename (file-name fi)) "CVS"))
546     (skip))
547 kaz 1.36 (let ((base (basename (file-name fi))))
548     (multiple-value-bind (suffix name) (suffix base)
549     (declare (ignore suffix))
550     (when (and (= (length name) 34)
551     (string= (subseq name 0 2) "F-")
552     (not (gethash (file-name fi) f-hash)))
553     (push (file-name fi) to-be-removed)))))
554     to-be-removed))
555 kaz 1.37
556     (defun displaced-path-read ()
557 kaz 1.55 (let ((*read-eval* nil))
558     (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
559     (read file)))))
560 kaz 1.37
561     (defun displaced-path-write (path)
562     (with-open-file (file *mcvs-displaced* :direction :output)
563     (prin1 path file)
564     (terpri file)))

  ViewVC Help
Powered by ViewVC 1.1.5