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

Diff of /meta-cvs/F-FFF16CA4956A36F19290AC9E1EBAFFD8

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.36.2.4 by kaz, Sat Jul 6 16:57:21 2002 UTC revision 1.66 by kaz, Tue Nov 28 07:47:22 2006 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
4    
5  (require "dirwalk")  (in-package :meta-cvs)
 (require "system")  
 (require "sync")  
 (require "chatter")  
 (require "restart")  
 (provide "mapping")  
6    
7  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
8    (defconstant *mcvs-dir* #.(path-cat "MCVS"))    (defconstant *admin-dir* "MCVS")
9    (defconstant *mcvs-map-name* "MAP")    (defconstant *map-file* "MAP")
10    (defconstant *mcvs-map-local-name* "MAP-LOCAL")    (defconstant *map-local-file* "MAP-LOCAL")
11    (defconstant *mcvs-displaced-name* "DISPLACED"))    (defconstant *displaced-file* "DISPLACED"))
12    
13  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
14    (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))    (defconstant *map-path* #.(path-cat *admin-dir* *map-file*))
15    (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* *mcvs-map-local-name*))    (defconstant *map-local-path* #.(path-cat *admin-dir* *map-local-file*))
16    (defconstant *mcvs-displaced* #.(path-cat *mcvs-dir* *mcvs-displaced-name*)))    (defconstant *displaced-path* #.(path-cat *admin-dir* *displaced-file*)))
17    
18  (defvar *displaced-path-prefix* nil)  (defvar *displaced-path-prefix* nil)
19  (defvar *displaced-path-length* nil)  (defvar *displaced-path-length* nil)
20    
21  ;; TODO: use getcwd()  (defun locate ()
22  (defun mcvs-locate ()    (let ((current-dir (split-fields (getcwd) *path-sep*))
23  "Search for Meta-CVS directory by looking in the current directory, and          (escape-levels *nesting-escape-option*))
24  if it is not found there, by changing directory up through successive      (dotimes (i (length current-dir) nil)
25  parent directories. Returns the path from the new current directory        (let* ((path-components (butlast current-dir i))
26  down to the original one, or the value nil if not found."               (path-string (reduce #'path-cat path-components)))
27    (if (ignore-errors (stat *mcvs-dir*))          (when (and (ignore-errors (stat (path-cat path-string *admin-dir*)))
28      "."                     (zerop (prog1 escape-levels (decf escape-levels))))
29      (let ((came-from (go-up)))            (when (> *nesting-escape-option* 0)
30        (if came-from              (chatter-info "using sandbox ~a~%" path-string))
31          (let ((locate (mcvs-locate)))            (chdir path-string)
32            (if locate            (return (if (zerop i)
33              (path-cat locate came-from)))))))                      "."
34                        (reduce #'path-cat (last current-dir i)))))))))
35    
36    (declaim (inline real-path-exists abstract-to-real-path
37                     real-to-abstract-path))
38    
39  (defun real-path-exists (path)  (defun real-path-exists (path)
40    (or (null *displaced-path-prefix*)    (or (null *displaced-path-prefix*)
# Line 46  down to the original one, or the value n Line 45  down to the original one, or the value n
45      (if (or (= (length path) (1- *displaced-path-length*))      (if (or (= (length path) (1- *displaced-path-length*))
46              (= (length path) *displaced-path-length*))              (= (length path) *displaced-path-length*))
47        *this-dir*        *this-dir*
48        (substring path *displaced-path-length*))        (subseq path *displaced-path-length*))
49      path))      path))
50    
51  (defun real-to-abstract-path (path)  (defun real-to-abstract-path (path)
# Line 54  down to the original one, or the value n Line 53  down to the original one, or the value n
53      (concatenate 'string *displaced-path-prefix* path)      (concatenate 'string *displaced-path-prefix* path)
54      path))      path))
55    
 (declaim (inline real-path-exists abstract-to-real-path  
                  real-to-abstract-path))  
   
56  (defmacro in-sandbox-root-dir (&body forms)  (defmacro in-sandbox-root-dir (&body forms)
57    (let ((downpath-sym (gensym "DOWNPATH-")))    (let ((downpath-sym (gensym "DOWNPATH-")))
58     `(current-dir-restore     `(current-dir-restore
59        (let ((,downpath-sym (mcvs-locate)))        (let ((,downpath-sym (locate)))
60          (when (not ,downpath-sym)          (when (not ,downpath-sym)
61            (error "mcvs: could not locate ~a directory." *mcvs-dir*))            (error "could not locate ~a directory." *admin-dir*))
62          (let* ((*displaced-path-prefix* (displaced-path-read))          (let* ((*displaced-path-prefix* (displaced-path-read))
63                 (*displaced-path-length* (if *displaced-path-prefix*                 (*displaced-path-length* (if *displaced-path-prefix*
64                                            (length *displaced-path-prefix*))))                                            (length *displaced-path-prefix*))))
# Line 73  down to the original one, or the value n Line 69  down to the original one, or the value n
69                                              (path-cat *this-dir* in-path)                                              (path-cat *this-dir* in-path)
70                                              (path-cat ,downpath-sym in-path)))                                              (path-cat ,downpath-sym in-path)))
71                        (if out-of-bounds                        (if out-of-bounds
72                          (error "mcvs: path ~a is not within sandbox." out-path)                          (error "path ~a is not within sandbox." out-path)
73                          out-path))))                          out-path))))
74              (symbol-macrolet ((sandbox-down-path ,downpath-sym))              (symbol-macrolet ((sandbox-down-path ,downpath-sym))
75                ,@forms)))))))                ,@forms)))))))
76    
77  (defun mapping-generate-name (suffix &key no-dir)  (defstruct mapping-entry
78    (let* ((suffix (if (or (null suffix)    (kind :file)
79                           (string= "" suffix))    (id "")
80                     ""    (path "")
81                     (format nil ".~a" suffix)))    (target "")
82           (name (format nil "F-~32,'0X~a" (guid-gen) suffix)))    (executable nil)
83      (if no-dir    (raw-plist nil))
84        name  
85        (path-cat *mcvs-dir* name))))  (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      (let ((same t))
93        (mapc #'(lambda (le re)
94                  (setf same (and same (equal-mapping-entries le re))))
95                left right)
96        same))
97    
98    (defun mapping-entry-parse-plist (entry)
99      (with-slots (executable raw-plist) entry
100        (destructuring-bind (&key exec &allow-other-keys)
101                            raw-plist
102          (setf executable exec)))
103      (values))
104    
105    (defun mapping-generate-id (&key no-dir (suffix "") (prefix "F-"))
106      (format nil "~a~a~32,'0X~a"
107              (if no-dir "" (concatenate 'string *admin-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    
 (defun mapping-extract-paths (filemap)  
   (mapcar #'second filemap))  
120  (declaim (inline mapping-extract-paths))  (declaim (inline mapping-extract-paths))
121    (defun mapping-extract-paths (filemap)
122      (mapcar #'mapping-entry-path filemap))
123    
124  (defun mapping-lookup (filemap path)  (defun mapping-lookup (filemap path)
125    (find path filemap :test #'path-equal :key #'second))    (find path filemap :test #'path-equal :key #'mapping-entry-path))
126    
127  (defun mapping-prefix-lookup (filemap prefix)  (defun mapping-prefix-lookup (filemap prefix)
128    (if (path-equal *this-dir* prefix)    (if (path-equal *this-dir* prefix)
129      (first filemap)      (first filemap)
130      (find prefix filemap :test #'path-prefix-equal :key #'second)))      (find prefix filemap :test #'path-prefix-equal :key #'mapping-entry-path)))
131    
132  (defun mapping-prefix-matches (filemap path)  (defun mapping-prefix-matches (filemap path)
133    (if (path-equal *this-dir* path)    (if (path-equal *this-dir* path)
134      filemap      filemap
135      (remove-if-not #'(lambda (entry)      (remove-if-not #'(lambda (entry)
136                         (path-prefix-equal path (second entry))) filemap)))                         (path-prefix-equal path (mapping-entry-path entry)))
137                       filemap)))
 (defun mapping-object-lookup (filemap object)  
   (find object filemap :test #'string= :key #'first))  
138    
139  (defun mapping-same-object-p (entry-one entry-two)  (defun mapping-same-id-p (entry-one entry-two)
140    (string= (first entry-one) (first entry-two)))    (string= (mapping-entry-id entry-one) (mapping-entry-id entry-two)))
141    
142  (defun mapping-same-path-p (entry-one entry-two)  (defun mapping-same-path-p (entry-one entry-two)
143    (path-equal (second entry-one) (second entry-two)))    (path-equal (mapping-entry-path entry-one) (mapping-entry-path entry-two)))
   
 (defun mapping-moved-p (entry-one entry-two)  
   (and (string= (first entry-one) (first entry-two))  
        (not (path-equal (second entry-one) (second entry-two)))))  
144    
145  (defun mapping-rename-files (filemap file-list old-prefix new-prefix)  (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
146  "Returns a new filemap, in which the pathames in the list file-list are edited  "Returns a new filemap, in which the pathames in the list file-list are edited
# Line 130  of the map is not preserved." Line 153  of the map is not preserved."
153               (canonicalize-path (path-cat prefix path)))))               (canonicalize-path (path-cat prefix path)))))
154      (let* ((op-len (length old-prefix))      (let* ((op-len (length old-prefix))
155             (delete-map (mapcan #'(lambda (entry)             (delete-map (mapcan #'(lambda (entry)
156                                     (let ((path (second entry)))                                     (with-slots (path) entry
157                                       (if (and (member path file-list                                       (if (and (member path file-list
158                                                        :test #'path-equal)                                                        :test #'path-equal)
159                                                (path-prefix-equal old-prefix                                                (path-prefix-equal old-prefix
160                                                                   path))                                                                   path))
161                                         (list entry)))) filemap))                                         (list entry)))) filemap))
162             (replace-map (mapcan #'(lambda (entry)             (replace-map (mapcan #'(lambda (entry)
163                                      (destructuring-bind (object path) entry                                      (with-slots (path) entry
164                                        (list (list object                                        (let ((new-entry (copy-mapping-entry
165                                                    (combine new-prefix                                                           entry)))
166                                                             (subseq path                                          (setf (mapping-entry-path new-entry)
167                                                                     op-len))))))                                                (combine new-prefix
168                                                           (subseq path op-len)))
169                                            (list new-entry))))
170                                   delete-map)))                                   delete-map)))
171      (append      (append
172        (set-difference        (set-difference
# Line 150  of the map is not preserved." Line 175  of the map is not preserved."
175        replace-map))))        replace-map))))
176    
177  (defun malformed-map ()  (defun malformed-map ()
178    (error "mcvs: malformed map (merge conflicts?): correct and run mcvs update."))    (error "malformed map (merge conflicts?): correct and run mcvs update."))
179    
180  (defun mapping-dupe-check (filemap)  (defun mapping-dupe-check (filemap)
181  "Signals an error condition if the filemap contains duplicate paths or  "Signals an error condition if the filemap contains duplicate paths or
182  duplicate objects. Otherwise returns the filemap, sorted by path."  duplicate objects. Otherwise returns the filemap, sorted by path."
183    (dolist (entry filemap)    (let ((dupes)
184      (when (or (not (consp entry))          (id-hash (make-hash-table :test #'equal))
185                (not (and (stringp (first entry))          (path-hash (make-hash-table :test #'equal)))
186                          (stringp (second entry)))))      (dolist (entry filemap)
187        (malformed-map)))        (if (gethash (mapping-entry-id entry) id-hash)
188            (push entry dupes)
189    (let (dupes          (setf (gethash (mapping-entry-id entry) id-hash) entry))
190          (sorted-map (sort (copy-list filemap) #'string< :key #'first)))        (if (gethash (mapping-entry-path entry) path-hash)
191      (let ((iter (rest filemap)) (current-item (first (first filemap))))          (push entry dupes)
192        (loop          (setf (gethash (mapping-entry-path entry) path-hash) entry)))
         (when (endp iter)  
           (return))  
         (if (string= (first (first iter)) current-item)  
           (push (first iter) dupes)  
           (setf current-item (first (first iter))))  
         (setf iter (rest iter))))  
   
     (setf sorted-map (sort sorted-map #'string< :key #'second))  
   
     (let ((iter (rest filemap)) (current-item (second (first filemap))))  
       (loop  
         (when (endp iter)  
           (return))  
         (if (path-equal (second (first iter)) current-item)  
           (push (first iter) dupes)  
           (setf current-item (second (first iter))))  
         (setf iter (rest iter))))  
   
193      (when dupes      (when dupes
194        (dolist (dupe dupes)        (dolist (dupe dupes)
195          (chatter-terse "duplicate ~a -> ~a~%" (first dupe) (second dupe)))          (chatter-terse "duplicate ~a -> ~a~%"
196        (error "mcvs: duplicates in map: correct and run mcvs update.")))                         (mapping-entry-id dupe) (mapping-entry-path dupe)))
197          (error "duplicates in map: correct and run mcvs update.")))
198    filemap)    filemap)
199    
200  (defun mapping-read (filename &key sanity-check)  (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                       (let ((entry (make-mapping-entry :kind :file
224                                                        :id (second item)
225                                                        :path (third item)
226                                                        :raw-plist (fourth item))))
227                         (when (fourth item)
228                           (mapping-entry-parse-plist entry))
229                         entry))
230                    ((:symlink)
231                       (when (not (third item))
232                         (error "bad map: symlink ~a has no target."
233                                (second item)))
234                       (make-mapping-entry :kind :symlink
235                                           :id (second item)
236                                           :path (third item)
237                                           :target (fourth item)
238                                           :raw-plist (fifth item)))
239                    (otherwise (error "bad type keyword ~s in map."
240                                      (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                  (with-slots (kind id path target executable raw-plist) entry
248                    (if executable
249                      (setf (getf raw-plist :exec) t)
250                      (remf raw-plist :exec))
251                    (case kind
252                      ((: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                      (otherwise (error "unknown mapping entry type ~s." kind)))))
257              filemap))
258    
259    (defun mapping-read-raw-map (stream)
260      (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    
267    (defun mapping-read (source &key sanity-check)
268    "Reads a Meta-CVS from a file, optionally performing a check
269    for duplicate entries"
270    (let (filemap)    (let (filemap)
271      (with-open-file (file filename :direction :input)      ;;
272        (setf filemap (read file nil :error))      ;; Read the raw data, ensure that the file contains
273        (when (or (eq filemap :error)      ;; a Lisp object and that it's a list, or at least a cons.
274                  (and (not (consp filemap)) (not (null filemap))))      ;;
275          (malformed-map)))      (if (streamp source)
276          (setf filemap (mapping-read-raw-map source))
277          (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        ;;
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      (if sanity-check      (if sanity-check
294        (mapping-dupe-check filemap)        (mapping-dupe-check filemap)
295        filemap)))        filemap)))
296    
297  (defun mapping-write (filemap filename &key sort-map)  (defun mapping-write (filemap filename &key sort-map)
298    (with-open-file (file filename :direction :output)    (when *dry-run-option*
299      (let ((*print-right-margin* 1))      (chatter-debug "not writing to ~a because of -n global option.~%" filename)
300        (prin1 (if sort-map      (return-from mapping-write))
301                 (sort (copy-list filemap) #'string< :key #'first)    (when sort-map
302                 filemap) file)      (setf filemap (sort (copy-list filemap)
303        (terpri file))))                          #'string< :key #'mapping-entry-id)))
304      (let ((raw-filemap (mapping-convert-out filemap)))
305        (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          (error (cond) (error "unable to write mapping file: ~a" cond)))))
311    
312  (defun mapping-synchronize ()  (defun mapping-synchronize (&key filemap (direction :either))
313  "Synchronizes the contents of files in the sandbox, and their corresponding  "Synchronizes the contents of files in the sandbox, and their corresponding
314  CVS files in the Meta-CVS directory. This must be done before any CVS operation  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  such as commit or update, so that the Meta-CVS files have the correct contents
316  reflecting local changes. It must also be done after any CVS update operation,  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"  to ensure that the newly incorporated changes are propagated to the sandbox"
318    (let ((filemap (mapping-read *mcvs-map-local*)))    (let ((filemap (or filemap (mapping-read *map-local-path*))))
319      (dolist (item filemap)      (dolist (entry filemap)
320        (can-restart-here ("Continue synchronizing files.")        (can-restart-here ("Continue synchronizing files.")
321          (destructuring-bind (left right) item          (with-slots (kind id path target executable) entry
322            (when (real-path-exists right)            (when (real-path-exists path)
323              (setf right (abstract-to-real-path right))              (case kind
324              (case (synchronize-files left right)                ((:file)
325                ((:left)                   (let ((left id) (right (abstract-to-real-path path)))
326                  (chatter-info "sync ~a -> ~a~%" left right))                     (case (synchronize-files left right executable
327                ((:right)                                              :direction direction)
328                  (chatter-info "sync ~a <- ~a~%" left right))                       ((:left)
329                ((:same))                         (chatter-info "sync ~a -> ~a~%" left right))
330                ((:dir)                       ((:right)
331                  (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."                         (chatter-info "sync ~a <- ~a~%" left right))
332                         left right))                       ((:same :no-sync))
333                ((nil)                       ((:dir)
334                  (error "mcvs-sync: neither ~a nor ~a exists."                         (error "cannot sync, either ~a or ~a is a directory."
335                         left right)))))))))                                left right))
336                         ((nil)
337                           (error "cannot sync, neither ~a nor ~a exists."
338                                  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                                       symlink target)
346                         (honor-dry-run (target symlink)
347                           (no-existence-error (unlink symlink))
348                           (ensure-directories-exist symlink)
349                           (symlink target symlink))))))))))))
350    
351  (defun mapping-difference (old-mapping new-mapping)  (defun mapping-difference (old-mapping new-mapping)
352  "Compute the difference between two mappings. Returns three values:  "Compute the difference between two mappings. Returns three values:
# Line 239  to ensure that the newly incorporated ch Line 354  to ensure that the newly incorporated ch
354  - a mapping containing only elements removed by new-mapping; and  - a mapping containing only elements removed by new-mapping; and
355  - a list of moved items, which contains pairs of elements from both, whose  - a list of moved items, which contains pairs of elements from both, whose
356    object name matches, but path differs."    object name matches, but path differs."
357    (let (added-items removed-items moved-pairs)    (multiple-value-bind (moved-pairs added-items removed-items)
358      (setf old-mapping (sort (copy-list old-mapping) #'string< :key #'first))                         (intersection-difference
359      (setf new-mapping (sort (copy-list new-mapping) #'string< :key #'first))                           new-mapping old-mapping
360                             :key #'mapping-entry-id :test #'equal
361      (loop                           :combine #'(lambda (new old)
362        (let* ((old-item (first old-mapping))                                        (unless (string= (mapping-entry-path new)
363               (new-item (first new-mapping)))                                                         (mapping-entry-path old))
364          (cond                                          (list old new)))
365            ((and (endp old-item) (endp new-item)) (return))                           :squash-nil t)
           ((string< (first old-item) (first new-item))  
              (pop old-mapping)  
              (push old-item removed-items))  
           ((string= (first old-item) (first new-item))  
              (pop old-mapping)  
              (pop new-mapping)  
              (when (not (path-equal (second old-item) (second new-item)))  
                (push (list old-item new-item) moved-pairs)))  
           (t  
              (pop new-mapping)  
              (push new-item added-items)))))  
366      (values added-items removed-items moved-pairs)))      (values added-items removed-items moved-pairs)))
367    
368  (defun mapping-update (&key no-delete-removed)  (defun mapping-update (&key no-delete-removed)
# Line 270  necessary to make the mapping up to date Line 374  necessary to make the mapping up to date
374  overwritten so it is identical to the repository one.  This is necessary to  overwritten so it is identical to the repository one.  This is necessary to
375  bring the local structure up to date after incorporating mapping changes  bring the local structure up to date after incorporating mapping changes
376  whether they came from the CVS repository, or from local operations."  whether they came from the CVS repository, or from local operations."
377  *mcvs-map-local* *mcvs-map*)  *map-local-path* *map-path*)
378    (let ((old-filemap (mapping-read *mcvs-map-local*))    (let ((old-filemap (mapping-read *map-local-path*))
379          (new-filemap (mapping-read *mcvs-map* :sanity-check t))          (new-filemap (mapping-read *map-path* :sanity-check t))
380            (rollback-needed t)
381          rollback-remove-items rollback-restore-items)          rollback-remove-items rollback-restore-items)
382      (restart-case      (unwind-protect
383        (multiple-value-bind (added-items removed-items moved-pairs)        (multiple-value-bind (added-items removed-items moved-pairs)
384                             (mapping-difference old-filemap new-filemap)                             (mapping-difference old-filemap new-filemap)
385          ;; First remove what has to be removed. This way when we          ;; First remove what has to be removed. This way when we
386          ;; do sanity checks, we won't complain about clobbering things          ;; do sanity checks, we won't complain about clobbering things
387          ;; that are slated to disappear.          ;; that are slated to disappear.
388          (dolist (item removed-items)          (dolist (item removed-items)
389            (when (real-path-exists (second item))            (when (real-path-exists (mapping-entry-path item))
390              (let ((real (abstract-to-real-path (second item))))              (let ((real (abstract-to-real-path (mapping-entry-path item))))
391                (chatter-terse "removing ~a~%" real)                (chatter-terse "removing ~a~%" real)
392                (unless no-delete-removed                (unless no-delete-removed
393                  (restart-case                  (restart-case
394                    (ensure-directories-gone real)                    (honor-dry-run (real)
395                    (ignore () :report "Ignore file removal error."))                      (ensure-directories-gone real))
396                      (continue () :report "Ignore file removal error."))
397                  (push item rollback-restore-items)))))                  (push item rollback-restore-items)))))
398    
399          (dolist (pair moved-pairs)          (dolist (pair moved-pairs)
400            (let ((old-item (first pair)))            (let ((old-item (first pair)))
401              (when (real-path-exists (second old-item))              (with-slots (path) old-item
402                (ensure-directories-gone (abstract-to-real-path (second old-item)))                (when (real-path-exists path)
403                (push old-item rollback-restore-items))))                  (honor-dry-run (path)
404                      (ensure-directories-gone (abstract-to-real-path path)))
405                    (push old-item rollback-restore-items)))))
406    
407          ;; Now check sanity of adds and moves, to verify they don't          ;; Now check sanity of adds and moves, to verify they don't
408          ;; clobber any local files.          ;; clobber any local files.
409          (let (clobber-add-items clobber-move-pairs)          (let (clobber-add-items clobber-move-pairs)
410            (dolist (item added-items)            (dolist (item added-items)
411              (when (real-path-exists (second item))              (with-slots (kind id path target) item
412                (let ((file-info (exists (abstract-to-real-path (second item)))))                (when (real-path-exists path)
413                  (when (and file-info                  (let* ((real-path (abstract-to-real-path path))
414                             (not (same-file-p file-info (stat (first item))))                         (file-info (exists real-path)))
415                             (not (mapping-lookup old-filemap (second item))))                    (when (and file-info
416                    (push item clobber-add-items)))))                               (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    
426            (dolist (item moved-pairs)            (dolist (item moved-pairs)
427              (destructuring-bind (old-item new-item) item              (destructuring-bind (old-item new-item) item
428                (declare (ignore old-item))                (declare (ignore old-item))
429                (when (real-path-exists (second new-item))                (with-slots (path) new-item
430                  (let ((file-info (exists (abstract-to-real-path (second new-item)))))                  (when (real-path-exists path)
431                    (when (and file-info                    (let ((file-info (exists (abstract-to-real-path path))))
432                               (not (mapping-lookup old-filemap (second new-item))))                      (when (and file-info
433                                   (not (mapping-lookup old-filemap path)))
434                      (push item clobber-move-pairs))))))                        (push item clobber-move-pairs)))))))
435    
436            (when (or clobber-add-items clobber-move-pairs)            (when (or clobber-add-items clobber-move-pairs)
437              (block nil              (super-restart-case
438                (restart-bind                (error "some moves or adds want to overwrite local files or directories.")
439                  ((print-clobbers                (info ()
440                     #'(lambda ()                  :report "Print list of adds or moves which want to overwrite."
441                         (dolist (item clobber-add-items)                  (dolist (item clobber-add-items)
442                           (format t "add: ~a~%"                    (format t "add: ~a~%"
443                                   (abstract-to-real-path (second item))))                            (abstract-to-real-path (mapping-entry-path item))))
444                         (dolist (pair clobber-move-pairs)                  (dolist (pair clobber-move-pairs)
445                           (format t "move ~a -> ~a~%"                    (format t "move ~a -> ~a~%"
446                                   (second (abstract-to-real-path (first pair)))                            (abstract-to-real-path (mapping-entry-path
447                                   (second (abstract-to-real-path (second pair))))))                                                     (first pair)))
448                    :report-function                            (abstract-to-real-path (mapping-entry-path
449                    #'(lambda (stream)                                                     (second pair))))))
450                        (write-string "Print list of adds or moves which want to overwrite."                (continue ()
451                                      stream)))                  :report "Go ahead and overwrite the target files."
452                   (do-clobber                  (unwind)))))
                    #'(lambda ()  
                        (return))  
                    :report-function  
                    #'(lambda (stream)  
                        (write-string "Go ahead and overwrite the target files."  
                                      stream))))  
                 (error "mcvs: some moves or adds want to overwrite local files or directories.")))))  
453    
454          ;; Sanity check passed, complete moves and adds.          ;; Sanity check passed, complete moves and adds.
455          (dolist (item moved-pairs)          (dolist (item moved-pairs)
456            (destructuring-bind (old-item new-item) item            (destructuring-bind (old-item new-item) item
457              (let ((real-old-exists (real-path-exists (second old-item)))              (with-slots ((old-path path) (old-id id)) old-item
458                    (real-new-exists (real-path-exists (second new-item))))                (with-slots ((new-path path) (new-id id) kind target executable)
459                (let ((real-old (and real-old-exists                            new-item
460                                     (abstract-to-real-path (second old-item))))                  (let ((real-old-exists (real-path-exists old-path))
461                      (real-new (and real-new-exists                        (real-new-exists (real-path-exists new-path)))
462                                     (abstract-to-real-path (second new-item)))))                    (let ((real-old (and real-old-exists
463                  (cond                                         (abstract-to-real-path old-path)))
464                    ((and real-old-exists real-new-exists)                          (real-new (and real-new-exists
465                       (chatter-terse "moving ~a -> ~a~%" real-old real-new))                                         (abstract-to-real-path new-path))))
466                    (real-new-exists                      (cond
467                       (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))                        ((and real-old-exists real-new-exists)
468                    (real-old-exists                           (chatter-terse "moving ~a -> ~a~%" real-old real-new))
469                       (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))                        (real-new-exists
470                             (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))
471                  (when real-new-exists                        (real-old-exists
472                    (no-existence-error (unlink real-new))                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
473                    (synchronize-files (first new-item) real-new))  
474                    (push new-item rollback-remove-items)))))                      (when real-new-exists
475                          (no-existence-error (honor-dry-run (real-new)
476                                                (unlink real-new)))
477                          (case kind
478                            ((:file)
479                               (synchronize-files new-id real-new executable
480                                                  :direction :right))
481                            ((:symlink)
482                               (honor-dry-run (target real-new)
483                                 (ensure-directories-exist real-new)
484                                 (symlink target real-new))))
485                          (push new-item rollback-remove-items))))))))
486    
487          (dolist (item added-items)          (dolist (item added-items)
488            (when (real-path-exists (second item))            (with-slots (kind id path target executable) item
489              (let ((real (abstract-to-real-path (second item))))              (when (real-path-exists path)
490                (can-restart-here ("Continue updating file structure.")                (let ((real (abstract-to-real-path path)))
491                  (chatter-terse "adding ~a~%" real)                  (can-restart-here ("Continue updating file structure.")
492                  (synchronize-files (first item) real)                    (no-existence-error (honor-dry-run (real)
493                  (push item rollback-remove-items))))))                                          (unlink real)))
494        (continue ()                    (case kind
495          :report "Restore all restructuring done so far."                      ((:file)
496          (chatter-debug "Restoring.~%")                         (chatter-terse "adding ~a~%" real)
497                           (synchronize-files id real executable
498                                              :direction :right))
499                        ((:symlink)
500                           (chatter-terse "linking ~a -> ~a~%" real target)
501                           (honor-dry-run (real)
502                             (ensure-directories-exist real)
503                             (symlink target real))))
504                      (push item rollback-remove-items))))))
505            (setf rollback-needed nil))
506          (when rollback-needed
507            (chatter-debug "Undoing directory structure changes.~%")
508          (dolist (item rollback-remove-items)          (dolist (item rollback-remove-items)
509            (let ((real (abstract-to-real-path (second item))))            (let ((real (abstract-to-real-path (mapping-entry-path item))))
510              (chatter-terse "removing ~a~%" real)              (chatter-terse "removing ~a~%" real)
511              (ensure-directories-gone real)))              (honor-dry-run (real)
512                  (ensure-directories-gone real))))
513          (dolist (item rollback-restore-items)          (dolist (item rollback-restore-items)
514            (let ((real (abstract-to-real-path (second item))))            (with-slots (kind path id target executable) item
515              (chatter-terse "restoring ~a~%" real)              (let ((real (abstract-to-real-path path)))
516              (synchronize-files (first item) real)))                (chatter-terse "restoring ~a~%" real)
517          (return-from mapping-update nil)))                (case kind
518                    ((:file)
519      (mapping-write new-filemap *mcvs-map-local*))                     (synchronize-files id real executable :direction :right))
520                    ((:symlink)
521                       (honor-dry-run (real)
522                         (ensure-directories-exist real)
523                         (symlink target real)))))))))
524        (mapping-write new-filemap *map-local-path*))
525    t)    t)
526    
527  (defun mapping-removed-files (filemap)  (defun mapping-removed-files (filemap)
528    (let ((to-be-removed ())    (let ((to-be-removed ())
529          (f-hash (make-hash-table :test #'equal)))          (f-hash (make-hash-table :test #'equal)))
530      (dolist (entry filemap)      (dolist (entry filemap)
531        (setf (gethash (first entry) f-hash) entry))        (setf (gethash (mapping-entry-id entry) f-hash) entry))
532      (for-each-file-info (fi *mcvs-dir*)      (for-each-file-info (fi *admin-dir*)
533          (when (and (directory-p fi)
534                     (path-equal (basename (file-name fi)) "CVS"))
535            (skip))
536        (let ((base (basename (file-name fi))))        (let ((base (basename (file-name fi))))
537          (multiple-value-bind (suffix name) (suffix base)          (multiple-value-bind (suffix name) (suffix base)
538            (declare (ignore suffix))            (declare (ignore suffix))
# Line 403  whether they came from the CVS repositor Line 543  whether they came from the CVS repositor
543      to-be-removed))      to-be-removed))
544    
545  (defun displaced-path-read ()  (defun displaced-path-read ()
546    (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)    (let ((*read-eval* nil))
547                     (read file))))      (ignore-errors (with-open-file (file *displaced-path* :direction :input)
548                         (read file)))))
549    
550  (defun displaced-path-write (path)  (defun displaced-path-write (path)
551    (with-open-file (file *mcvs-displaced* :direction :output)    (with-open-file (file *displaced-path* :direction :output)
552      (prin1 path file)      (prin1 path file)
553      (terpri file)))      (terpri file)))

Legend:
Removed from v.1.36.2.4  
changed lines
  Added in v.1.66

  ViewVC Help
Powered by ViewVC 1.1.5