/[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 - (hide annotations)
Fri Mar 15 23:13:55 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: partial-sandbox-branch~branch-point, old-convert-hacking-branch~branch-point, mcvs-0-16, mcvs-0-15, mcvs-0-14, mcvs-0-17, mcvs-0-11, mcvs-0-10, mcvs-0-13, mcvs-0-12, deferred-adds-branch~branch-point
Branch point for: partial-sandbox-branch, deferred-adds-branch, old-convert-hacking-branch
Changes since 1.20: +1 -1 lines
* add.lisp (mcvs-add): Error message changed to tell user to use
-R to add directory.

* remove.lisp (mcvs-remove): New generalized boolean parameter
indicates to do a recursive remove. This is controlled by the
-R option which already exists. Behavior changed to not act
on directories unless recursion is explicitly requested.
(mcvs-remove-wrapper): Extract "R" option, pass down new boolean
to mcvs-remove.
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     (can-restart-here ("Continue adding files.")
34 kaz 1.4 (cond
35 kaz 1.5 ((path-prefix-equal *mcvs-dir* full-name)
36 kaz 1.10 (error "mcvs-add: path ~a is in a reserved Meta-CVS area."
37 kaz 1.5 full-name))
38 kaz 1.12 ((mapping-lookup filemap full-name)
39 kaz 1.20 (chatter-info "mcvs-add: ~a already added.~%" full-name))
40 kaz 1.4 ((directory-p full-name)
41     (when (not recursivep)
42 kaz 1.21 (error "mcvs-add: ~a, is a directory, use -R to add." full-name)))
43 kaz 1.4 ((not (regular-p full-name))
44 kaz 1.13 (error "mcvs-add: cannot add ~a, not regular file."
45 kaz 1.4 full-name))
46     (t
47 kaz 1.18 (let* ((suffix (suffix full-name))
48     (f-file (mapping-generate-name suffix)))
49     (when suffix
50     (setf new-types (adjoin (list suffix :default)
51     new-types :test #'equal)))
52     (push (list f-file full-name) new-map-entries))))))))
53    
54     (setf new-types (set-difference
55     new-types types :key #'first :test #'string=))
56    
57     (unwind-protect
58     (setf new-types (types-let-user-edit new-types *mcvs-new-types*))
59     (ignore-errors (unlink *mcvs-new-types*)))
60    
61     (setf new-map-entries (types-remove-ignores new-types new-map-entries))
62 kaz 1.19 (setf new-map-entries (types-remove-ignores types new-map-entries))
63 kaz 1.18
64     (when new-map-entries
65     (dolist (map-entry new-map-entries)
66     (destructuring-bind (f-file path-name) map-entry
67     (push map-entry filemap)
68     (chatter-info "mapping ~a <- ~a~%" f-file path-name)
69     (link path-name f-file)))
70    
71     (mapping-write filemap *mcvs-map* :sort-map t)
72    
73     (when (setf types (append types new-types))
74     (types-write types *mcvs-types*))
75    
76 kaz 1.20 (chatter-debug "Synchronizing.~%")
77 kaz 1.1 (mapping-synchronize)
78    
79 kaz 1.18 (let ((add-commands (types-make-cvs-adds types new-map-entries)))
80     (loop
81     (restart-case
82     (current-dir-restore
83     (chdir *mcvs-dir*)
84 kaz 1.20 (chatter-debug "Invoking CVS.~%")
85 kaz 1.18 (dolist (add-args add-commands)
86     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
87     "add" ,@(format-opt add-options)
88     ,@add-args)))
89     (error "CVS add failed.")))
90     (when (and types (not types-exists))
91     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
92     "add" ,*mcvs-types-name*)))
93     (error "CVS add failed.")))
94     (return))
95     (retry ()
96     :report "Try invoking CVS again.")
97     (continue ()
98     :report "Undo everything; restore the mapping."
99 kaz 1.20 (chatter-debug "Restoring map.~%")
100 kaz 1.18 (mapping-write saved-filemap *mcvs-map*)
101     (ignore-errors
102     (dolist (entry new-map-entries)
103     (unlink (first entry))))
104     (return)))))
105 kaz 1.14
106 kaz 1.20 (chatter-debug "Updating file structure.~%")
107 kaz 1.1 (mapping-update))))
108     (values))
109 kaz 1.6
110 kaz 1.8 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
111 kaz 1.6 (multiple-value-bind (recursivep rest-add-options)
112 kaz 1.8 (separate "R" cvs-command-options
113 kaz 1.6 :key #'first :test #'string=)
114     (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5