/[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 - (hide annotations)
Sun Oct 6 08:17:28 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-98, mcvs-1-0-branch~branch-point, mcvs-0-97
Branch point for: mcvs-1-0-branch
Changes since 1.48: +3 -2 lines
* code/remap.lisp (mcvs-remap): Preserve property lists of
mapping entries, and pick up changes in execute permission.

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

  ViewVC Help
Powered by ViewVC 1.1.5