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

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5