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

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5