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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Thu Jan 31 05:35:02 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.9: +2 -2 lines
MCVS is being renamed to Meta-CVS.
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.1 (provide "add")
12    
13 kaz 1.6 (defun mcvs-add (recursivep cvs-options add-options files)
14 kaz 1.3 (in-sandbox-root-dir
15     (let (filemap new-mcvs-files)
16 kaz 1.1 (with-open-file (file *mcvs-map* :direction :input)
17     (setf filemap (read file)))
18    
19     (chatter-info "Mapping.~%")
20 kaz 1.4
21 kaz 1.1 (dolist (file files)
22 kaz 1.4 (let (expanded-paths)
23     (if recursivep
24     (for-each-path (full-name (sandbox-translate-path file))
25 kaz 1.5 (push (canonicalize-path full-name) expanded-paths))
26 kaz 1.4 (push (sandbox-translate-path file) expanded-paths))
27     (nreverse expanded-paths)
28    
29 kaz 1.5 (dolist (full-name expanded-paths)
30     (can-restart-here ("Continue adding files.")
31 kaz 1.4 (cond
32 kaz 1.5 ((path-prefix-equal *mcvs-dir* full-name)
33 kaz 1.10 (error "mcvs-add: path ~a is in a reserved Meta-CVS area."
34 kaz 1.5 full-name))
35 kaz 1.4 ((filemap-lookup filemap full-name)
36     (chatter-terse "mcvs-add: ~a already added.~%" full-name))
37     ((directory-p full-name)
38     (when (not recursivep)
39     (error "mcvs-add: ~a, is a directory.~%" full-name)))
40     ((not (regular-p full-name))
41     (error "mcvs-add: cannot add ~a, not regular file.~%"
42     full-name))
43     (t
44     (let ((mcvs-file (filemap-generate-name)))
45     (chatter-info "~a <- ~a~%" mcvs-file full-name)
46     (link full-name mcvs-file)
47     (push (basename mcvs-file) new-mcvs-files)
48     (push (list mcvs-file full-name) filemap))))))))
49 kaz 1.1
50     (with-open-file (file *mcvs-map* :direction :output)
51     (let ((*print-right-margin* 1))
52     (prin1 (filemap-sort filemap) file)
53     (terpri file)))
54    
55     (when new-mcvs-files
56     (chatter-info "Synchronizing.~%")
57     (mapping-synchronize)
58    
59     (current-dir-restore
60     (chdir *mcvs-dir*)
61     (chatter-info "Invoking CVS.~%")
62 kaz 1.8 (execute-program `("cvs" ,@(format-opt cvs-options)
63     "add" ,@(format-opt add-options)
64 kaz 1.6 ,@new-mcvs-files)))
65 kaz 1.1
66     (chatter-info "Updating file structure.~%")
67     (mapping-update))))
68     (values))
69 kaz 1.6
70 kaz 1.8 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
71 kaz 1.6 (multiple-value-bind (recursivep rest-add-options)
72 kaz 1.8 (separate "R" cvs-command-options
73 kaz 1.6 :key #'first :test #'string=)
74     (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5