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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (hide annotations)
Thu Nov 21 06:15:15 2002 UTC (11 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.54: +9 -7 lines
Merging from mcvs-1-0-branch.

Some security fixes.  Funny I didn't think of this sooner!

* code/types.lisp (types-read): Make sure *read-eval* is bound to
nil when calling READ.

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

  ViewVC Help
Powered by ViewVC 1.1.5