/[meta-cvs]/meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65
ViewVC logotype

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Sun Feb 1 05:14:53 2004 UTC (10 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.12: +30 -23 lines
Merging from mcvs-1-0-branch.
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 "dirwalk")
7 (require "chatter")
8 (require "split")
9 (require "mapping")
10 (require "rcs-utils")
11 (require "mcvs-package")
12 (provide "convert")
13
14 (in-package "META-CVS")
15
16 (defun remove-attic-component (path)
17 (let ((split-path (nreverse (split-fields path "/")))
18 (attic-p nil))
19 (when (string= (first split-path) "Attic")
20 (pop split-path)
21 (setf attic-p t))
22 (values (reduce #'(lambda (x y) (format nil "~a/~a" x y))
23 (nreverse split-path)
24 :initial-value ".")
25 attic-p)))
26
27 (defun classify-tags (tags)
28 (let (version-tags branch-tags)
29 (dolist (tag tags (values version-tags branch-tags))
30 (destructuring-bind (tag-name tag-value) tag
31 (if (search ".0." tag-value)
32 (push tag-name branch-tags)
33 (push tag-name version-tags))))))
34
35 (defun mcvs-convert (source-dir target-dir)
36 (when (ignore-errors (stat target-dir))
37 (error "a directory or file called ~a exists here already."
38 target-dir))
39
40 (multiple-value-bind (path created)
41 (ensure-directories-exist (path-cat target-dir
42 *mcvs-map-name*))
43 (declare (ignore path))
44 (if (not created)
45 (error "unable to create directory ~a." target-dir)))
46
47 (let (filemap all-version-tags all-branch-tags attic-made)
48 (current-dir-restore
49 (chdir source-dir)
50 (for-each-file-info (fi ".")
51 (when (and (directory-p fi)
52 (path-equal (basename (file-name fi)) "CVS"))
53 (skip))
54 (when (regular-p fi)
55 (let ((canon-name (canonicalize-path (file-name fi))))
56 (multiple-value-bind (suffix basename dir)
57 (suffix canon-name #\,)
58 (multiple-value-bind (no-attic-dir attic-p)
59 (remove-attic-component (or dir "."))
60 (when (and suffix (string= suffix "v"))
61 (let* ((no-attic-suffix-name
62 (canonicalize-path (path-cat no-attic-dir basename)))
63 (f-name (mapping-generate-id :suffix (suffix basename)
64 :no-dir t))
65 (orig-rcs (path-cat source-dir canon-name))
66 (new-rcs (apply #'path-cat `(,target-dir
67 ,@(if attic-p '("Attic"))
68 ,(format nil "~A,v"
69 f-name)))))
70 (in-original-dir
71 (when attic-p
72 (unless attic-made
73 (ensure-directories-exist new-rcs)
74 (setf attic-made t)))
75 (chatter-info "hard linking ~a -> ~a~%" orig-rcs new-rcs)
76 (link orig-rcs new-rcs))
77 (push (make-mapping-entry :kind :file
78 :id (path-cat *mcvs-dir* f-name)
79 :path no-attic-suffix-name
80 :executable (executable-p fi))
81 filemap)
82 (with-open-file (f (parse-posix-namestring canon-name)
83 :direction :input)
84 (chatter-info "scanning ~a~%" canon-name)
85 (let ((rcs-file (rcs-parse f)))
86 (multiple-value-bind (version-tags branch-tags)
87 (classify-tags (rcs-admin-symbols (rcs-file-admin rcs-file)))
88 (setf all-version-tags (nunion all-version-tags
89 version-tags
90 :test #'string=))
91 (setf all-branch-tags (nunion all-branch-tags branch-tags
92 :test #'string=)))))))))))))
93
94 (current-dir-restore
95 (chdir target-dir)
96 (chatter-info "writing ~a~%" *mcvs-map-name*)
97 (mapping-write filemap *mcvs-map-name* :sort-map t)
98
99 (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."
100 "-t/dev/null" ,*mcvs-map-name*))
101 (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))
102
103 (chatter-info "setting up version and branch tags in ~a~%" *mcvs-map-name*)
104 (unless (null all-version-tags)
105 (execute-program-xargs '("rcs")
106 (mapcar #'(lambda (tag)
107 (format nil "-n~A:1.1" tag))
108 all-version-tags)
109 (list *mcvs-map-name*)))
110
111 (let ((branch-counter 0))
112 (unless (null all-branch-tags)
113 (execute-program-xargs '("rcs")
114 (mapcar #'(lambda (tag)
115 (format nil
116 "-n~A:1.1.0.~A"
117 tag (incf branch-counter
118 2)))
119 all-branch-tags)
120 (list *mcvs-map-name*)))))))
121
122 (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)
123 (declare (ignore cvs-options cvs-command-options))
124 (if (/= (length mcvs-args) 2)
125 (error "specify cvs source dir and new target dir."))
126 (mcvs-convert (first mcvs-args) (second mcvs-args)))
127
128 (defconstant *convert-help*
129 "Syntax:
130
131 mcvs convert source-cvs-module target-mcvs-module
132
133 Options:
134
135 None.
136
137 Semantics:
138
139 The convert command builds a Meta-CVS module directly out of the RCS files of
140 a CVS module. The source-cvs-module is the pathname to an existing
141 module directory in the CVS repository containing an ordinary CVS module.
142 The target-mcvs-module is the pathname of a new Meta-CVS module directory to
143 be created.
144
145 The source and target paths have to be on the same filesystem volume.
146
147 The chmod and rcs programs are required.
148
149 The algorithm is extremely naive:
150
151 - A list of the pathnames of the RCS files is collected, as the basis for
152 creating the MAP file. The Attic directory components are removed from these
153 paths, and the ,v suffixes are stripped.
154
155 - The execute property of files is lifted from the permission bits on
156 the RCS files.
157
158 - The MAP,v file is created using the ``rcs ci'' command.
159
160 - The F- files are generated as hard links to the RCS files, to save space
161 and avoid the overhead of copying.
162
163 - All of the RCS files are scanned to find version and branch tags. Quite
164 naively, the version tags are installed in the MAP file, all pointing to
165 revision 1.1. The branch tags are installed in MAP, pointing to revisions
166 1.1.0.2, 1.1.0.4, ... This is a lame attempt to make it possible to check
167 out past baselines. But note that the contents of MAP don't vary: only a
168 single version node is generated with a fixed set of files. It is not taken
169 into consideration that some of the CVS files may be deleted in the head
170 revision or some branches. Therefore, when the resulting Meta-CVS project is
171 checked out, or when past versions are retrieved, there may be complaints
172 from Meta-CVS about nonexistent files.
173
174 The complaints about nonexistent files may be fixed at the tips of the
175 main trunk or branches using the ``mcvs remap'' command which will purge
176 the working MAP of entries for F- files for which no working copy is found.
177 A commit will then commit the change so that subsequent work may continue
178 without any more complaints.
179
180 The hard linking of the original RCS objects under F- names means that any
181 permission, ownership or time-stamp changes done in the CVS module will
182 affect the content of the Meta-CVS module and vice versa. Destructive
183 modifications to the file contents, ditto. Be careful!
184
185 If the hard links make you nervous, do a deep copy of the module,
186 using ``cp -a source-dir target-dir''.
187
188 Note that CVS does not destructively manipulate RCS files. A commit
189 or tagging operation creates a new RCS object which atomically replaces the
190 old hard link. This means that a commit to a file in the Meta-CVS module will
191 not affect the CVS module and vice versa.")

  ViewVC Help
Powered by ViewVC 1.1.5