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

Contents of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.65 - (hide annotations)
Tue Nov 28 04:12:08 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.64: +2 -2 lines
Getting rid of mcvs- prefixes.

* code/package.lisp (defpackage): shadow the merge symbol.

* code/purge.lisp (mcvs-purge): renamed to purge
(mcvs-purge-wrapper): renamed to purge-wrapper

* code/restore.lisp (mcvs-restore): renamed to restore
(mcvs-restore-wrapper): renamed to restore-wrapper

* code/update.lisp (mcvs-update): renamed to update
(mcvs-update-wrapper): renamed to update-wrapper

* code/main.lisp (mcvs-help): renamed to help
(*mcvs-command-table*): renamed to *command-table*
(mcvs-terminate catch): renamed to terminate.

* code/execute.lisp (mcvs-execute): renamed to execute

* code/move.lisp (mcvs-move): renamed to move
(mcvs-move-wrapper): renamed to move-wrapper

* code/grab.lisp (mcvs-grab): renamed to grab
(mcvs-grab-wrapper): renamed to grab-wrapper

* code/prop.lisp (mcvs-prop): renamed to prop
(mcvs-prop-wrapper): renamed to prop-wrapper

* code/filt.lisp (mcvs-filt-loop): renamed to filt-loop
(mcvs-filt): renamed to filt
(mcvs-remote-filt): renamed to remote-filt
(mcvs-filt-wrapper): renamed to filt-wrapper
(mcvs-remote-filt-wrapper): renamed to remote-filt-wrapper

* code/branch.lisp (mcvs-branch): renamed to branch
(mcvs-branch-wrapper): renamed to branch-wrapper
(mcvs-merge): renamed to merge
(mcvs-list-branches): renamed to list-branches
(mcvs-merge-wrapper): renamed to merge-wrapper
(mcvs-remerge-wrapper): renamed to remerge-wrapper
(mcvs-list-branches-wrapper): renamed to list-branches-wrapper
(mcvs-switch-wrapper): renamed to switch-wrapper

* code/link.lisp (mcvs-link): renamed to ln
(mcvs-link-wrapper): renamed to link-wrapper

* code/watch.lisp (mcvs-watch): renamed to watch
(mcvs-watch-wrapper): renamed to watch-wrapper

* code/add.lisp (mcvs-add): renamed to add
(mcvs-add-wrapper): renamed to add-wrapper

* code/remove.lisp (mcvs-remove): renamed to rm
(mcvs-remove-wrapper): renamed to remove-wrapper

* code/convert.lisp (mcvs-convert): renamed to convert
(mcvs-convert-wrapper): renamed to convert-wrapper

* code/error.lisp (mcvs-terminate): renamed to terminate
(mcvs-error-handler): renamed to error-handler
(*mcvs-error-treatment*): renamed to *error-treatment*
(*mcvs-errors-occured-p*): renamed to *errors-occured-p*

* code/checkout.lisp (mcvs-checkout): renamed to checkout
(mcvs-checkout-wrapper): renamed to checkout-wrapper
(mcvs-export-wrapper): renamed to export-wrapper

* code/generic.lisp (mcvs-generic): renamed to generic
(mcvs-commit-wrapper): renamed to commit-wrapper
(mcvs-diff-wrapper): renamed to diff-wrapper
(mcvs-tag-wrapper): renamed to tag-wrapper
(mcvs-log-wrapper): renamed to log-wrapper
(mcvs-status-wrapper): renamed to status-wrapper
(mcvs-annotate-wrapper): renamed to annotate-wrapper
(mcvs-watchers-wrapper): renamed to watchers-wrapper
(mcvs-edit-wrapper): renamed to edit-wrapper
(mcvs-unedit-wrapper): renamed to unedit-wrapper
(mcvs-editors-wrapper): renamed to editors-wrapper
(mcvs-sync-to-wrapper): renamed to sync-to-wrapper
(mcvs-sync-from-wrapper): renamed to sync-from-wrapper

* code/create.lisp (mcvs-create): renamed to create
(mcvs-create-wrapper): renamed to create-wrapper

* code/remap.lisp (mcvs-remap): renamed to remap
(mcvs-remap-wrapper): renamed to remap-wrapper

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

  ViewVC Help
Powered by ViewVC 1.1.5