/[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.49 by kaz, Sun Oct 6 08:17:28 2002 UTC revision 1.49.2.12 by kaz, Sun Apr 13 06:32:27 2003 UTC
# Line 4  Line 4 
4    
5  (require "dirwalk")  (require "dirwalk")
6  (require "system")  (require "system")
7    (require "options")
8  (require "sync")  (require "sync")
9  (require "chatter")  (require "chatter")
10  (require "restart")  (require "restart")
# Line 25  Line 26 
26  (defvar *displaced-path-length* nil)  (defvar *displaced-path-length* nil)
27    
28  (defun mcvs-locate ()  (defun mcvs-locate ()
29    (let ((current-dir (split-fields (getcwd) *path-sep*)))    (let ((current-dir (split-fields (getcwd) *path-sep*))
30            (escape-levels *nesting-escape-option*))
31      (dotimes (i (length current-dir) nil)      (dotimes (i (length current-dir) nil)
32        (let* ((path-components (butlast current-dir i))        (let* ((path-components (butlast current-dir i))
33               (path-string (reduce #'path-cat path-components)))               (path-string (reduce #'path-cat path-components)))
34          (when (ignore-errors (stat (path-cat path-string *mcvs-dir*)))          (when (and (ignore-errors (stat (path-cat path-string *mcvs-dir*)))
35                       (zerop (prog1 escape-levels (decf escape-levels))))
36              (when (> *nesting-escape-option* 0)
37                (chatter-info "using sandbox ~a~%" path-string))
38            (chdir path-string)            (chdir path-string)
39            (return (if (zerop i)            (return (if (zerop i)
40                      "."                      "."
41                      (reduce #'path-cat (last current-dir i)))))))))                      (reduce #'path-cat (last current-dir i)))))))))
42    
43    (declaim (inline real-path-exists abstract-to-real-path
44                     real-to-abstract-path))
45    
46  (defun real-path-exists (path)  (defun real-path-exists (path)
47    (or (null *displaced-path-prefix*)    (or (null *displaced-path-prefix*)
48        (path-prefix-equal *displaced-path-prefix* path)))        (path-prefix-equal *displaced-path-prefix* path)))
# Line 52  Line 60 
60      (concatenate 'string *displaced-path-prefix* path)      (concatenate 'string *displaced-path-prefix* path)
61      path))      path))
62    
 (declaim (inline real-path-exists abstract-to-real-path  
                  real-to-abstract-path))  
   
63  (defmacro in-sandbox-root-dir (&body forms)  (defmacro in-sandbox-root-dir (&body forms)
64    (let ((downpath-sym (gensym "DOWNPATH-")))    (let ((downpath-sym (gensym "DOWNPATH-")))
65     `(current-dir-restore     `(current-dir-restore
# Line 119  Line 124 
124                   filemap                   filemap
125                   :key #'mapping-entry-kind))                   :key #'mapping-entry-kind))
126    
127    (declaim (inline mapping-extract-paths))
128  (defun mapping-extract-paths (filemap)  (defun mapping-extract-paths (filemap)
129    (mapcar #'mapping-entry-path filemap))    (mapcar #'mapping-entry-path filemap))
 (declaim (inline mapping-extract-paths))  
130    
131  (defun mapping-lookup (filemap path)  (defun mapping-lookup (filemap path)
132    (find path filemap :test #'path-equal :key #'mapping-entry-path))    (find path filemap :test #'path-equal :key #'mapping-entry-path))
# Line 258  the external form that is written out to Line 263  the external form that is written out to
263                    (otherwise (error "unknown mapping entry type ~s." kind)))))                    (otherwise (error "unknown mapping entry type ~s." kind)))))
264            filemap))            filemap))
265    
266  (defun mapping-read (filename &key sanity-check)  (defun mapping-read-raw-map (stream)
267      (let ((*read-eval* nil))
268        (let ((map (read stream nil :error)))
269          (if (or (eq map :error)
270                    (and (not (consp map)) (not (null map))))
271            (malformed-map)
272            map))))
273    
274    (defun mapping-read (source &key sanity-check)
275  "Reads a Meta-CVS from a file, optionally performing a check  "Reads a Meta-CVS from a file, optionally performing a check
276  for duplicate entries"  for duplicate entries"
277    (let (filemap)    (let (filemap)
# Line 266  for duplicate entries" Line 279  for duplicate entries"
279      ;; Read the raw data, ensure that the file contains      ;; Read the raw data, ensure that the file contains
280      ;; 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.
281      ;;      ;;
282      (with-open-file (file filename :direction :input)      (if (streamp source)
283        (setf filemap (read file nil :error))        (setf filemap (mapping-read-raw-map source))
284        (when (or (eq filemap :error)        (restart-case
285                  (and (not (consp filemap)) (not (null filemap))))          (with-open-file (stream source :direction :input)
286          (malformed-map)))            (setf filemap (mapping-read-raw-map stream)))
287            (continue ()
288              :report "Pretend that an empty map was correctly read."
289              (setf filemap nil))))
290      ;;      ;;
291      ;; Distinguish between the old-style Meta-CVS map and      ;; Distinguish between the old-style Meta-CVS map and
292      ;; 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 286  for duplicate entries" Line 302  for duplicate entries"
302        filemap)))        filemap)))
303    
304  (defun mapping-write (filemap filename &key sort-map)  (defun mapping-write (filemap filename &key sort-map)
305      (when *dry-run-option*
306        (chatter-debug "not writing to ~a because of -n global option.~%" filename)
307        (return-from mapping-write))
308    (when sort-map    (when sort-map
309      (setf filemap (sort (copy-list filemap)      (setf filemap (sort (copy-list filemap)
310                          #'string< :key #'mapping-entry-id)))                          #'string< :key #'mapping-entry-id)))
# Line 297  for duplicate entries" Line 316  for duplicate entries"
316            (terpri file)))            (terpri file)))
317        (error (cond) (error "unable to write mapping file: ~a" cond)))))        (error (cond) (error "unable to write mapping file: ~a" cond)))))
318    
319  (defun mapping-synchronize ()  (defun mapping-synchronize (&key filemap (direction :either))
320  "Synchronizes the contents of files in the sandbox, and their corresponding  "Synchronizes the contents of files in the sandbox, and their corresponding
321  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
322  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
323  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,
324  to ensure that the newly incorporated changes are propagated to the sandbox"  to ensure that the newly incorporated changes are propagated to the sandbox"
325    (let ((filemap (mapping-read *mcvs-map-local*)))    (let ((filemap (or filemap (mapping-read *mcvs-map-local*))))
326      (dolist (entry filemap)      (dolist (entry filemap)
327        (can-restart-here ("Continue synchronizing files.")        (can-restart-here ("Continue synchronizing files.")
328          (with-slots (kind id path target executable) entry          (with-slots (kind id path target executable) entry
# Line 311  to ensure that the newly incorporated ch Line 330  to ensure that the newly incorporated ch
330              (case kind              (case kind
331                ((:file)                ((:file)
332                   (let ((left id) (right (abstract-to-real-path path)))                   (let ((left id) (right (abstract-to-real-path path)))
333                     (case (synchronize-files left right executable)                     (case (synchronize-files left right executable
334                                                :direction direction)
335                       ((:left)                       ((:left)
336                         (chatter-info "sync ~a -> ~a~%" left right))                         (chatter-info "sync ~a -> ~a~%" left right))
337                       ((:right)                       ((:right)
338                         (chatter-info "sync ~a <- ~a~%" left right))                         (chatter-info "sync ~a <- ~a~%" left right))
339                       ((:same))                       ((:same :no-sync))
340                       ((:dir)                       ((:dir)
341                         (error "cannot sync, either ~a or ~a is a directory."                         (error "cannot sync, either ~a or ~a is a directory."
342                                left right))                                left right))
# Line 328  to ensure that the newly incorporated ch Line 348  to ensure that the newly incorporated ch
348                          (linkdata (no-existence-error (readlink symlink))))                          (linkdata (no-existence-error (readlink symlink))))
349                     (when (or (not linkdata)                     (when (or (not linkdata)
350                               (not (string= linkdata target)))                               (not (string= linkdata target)))
                      (no-existence-error (unlink symlink))  
                      (ensure-directories-exist symlink)  
                      (symlink target symlink)  
351                       (chatter-info "linking: ~a -> ~a~%"                       (chatter-info "linking: ~a -> ~a~%"
352                                     symlink target)))))))))))                                     symlink target)
353                         (honor-dry-run (target symlink)
354                           (no-existence-error (unlink symlink))
355                           (ensure-directories-exist symlink)
356                           (symlink target symlink))))))))))))
357    
358  (defun mapping-difference (old-mapping new-mapping)  (defun mapping-difference (old-mapping new-mapping)
359  "Compute the difference between two mappings. Returns three values:  "Compute the difference between two mappings. Returns three values:
# Line 376  whether they came from the CVS repositor Line 397  whether they came from the CVS repositor
397                (chatter-terse "removing ~a~%" real)                (chatter-terse "removing ~a~%" real)
398                (unless no-delete-removed                (unless no-delete-removed
399                  (restart-case                  (restart-case
400                    (ensure-directories-gone real)                    (honor-dry-run (real)
401                        (ensure-directories-gone real))
402                    (ignore () :report "Ignore file removal error."))                    (ignore () :report "Ignore file removal error."))
403                  (push item rollback-restore-items)))))                  (push item rollback-restore-items)))))
404    
# Line 384  whether they came from the CVS repositor Line 406  whether they came from the CVS repositor
406            (let ((old-item (first pair)))            (let ((old-item (first pair)))
407              (with-slots (path) old-item              (with-slots (path) old-item
408                (when (real-path-exists path)                (when (real-path-exists path)
409                  (ensure-directories-gone (abstract-to-real-path path))                  (honor-dry-run (path)
410                      (ensure-directories-gone (abstract-to-real-path path)))
411                  (push old-item rollback-restore-items)))))                  (push old-item rollback-restore-items)))))
412    
413          ;; 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 417  whether they came from the CVS repositor Line 440  whether they came from the CVS repositor
440                        (push item clobber-move-pairs)))))))                        (push item clobber-move-pairs)))))))
441    
442            (when (or clobber-add-items clobber-move-pairs)            (when (or clobber-add-items clobber-move-pairs)
443              (block nil              (super-restart-case
444                (restart-bind                (error "some moves or adds want to overwrite local files or directories.")
445                  ((print-clobbers                (print-clobbers ()
446                     #'(lambda ()                  :report "Print list of adds or moves which want to overwrite."
447                         (dolist (item clobber-add-items)                  (dolist (item clobber-add-items)
448                           (format t "add: ~a~%"                    (format t "add: ~a~%"
449                                   (abstract-to-real-path (mapping-entry-path item))))                            (abstract-to-real-path (mapping-entry-path item))))
450                         (dolist (pair clobber-move-pairs)                  (dolist (pair clobber-move-pairs)
451                           (format t "move ~a -> ~a~%"                    (format t "move ~a -> ~a~%"
452                                   (abstract-to-real-path (mapping-entry-path                            (abstract-to-real-path (mapping-entry-path
453                                                            (first pair)))                                                     (first pair)))
454                                   (abstract-to-real-path (mapping-entry-path                            (abstract-to-real-path (mapping-entry-path
455                                                            (second pair))))))                                                     (second pair))))))
456                    :report-function                (do-clobber ()
457                    #'(lambda (stream)                  :report "Go ahead and overwrite the target files."
458                        (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 "some moves or adds want to overwrite local files or directories.")))))  
459    
460          ;; Sanity check passed, complete moves and adds.          ;; Sanity check passed, complete moves and adds.
461          (dolist (item moved-pairs)          (dolist (item moved-pairs)
# Line 464  whether they came from the CVS repositor Line 478  whether they came from the CVS repositor
478                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
479    
480                      (when real-new-exists                      (when real-new-exists
481                        (no-existence-error (unlink real-new))                        (no-existence-error (honor-dry-run (real-new)
482                                                (unlink real-new)))
483                        (case kind                        (case kind
484                          ((:file)                          ((:file)
485                             (synchronize-files new-id real-new executable))                             (synchronize-files new-id real-new executable
486                                                  :direction :right))
487                          ((:symlink)                          ((:symlink)
488                             (ensure-directories-exist real-new)                             (honor-dry-run (target real-new)
489                             (symlink target real-new)))                               (ensure-directories-exist real-new)
490                                 (symlink target real-new))))
491                        (push new-item rollback-remove-items))))))))                        (push new-item rollback-remove-items))))))))
492    
493          (dolist (item added-items)          (dolist (item added-items)
# Line 478  whether they came from the CVS repositor Line 495  whether they came from the CVS repositor
495              (when (real-path-exists path)              (when (real-path-exists path)
496                (let ((real (abstract-to-real-path path)))                (let ((real (abstract-to-real-path path)))
497                  (can-restart-here ("Continue updating file structure.")                  (can-restart-here ("Continue updating file structure.")
498                      (no-existence-error (honor-dry-run (real)
499                                            (unlink real)))
500                    (case kind                    (case kind
501                      ((:file)                      ((:file)
502                         (chatter-terse "adding ~a~%" real)                         (chatter-terse "adding ~a~%" real)
503                         (synchronize-files id real executable))                         (synchronize-files id real executable
504                                              :direction :right))
505                      ((:symlink)                      ((:symlink)
506                         (chatter-terse "linking ~a -> ~a~%" real target)                         (chatter-terse "linking ~a -> ~a~%" real target)
507                         (no-existence-error (unlink real))                         (honor-dry-run (real)
508                         (ensure-directories-exist real)                           (ensure-directories-exist real)
509                         (symlink target real)))                           (symlink target real))))
510                    (push item rollback-remove-items)))))))                    (push item rollback-remove-items)))))))
511        (continue ()        (continue ()
512          :report "Restore all restructuring done so far."          :report "Restore all restructuring done so far."
# Line 494  whether they came from the CVS repositor Line 514  whether they came from the CVS repositor
514          (dolist (item rollback-remove-items)          (dolist (item rollback-remove-items)
515            (let ((real (abstract-to-real-path (mapping-entry-path item))))            (let ((real (abstract-to-real-path (mapping-entry-path item))))
516              (chatter-terse "removing ~a~%" real)              (chatter-terse "removing ~a~%" real)
517              (ensure-directories-gone real)))              (honor-dry-run (real)
518                  (ensure-directories-gone real))))
519          (dolist (item rollback-restore-items)          (dolist (item rollback-restore-items)
520            (with-slots (kind path id target executable) item            (with-slots (kind path id target executable) item
521              (let ((real (abstract-to-real-path path)))              (let ((real (abstract-to-real-path path)))
522                (chatter-terse "restoring ~a~%" real)                (chatter-terse "restoring ~a~%" real)
523                (case kind                (case kind
524                  ((:file)                  ((:file)
525                     (synchronize-files id real executable))                     (synchronize-files id real executable :direction :right))
526                  ((:symlink)                  ((:symlink)
527                     (ensure-directories-exist real)                     (honor-dry-run (real)
528                     (symlink target real))))))                       (ensure-directories-exist real)
529                         (symlink target real)))))))
530          (return-from mapping-update nil)))          (return-from mapping-update nil)))
531    
532      (mapping-write new-filemap *mcvs-map-local*))      (mapping-write new-filemap *mcvs-map-local*))
# Line 516  whether they came from the CVS repositor Line 538  whether they came from the CVS repositor
538      (dolist (entry filemap)      (dolist (entry filemap)
539        (setf (gethash (mapping-entry-id entry) f-hash) entry))        (setf (gethash (mapping-entry-id entry) f-hash) entry))
540      (for-each-file-info (fi *mcvs-dir*)      (for-each-file-info (fi *mcvs-dir*)
541          (when (and (directory-p fi)
542                     (path-equal (basename (file-name fi)) "CVS"))
543            (skip))
544        (let ((base (basename (file-name fi))))        (let ((base (basename (file-name fi))))
545          (multiple-value-bind (suffix name) (suffix base)          (multiple-value-bind (suffix name) (suffix base)
546            (declare (ignore suffix))            (declare (ignore suffix))
# Line 526  whether they came from the CVS repositor Line 551  whether they came from the CVS repositor
551      to-be-removed))      to-be-removed))
552    
553  (defun displaced-path-read ()  (defun displaced-path-read ()
554    (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)    (let ((*read-eval* nil))
555                     (read file))))      (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
556                         (read file)))))
557    
558  (defun displaced-path-write (path)  (defun displaced-path-write (path)
559    (with-open-file (file *mcvs-displaced* :direction :output)    (with-open-file (file *mcvs-displaced* :direction :output)

Legend:
Removed from v.1.49  
changed lines
  Added in v.1.49.2.12

  ViewVC Help
Powered by ViewVC 1.1.5