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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.59 - (hide annotations)
Tue Mar 4 05:55:11 2003 UTC (11 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.58: +16 -25 lines
Merging from mcvs-1-0-branch.

* code/mapping.lisp (mapping-update): Rewrite restart-bind
block using super-restart-case.
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     (with-open-file (stream source :direction :input)
288     (setf filemap (mapping-read-raw-map stream))))
289 kaz 1.42 ;;
290     ;; Distinguish between the old-style Meta-CVS map and
291     ;; the new one. The old one is a list of lists of strings.
292     ;; The new one is a list of lists having a keyword in
293     ;; the first position.
294     ;;
295     (setf filemap (if (or (null filemap) (keywordp (first (first filemap))))
296     (mapping-convert-in filemap)
297     (mapping-convert-old-style-in filemap)))
298    
299 kaz 1.11 (if sanity-check
300 kaz 1.14 (mapping-dupe-check filemap)
301 kaz 1.11 filemap)))
302    
303     (defun mapping-write (filemap filename &key sort-map)
304 kaz 1.54 (when *dry-run-option*
305     (chatter-debug "not writing to ~a because of -n global option.~%" filename)
306     (return-from mapping-write))
307 kaz 1.42 (when sort-map
308     (setf filemap (sort (copy-list filemap)
309     #'string< :key #'mapping-entry-id)))
310     (let ((raw-filemap (mapping-convert-out filemap)))
311 kaz 1.46 (handler-case
312     (with-open-file (file filename :direction :output)
313     (let ((*print-right-margin* 1))
314     (prin1 raw-filemap file)
315     (terpri file)))
316 kaz 1.47 (error (cond) (error "unable to write mapping file: ~a" cond)))))
317 kaz 1.11
318 kaz 1.56 (defun mapping-synchronize (&optional filemap)
319 kaz 1.1 "Synchronizes the contents of files in the sandbox, and their corresponding
320 kaz 1.10 CVS files in the Meta-CVS directory. This must be done before any CVS operation
321     such as commit or update, so that the Meta-CVS files have the correct contents
322 kaz 1.1 reflecting local changes. It must also be done after any CVS update operation,
323     to ensure that the newly incorporated changes are propagated to the sandbox"
324 kaz 1.56 (let ((filemap (or filemap (mapping-read *mcvs-map-local*))))
325 kaz 1.43 (dolist (entry filemap)
326 kaz 1.1 (can-restart-here ("Continue synchronizing files.")
327 kaz 1.43 (with-slots (kind id path target executable) entry
328 kaz 1.42 (when (real-path-exists path)
329     (case kind
330     ((:file)
331     (let ((left id) (right (abstract-to-real-path path)))
332 kaz 1.43 (case (synchronize-files left right executable)
333 kaz 1.42 ((:left)
334     (chatter-info "sync ~a -> ~a~%" left right))
335     ((:right)
336     (chatter-info "sync ~a <- ~a~%" left right))
337     ((:same))
338     ((:dir)
339 kaz 1.46 (error "cannot sync, either ~a or ~a is a directory."
340 kaz 1.42 left right))
341     ((nil)
342 kaz 1.46 (error "cannot sync, neither ~a nor ~a exists."
343 kaz 1.42 left right)))))
344     ((:symlink)
345     (let* ((symlink (abstract-to-real-path path))
346     (linkdata (no-existence-error (readlink symlink))))
347     (when (or (not linkdata)
348     (not (string= linkdata target)))
349     (chatter-info "linking: ~a -> ~a~%"
350 kaz 1.54 symlink target)
351     (honor-dry-run (target symlink)
352     (no-existence-error (unlink symlink))
353     (ensure-directories-exist symlink)
354     (symlink target symlink))))))))))))
355 kaz 1.1
356 kaz 1.17 (defun mapping-difference (old-mapping new-mapping)
357     "Compute the difference between two mappings. Returns three values:
358 kaz 1.22 - a mapping containing only elements added by new-mapping;
359     - a mapping containing only elements removed by new-mapping; and
360     - a list of moved items, which contains pairs of elements from both, whose
361     object name matches, but path differs."
362 kaz 1.39 (multiple-value-bind (moved-pairs added-items removed-items)
363 kaz 1.38 (intersection-difference
364     new-mapping old-mapping
365 kaz 1.42 :key #'mapping-entry-id :test #'equal
366 kaz 1.38 :combine #'(lambda (new old)
367 kaz 1.42 (unless (string= (mapping-entry-path new)
368     (mapping-entry-path old))
369 kaz 1.39 (list old new)))
370     :squash-nil t)
371     (values added-items removed-items moved-pairs)))
372 kaz 1.17
373 kaz 1.35 (defun mapping-update (&key no-delete-removed)
374 kaz 1.1 #.(format nil
375 kaz 1.10 "Reads the Meta-CVS mapping files ~a and ~a, the local
376 kaz 1.1 mapping and repository mapping, respectively. It computes the difference
377     between them and then reorganizes the file structure of the sandbox as
378     necessary to make the mapping up to date. Then the local mapping file is
379     overwritten so it is identical to the repository one. This is necessary to
380 kaz 1.19 bring the local structure up to date after incorporating mapping changes
381     whether they came from the CVS repository, or from local operations."
382 kaz 1.1 *mcvs-map-local* *mcvs-map*)
383 kaz 1.11 (let ((old-filemap (mapping-read *mcvs-map-local*))
384 kaz 1.22 (new-filemap (mapping-read *mcvs-map* :sanity-check t))
385     rollback-remove-items rollback-restore-items)
386     (restart-case
387     (multiple-value-bind (added-items removed-items moved-pairs)
388     (mapping-difference old-filemap new-filemap)
389     ;; First remove what has to be removed. This way when we
390     ;; do sanity checks, we won't complain about clobbering things
391     ;; that are slated to disappear.
392 kaz 1.37 (dolist (item removed-items)
393 kaz 1.42 (when (real-path-exists (mapping-entry-path item))
394     (let ((real (abstract-to-real-path (mapping-entry-path item))))
395 kaz 1.37 (chatter-terse "removing ~a~%" real)
396     (unless no-delete-removed
397     (restart-case
398 kaz 1.54 (honor-dry-run (real)
399     (ensure-directories-gone real))
400 kaz 1.37 (ignore () :report "Ignore file removal error."))
401     (push item rollback-restore-items)))))
402 kaz 1.22
403     (dolist (pair moved-pairs)
404     (let ((old-item (first pair)))
405 kaz 1.42 (with-slots (path) old-item
406     (when (real-path-exists path)
407 kaz 1.54 (honor-dry-run (path)
408     (ensure-directories-gone (abstract-to-real-path path)))
409 kaz 1.42 (push old-item rollback-restore-items)))))
410 kaz 1.22
411     ;; Now check sanity of adds and moves, to verify they don't
412     ;; clobber any local files.
413 kaz 1.23 (let (clobber-add-items clobber-move-pairs)
414     (dolist (item added-items)
415 kaz 1.42 (with-slots (kind id path target) item
416     (when (real-path-exists path)
417     (let* ((real-path (abstract-to-real-path path))
418     (file-info (exists real-path)))
419     (when (and file-info
420     (case kind
421     ((:file)
422     (not (same-file-p file-info (stat id))))
423     ((:symlink)
424     (not (string= (readlink real-path)
425     target)))
426     (otherwise t))
427     (not (mapping-lookup old-filemap path)))
428     (push item clobber-add-items))))))
429 kaz 1.23
430     (dolist (item moved-pairs)
431     (destructuring-bind (old-item new-item) item
432     (declare (ignore old-item))
433 kaz 1.42 (with-slots (path) new-item
434     (when (real-path-exists path)
435     (let ((file-info (exists (abstract-to-real-path path))))
436     (when (and file-info
437     (not (mapping-lookup old-filemap path)))
438     (push item clobber-move-pairs)))))))
439 kaz 1.23
440     (when (or clobber-add-items clobber-move-pairs)
441 kaz 1.59 (super-restart-case
442     (error "some moves or adds want to overwrite local files or directories.")
443     (print-clobbers ()
444     :report "Print list of adds or moves which want to overwrite."
445     (dolist (item clobber-add-items)
446     (format t "add: ~a~%"
447     (abstract-to-real-path (mapping-entry-path item))))
448     (dolist (pair clobber-move-pairs)
449     (format t "move ~a -> ~a~%"
450     (abstract-to-real-path (mapping-entry-path
451     (first pair)))
452     (abstract-to-real-path (mapping-entry-path
453     (second pair))))))
454     (do-clobber ()
455     :report "Go ahead and overwrite the target files."
456     (unwind)))))
457 kaz 1.19
458 kaz 1.22 ;; Sanity check passed, complete moves and adds.
459     (dolist (item moved-pairs)
460     (destructuring-bind (old-item new-item) item
461 kaz 1.42 (with-slots ((old-path path) (old-id id)) old-item
462 kaz 1.43 (with-slots ((new-path path) (new-id id) kind target executable)
463     new-item
464 kaz 1.42 (let ((real-old-exists (real-path-exists old-path))
465     (real-new-exists (real-path-exists new-path)))
466     (let ((real-old (and real-old-exists
467     (abstract-to-real-path old-path)))
468     (real-new (and real-new-exists
469     (abstract-to-real-path new-path))))
470     (cond
471     ((and real-old-exists real-new-exists)
472     (chatter-terse "moving ~a -> ~a~%" real-old real-new))
473     (real-new-exists
474     (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))
475     (real-old-exists
476     (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
477    
478     (when real-new-exists
479 kaz 1.54 (no-existence-error (honor-dry-run (real-new)
480     (unlink real-new)))
481 kaz 1.42 (case kind
482     ((:file)
483 kaz 1.43 (synchronize-files new-id real-new executable))
484 kaz 1.42 ((:symlink)
485 kaz 1.54 (honor-dry-run (target real-new)
486     (ensure-directories-exist real-new)
487     (symlink target real-new))))
488 kaz 1.42 (push new-item rollback-remove-items))))))))
489 kaz 1.1
490 kaz 1.22 (dolist (item added-items)
491 kaz 1.43 (with-slots (kind id path target executable) item
492 kaz 1.42 (when (real-path-exists path)
493     (let ((real (abstract-to-real-path path)))
494     (can-restart-here ("Continue updating file structure.")
495 kaz 1.54 (no-existence-error (honor-dry-run (real)
496     (unlink real)))
497 kaz 1.42 (case kind
498     ((:file)
499     (chatter-terse "adding ~a~%" real)
500 kaz 1.43 (synchronize-files id real executable))
501 kaz 1.42 ((:symlink)
502     (chatter-terse "linking ~a -> ~a~%" real target)
503 kaz 1.54 (honor-dry-run (real)
504     (ensure-directories-exist real)
505     (symlink target real))))
506 kaz 1.42 (push item rollback-remove-items)))))))
507 kaz 1.22 (continue ()
508     :report "Restore all restructuring done so far."
509 kaz 1.28 (chatter-debug "Restoring.~%")
510 kaz 1.22 (dolist (item rollback-remove-items)
511 kaz 1.42 (let ((real (abstract-to-real-path (mapping-entry-path item))))
512 kaz 1.37 (chatter-terse "removing ~a~%" real)
513 kaz 1.54 (honor-dry-run (real)
514     (ensure-directories-gone real))))
515 kaz 1.22 (dolist (item rollback-restore-items)
516 kaz 1.43 (with-slots (kind path id target executable) item
517 kaz 1.42 (let ((real (abstract-to-real-path path)))
518     (chatter-terse "restoring ~a~%" real)
519     (case kind
520     ((:file)
521 kaz 1.43 (synchronize-files id real executable))
522 kaz 1.42 ((:symlink)
523 kaz 1.54 (honor-dry-run (real)
524     (ensure-directories-exist real)
525     (symlink target real)))))))
526 kaz 1.24 (return-from mapping-update nil)))
527 kaz 1.1
528 kaz 1.24 (mapping-write new-filemap *mcvs-map-local*))
529     t)
530 kaz 1.36
531     (defun mapping-removed-files (filemap)
532     (let ((to-be-removed ())
533     (f-hash (make-hash-table :test #'equal)))
534     (dolist (entry filemap)
535 kaz 1.42 (setf (gethash (mapping-entry-id entry) f-hash) entry))
536 kaz 1.36 (for-each-file-info (fi *mcvs-dir*)
537 kaz 1.51 (when (and (directory-p fi)
538     (path-equal (basename (file-name fi)) "CVS"))
539     (skip))
540 kaz 1.36 (let ((base (basename (file-name fi))))
541     (multiple-value-bind (suffix name) (suffix base)
542     (declare (ignore suffix))
543     (when (and (= (length name) 34)
544     (string= (subseq name 0 2) "F-")
545     (not (gethash (file-name fi) f-hash)))
546     (push (file-name fi) to-be-removed)))))
547     to-be-removed))
548 kaz 1.37
549     (defun displaced-path-read ()
550 kaz 1.55 (let ((*read-eval* nil))
551     (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
552     (read file)))))
553 kaz 1.37
554     (defun displaced-path-write (path)
555     (with-open-file (file *mcvs-displaced* :direction :output)
556     (prin1 path file)
557     (terpri file)))

  ViewVC Help
Powered by ViewVC 1.1.5