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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (show annotations)
Tue Mar 12 19:54:58 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-9, mcvs-0-8
Changes since 1.19: +6 -6 lines
* update.lisp (mcvs-update): Changing level of chatter messages.
* move.lisp (mcvs-move): Likewise.
* add.lisp (mcvs-add): Likewise.
* remove.lisp (mcvs-remove): Likewise.
* checkout.lisp (mcvs-checkout): Likewise.
* generic.lisp (mcvs-generic): Likewise.
* import.lisp (mcvs-import): Likewise.
* mapping.lisp (mapping-dupe-check): Likewise.
(mapping-update): Likewise.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (require "system")
6 (require "mapping")
7 (require "chatter")
8 (require "dirwalk")
9 (require "seqfuncs")
10 (require "options")
11 (require "types")
12 (provide "add")
13
14 (defun mcvs-add (recursivep cvs-options add-options files)
15 (in-sandbox-root-dir
16 (let* ((filemap (mapping-read *mcvs-map*))
17 (saved-filemap (copy-list filemap))
18 (types-exists (exists *mcvs-types*))
19 (types (and types-exists (types-read *mcvs-types*)))
20 new-map-entries new-types)
21
22 (chatter-debug "Mapping.~%")
23
24 (dolist (file files)
25 (let (expanded-paths)
26 (if recursivep
27 (for-each-path (full-name (sandbox-translate-path file))
28 (push (canonicalize-path full-name) expanded-paths))
29 (push (sandbox-translate-path file) expanded-paths))
30 (nreverse expanded-paths)
31
32 (dolist (full-name expanded-paths)
33 (can-restart-here ("Continue adding files.")
34 (cond
35 ((path-prefix-equal *mcvs-dir* full-name)
36 (error "mcvs-add: path ~a is in a reserved Meta-CVS area."
37 full-name))
38 ((mapping-lookup filemap full-name)
39 (chatter-info "mcvs-add: ~a already added.~%" full-name))
40 ((directory-p full-name)
41 (when (not recursivep)
42 (error "mcvs-add: ~a, is a directory." full-name)))
43 ((not (regular-p full-name))
44 (error "mcvs-add: cannot add ~a, not regular file."
45 full-name))
46 (t
47 (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 (setf new-map-entries (types-remove-ignores types new-map-entries))
63
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 (chatter-debug "Synchronizing.~%")
77 (mapping-synchronize)
78
79 (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 (chatter-debug "Invoking CVS.~%")
85 (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 (chatter-debug "Restoring map.~%")
100 (mapping-write saved-filemap *mcvs-map*)
101 (ignore-errors
102 (dolist (entry new-map-entries)
103 (unlink (first entry))))
104 (return)))))
105
106 (chatter-debug "Updating file structure.~%")
107 (mapping-update))))
108 (values))
109
110 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
111 (multiple-value-bind (recursivep rest-add-options)
112 (separate "R" cvs-command-options
113 :key #'first :test #'string=)
114 (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5