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

Contents of /meta-cvs/F-73871F8E513E48E095DE0FEFB1CFC48B

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22.2.1 - (hide annotations)
Sun Aug 25 18:20:44 2002 UTC (11 years, 8 months ago) by kaz
Branch: symlink-branch
CVS Tags: symlink-branch~merged-to-HEAD-0
Changes since 1.22: +27 -13 lines
* code/add.lisp (mcvs-add): Change to new mapping-entry data structure
and handle symbolic links.

* code/types.lisp (types-remove-ignores, types-make-cvs-adds):
Change to new mapping-entry data structure.

* code/mapping.lisp (mapping-generate-name): Renamed to
mapping-generate-id. Interface changes slightly.
(mapping-extract-kind): New function, factored out from mcvs-generic.
(mapping-update): Unlink existing symbolic link before
re-linking it.

* code/convert.lisp (mcvs-convert): Use new name and interface
of mapping-generate-name function.

* code/create.lisp (mcvs-create): Likewise.

* code/generic.lisp (mcvs-generic): Code to extract :file
entries from map factored out to mapping-extract-kind.
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.22.2.1 (let ((abs-name (real-to-abstract-path full-name))
34     (file-info (stat full-name)))
35 kaz 1.22 (can-restart-here ("Continue adding files.")
36     (cond
37     ((path-prefix-equal *mcvs-dir* full-name)
38     (error "mcvs-add: path ~a is in a reserved Meta-CVS area."
39     full-name))
40     ((mapping-lookup filemap abs-name)
41     (chatter-info "mcvs-add: ~a already added.~%" full-name))
42 kaz 1.22.2.1 ((directory-p file-info)
43 kaz 1.22 (when (not recursivep)
44     (error "mcvs-add: ~a, is a directory, use -R to add." full-name)))
45 kaz 1.22.2.1 ((regular-p file-info)
46 kaz 1.22 (let* ((suffix (suffix full-name))
47 kaz 1.22.2.1 (f-file (mapping-generate-id :suffix suffix)))
48 kaz 1.22 (when suffix
49     (setf new-types (adjoin (list suffix :default)
50     new-types :test #'equal)))
51 kaz 1.22.2.1 (push (make-mapping-entry :kind :file
52     :id f-file
53     :path abs-name)
54     new-map-entries)))
55     ((symlink-p file-info)
56     (let ((id (mapping-generate-id :no-dir t :prefix "S-")))
57     (push (make-mapping-entry :kind :symlink
58     :id id
59     :path abs-name
60     :target (readlink full-name))
61     new-map-entries)))
62     (t
63     (error "mcvs-add: cannot add ~a, not regular file or symlink."
64     full-name))))))))
65 kaz 1.18
66     (setf new-types (set-difference
67     new-types types :key #'first :test #'string=))
68    
69     (unwind-protect
70     (setf new-types (types-let-user-edit new-types *mcvs-new-types*))
71     (ignore-errors (unlink *mcvs-new-types*)))
72    
73     (setf new-map-entries (types-remove-ignores new-types new-map-entries))
74 kaz 1.19 (setf new-map-entries (types-remove-ignores types new-map-entries))
75 kaz 1.18
76     (when new-map-entries
77     (dolist (map-entry new-map-entries)
78 kaz 1.22.2.1 (with-slots (kind id path) map-entry
79 kaz 1.18 (push map-entry filemap)
80 kaz 1.22.2.1 (let ((real-name (abstract-to-real-path path)))
81     (chatter-info "mapping ~a <- ~a~%" id real-name)
82     (if (eq kind :file)
83     (link real-name id)))))
84 kaz 1.18
85     (mapping-write filemap *mcvs-map* :sort-map t)
86    
87     (when (setf types (append types new-types))
88     (types-write types *mcvs-types*))
89    
90 kaz 1.20 (chatter-debug "Synchronizing.~%")
91 kaz 1.1 (mapping-synchronize)
92    
93 kaz 1.22.2.1 (setf new-map-entries (mapping-extract-kind new-map-entries :file))
94    
95 kaz 1.18 (let ((add-commands (types-make-cvs-adds types new-map-entries)))
96     (loop
97     (restart-case
98     (current-dir-restore
99     (chdir *mcvs-dir*)
100 kaz 1.20 (chatter-debug "Invoking CVS.~%")
101 kaz 1.18 (dolist (add-args add-commands)
102     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
103     "add" ,@(format-opt add-options)
104     ,@add-args)))
105     (error "CVS add failed.")))
106     (when (and types (not types-exists))
107     (when (not (execute-program `("cvs" ,@(format-opt cvs-options)
108     "add" ,*mcvs-types-name*)))
109     (error "CVS add failed.")))
110     (return))
111     (retry ()
112     :report "Try invoking CVS again.")
113     (continue ()
114     :report "Undo everything; restore the mapping."
115 kaz 1.20 (chatter-debug "Restoring map.~%")
116 kaz 1.18 (mapping-write saved-filemap *mcvs-map*)
117     (ignore-errors
118     (dolist (entry new-map-entries)
119 kaz 1.22.2.1 (unlink (mapping-entry-id entry))))
120 kaz 1.18 (return)))))
121 kaz 1.14
122 kaz 1.20 (chatter-debug "Updating file structure.~%")
123 kaz 1.1 (mapping-update))))
124     (values))
125 kaz 1.6
126 kaz 1.8 (defun mcvs-add-wrapper (cvs-options cvs-command-options mcvs-args)
127 kaz 1.6 (multiple-value-bind (recursivep rest-add-options)
128 kaz 1.8 (separate "R" cvs-command-options
129 kaz 1.6 :key #'first :test #'string=)
130     (mcvs-add recursivep cvs-options rest-add-options mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5