/[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.9 by kaz, Thu Feb 13 07:20:49 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)        (with-open-file (stream source :direction :input)
285                  (and (not (consp filemap)) (not (null filemap))))          (setf filemap (mapping-read-raw-map stream))))
         (malformed-map)))  
286      ;;      ;;
287      ;; Distinguish between the old-style Meta-CVS map and      ;; Distinguish between the old-style Meta-CVS map and
288      ;; 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 298  for duplicate entries"
298        filemap)))        filemap)))
299    
300  (defun mapping-write (filemap filename &key sort-map)  (defun mapping-write (filemap filename &key sort-map)
301      (when *dry-run-option*
302        (chatter-debug "not writing to ~a because of -n global option.~%" filename)
303        (return-from mapping-write))
304    (when sort-map    (when sort-map
305      (setf filemap (sort (copy-list filemap)      (setf filemap (sort (copy-list filemap)
306                          #'string< :key #'mapping-entry-id)))                          #'string< :key #'mapping-entry-id)))
# Line 297  for duplicate entries" Line 312  for duplicate entries"
312            (terpri file)))            (terpri file)))
313        (error (cond) (error "unable to write mapping file: ~a" cond)))))        (error (cond) (error "unable to write mapping file: ~a" cond)))))
314    
315  (defun mapping-synchronize ()  (defun mapping-synchronize (&optional filemap)
316  "Synchronizes the contents of files in the sandbox, and their corresponding  "Synchronizes the contents of files in the sandbox, and their corresponding
317  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
318  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
319  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,
320  to ensure that the newly incorporated changes are propagated to the sandbox"  to ensure that the newly incorporated changes are propagated to the sandbox"
321    (let ((filemap (mapping-read *mcvs-map-local*)))    (let ((filemap (or filemap (mapping-read *mcvs-map-local*))))
322      (dolist (entry filemap)      (dolist (entry filemap)
323        (can-restart-here ("Continue synchronizing files.")        (can-restart-here ("Continue synchronizing files.")
324          (with-slots (kind id path target executable) entry          (with-slots (kind id path target executable) entry
# Line 328  to ensure that the newly incorporated ch Line 343  to ensure that the newly incorporated ch
343                          (linkdata (no-existence-error (readlink symlink))))                          (linkdata (no-existence-error (readlink symlink))))
344                     (when (or (not linkdata)                     (when (or (not linkdata)
345                               (not (string= linkdata target)))                               (not (string= linkdata target)))
                      (no-existence-error (unlink symlink))  
                      (ensure-directories-exist symlink)  
                      (symlink target symlink)  
346                       (chatter-info "linking: ~a -> ~a~%"                       (chatter-info "linking: ~a -> ~a~%"
347                                     symlink target)))))))))))                                     symlink target)
348                         (honor-dry-run (target symlink)
349                           (no-existence-error (unlink symlink))
350                           (ensure-directories-exist symlink)
351                           (symlink target symlink))))))))))))
352    
353  (defun mapping-difference (old-mapping new-mapping)  (defun mapping-difference (old-mapping new-mapping)
354  "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 392  whether they came from the CVS repositor
392                (chatter-terse "removing ~a~%" real)                (chatter-terse "removing ~a~%" real)
393                (unless no-delete-removed                (unless no-delete-removed
394                  (restart-case                  (restart-case
395                    (ensure-directories-gone real)                    (honor-dry-run (real)
396                        (ensure-directories-gone real))
397                    (ignore () :report "Ignore file removal error."))                    (ignore () :report "Ignore file removal error."))
398                  (push item rollback-restore-items)))))                  (push item rollback-restore-items)))))
399    
# Line 384  whether they came from the CVS repositor Line 401  whether they came from the CVS repositor
401            (let ((old-item (first pair)))            (let ((old-item (first pair)))
402              (with-slots (path) old-item              (with-slots (path) old-item
403                (when (real-path-exists path)                (when (real-path-exists path)
404                  (ensure-directories-gone (abstract-to-real-path path))                  (honor-dry-run (path)
405                      (ensure-directories-gone (abstract-to-real-path path)))
406                  (push old-item rollback-restore-items)))))                  (push old-item rollback-restore-items)))))
407    
408          ;; 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 464  whether they came from the CVS repositor Line 482  whether they came from the CVS repositor
482                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
483    
484                      (when real-new-exists                      (when real-new-exists
485                        (no-existence-error (unlink real-new))                        (no-existence-error (honor-dry-run (real-new)
486                                                (unlink real-new)))
487                        (case kind                        (case kind
488                          ((:file)                          ((:file)
489                             (synchronize-files new-id real-new executable))                             (synchronize-files new-id real-new executable))
490                          ((:symlink)                          ((:symlink)
491                             (ensure-directories-exist real-new)                             (honor-dry-run (target real-new)
492                             (symlink target real-new)))                               (ensure-directories-exist real-new)
493                                 (symlink target real-new))))
494                        (push new-item rollback-remove-items))))))))                        (push new-item rollback-remove-items))))))))
495    
496          (dolist (item added-items)          (dolist (item added-items)
# Line 478  whether they came from the CVS repositor Line 498  whether they came from the CVS repositor
498              (when (real-path-exists path)              (when (real-path-exists path)
499                (let ((real (abstract-to-real-path path)))                (let ((real (abstract-to-real-path path)))
500                  (can-restart-here ("Continue updating file structure.")                  (can-restart-here ("Continue updating file structure.")
501                      (no-existence-error (honor-dry-run (real)
502                                            (unlink real)))
503                    (case kind                    (case kind
504                      ((:file)                      ((:file)
505                         (chatter-terse "adding ~a~%" real)                         (chatter-terse "adding ~a~%" real)
506                         (synchronize-files id real executable))                         (synchronize-files id real executable))
507                      ((:symlink)                      ((:symlink)
508                         (chatter-terse "linking ~a -> ~a~%" real target)                         (chatter-terse "linking ~a -> ~a~%" real target)
509                         (no-existence-error (unlink real))                         (honor-dry-run (real)
510                         (ensure-directories-exist real)                           (ensure-directories-exist real)
511                         (symlink target real)))                           (symlink target real))))
512                    (push item rollback-remove-items)))))))                    (push item rollback-remove-items)))))))
513        (continue ()        (continue ()
514          :report "Restore all restructuring done so far."          :report "Restore all restructuring done so far."
# Line 494  whether they came from the CVS repositor Line 516  whether they came from the CVS repositor
516          (dolist (item rollback-remove-items)          (dolist (item rollback-remove-items)
517            (let ((real (abstract-to-real-path (mapping-entry-path item))))            (let ((real (abstract-to-real-path (mapping-entry-path item))))
518              (chatter-terse "removing ~a~%" real)              (chatter-terse "removing ~a~%" real)
519              (ensure-directories-gone real)))              (honor-dry-run (real)
520                  (ensure-directories-gone real))))
521          (dolist (item rollback-restore-items)          (dolist (item rollback-restore-items)
522            (with-slots (kind path id target executable) item            (with-slots (kind path id target executable) item
523              (let ((real (abstract-to-real-path path)))              (let ((real (abstract-to-real-path path)))
# Line 503  whether they came from the CVS repositor Line 526  whether they came from the CVS repositor
526                  ((:file)                  ((:file)
527                     (synchronize-files id real executable))                     (synchronize-files id real executable))
528                  ((:symlink)                  ((:symlink)
529                     (ensure-directories-exist real)                     (honor-dry-run (real)
530                     (symlink target real))))))                       (ensure-directories-exist real)
531                         (symlink target real)))))))
532          (return-from mapping-update nil)))          (return-from mapping-update nil)))
533    
534      (mapping-write new-filemap *mcvs-map-local*))      (mapping-write new-filemap *mcvs-map-local*))
# Line 516  whether they came from the CVS repositor Line 540  whether they came from the CVS repositor
540      (dolist (entry filemap)      (dolist (entry filemap)
541        (setf (gethash (mapping-entry-id entry) f-hash) entry))        (setf (gethash (mapping-entry-id entry) f-hash) entry))
542      (for-each-file-info (fi *mcvs-dir*)      (for-each-file-info (fi *mcvs-dir*)
543          (when (and (directory-p fi)
544                     (path-equal (basename (file-name fi)) "CVS"))
545            (skip))
546        (let ((base (basename (file-name fi))))        (let ((base (basename (file-name fi))))
547          (multiple-value-bind (suffix name) (suffix base)          (multiple-value-bind (suffix name) (suffix base)
548            (declare (ignore suffix))            (declare (ignore suffix))
# Line 526  whether they came from the CVS repositor Line 553  whether they came from the CVS repositor
553      to-be-removed))      to-be-removed))
554    
555  (defun displaced-path-read ()  (defun displaced-path-read ()
556    (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)    (let ((*read-eval* nil))
557                     (read file))))      (ignore-errors (with-open-file (file *mcvs-displaced* :direction :input)
558                         (read file)))))
559    
560  (defun displaced-path-write (path)  (defun displaced-path-write (path)
561    (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.9

  ViewVC Help
Powered by ViewVC 1.1.5