/[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.2 - (hide annotations)
Sun Aug 25 18:20:45 2002 UTC (11 years, 7 months ago) by kaz
Branch: symlink-branch
Changes since 1.40.2.1: +25 -12 lines
* code/add.lisp (mcvs-add): Change to new mapping-entry data structure
and handle symbolic links.

* code/types.lisp (types-remove-ignores, types-make-cvs-adds):
Change to new mapping-entry data structure.

* code/mapping.lisp (mapping-generate-name): Renamed to
mapping-generate-id. Interface changes slightly.
(mapping-extract-kind): New function, factored out from mcvs-generic.
(mapping-update): Unlink existing symbolic link before
re-linking it.

* code/convert.lisp (mcvs-convert): Use new name and interface
of mapping-generate-name function.

* code/create.lisp (mcvs-create): Likewise.

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

  ViewVC Help
Powered by ViewVC 1.1.5