/[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.5 by kaz, Mon Nov 4 02:07:35 2002 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 258  the external form that is written out to Line 259  the external form that is written out to
259                    (otherwise (error "unknown mapping entry type ~s." kind)))))                    (otherwise (error "unknown mapping entry type ~s." kind)))))
260            filemap))            filemap))
261    
262  (defun mapping-read (filename &key sanity-check)  (defun mapping-read-raw-map (stream)
263      (let ((map (read stream nil :error)))
264        (if (or (eq map :error)
265                  (and (not (consp map)) (not (null map))))
266          (malformed-map)
267          map)))
268    
269    (defun mapping-read (source &key sanity-check)
270  "Reads a Meta-CVS from a file, optionally performing a check  "Reads a Meta-CVS from a file, optionally performing a check
271  for duplicate entries"  for duplicate entries"
272    (let (filemap)    (let (filemap)
# Line 266  for duplicate entries" Line 274  for duplicate entries"
274      ;; Read the raw data, ensure that the file contains      ;; Read the raw data, ensure that the file contains
275      ;; 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.
276      ;;      ;;
277      (with-open-file (file filename :direction :input)      (if (streamp source)
278        (setf filemap (read file nil :error))        (setf filemap (mapping-read-raw-map source))
279        (when (or (eq filemap :error)        (with-open-file (stream source :direction :input)
280                  (and (not (consp filemap)) (not (null filemap))))          (setf filemap (mapping-read-raw-map stream))))
         (malformed-map)))  
281      ;;      ;;
282      ;; Distinguish between the old-style Meta-CVS map and      ;; Distinguish between the old-style Meta-CVS map and
283      ;; 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 293  for duplicate entries"
293        filemap)))        filemap)))
294    
295  (defun mapping-write (filemap filename &key sort-map)  (defun mapping-write (filemap filename &key sort-map)
296      (when *dry-run-option*
297        (chatter-debug "not writing to ~a because of -n global option.~%" filename)
298        (return-from mapping-write))
299    (when sort-map    (when sort-map
300      (setf filemap (sort (copy-list filemap)      (setf filemap (sort (copy-list filemap)
301                          #'string< :key #'mapping-entry-id)))                          #'string< :key #'mapping-entry-id)))
# Line 328  to ensure that the newly incorporated ch Line 338  to ensure that the newly incorporated ch
338                          (linkdata (no-existence-error (readlink symlink))))                          (linkdata (no-existence-error (readlink symlink))))
339                     (when (or (not linkdata)                     (when (or (not linkdata)
340                               (not (string= linkdata target)))                               (not (string= linkdata target)))
                      (no-existence-error (unlink symlink))  
                      (ensure-directories-exist symlink)  
                      (symlink target symlink)  
341                       (chatter-info "linking: ~a -> ~a~%"                       (chatter-info "linking: ~a -> ~a~%"
342                                     symlink target)))))))))))                                     symlink target)
343                         (honor-dry-run (target symlink)
344                           (no-existence-error (unlink symlink))
345                           (ensure-directories-exist symlink)
346                           (symlink target symlink))))))))))))
347    
348  (defun mapping-difference (old-mapping new-mapping)  (defun mapping-difference (old-mapping new-mapping)
349  "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 387  whether they came from the CVS repositor
387                (chatter-terse "removing ~a~%" real)                (chatter-terse "removing ~a~%" real)
388                (unless no-delete-removed                (unless no-delete-removed
389                  (restart-case                  (restart-case
390                    (ensure-directories-gone real)                    (honor-dry-run (real)
391                        (ensure-directories-gone real))
392                    (ignore () :report "Ignore file removal error."))                    (ignore () :report "Ignore file removal error."))
393                  (push item rollback-restore-items)))))                  (push item rollback-restore-items)))))
394    
# Line 384  whether they came from the CVS repositor Line 396  whether they came from the CVS repositor
396            (let ((old-item (first pair)))            (let ((old-item (first pair)))
397              (with-slots (path) old-item              (with-slots (path) old-item
398                (when (real-path-exists path)                (when (real-path-exists path)
399                  (ensure-directories-gone (abstract-to-real-path path))                  (honor-dry-run (path)
400                      (ensure-directories-gone (abstract-to-real-path path)))
401                  (push old-item rollback-restore-items)))))                  (push old-item rollback-restore-items)))))
402    
403          ;; 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 477  whether they came from the CVS repositor
477                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))                           (chatter-terse "moving ~a -> (out-of-sandbox)~%" real-old)))
478    
479                      (when real-new-exists                      (when real-new-exists
480                        (no-existence-error (unlink real-new))                        (no-existence-error (honor-dry-run (real-new)
481                                                (unlink real-new)))
482                        (case kind                        (case kind
483                          ((:file)                          ((:file)
484                             (synchronize-files new-id real-new executable))                             (synchronize-files new-id real-new executable))
485                          ((:symlink)                          ((:symlink)
486                             (ensure-directories-exist real-new)                             (honor-dry-run (target real-new)
487                             (symlink target real-new)))                               (ensure-directories-exist real-new)
488                                 (symlink target real-new))))
489                        (push new-item rollback-remove-items))))))))                        (push new-item rollback-remove-items))))))))
490    
491          (dolist (item added-items)          (dolist (item added-items)
# Line 478  whether they came from the CVS repositor Line 493  whether they came from the CVS repositor
493              (when (real-path-exists path)              (when (real-path-exists path)
494                (let ((real (abstract-to-real-path path)))                (let ((real (abstract-to-real-path path)))
495                  (can-restart-here ("Continue updating file structure.")                  (can-restart-here ("Continue updating file structure.")
496                      (no-existence-error (honor-dry-run (real)
497                                            (unlink real)))
498                    (case kind                    (case kind
499                      ((:file)                      ((:file)
500                         (chatter-terse "adding ~a~%" real)                         (chatter-terse "adding ~a~%" real)
501                         (synchronize-files id real executable))                         (synchronize-files id real executable))
502                      ((:symlink)                      ((:symlink)
503                         (chatter-terse "linking ~a -> ~a~%" real target)                         (chatter-terse "linking ~a -> ~a~%" real target)
504                         (no-existence-error (unlink real))                         (honor-dry-run (real)
505                         (ensure-directories-exist real)                           (ensure-directories-exist real)
506                         (symlink target real)))                           (symlink target real))))
507                    (push item rollback-remove-items)))))))                    (push item rollback-remove-items)))))))
508        (continue ()        (continue ()
509          :report "Restore all restructuring done so far."          :report "Restore all restructuring done so far."
# Line 494  whether they came from the CVS repositor Line 511  whether they came from the CVS repositor
511          (dolist (item rollback-remove-items)          (dolist (item rollback-remove-items)
512            (let ((real (abstract-to-real-path (mapping-entry-path item))))            (let ((real (abstract-to-real-path (mapping-entry-path item))))
513              (chatter-terse "removing ~a~%" real)              (chatter-terse "removing ~a~%" real)
514              (ensure-directories-gone real)))              (honor-dry-run (real)
515                  (ensure-directories-gone real))))
516          (dolist (item rollback-restore-items)          (dolist (item rollback-restore-items)
517            (with-slots (kind path id target executable) item            (with-slots (kind path id target executable) item
518              (let ((real (abstract-to-real-path path)))              (let ((real (abstract-to-real-path path)))
# Line 503  whether they came from the CVS repositor Line 521  whether they came from the CVS repositor
521                  ((:file)                  ((:file)
522                     (synchronize-files id real executable))                     (synchronize-files id real executable))
523                  ((:symlink)                  ((:symlink)
524                     (ensure-directories-exist real)                     (honor-dry-run (real)
525                     (symlink target real))))))                       (ensure-directories-exist real)
526                         (symlink target real)))))))
527          (return-from mapping-update nil)))          (return-from mapping-update nil)))
528    
529      (mapping-write new-filemap *mcvs-map-local*))      (mapping-write new-filemap *mcvs-map-local*))
# Line 516  whether they came from the CVS repositor Line 535  whether they came from the CVS repositor
535      (dolist (entry filemap)      (dolist (entry filemap)
536        (setf (gethash (mapping-entry-id entry) f-hash) entry))        (setf (gethash (mapping-entry-id entry) f-hash) entry))
537      (for-each-file-info (fi *mcvs-dir*)      (for-each-file-info (fi *mcvs-dir*)
538          (when (and (directory-p fi)
539                     (path-equal (basename (file-name fi)) "CVS"))
540            (skip))
541        (let ((base (basename (file-name fi))))        (let ((base (basename (file-name fi))))
542          (multiple-value-bind (suffix name) (suffix base)          (multiple-value-bind (suffix name) (suffix base)
543            (declare (ignore suffix))            (declare (ignore suffix))

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

  ViewVC Help
Powered by ViewVC 1.1.5