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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5