/[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 by kaz, Tue Jul 2 18:32:52 2002 UTC revision 1.37 by kaz, Sat Jul 6 17:15:02 2002 UTC
# Line 12  Line 12 
12  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
13    (defconstant *mcvs-dir* #.(path-cat "MCVS"))    (defconstant *mcvs-dir* #.(path-cat "MCVS"))
14    (defconstant *mcvs-map-name* "MAP")    (defconstant *mcvs-map-name* "MAP")
15    (defconstant *mcvs-map-local-name* "MAP-LOCAL"))    (defconstant *mcvs-map-local-name* "MAP-LOCAL")
16      (defconstant *mcvs-displaced-name* "DISPLACED"))
17    
18  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
19    (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))    (defconstant *mcvs-map* #.(path-cat *mcvs-dir* *mcvs-map-name*))
20    (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* *mcvs-map-local-name*)))    (defconstant *mcvs-map-local* #.(path-cat *mcvs-dir* *mcvs-map-local-name*))
21      (defconstant *mcvs-displaced* #.(path-cat *mcvs-dir* *mcvs-displaced-name*)))
22    
23    (defvar *displaced-path-prefix* nil)
24    (defvar *displaced-path-length* nil)
25    
26  ;; TODO: use getcwd()  ;; TODO: use getcwd()
27  (defun mcvs-locate ()  (defun mcvs-locate ()
# Line 32  down to the original one, or the value n Line 37  down to the original one, or the value n
37            (if locate            (if locate
38              (path-cat locate came-from)))))))              (path-cat locate came-from)))))))
39    
40    (defun real-path-exists (path)
41      (or (null *displaced-path-prefix*)
42          (path-prefix-equal *displaced-path-prefix* path)))
43    
44    (defun abstract-to-real-path (path)
45      (if *displaced-path-length*
46        (if (or (= (length path) (1- *displaced-path-length*))
47                (= (length path) *displaced-path-length*))
48          *this-dir*
49          (substring path *displaced-path-length*))
50        path))
51    
52    (defun real-to-abstract-path (path)
53      (if *displaced-path-prefix*
54        (concatenate 'string *displaced-path-prefix* path)
55        path))
56    
57    (declaim (inline real-path-exists abstract-to-real-path
58                     real-to-abstract-path))
59    
60  (defmacro in-sandbox-root-dir (&body forms)  (defmacro in-sandbox-root-dir (&body forms)
61    (let ((downpath-sym (gensym "DOWNPATH-")))    (let ((downpath-sym (gensym "DOWNPATH-")))
62     `(current-dir-restore     `(current-dir-restore
63        (let ((,downpath-sym (mcvs-locate)))        (let ((,downpath-sym (mcvs-locate)))
64          (when (not ,downpath-sym)          (when (not ,downpath-sym)
65            (error "mcvs: could not locate ~a directory." *mcvs-dir*))            (error "mcvs: could not locate ~a directory." *mcvs-dir*))
66          (flet ((sandbox-translate-path (in-path)          (let* ((*displaced-path-prefix* (displaced-path-read))
67                   (multiple-value-bind (out-path out-of-bounds)                 (*displaced-path-length* (if *displaced-path-prefix*
68                                        (canonicalize-path                                            (length *displaced-path-prefix*))))
69                                          (if (path-absolute-p in-path)            (flet ((sandbox-translate-path (in-path)
70                                            (path-cat *this-dir* in-path)                     (multiple-value-bind (out-path out-of-bounds)
71                                            (path-cat ,downpath-sym in-path)))                                          (canonicalize-path
72                      (if out-of-bounds                                            (if (path-absolute-p in-path)
73                        (error "mcvs: path ~a is not within sandbox." out-path)                                              (path-cat *this-dir* in-path)
74                        out-path))))                                              (path-cat ,downpath-sym in-path)))
75            (symbol-macrolet ((sandbox-down-path ,downpath-sym))                        (if out-of-bounds
76              ,@forms))))))                          (error "mcvs: path ~a is not within sandbox." out-path)
77                            out-path))))
78                (symbol-macrolet ((sandbox-down-path ,downpath-sym))
79                  ,@forms)))))))
80    
81  (defun mapping-generate-name (suffix &key no-dir)  (defun mapping-generate-name (suffix &key no-dir)
82    (let* ((suffix (if (or (null suffix)    (let* ((suffix (if (or (null suffix)
# Line 190  to ensure that the newly incorporated ch Line 218  to ensure that the newly incorporated ch
218      (dolist (item filemap)      (dolist (item filemap)
219        (can-restart-here ("Continue synchronizing files.")        (can-restart-here ("Continue synchronizing files.")
220          (destructuring-bind (left right) item          (destructuring-bind (left right) item
221            (case (synchronize-files left right)            (when (real-path-exists right)
222              ((:left)              (setf right (abstract-to-real-path right))
223                (chatter-info "sync ~a -> ~a~%" left right))              (case (synchronize-files left right)
224              ((:right)                ((:left)
225                (chatter-info "sync ~a <- ~a~%" left right))                  (chatter-info "sync ~a -> ~a~%" left right))
226              ((:same))                ((:right)
227              ((:dir)                  (chatter-info "sync ~a <- ~a~%" left right))
228                (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."                ((:same))
229                       left right))                ((:dir)
230              ((nil)                  (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."
231                (error "mcvs-sync: neither ~a nor ~a exists."                         left right))
232                       left right))))))))                ((nil)
233                    (error "mcvs-sync: neither ~a nor ~a exists."
234                           left right)))))))))
235    
236  (defun mapping-difference (old-mapping new-mapping)  (defun mapping-difference (old-mapping new-mapping)
237  "Compute the difference between two mappings. Returns three values:  "Compute the difference between two mappings. Returns three values:
# Line 250  whether they came from the CVS repositor Line 280  whether they came from the CVS repositor
280          ;; First remove what has to be removed. This way when we          ;; First remove what has to be removed. This way when we
281          ;; do sanity checks, we won't complain about clobbering things          ;; do sanity checks, we won't complain about clobbering things
282          ;; that are slated to disappear.          ;; that are slated to disappear.
283          (unless no-delete-removed          (dolist (item removed-items)
284            (dolist (item removed-items)            (when (real-path-exists (second item))
285              (chatter-terse "removing ~a~%" (second item))              (let ((real (abstract-to-real-path (second item))))
286              (restart-case                (chatter-terse "removing ~a~%" real)
287                (ensure-directories-gone (second item))                (unless no-delete-removed
288                (ignore () :report "Ignore file removal error."))                  (restart-case
289              (push item rollback-restore-items)))                    (ensure-directories-gone real)
290                      (ignore () :report "Ignore file removal error."))
291                    (push item rollback-restore-items)))))
292    
293          (dolist (pair moved-pairs)          (dolist (pair moved-pairs)
294            (let ((old-item (first pair)))            (let ((old-item (first pair)))
295              (ensure-directories-gone (second old-item))              (when (real-path-exists (second old-item))
296              (push old-item rollback-restore-items)))                (ensure-directories-gone (abstract-to-real-path (second old-item)))
297                  (push old-item rollback-restore-items))))
298    
299          ;; Now check sanity of adds and moves, to verify they don't          ;; Now check sanity of adds and moves, to verify they don't
300          ;; clobber any local files.          ;; clobber any local files.
301          (let (clobber-add-items clobber-move-pairs)          (let (clobber-add-items clobber-move-pairs)
302            (dolist (item added-items)            (dolist (item added-items)
303              (let ((file-info (exists (second item))))              (when (real-path-exists (second item))
304                (when (and file-info                (let ((file-info (exists (abstract-to-real-path (second item)))))
305                           (not (same-file-p file-info (stat (first item))))                  (when (and file-info
306                           (not (mapping-lookup old-filemap (second item))))                             (not (same-file-p file-info (stat (first item))))
307                  (push item clobber-add-items))))                             (not (mapping-lookup old-filemap (second item))))
308                      (push item clobber-add-items)))))
309    
310            (dolist (item moved-pairs)            (dolist (item moved-pairs)
311              (destructuring-bind (old-item new-item) item              (destructuring-bind (old-item new-item) item
312                (declare (ignore old-item))                (declare (ignore old-item))
313                (let ((file-info (exists (second new-item))))                (when (real-path-exists (second new-item))
314                  (when (and file-info                  (let ((file-info (exists (abstract-to-real-path (second new-item)))))
315                             (not (mapping-lookup old-filemap (second new-item))))                    (when (and file-info
316                                 (not (mapping-lookup old-filemap (second new-item))))
317    
318                    (push item clobber-move-pairs)))))                      (push item clobber-move-pairs))))))
319    
320            (when (or clobber-add-items clobber-move-pairs)            (when (or clobber-add-items clobber-move-pairs)
321              (block nil              (block nil
# Line 288  whether they came from the CVS repositor Line 323  whether they came from the CVS repositor
323                  ((print-clobbers                  ((print-clobbers
324                     #'(lambda ()                     #'(lambda ()
325                         (dolist (item clobber-add-items)                         (dolist (item clobber-add-items)
326                           (format t "add: ~a~%" (second item)))                           (format t "add: ~a~%"
327                                     (abstract-to-real-path (second item))))
328                         (dolist (pair clobber-move-pairs)                         (dolist (pair clobber-move-pairs)
329                           (format t "move ~a -> ~a~%" (second (first pair))                           (format t "move ~a -> ~a~%"
330                                                       (second (second pair)))))                                   (second (abstract-to-real-path (first pair)))
331                                     (second (abstract-to-real-path (second pair))))))
332                    :report-function                    :report-function
333                    #'(lambda (stream)                    #'(lambda (stream)
334                        (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 308  whether they came from the CVS repositor Line 345  whether they came from the CVS repositor
345          ;; Sanity check passed, complete moves and adds.          ;; Sanity check passed, complete moves and adds.
346          (dolist (item moved-pairs)          (dolist (item moved-pairs)
347            (destructuring-bind (old-item new-item) item            (destructuring-bind (old-item new-item) item
348              (chatter-terse "moving ~a -> ~a~%" (second old-item)              (let ((real-old-exists (real-path-exists (second old-item)))
349                                                (second new-item))                    (real-new-exists (real-path-exists (second new-item))))
350              (no-existence-error (unlink (second new-item)))                (let ((real-old (and real-old-exists
351              (synchronize-files (first new-item) (second new-item))                                     (abstract-to-real-path (second old-item))))
352              (push new-item rollback-remove-items)))                      (real-new (and real-new-exists
353                                       (abstract-to-real-path (second new-item)))))
354                    (cond
355                      ((and real-old-exists real-new-exists)
356                         (chatter-terse "moving ~a -> ~a~%" real-old real-new))
357                      (real-new-exists
358                         (chatter-terse "moving (out-of-sandbox) -> ~a~%" real-new))
359                      (real-old-exists
360                         (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
361    
362                    (when real-new-exists
363                      (no-existence-error (unlink real-new))
364                      (synchronize-files (first new-item) real-new))
365                      (push new-item rollback-remove-items)))))
366    
367          (dolist (item added-items)          (dolist (item added-items)
368            (can-restart-here ("Continue updating file structure.")            (when (real-path-exists (second item))
369              (chatter-terse "adding ~a~%" (second item))              (let ((real (abstract-to-real-path (second item))))
370              (synchronize-files (first item) (second item))                (can-restart-here ("Continue updating file structure.")
371              (push item rollback-remove-items))))                  (chatter-terse "adding ~a~%" real)
372                    (synchronize-files (first item) real)
373                    (push item rollback-remove-items))))))
374        (continue ()        (continue ()
375          :report "Restore all restructuring done so far."          :report "Restore all restructuring done so far."
376          (chatter-debug "Restoring.~%")          (chatter-debug "Restoring.~%")
377          (dolist (item rollback-remove-items)          (dolist (item rollback-remove-items)
378            (chatter-terse "removing ~a~%" (second item))            (let ((real (abstract-to-real-path (second item))))
379            (ensure-directories-gone (second item)))              (chatter-terse "removing ~a~%" real)
380                (ensure-directories-gone real)))
381          (dolist (item rollback-restore-items)          (dolist (item rollback-restore-items)
382            (chatter-terse "restoring ~a~%" (second item))            (let ((real (abstract-to-real-path (second item))))
383            (synchronize-files (first item) (second item)))              (chatter-terse "restoring ~a~%" real)
384                (synchronize-files (first item) real)))
385          (return-from mapping-update nil)))          (return-from mapping-update nil)))
386    
387      (mapping-write new-filemap *mcvs-map-local*))      (mapping-write new-filemap *mcvs-map-local*))
# Line 347  whether they came from the CVS repositor Line 401  whether they came from the CVS repositor
401                       (not (gethash (file-name fi) f-hash)))                       (not (gethash (file-name fi) f-hash)))
402              (push (file-name fi) to-be-removed)))))              (push (file-name fi) to-be-removed)))))
403      to-be-removed))      to-be-removed))
404    
405    (defun displaced-path-read ()
406      (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
407                       (read file))))
408    
409    (defun displaced-path-write (path)
410      (with-open-file (file *mcvs-displaced* :direction :output)
411        (prin1 path file)
412        (terpri file)))

Legend:
Removed from v.1.36  
changed lines
  Added in v.1.37

  ViewVC Help
Powered by ViewVC 1.1.5