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

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sat Feb 9 03:34:17 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
* convert.lisp: New file. Contains conversion utility
to make an Meta-CVS repository from an ordinary CVS repository,
while preserving all history, tags and branches.
(remove-attic-component, classify-tags, read-tags,
mcvs-convert): New functions.

* posix.lisp (suffix): New function. Computes suffix of file.
(execute-program-xargs): New optional parameter, for specifying
fixed part added at the end of each generated command line.

* mapping.lisp (*mcvs-map-name*, *mcvs-local-map-name*): New constants.
(*mcvs-map*, *mcvs-map-local*): Redefined in terms of new constants.
(mapping-generate-name): New key parameter no-dir for not adding
the directory prefix.
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 "split")
8 (require "mapping")
9 (provide "convert")
10
11 (defun remove-attic-component (path)
12 (let* ((split-path (split-fields path "/"))
13 (len (length split-path)))
14 (when (and (>= len 2) (string= (nth (- len 2) split-path) "Attic"))
15 (setf split-path (append (butlast (butlast split-path))
16 (last split-path))))
17 (reduce #'(lambda (x y) (format nil "~a/~a" x y)) split-path)))
18
19 (defun classify-tags (tags)
20 (let (version-tags branch-tags)
21 (dolist (tag tags (values version-tags branch-tags))
22 (destructuring-bind (tag-name tag-value)
23 (split-fields tag #(#\:))
24 (if (search ".0." tag-value)
25 (push tag-name branch-tags)
26 (push tag-name version-tags))))))
27
28
29 (defun read-tags (filename)
30 (let (tags)
31 (with-open-file (stream filename :direction :input)
32 (block file-reading-loop
33 (loop
34 (let ((line (read-line stream nil)))
35 (cond
36 ((null line) (return-from file-reading-loop))
37 ((string= line "symbols")
38 (loop
39 (let ((tag-line (read-line stream nil)))
40 (cond
41 ((null tag-line) (return-from file-reading-loop))
42 ((char-equal #\tab (char tag-line 0))
43 (push (string-trim #(#\space #\tab #\;) tag-line)
44 tags))
45 (t (return-from file-reading-loop)))))))))))
46 (classify-tags tags)))
47
48 (defun mcvs-convert (source-dir target-dir)
49 (when (ignore-errors (stat target-dir))
50 (error "mcvs-convert: a directory or file called ~a exists here already."
51 target-dir))
52
53 (multiple-value-bind (path created)
54 (ensure-directories-exist (path-cat target-dir
55 *mcvs-map-name*))
56 (declare (ignore path))
57 (if (not created)
58 (error "mcvs-convert: unable to create directory ~a." module)))
59
60 (let (filemap all-version-tags all-branch-tags)
61 (current-dir-restore
62 (chdir source-dir)
63 (for-each-file-info (fi ".")
64 (when (regular-p fi)
65 (let* ((canon-name (canonicalize-path (file-name fi)))
66 (f-name (mapping-generate-name :no-dir t)))
67 (multiple-value-bind (suffix suffix-free-name)
68 (suffix canon-name #\,)
69 (when (and suffix (string= suffix "v"))
70 (let ((attic-free-name
71 (remove-attic-component suffix-free-name)))
72 (link canon-name (path-cat *up-dir*
73 target-dir
74 (format nil "~A,v" f-name)))
75 (push (list (path-cat *mcvs-dir* f-name) attic-free-name)
76 filemap)
77 (multiple-value-bind (version-tags branch-tags)
78 (read-tags (file-name fi))
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=))))))))))
84
85 (current-dir-restore
86 (chdir target-dir)
87 (mapping-write filemap *mcvs-map-name*)
88
89 (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."
90 "-t/dev/null" ,*mcvs-map-name*))
91 (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))
92
93 (execute-program-xargs '("rcs")
94 (mapcar #'(lambda (tag)
95 (format nil "-n~A:1.1" tag))
96 all-version-tags)
97 (list *mcvs-map-name*))
98
99 (let ((branch-counter 0))
100 (execute-program-xargs '("rcs")
101 (mapcar #'(lambda (tag)
102 (format nil
103 "-n~A:1.1.0.~A"
104 tag (+ 2 branch-counter)))
105 all-branch-tags)
106 (list *mcvs-map-name*))))))
107

  ViewVC Help
Powered by ViewVC 1.1.5