ViewVC logotype

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.18 - (show annotations)
Tue Nov 28 07:47:22 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.17: +14 -14 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

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

  ViewVC Help
Powered by ViewVC 1.1.5