/[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.40 by kaz, Mon Aug 5 19:19:58 2002 UTC revision 1.40.2.3 by kaz, Sun Aug 25 19:31:51 2002 UTC
# Line 76  Line 76 
76              (symbol-macrolet ((sandbox-down-path ,downpath-sym))              (symbol-macrolet ((sandbox-down-path ,downpath-sym))
77                ,@forms)))))))                ,@forms)))))))
78    
79  (defun mapping-generate-name (suffix &key no-dir)  (defstruct mapping-entry
80    (let* ((suffix (if (or (null suffix)    (kind :file)
81                           (string= "" suffix))    (id "")
82                     ""    (path "")
83                     (format nil ".~a" suffix)))    (target ""))
84           (name (format nil "F-~32,'0X~a" (guid-gen) suffix)))  
85      (if no-dir  (defun mapping-generate-id (&key no-dir (suffix "") (prefix "F-"))
86        name    (format nil "~a~a~32,'0X~a"
87        (path-cat *mcvs-dir* name))))            (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    
100  (defun mapping-extract-paths (filemap)  (defun mapping-extract-paths (filemap)
101    (mapcar #'second filemap))    (mapcar #'mapping-entry-path filemap))
102  (declaim (inline mapping-extract-paths))  (declaim (inline mapping-extract-paths))
103    
104  (defun mapping-lookup (filemap path)  (defun mapping-lookup (filemap path)
105    (find path filemap :test #'path-equal :key #'second))    (find path filemap :test #'path-equal :key #'mapping-entry-path))
106    
107  (defun mapping-prefix-lookup (filemap prefix)  (defun mapping-prefix-lookup (filemap prefix)
108    (if (path-equal *this-dir* prefix)    (if (path-equal *this-dir* prefix)
109      (first filemap)      (first filemap)
110      (find prefix filemap :test #'path-prefix-equal :key #'second)))      (find prefix filemap :test #'path-prefix-equal :key #'mapping-entry-path)))
111    
112  (defun mapping-prefix-matches (filemap path)  (defun mapping-prefix-matches (filemap path)
113    (if (path-equal *this-dir* path)    (if (path-equal *this-dir* path)
114      filemap      filemap
115      (remove-if-not #'(lambda (entry)      (remove-if-not #'(lambda (entry)
116                         (path-prefix-equal path (second entry))) filemap)))                         (path-prefix-equal path (mapping-entry-path entry)))
117                       filemap)))
118    
119  (defun mapping-object-lookup (filemap object)  (defun mapping-same-id-p (entry-one entry-two)
120    (find object filemap :test #'string= :key #'first))    (string= (mapping-entry-id entry-one) (mapping-entry-id entry-two)))
   
 (defun mapping-same-object-p (entry-one entry-two)  
   (string= (first entry-one) (first entry-two)))  
121    
122  (defun mapping-same-path-p (entry-one entry-two)  (defun mapping-same-path-p (entry-one entry-two)
123    (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)))))  
124    
125  (defun mapping-rename-files (filemap file-list old-prefix new-prefix)  (defun mapping-rename-files (filemap file-list old-prefix new-prefix)
126  "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 128  of the map is not preserved." Line 133  of the map is not preserved."
133               (canonicalize-path (path-cat prefix path)))))               (canonicalize-path (path-cat prefix path)))))
134      (let* ((op-len (length old-prefix))      (let* ((op-len (length old-prefix))
135             (delete-map (mapcan #'(lambda (entry)             (delete-map (mapcan #'(lambda (entry)
136                                     (let ((path (second entry)))                                     (with-slots (path) entry
137                                       (if (and (member path file-list                                       (if (and (member path file-list
138                                                        :test #'path-equal)                                                        :test #'path-equal)
139                                                (path-prefix-equal old-prefix                                                (path-prefix-equal old-prefix
140                                                                   path))                                                                   path))
141                                         (list entry)))) filemap))                                         (list entry)))) filemap))
142             (replace-map (mapcan #'(lambda (entry)             (replace-map (mapcan #'(lambda (entry)
143                                      (destructuring-bind (object path) entry                                      (with-slots (path) entry
144                                        (list (list object                                        (let ((new-entry (copy-mapping-entry
145                                                    (combine new-prefix                                                           entry)))
146                                                             (subseq path                                          (setf (mapping-entry-path new-entry)
147                                                                     op-len))))))                                                (combine new-prefix
148                                                           (subseq path op-len)))
149                                            (list new-entry))))
150                                   delete-map)))                                   delete-map)))
151      (append      (append
152        (set-difference        (set-difference
# Line 153  of the map is not preserved." Line 160  of the map is not preserved."
160  (defun mapping-dupe-check (filemap)  (defun mapping-dupe-check (filemap)
161  "Signals an error condition if the filemap contains duplicate paths or  "Signals an error condition if the filemap contains duplicate paths or
162  duplicate objects. Otherwise returns the filemap, sorted by path."  duplicate objects. Otherwise returns the filemap, sorted by path."
163    (dolist (entry filemap)    (let ((dupes)
164      (when (or (not (consp entry))          (id-hash (make-hash-table :test #'equal))
165                (not (and (stringp (first entry))          (path-hash (make-hash-table :test #'equal)))
166                          (stringp (second entry)))))      (dolist (entry filemap)
167        (malformed-map)))        (if (gethash (mapping-entry-id entry) id-hash)
168            (push entry dupes)
169    (let (dupes          (setf (gethash (mapping-entry-id entry) id-hash) entry))
170          (sorted-map (sort (copy-list filemap) #'string< :key #'first)))        (if (gethash (mapping-entry-path entry) path-hash)
171      (let ((iter (rest filemap)) (current-item (first (first filemap))))          (push entry dupes)
172        (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))))  
   
173      (when dupes      (when dupes
174        (dolist (dupe dupes)        (dolist (dupe dupes)
175          (chatter-terse "duplicate ~a -> ~a~%" (first dupe) (second dupe)))          (chatter-terse "duplicate ~a -> ~a~%"
176                           (mapping-entry-id dupe) (mapping-entry-path dupe)))
177        (error "mcvs: duplicates in map: correct and run mcvs update.")))        (error "mcvs: duplicates in map: correct and run mcvs update.")))
178    filemap)    filemap)
179    
180    (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  (defun mapping-read (filename &key sanity-check)  (defun mapping-read (filename &key sanity-check)
230    "Reads a Meta-CVS from a file, optionally performing a check
231    for duplicate entries"
232    (let (filemap)    (let (filemap)
233        ;;
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      (with-open-file (file filename :direction :input)      (with-open-file (file filename :direction :input)
238        (setf filemap (read file nil :error))        (setf filemap (read file nil :error))
239        (when (or (eq filemap :error)        (when (or (eq filemap :error)
240                  (and (not (consp filemap)) (not (null filemap))))                  (and (not (consp filemap)) (not (null filemap))))
241          (malformed-map)))          (malformed-map)))
242        ;;
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      (if sanity-check      (if sanity-check
253        (mapping-dupe-check filemap)        (mapping-dupe-check filemap)
254        filemap)))        filemap)))
255    
256  (defun mapping-write (filemap filename &key sort-map)  (defun mapping-write (filemap filename &key sort-map)
257    (with-open-file (file filename :direction :output)    (when sort-map
258      (let ((*print-right-margin* 1))      (setf filemap (sort (copy-list filemap)
259        (prin1 (if sort-map                          #'string< :key #'mapping-entry-id)))
260                 (sort (copy-list filemap) #'string< :key #'first)    (let ((raw-filemap (mapping-convert-out filemap)))
261                 filemap) file)      (with-open-file (file filename :direction :output)
262        (terpri file))))        (let ((*print-right-margin* 1))
263            (prin1 raw-filemap file)
264            (terpri file)))))
265    
266  (defun mapping-synchronize ()  (defun mapping-synchronize ()
267  "Synchronizes the contents of files in the sandbox, and their corresponding  "Synchronizes the contents of files in the sandbox, and their corresponding
# Line 215  to ensure that the newly incorporated ch Line 272  to ensure that the newly incorporated ch
272    (let ((filemap (mapping-read *mcvs-map-local*)))    (let ((filemap (mapping-read *mcvs-map-local*)))
273      (dolist (item filemap)      (dolist (item filemap)
274        (can-restart-here ("Continue synchronizing files.")        (can-restart-here ("Continue synchronizing files.")
275          (destructuring-bind (left right) item          (with-slots (kind id path target) item
276            (when (real-path-exists right)            (when (real-path-exists path)
277              (setf right (abstract-to-real-path right))              (case kind
278              (case (synchronize-files left right)                ((:file)
279                ((:left)                   (let ((left id) (right (abstract-to-real-path path)))
280                  (chatter-info "sync ~a -> ~a~%" left right))                     (case (synchronize-files left right)
281                ((:right)                       ((:left)
282                  (chatter-info "sync ~a <- ~a~%" left right))                         (chatter-info "sync ~a -> ~a~%" left right))
283                ((:same))                       ((:right)
284                ((:dir)                         (chatter-info "sync ~a <- ~a~%" left right))
285                  (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."                       ((:same))
286                         left right))                       ((:dir)
287                ((nil)                         (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."
288                  (error "mcvs-sync: neither ~a nor ~a exists."                                left right))
289                         left right)))))))))                       ((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                         (ensure-directories-exist symlink)
299                         (symlink target symlink)
300                         (chatter-info "linking: ~a -> ~a~%"
301                                       symlink target)))))))))))
302    
303  (defun mapping-difference (old-mapping new-mapping)  (defun mapping-difference (old-mapping new-mapping)
304  "Compute the difference between two mappings. Returns three values:  "Compute the difference between two mappings. Returns three values:
# Line 240  to ensure that the newly incorporated ch Line 309  to ensure that the newly incorporated ch
309    (multiple-value-bind (moved-pairs added-items removed-items)    (multiple-value-bind (moved-pairs added-items removed-items)
310                         (intersection-difference                         (intersection-difference
311                           new-mapping old-mapping                           new-mapping old-mapping
312                           :key #'first :test #'equal                           :key #'mapping-entry-id :test #'equal
313                           :combine #'(lambda (new old)                           :combine #'(lambda (new old)
314                                        (unless (string= (second new)                                        (unless (string= (mapping-entry-path new)
315                                                         (second old))                                                         (mapping-entry-path old))
316                                          (list old new)))                                          (list old new)))
317                           :squash-nil t)                           :squash-nil t)
318      (values added-items removed-items moved-pairs)))      (values added-items removed-items moved-pairs)))
# Line 268  whether they came from the CVS repositor Line 337  whether they came from the CVS repositor
337          ;; do sanity checks, we won't complain about clobbering things          ;; do sanity checks, we won't complain about clobbering things
338          ;; that are slated to disappear.          ;; that are slated to disappear.
339          (dolist (item removed-items)          (dolist (item removed-items)
340            (when (real-path-exists (second item))            (when (real-path-exists (mapping-entry-path item))
341              (let ((real (abstract-to-real-path (second item))))              (let ((real (abstract-to-real-path (mapping-entry-path item))))
342                (chatter-terse "removing ~a~%" real)                (chatter-terse "removing ~a~%" real)
343                (unless no-delete-removed                (unless no-delete-removed
344                  (restart-case                  (restart-case
# Line 279  whether they came from the CVS repositor Line 348  whether they came from the CVS repositor
348    
349          (dolist (pair moved-pairs)          (dolist (pair moved-pairs)
350            (let ((old-item (first pair)))            (let ((old-item (first pair)))
351              (when (real-path-exists (second old-item))              (with-slots (path) old-item
352                (ensure-directories-gone (abstract-to-real-path (second old-item)))                (when (real-path-exists path)
353                (push old-item rollback-restore-items))))                  (ensure-directories-gone (abstract-to-real-path path))
354                    (push old-item rollback-restore-items)))))
355    
356          ;; Now check sanity of adds and moves, to verify they don't          ;; Now check sanity of adds and moves, to verify they don't
357          ;; clobber any local files.          ;; clobber any local files.
358          (let (clobber-add-items clobber-move-pairs)          (let (clobber-add-items clobber-move-pairs)
359            (dolist (item added-items)            (dolist (item added-items)
360              (when (real-path-exists (second item))              (with-slots (kind id path target) item
361                (let ((file-info (exists (abstract-to-real-path (second item)))))                (when (real-path-exists path)
362                  (when (and file-info                  (let* ((real-path (abstract-to-real-path path))
363                             (not (same-file-p file-info (stat (first item))))                         (file-info (exists real-path)))
364                             (not (mapping-lookup old-filemap (second item))))                    (when (and file-info
365                    (push item clobber-add-items)))))                               (case kind
366                                   ((:file)
367                                      (not (same-file-p file-info (stat id))))
368                                   ((:symlink)
369                                      (not (string= (readlink real-path)
370                                                    target)))
371                                   (otherwise t))
372                                 (not (mapping-lookup old-filemap path)))
373                        (push item clobber-add-items))))))
374    
375            (dolist (item moved-pairs)            (dolist (item moved-pairs)
376              (destructuring-bind (old-item new-item) item              (destructuring-bind (old-item new-item) item
377                (declare (ignore old-item))                (declare (ignore old-item))
378                (when (real-path-exists (second new-item))                (with-slots (path) new-item
379                  (let ((file-info (exists (abstract-to-real-path (second new-item)))))                  (when (real-path-exists path)
380                    (when (and file-info                    (let ((file-info (exists (abstract-to-real-path path))))
381                               (not (mapping-lookup old-filemap (second new-item))))                      (when (and file-info
382                                   (not (mapping-lookup old-filemap path)))
383                      (push item clobber-move-pairs))))))                        (push item clobber-move-pairs)))))))
384    
385            (when (or clobber-add-items clobber-move-pairs)            (when (or clobber-add-items clobber-move-pairs)
386              (block nil              (block nil
# Line 311  whether they came from the CVS repositor Line 389  whether they came from the CVS repositor
389                     #'(lambda ()                     #'(lambda ()
390                         (dolist (item clobber-add-items)                         (dolist (item clobber-add-items)
391                           (format t "add: ~a~%"                           (format t "add: ~a~%"
392                                   (abstract-to-real-path (second item))))                                   (abstract-to-real-path (mapping-entry-path item))))
393                         (dolist (pair clobber-move-pairs)                         (dolist (pair clobber-move-pairs)
394                           (format t "move ~a -> ~a~%"                           (format t "move ~a -> ~a~%"
395                                   (second (abstract-to-real-path (first pair)))                                   (abstract-to-real-path (mapping-entry-path
396                                   (second (abstract-to-real-path (second pair))))))                                                            (first pair)))
397                                     (abstract-to-real-path (mapping-entry-path
398                                                              (second pair))))))
399                    :report-function                    :report-function
400                    #'(lambda (stream)                    #'(lambda (stream)
401                        (write-string "Print list of adds or moves which want to overwrite."                        (write-string "Print list of adds or moves which want to overwrite."
# Line 332  whether they came from the CVS repositor Line 412  whether they came from the CVS repositor
412          ;; Sanity check passed, complete moves and adds.          ;; Sanity check passed, complete moves and adds.
413          (dolist (item moved-pairs)          (dolist (item moved-pairs)
414            (destructuring-bind (old-item new-item) item            (destructuring-bind (old-item new-item) item
415              (let ((real-old-exists (real-path-exists (second old-item)))              (with-slots ((old-path path) (old-id id)) old-item
416                    (real-new-exists (real-path-exists (second new-item))))                (with-slots ((new-path path) (new-id id) kind target) new-item
417                (let ((real-old (and real-old-exists                  (let ((real-old-exists (real-path-exists old-path))
418                                     (abstract-to-real-path (second old-item))))                        (real-new-exists (real-path-exists new-path)))
419                      (real-new (and real-new-exists                    (let ((real-old (and real-old-exists
420                                     (abstract-to-real-path (second new-item)))))                                         (abstract-to-real-path old-path)))
421                  (cond                          (real-new (and real-new-exists
422                    ((and real-old-exists real-new-exists)                                         (abstract-to-real-path new-path))))
423                       (chatter-terse "moving ~a -> ~a~%" real-old real-new))                      (cond
424                    (real-new-exists                        ((and real-old-exists real-new-exists)
425                       (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))                           (chatter-terse "moving ~a -> ~a~%" real-old real-new))
426                    (real-old-exists                        (real-new-exists
427                       (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))                           (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))
428                          (real-old-exists
429                  (when real-new-exists                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
430                    (no-existence-error (unlink real-new))  
431                    (synchronize-files (first new-item) real-new))                      (when real-new-exists
432                    (push new-item rollback-remove-items)))))                        (no-existence-error (unlink real-new))
433                          (case kind
434                            ((:file)
435                               (synchronize-files new-id real-new))
436                            ((:symlink)
437                               (ensure-directories-exist real-new)
438                               (symlink target real-new)))
439                          (push new-item rollback-remove-items))))))))
440    
441          (dolist (item added-items)          (dolist (item added-items)
442            (when (real-path-exists (second item))            (with-slots (kind id path target) item
443              (let ((real (abstract-to-real-path (second item))))              (when (real-path-exists path)
444                (can-restart-here ("Continue updating file structure.")                (let ((real (abstract-to-real-path path)))
445                  (chatter-terse "adding ~a~%" real)                  (can-restart-here ("Continue updating file structure.")
446                  (synchronize-files (first item) real)                    (case kind
447                  (push item rollback-remove-items))))))                      ((:file)
448                           (chatter-terse "adding ~a~%" real)
449                           (synchronize-files id real))
450                        ((:symlink)
451                           (chatter-terse "linking ~a -> ~a~%" real target)
452                           (no-existence-error (unlink real))
453                           (ensure-directories-exist real)
454                           (symlink target real)))
455                      (push item rollback-remove-items)))))))
456        (continue ()        (continue ()
457          :report "Restore all restructuring done so far."          :report "Restore all restructuring done so far."
458          (chatter-debug "Restoring.~%")          (chatter-debug "Restoring.~%")
459          (dolist (item rollback-remove-items)          (dolist (item rollback-remove-items)
460            (let ((real (abstract-to-real-path (second item))))            (let ((real (abstract-to-real-path (mapping-entry-path item))))
461              (chatter-terse "removing ~a~%" real)              (chatter-terse "removing ~a~%" real)
462              (ensure-directories-gone real)))              (ensure-directories-gone real)))
463          (dolist (item rollback-restore-items)          (dolist (item rollback-restore-items)
464            (let ((real (abstract-to-real-path (second item))))            (with-slots (kind path id target) item
465              (chatter-terse "restoring ~a~%" real)              (let ((real (abstract-to-real-path path)))
466              (synchronize-files (first item) real)))                (chatter-terse "restoring ~a~%" real)
467                  (case kind
468                    ((:file)
469                       (synchronize-files id real))
470                    ((:symlink)
471                       (ensure-directories-exist real)
472                       (symlink target real))))))
473          (return-from mapping-update nil)))          (return-from mapping-update nil)))
474    
475      (mapping-write new-filemap *mcvs-map-local*))      (mapping-write new-filemap *mcvs-map-local*))
# Line 378  whether they came from the CVS repositor Line 479  whether they came from the CVS repositor
479    (let ((to-be-removed ())    (let ((to-be-removed ())
480          (f-hash (make-hash-table :test #'equal)))          (f-hash (make-hash-table :test #'equal)))
481      (dolist (entry filemap)      (dolist (entry filemap)
482        (setf (gethash (first entry) f-hash) entry))        (setf (gethash (mapping-entry-id entry) f-hash) entry))
483      (for-each-file-info (fi *mcvs-dir*)      (for-each-file-info (fi *mcvs-dir*)
484        (let ((base (basename (file-name fi))))        (let ((base (basename (file-name fi))))
485          (multiple-value-bind (suffix name) (suffix base)          (multiple-value-bind (suffix name) (suffix base)

Legend:
Removed from v.1.40  
changed lines
  Added in v.1.40.2.3

  ViewVC Help
Powered by ViewVC 1.1.5