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

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Thu Jan 29 05:00:15 2004 UTC (10 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.8: +35 -29 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.9 (let* ((split-path (nreverse (split-fields path "/"))))
18     (when (string= (first split-path) "Attic")
19     (pop split-path))
20     (reduce #'(lambda (x y) (format nil "~a/~a" x y)) (nreverse split-path))))
21 kaz 1.1
22     (defun classify-tags (tags)
23     (let (version-tags branch-tags)
24     (dolist (tag tags (values version-tags branch-tags))
25 kaz 1.3 (destructuring-bind (tag-name tag-value) tag
26 kaz 1.1 (if (search ".0." tag-value)
27     (push tag-name branch-tags)
28     (push tag-name version-tags))))))
29    
30     (defun mcvs-convert (source-dir target-dir)
31     (when (ignore-errors (stat target-dir))
32 kaz 1.6 (error "a directory or file called ~a exists here already."
33 kaz 1.1 target-dir))
34    
35     (multiple-value-bind (path created)
36     (ensure-directories-exist (path-cat target-dir
37     *mcvs-map-name*))
38     (declare (ignore path))
39     (if (not created)
40 kaz 1.6 (error "unable to create directory ~a." target-dir)))
41 kaz 1.1
42     (let (filemap all-version-tags all-branch-tags)
43     (current-dir-restore
44 kaz 1.9 (chatter-info "descending into ~a~%" source-dir)
45 kaz 1.1 (chdir source-dir)
46     (for-each-file-info (fi ".")
47     (when (regular-p fi)
48 kaz 1.3 (let ((canon-name (canonicalize-path (file-name fi))))
49 kaz 1.9 (multiple-value-bind (suffix basename dir)
50 kaz 1.1 (suffix canon-name #\,)
51     (when (and suffix (string= suffix "v"))
52 kaz 1.9 (let* ((dir (or dir "."))
53     (no-attic-dir (remove-attic-component dir))
54     (no-attic-suffix-name (path-cat no-attic-dir basename))
55     (f-name (mapping-generate-id :suffix (suffix basename)
56     :no-dir t))
57     (rcs-name (path-cat *up-dir* target-dir
58     (format nil "~A,v" f-name))))
59     (chatter-info "hard linking ~a -> ~a~%"
60     canon-name
61     rcs-name)
62     (link canon-name rcs-name)
63 kaz 1.7 (push (make-mapping-entry :kind :file
64     :id (path-cat *mcvs-dir* f-name)
65 kaz 1.9 :path no-attic-suffix-name
66 kaz 1.7 :executable (executable-p fi))
67 kaz 1.1 filemap)
68 kaz 1.3 (with-open-file (f (parse-posix-namestring canon-name)
69     :direction :input)
70 kaz 1.9 (chatter-info "scanning ~a~%" canon-name)
71 kaz 1.3 (let ((rcs-file (rcs-parse f)))
72     (multiple-value-bind (version-tags branch-tags)
73     (classify-tags (rcs-admin-symbols (rcs-file-admin rcs-file)))
74     (setf all-version-tags (nunion all-version-tags
75     version-tags
76     :test #'string=))
77     (setf all-branch-tags (nunion all-branch-tags branch-tags
78     :test #'string=))))))))))))
79 kaz 1.1
80     (current-dir-restore
81     (chdir target-dir)
82 kaz 1.9 (chatter-info "writing ~a~%" *mcvs-map-name*)
83 kaz 1.1 (mapping-write filemap *mcvs-map-name*)
84    
85     (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."
86     "-t/dev/null" ,*mcvs-map-name*))
87     (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))
88    
89 kaz 1.9 (chatter-info "setting up version and branch tags in ~a~%" *mcvs-map-name*)
90     (unless (null all-version-tags)
91     (execute-program-xargs '("rcs")
92     (mapcar #'(lambda (tag)
93     (format nil "-n~A:1.1" tag))
94     all-version-tags)
95     (list *mcvs-map-name*)))
96 kaz 1.1
97     (let ((branch-counter 0))
98 kaz 1.9 (unless (null all-branch-tags)
99     (execute-program-xargs '("rcs")
100     (mapcar #'(lambda (tag)
101     (format nil
102     "-n~A:1.1.0.~A"
103     tag (+ 2 branch-counter)))
104     all-branch-tags)
105     (list *mcvs-map-name*)))))))
106 kaz 1.1
107 kaz 1.2 (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)
108     (declare (ignore cvs-options cvs-command-options))
109     (if (/= (length mcvs-args) 2)
110 kaz 1.6 (error "specify cvs source dir and new target dir."))
111 kaz 1.2 (mcvs-convert (first mcvs-args) (second mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5