/[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.2.4 by kaz, Tue Aug 27 03:19:05 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")  
 (require "seqfuncs")  
 (provide "mapping")  
6    
7  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
8    (defconstant *mcvs-dir* "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  (defun mcvs-locate ()  (defun locate ()
22    (let ((current-dir (split-fields (getcwd) *path-sep*)))    (let ((current-dir (split-fields (getcwd) *path-sep*))
23            (escape-levels *nesting-escape-option*))
24      (dotimes (i (length current-dir) nil)      (dotimes (i (length current-dir) nil)
25        (let* ((path-components (butlast current-dir i))        (let* ((path-components (butlast current-dir i))
26               (path-string (reduce #'path-cat path-components)))               (path-string (reduce #'path-cat path-components)))
27          (when (ignore-errors (stat (path-cat path-string *mcvs-dir*)))          (when (and (ignore-errors (stat (path-cat path-string *admin-dir*)))
28                       (zerop (prog1 escape-levels (decf escape-levels))))
29              (when (> *nesting-escape-option* 0)
30                (chatter-info "using sandbox ~a~%" path-string))
31            (chdir path-string)            (chdir path-string)
32            (return (if (zerop i)            (return (if (zerop i)
33                      "."                      "."
34                      (reduce #'path-cat (last current-dir i)))))))))                      (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*)
41        (path-prefix-equal *displaced-path-prefix* path)))        (path-prefix-equal *displaced-path-prefix* path)))
# Line 44  Line 45 
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 52  Line 53 
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 71  Line 69 
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)))))))
# Line 80  Line 78 
78    (kind :file)    (kind :file)
79    (id "")    (id "")
80    (path "")    (path "")
81    (target ""))    (target "")
82      (executable nil)
83      (raw-plist nil))
84    
85  (defun equal-mapping-entries (left right)  (defun equal-mapping-entries (left right)
86    (and (eq (mapping-entry-kind left) (mapping-entry-kind right))    (and (eq (mapping-entry-kind left) (mapping-entry-kind right))
# Line 89  Line 89 
89         (equal (mapping-entry-target left) (mapping-entry-target right))))         (equal (mapping-entry-target left) (mapping-entry-target right))))
90    
91  (defun equal-filemaps (left right)  (defun equal-filemaps (left right)
92    (let ((same nil))    (let ((same t))
93      (mapc #'(lambda (le re)      (mapc #'(lambda (le re)
94                (setf same (and same (equal-mapping-entries le re))))                (setf same (and same (equal-mapping-entries le re))))
95              left right)))              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-"))  (defun mapping-generate-id (&key no-dir (suffix "") (prefix "F-"))
106    (format nil "~a~a~32,'0X~a"    (format nil "~a~a~32,'0X~a"
107            (if no-dir "" (concatenate 'string *mcvs-dir* *path-sep*))            (if no-dir "" (concatenate 'string *admin-dir* *path-sep*))
108            prefix            prefix
109            (guid-gen)            (guid-gen)
110            (if (or (null suffix) (string= "" suffix))            (if (or (null suffix) (string= "" suffix))
# Line 109  Line 117 
117                   filemap                   filemap
118                   :key #'mapping-entry-kind))                   :key #'mapping-entry-kind))
119    
120    (declaim (inline mapping-extract-paths))
121  (defun mapping-extract-paths (filemap)  (defun mapping-extract-paths (filemap)
122    (mapcar #'mapping-entry-path filemap))    (mapcar #'mapping-entry-path filemap))
 (declaim (inline mapping-extract-paths))  
123    
124  (defun mapping-lookup (filemap path)  (defun mapping-lookup (filemap path)
125    (find path filemap :test #'path-equal :key #'mapping-entry-path))    (find path filemap :test #'path-equal :key #'mapping-entry-path))
# Line 167  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
# Line 186  duplicate objects. Otherwise returns the Line 194  duplicate objects. Otherwise returns the
194        (dolist (dupe dupes)        (dolist (dupe dupes)
195          (chatter-terse "duplicate ~a -> ~a~%"          (chatter-terse "duplicate ~a -> ~a~%"
196                         (mapping-entry-id dupe) (mapping-entry-path dupe)))                         (mapping-entry-id dupe) (mapping-entry-path dupe)))
197        (error "mcvs: duplicates in map: correct and run mcvs update.")))        (error "duplicates in map: correct and run mcvs update.")))
198    filemap)    filemap)
199    
200  (defun mapping-convert-old-style-in (raw-filemap)  (defun mapping-convert-old-style-in (raw-filemap)
# Line 212  representation---a list of mapping-entry Line 220  representation---a list of mapping-entry
220                  (malformed-map))                  (malformed-map))
221                (case (first item)                (case (first item)
222                  ((:file)                  ((:file)
223                     (make-mapping-entry :kind :file                     (let ((entry (make-mapping-entry :kind :file
224                                         :id (second item)                                                      :id (second item)
225                                         :path (third item)))                                                      :path (third item)
226                                                        :raw-plist (fourth item))))
227                         (when (fourth item)
228                           (mapping-entry-parse-plist entry))
229                         entry))
230                  ((:symlink)                  ((:symlink)
231                     (when (not (third item))                     (when (not (third item))
232                       (error "mcvs: bad map: symlink ~a has no target."                       (error "bad map: symlink ~a has no target."
233                              (second item)))                              (second item)))
234                     (make-mapping-entry :kind :symlink                     (make-mapping-entry :kind :symlink
235                                         :id (second item)                                         :id (second item)
236                                         :path (third item)                                         :path (third item)
237                                         :target (fourth item)))                                         :target (fourth item)
238                  (otherwise (error "mcvs: bad type keyword ~s in map."                                         :raw-plist (fifth item)))
239                    (otherwise (error "bad type keyword ~s in map."
240                                    (first item)))))                                    (first item)))))
241            raw-filemap))            raw-filemap))
242    
# Line 231  representation---a list of mapping-entry Line 244  representation---a list of mapping-entry
244  "Converts the internal representation of a Meta-CVS mapping to  "Converts the internal representation of a Meta-CVS mapping to
245  the external form that is written out to files."  the external form that is written out to files."
246    (mapcar #'(lambda (entry)    (mapcar #'(lambda (entry)
247                (with-slots (kind id path target) entry                (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                  (case kind
252                    ((:file) (list kind id path))                    ((:file) (list* kind id path
253                    ((:symlink) (list kind id path target))                                    (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)))))                    (otherwise (error "unknown mapping entry type ~s." kind)))))
257            filemap))            filemap))
258    
259  (defun mapping-read (filename &key sanity-check)  (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  "Reads a Meta-CVS from a file, optionally performing a check
269  for duplicate entries"  for duplicate entries"
270    (let (filemap)    (let (filemap)
# Line 246  for duplicate entries" Line 272  for duplicate entries"
272      ;; Read the raw data, ensure that the file contains      ;; Read the raw data, ensure that the file contains
273      ;; a Lisp object and that it's a list, or at least a cons.      ;; a Lisp object and that it's a list, or at least a cons.
274      ;;      ;;
275      (with-open-file (file filename :direction :input)      (if (streamp source)
276        (setf filemap (read file nil :error))        (setf filemap (mapping-read-raw-map source))
277        (when (or (eq filemap :error)        (restart-case
278                  (and (not (consp filemap)) (not (null filemap))))          (with-open-file (stream source :direction :input)
279          (malformed-map)))            (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      ;; Distinguish between the old-style Meta-CVS map and
285      ;; the new one. The old one is a list of lists of strings.      ;; the new one. The old one is a list of lists of strings.
# Line 266  for duplicate entries" Line 295  for duplicate entries"
295        filemap)))        filemap)))
296    
297  (defun mapping-write (filemap filename &key sort-map)  (defun mapping-write (filemap filename &key sort-map)
298      (when *dry-run-option*
299        (chatter-debug "not writing to ~a because of -n global option.~%" filename)
300        (return-from mapping-write))
301    (when sort-map    (when sort-map
302      (setf filemap (sort (copy-list filemap)      (setf filemap (sort (copy-list filemap)
303                          #'string< :key #'mapping-entry-id)))                          #'string< :key #'mapping-entry-id)))
304    (let ((raw-filemap (mapping-convert-out filemap)))    (let ((raw-filemap (mapping-convert-out filemap)))
305      (with-open-file (file filename :direction :output)      (handler-case
306        (let ((*print-right-margin* 1))        (with-open-file (file filename :direction :output)
307          (prin1 raw-filemap file)          (let ((*print-right-margin* 1))
308          (terpri file)))))            (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          (with-slots (kind id path target) item          (with-slots (kind id path target executable) entry
322            (when (real-path-exists path)            (when (real-path-exists path)
323              (case kind              (case kind
324                ((:file)                ((:file)
325                   (let ((left id) (right (abstract-to-real-path path)))                   (let ((left id) (right (abstract-to-real-path path)))
326                     (case (synchronize-files left right)                     (case (synchronize-files left right executable
327                                                :direction direction)
328                       ((:left)                       ((:left)
329                         (chatter-info "sync ~a -> ~a~%" left right))                         (chatter-info "sync ~a -> ~a~%" left right))
330                       ((:right)                       ((:right)
331                         (chatter-info "sync ~a <- ~a~%" left right))                         (chatter-info "sync ~a <- ~a~%" left right))
332                       ((:same))                       ((:same :no-sync))
333                       ((:dir)                       ((:dir)
334                         (error "mcvs-sync: cannot sync, either ~a or ~a is a directory."                         (error "cannot sync, either ~a or ~a is a directory."
335                                left right))                                left right))
336                       ((nil)                       ((nil)
337                         (error "mcvs-sync: neither ~a nor ~a exists."                         (error "cannot sync, neither ~a nor ~a exists."
338                                left right)))))                                left right)))))
339                ((:symlink)                ((:symlink)
340                   (let* ((symlink (abstract-to-real-path path))                   (let* ((symlink (abstract-to-real-path path))
341                          (linkdata (no-existence-error (readlink symlink))))                          (linkdata (no-existence-error (readlink symlink))))
342                     (when (or (not linkdata)                     (when (or (not linkdata)
343                               (not (string= linkdata target)))                               (not (string= linkdata target)))
                      (no-existence-error (unlink symlink))  
                      (ensure-directories-exist symlink)  
                      (symlink target symlink)  
344                       (chatter-info "linking: ~a -> ~a~%"                       (chatter-info "linking: ~a -> ~a~%"
345                                     symlink target)))))))))))                                     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 338  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
# Line 354  whether they came from the CVS repositor Line 391  whether they came from the CVS repositor
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              (with-slots (path) old-item              (with-slots (path) old-item
402                (when (real-path-exists path)                (when (real-path-exists path)
403                  (ensure-directories-gone (abstract-to-real-path path))                  (honor-dry-run (path)
404                      (ensure-directories-gone (abstract-to-real-path path)))
405                  (push old-item rollback-restore-items)))))                  (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
# Line 395  whether they came from the CVS repositor Line 434  whether they came from the CVS repositor
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 (mapping-entry-path 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                                   (abstract-to-real-path (mapping-entry-path                            (abstract-to-real-path (mapping-entry-path
447                                                            (first pair)))                                                     (first pair)))
448                                   (abstract-to-real-path (mapping-entry-path                            (abstract-to-real-path (mapping-entry-path
449                                                            (second pair))))))                                                     (second pair))))))
450                    :report-function                (continue ()
451                    #'(lambda (stream)                  :report "Go ahead and overwrite the target files."
452                        (write-string "Print list of adds or moves which want to overwrite."                  (unwind)))))
                                     stream)))  
                  (do-clobber  
                    #'(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              (with-slots ((old-path path) (old-id id)) old-item              (with-slots ((old-path path) (old-id id)) old-item
458                (with-slots ((new-path path) (new-id id) kind target) new-item                (with-slots ((new-path path) (new-id id) kind target executable)
459                              new-item
460                  (let ((real-old-exists (real-path-exists old-path))                  (let ((real-old-exists (real-path-exists old-path))
461                        (real-new-exists (real-path-exists new-path)))                        (real-new-exists (real-path-exists new-path)))
462                    (let ((real-old (and real-old-exists                    (let ((real-old (and real-old-exists
# Line 441  whether they came from the CVS repositor Line 472  whether they came from the CVS repositor
472                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
473    
474                      (when real-new-exists                      (when real-new-exists
475                        (no-existence-error (unlink real-new))                        (no-existence-error (honor-dry-run (real-new)
476                                                (unlink real-new)))
477                        (case kind                        (case kind
478                          ((:file)                          ((:file)
479                             (synchronize-files new-id real-new))                             (synchronize-files new-id real-new executable
480                                                  :direction :right))
481                          ((:symlink)                          ((:symlink)
482                             (ensure-directories-exist real-new)                             (honor-dry-run (target real-new)
483                             (symlink target real-new)))                               (ensure-directories-exist real-new)
484                                 (symlink target real-new))))
485                        (push new-item rollback-remove-items))))))))                        (push new-item rollback-remove-items))))))))
486    
487          (dolist (item added-items)          (dolist (item added-items)
488            (with-slots (kind id path target) item            (with-slots (kind id path target executable) item
489              (when (real-path-exists path)              (when (real-path-exists path)
490                (let ((real (abstract-to-real-path path)))                (let ((real (abstract-to-real-path path)))
491                  (can-restart-here ("Continue updating file structure.")                  (can-restart-here ("Continue updating file structure.")
492                      (no-existence-error (honor-dry-run (real)
493                                            (unlink real)))
494                    (case kind                    (case kind
495                      ((:file)                      ((:file)
496                         (chatter-terse "adding ~a~%" real)                         (chatter-terse "adding ~a~%" real)
497                         (synchronize-files id real))                         (synchronize-files id real executable
498                                              :direction :right))
499                      ((:symlink)                      ((:symlink)
500                         (chatter-terse "linking ~a -> ~a~%" real target)                         (chatter-terse "linking ~a -> ~a~%" real target)
501                         (no-existence-error (unlink real))                         (honor-dry-run (real)
502                         (ensure-directories-exist real)                           (ensure-directories-exist real)
503                         (symlink target real)))                           (symlink target real))))
504                    (push item rollback-remove-items)))))))                    (push item rollback-remove-items))))))
505        (continue ()          (setf rollback-needed nil))
506          :report "Restore all restructuring done so far."        (when rollback-needed
507          (chatter-debug "Restoring.~%")          (chatter-debug "Undoing directory structure changes.~%")
508          (dolist (item rollback-remove-items)          (dolist (item rollback-remove-items)
509            (let ((real (abstract-to-real-path (mapping-entry-path 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            (with-slots (kind path id target) item            (with-slots (kind path id target executable) item
515              (let ((real (abstract-to-real-path path)))              (let ((real (abstract-to-real-path path)))
516                (chatter-terse "restoring ~a~%" real)                (chatter-terse "restoring ~a~%" real)
517                (case kind                (case kind
518                  ((:file)                  ((:file)
519                     (synchronize-files id real))                     (synchronize-files id real executable :direction :right))
520                  ((:symlink)                  ((:symlink)
521                     (ensure-directories-exist real)                     (honor-dry-run (real)
522                     (symlink target real))))))                       (ensure-directories-exist real)
523          (return-from mapping-update nil)))                       (symlink target real)))))))))
524        (mapping-write new-filemap *map-local-path*))
     (mapping-write new-filemap *mcvs-map-local*))  
525    t)    t)
526    
527  (defun mapping-removed-files (filemap)  (defun mapping-removed-files (filemap)
# Line 492  whether they came from the CVS repositor Line 529  whether they came from the CVS repositor
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 (mapping-entry-id 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 503  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.40.2.4  
changed lines
  Added in v.1.66

  ViewVC Help
Powered by ViewVC 1.1.5