/[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.5 - (hide annotations)
Mon Nov 4 02:07:35 2002 UTC (11 years, 5 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-0-99
Changes since 1.49.2.4: +24 -15 lines
More support for -n option.

* code/mcvs-main.lisp (*usage*): Document -n option.

* code/move.lisp (mcvs-move-wrapper): Remove bogus error check
for presence of global options.

* code/options.lisp (honor-dry-run): New macro for conditionally
not executing some forms if it's a dry run, and logging some
debugging information.

* code/sync.lisp (synchronize-files): Honor dry run.

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