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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40.2.1 - (hide annotations)
Sun Aug 25 16:07:05 2002 UTC (11 years, 8 months ago) by kaz
Branch: symlink-branch
Changes since 1.40: +202 -122 lines
Support for symbolic links added to the mapping module.  The format of
the map file has changed to accomodate this.  The new format of the
list entries is (:keyword "id" "path" ...) where the keyword is either
:file or :symlink (for now, extensible obviously), "id" is a unique
identifier (for regular files, it is their MCVS/F-* name) and "path" is
the sandbox path. Other things can follow; for symlinks, there is a
string representing the symlink target.  Internally, a new data type
called mapping-entry is used; this is a struct. So the functions which
read and write maps now convert between the struct format and the above
format.

* code/unix-bindings/unix.lisp (unix-funcs:readlink): New function.

* code/unix-bindings/impl.c (impl_readlink): New function.

* code/clisp-unix.lisp (readlink-error): New condition.
(initialize-instance readlink-error): New method for
initialize-instance generic function, specialized for readlink-error.
(readlink): New function.

* code/mapping.lisp (mapping-entry): New struct, with slots
file, id, path and target.
(mapping-same-object-p): Renamed to mapping-same-id-p.
(mapping-object-lookup, mapping-moved-p): Unused functions removed.
(mapping-extract-paths, mapping-lookup, mapping-prefix-lookup,
mapping-prefix-matches, mapping-same-path-p, mapping-rename-files,
mapping-removed-files): Functions updated to use the new data
structure.
(mapping-dupe-checks): Rewritten for new data structure, and to
use hashes rather than silly sorting.
(mapping-convert-old-style-in, mapping-convert-in,
mapping-convert-out): New functions.
(mapping-read): Handle new and old style representations,
handle conversion to internal representation.
(mapping-write): Convert to new-style external representation
before writing out.
(mapping-synchronize): Handle symbolic links. If a link is missing,
create it. If it's present but different from what it should be,
erase it and re-create it.
(mapping-update): Use new data structure. Handle symbolic links.

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

  ViewVC Help
Powered by ViewVC 1.1.5