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

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Sat Jan 31 23:09:58 2004 UTC (10 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.11: +50 -35 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.4 (require "rcs-utils")
11 kaz 1.8 (require "mcvs-package")
12 kaz 1.1 (provide "convert")
13 kaz 1.8
14     (in-package "META-CVS")
15 kaz 1.1
16     (defun remove-attic-component (path)
17 kaz 1.12 (let ((split-path (nreverse (split-fields path "/")))
18     (attic-p nil))
19 kaz 1.9 (when (string= (first split-path) "Attic")
20 kaz 1.12 (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 kaz 1.1
27     (defun classify-tags (tags)
28     (let (version-tags branch-tags)
29     (dolist (tag tags (values version-tags branch-tags))
30 kaz 1.3 (destructuring-bind (tag-name tag-value) tag
31 kaz 1.1 (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 kaz 1.6 (error "a directory or file called ~a exists here already."
38 kaz 1.1 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 kaz 1.6 (error "unable to create directory ~a." target-dir)))
46 kaz 1.1
47 kaz 1.12 (let (filemap all-version-tags all-branch-tags attic-made)
48 kaz 1.1 (current-dir-restore
49 kaz 1.9 (chatter-info "descending into ~a~%" source-dir)
50 kaz 1.1 (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     (rcs-name (apply #'path-cat `(,*up-dir* ,target-dir
67     ,@(if attic-p '("Attic"))
68     ,(format nil "~A,v"
69     f-name)))))
70     (when attic-p
71     (unless attic-made
72     (ensure-directories-exist rcs-name)
73     (setf attic-made t)))
74     (chatter-info "hard linking ~a -> ~a~%"
75     canon-name
76     rcs-name)
77     (link canon-name rcs-name)
78     (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     (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."
101     "-t/dev/null" ,*mcvs-map-name*))
102     (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))
103    
104 kaz 1.9 (chatter-info "setting up version and branch tags in ~a~%" *mcvs-map-name*)
105     (unless (null all-version-tags)
106     (execute-program-xargs '("rcs")
107     (mapcar #'(lambda (tag)
108     (format nil "-n~A:1.1" tag))
109     all-version-tags)
110     (list *mcvs-map-name*)))
111 kaz 1.1
112     (let ((branch-counter 0))
113 kaz 1.9 (unless (null all-branch-tags)
114     (execute-program-xargs '("rcs")
115     (mapcar #'(lambda (tag)
116     (format nil
117     "-n~A:1.1.0.~A"
118 kaz 1.10 tag (incf branch-counter
119     2)))
120 kaz 1.9 all-branch-tags)
121     (list *mcvs-map-name*)))))))
122 kaz 1.1
123 kaz 1.2 (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)
124     (declare (ignore cvs-options cvs-command-options))
125     (if (/= (length mcvs-args) 2)
126 kaz 1.6 (error "specify cvs source dir and new target dir."))
127 kaz 1.2 (mcvs-convert (first mcvs-args) (second mcvs-args)))
128 kaz 1.10
129     (defconstant *convert-help*
130     "Syntax:
131    
132     mcvs convert source-cvs-module target-mcvs-module
133    
134     Options:
135    
136     None.
137    
138     Semantics:
139    
140     The convert command builds a Meta-CVS module directly out of the RCS files of
141     a CVS module. It must be run in the root directory of a CVS repository.
142     It requires the chmod and rcs command line tools.
143    
144     The algorithm is extremely naive. A list of the pathnames of the RCS files
145     is collected, as the basis for creating the MAP file. The Attic directory
146     components are removed from these paths, and the ,v suffixes are stripped.
147    
148     The execute property of files is lifted from the permission bits on
149     the RCS files.
150    
151     The MAP,v file is created using the ``rcs ci'' command.
152    
153     The F- files are generated as hard links to the RCS files, to save space
154     and avoid the overhead of copying.
155    
156     All of the RCS files are scanned to find version and branch tags. Quite
157     naively, the version tags are installed in the MAP file, all pointing to
158     revision 1.1. The branch tags are installed in MAP, pointing to revisions
159     1.1.0.2, 1.1.0.4, ... This is a lame attempt to make it possible to check
160     out past baselines. But note that the contents of MAP don't vary: only a
161     single version node is generated with a fixed set of files. It is not taken
162     into consideration that some of the CVS files may be deleted in the head
163     revision or some branches. Therefore, when the resulting Meta-CVS project is
164     checked out, or when past versions are retrieved, there may be complaints
165     from Meta-CVS about nonexistent files.
166 kaz 1.12
167     The complaints about nonexistent files may be fixed at the tips of the
168     main trunk or branches using the ``mcvs remap'' command which will purge
169     the working MAP of entries for F- files for which no working copy is found.
170     A commit will then commit the change so that subsequent work may continue
171     without any more complaints.
172 kaz 1.10
173     The hard linking of the original RCS objects under F- names means that any
174     permission, ownership or time-stamp changes done in the CVS module will
175     affect the content of the Meta-CVS module and vice versa. Destructive
176     modifications to the file contents, ditto. Be careful!
177    
178     If the hard links make you nervous, do a deep copy of the module,
179     using ``cp -a source-dir target-dir''.
180    
181     Note that CVS does not destructively manipulate RCS files. A commit
182     or tagging operation creates a new RCS object which atomically replaces the
183     old hard link. This means that a commit to a file in the Meta-CVS module will
184     not affect the CVS module and vice versa.")

  ViewVC Help
Powered by ViewVC 1.1.5