/[meta-cvs]/meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B
ViewVC logotype

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21.4.1 - (hide annotations)
Sat Jul 6 15:33:47 2002 UTC (11 years, 9 months ago) by kaz
Branch: partial-sandbox-branch
CVS Tags: partial-sandbox-branch~merged-to-HEAD-0
Changes since 1.21: +24 -22 lines
* add.lisp (mcvs-add): Added path conversions to support
partial sandboxes.
1 kaz 1.10 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.7 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "system")
6     (require "mapping")
7     (require "chatter")
8 kaz 1.4 (require "dirwalk")
9 kaz 1.6 (require "seqfuncs")
10 kaz 1.8 (require "options")
11 kaz 1.18 (require "types")
12 kaz 1.1 (provide "add")
13    
14 kaz 1.6 (defun mcvs-add (recursivep cvs-options add-options files)
15 kaz 1.3 (in-sandbox-root-dir
16 kaz 1.14 (let* ((filemap (mapping-read *mcvs-map*))
17     (saved-filemap (copy-list filemap))
18 kaz 1.18 (types-exists (exists *mcvs-types*))
19     (types (and types-exists (types-read *mcvs-types*)))
20     new-map-entries new-types)
21 kaz 1.1
22 kaz 1.20 (chatter-debug "Mapping.~%")
23 kaz 1.4
24 kaz 1.1 (dolist (file files)
25 kaz 1.4 (let (expanded-paths)
26     (if recursivep
27     (for-each-path (full-name (sandbox-translate-path file))
28 kaz 1.5 (push (canonicalize-path full-name) expanded-paths))
29 kaz 1.4 (push (sandbox-translate-path file) expanded-paths))
30     (nreverse expanded-paths)
31    
32 kaz 1.5 (dolist (full-name expanded-paths)
33 kaz 1.21.4.1 (let ((abs-name (real-to-abstract-path full-name)))
34     (can-restart-here ("Continue adding files.")
35     (cond
36     ((path-prefix-equal *mcvs-dir* full-name)
37     (error "mcvs-add: path ~a is in a reserved Meta-CVS area."
38     full-name))
39     ((mapping-lookup filemap abs-name)
40     (chatter-info "mcvs-add: ~a already added.~%" full-name))
41     ((directory-p full-name)
42     (when (not recursivep)
43     (error "mcvs-add: ~a, is a directory, use -R to add." full-name)))
44     ((not (regular-p full-name))
45     (error "mcvs-add: cannot add ~a, not regular file."
46     full-name))
47     (t
48     (let* ((suffix (suffix full-name))
49     (f-file (mapping-generate-name suffix)))
50     (when suffix
51     (setf new-types (adjoin (list suffix :default)
52     new-types :test #'equal)))
53     (push (list f-file abs-name) new-map-entries)))))))))
54 kaz 1.18
55     (setf new-types (set-difference
56     new-types types :key #'first :test #'string=))
57    
58     (unwind-protect
59     (setf new-types (types-let-user-edit new-types *mcvs-new-types*))
60     (ignore-errors (unlink *mcvs-new-types*)))
61    
62     (setf new-map-entries (types-remove-ignores new-types new-map-entries))
63 kaz 1.19 (setf new-map-entries (types-remove-ignores types new-map-entries))
64 kaz 1.18
65     (when new-map-entries
66     (dolist (map-entry new-map-entries)
67     (destructuring-bind (f-file path-name) map-entry
68     (push map-entry filemap)
69 kaz 1.21.4.1 (let ((real-name (abstract-to-real-path path-name)))
70     (chatter-info "mapping ~a <- ~a~%" f-file real-name)
71     (link real-name f-file))))
72 kaz 1.18
73     (mapping-write filemap *mcvs-map* :sort-map t)
74    
75     (when (setf types (append types new-types))
76     (types-write types *mcvs-types*))
77    
78 kaz 1.20 (chatter-debug "Synchronizing.~%")
79 kaz 1.1 (mapping-synchronize)
80    
81 kaz 1.18 (let ((add-commands (types-make-cvs-adds types new-map-entries)))
82     (loop
83     (restart-case
84     (current-dir-restore
85     (chdir *mcvs-dir*)
86 kaz 1.20 (chatter-debug "Invoking CVS.~%")
87 kaz 1.18 (dolist (add-args add-commands)
88     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
89     "add" ,@(format-opt add-options)
90     ,@add-args)))
91     (error "CVS add failed.")))
92     (when (and types (not types-exists))
93     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
94     "add" ,*mcvs-types-name*)))
95     (error "CVS add failed.")))
96     (return))
97     (retry ()
98     :report "Try invoking CVS again.")
99     (continue ()
100     :report "Undo everything; restore the mapping."
101 kaz 1.20 (chatter-debug "Restoring map.~%")
102 kaz 1.18 (mapping-write saved-filemap *mcvs-map*)
103     (ignore-errors
104     (dolist (entry new-map-entries)
105     (unlink (first entry))))
106     (return)))))
107 kaz 1.14
108 kaz 1.20 (chatter-debug "Updating file structure.~%")
109 kaz 1.1 (mapping-update))))
110     (values))
111 kaz 1.6
112 kaz 1.8 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
113 kaz 1.6 (multiple-value-bind (recursivep rest-add-options)
114 kaz 1.8 (separate "R" cvs-command-options
115 kaz 1.6 :key #'first :test #'string=)
116     (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5