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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Sat Mar 9 21:44:28 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-7
Changes since 1.17: +58 -31 lines
Support for file type keyword treatment under mcvs add.

* add.lisp (mcvs-add): Restructured to build up list of new file
suffixes, allow the user to edit the file which determines how
they are treated, filter out ignored files and pass -k options
to multiple cvs adds.

* types.lisp (*mcvs-new-types*): New constant.
(*types-comments*): Constant moved here from import.lisp.
(types-remove-ignores): New function. Code factored out from
mcvs-import.
(types-let-user-edit): Likewise.
(types-make-cvs-adds): New function.

* import.lisp (*types-comments*): Constant removed. Moved to
types.lisp
(mcvs-import): Code factored out to new functions in types.lisp, which
are also used by add.lisp.
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     (chatter-info "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.4 (chatter-terse "mcvs-add: ~a already added.~%" full-name))
40     ((directory-p full-name)
41     (when (not recursivep)
42 kaz 1.13 (error "mcvs-add: ~a, is a directory." 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    
63     (when new-map-entries
64     (dolist (map-entry new-map-entries)
65     (destructuring-bind (f-file path-name) map-entry
66     (push map-entry filemap)
67     (chatter-info "mapping ~a <- ~a~%" f-file path-name)
68     (link path-name f-file)))
69    
70     (mapping-write filemap *mcvs-map* :sort-map t)
71    
72     (when (setf types (append types new-types))
73     (types-write types *mcvs-types*))
74    
75 kaz 1.1 (chatter-info "Synchronizing.~%")
76     (mapping-synchronize)
77    
78 kaz 1.18 (let ((add-commands (types-make-cvs-adds types new-map-entries)))
79     (loop
80     (restart-case
81     (current-dir-restore
82     (chdir *mcvs-dir*)
83     (chatter-info "Invoking CVS.~%")
84     (dolist (add-args add-commands)
85     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
86     "add" ,@(format-opt add-options)
87     ,@add-args)))
88     (error "CVS add failed.")))
89     (when (and types (not types-exists))
90     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
91     "add" ,*mcvs-types-name*)))
92     (error "CVS add failed.")))
93     (return))
94     (retry ()
95     :report "Try invoking CVS again.")
96     (continue ()
97     :report "Undo everything; restore the mapping."
98     (chatter-terse "Restoring map.~%")
99     (mapping-write saved-filemap *mcvs-map*)
100     (ignore-errors
101     (dolist (entry new-map-entries)
102     (unlink (first entry))))
103     (return)))))
104 kaz 1.14
105 kaz 1.1 (chatter-info "Updating file structure.~%")
106     (mapping-update))))
107     (values))
108 kaz 1.6
109 kaz 1.8 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
110 kaz 1.6 (multiple-value-bind (recursivep rest-add-options)
111 kaz 1.8 (separate "R" cvs-command-options
112 kaz 1.6 :key #'first :test #'string=)
113     (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5