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

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Sat Aug 31 20:53:13 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24, mcvs-0-22, mcvs-0-23, mcvs-0-95, mcvs-0-96
Changes since 1.4: +2 -2 lines
Merging symlink-branch to main trunk.
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 "chatter")
8 (require "split")
9 (require "mapping")
10 (require "rcs-utils")
11 (provide "convert")
12
13 (defun remove-attic-component (path)
14 (let* ((split-path (split-fields path "/"))
15 (len (length split-path)))
16 (when (and (>= len 2) (string= (nth (- len 2) split-path) "Attic"))
17 (setf split-path (append (butlast (butlast split-path))
18 (last split-path))))
19 (reduce #'(lambda (x y) (format nil "~a/~a" x y)) split-path)))
20
21 (defun classify-tags (tags)
22 (let (version-tags branch-tags)
23 (dolist (tag tags (values version-tags branch-tags))
24 (destructuring-bind (tag-name tag-value) tag
25 (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 (error "mcvs-convert: a directory or file called ~a exists here already."
32 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 (error "mcvs-convert: unable to create directory ~a." target-dir)))
40
41 (let (filemap all-version-tags all-branch-tags)
42 (current-dir-restore
43 (chdir source-dir)
44 (for-each-file-info (fi ".")
45 (when (regular-p fi)
46 (let ((canon-name (canonicalize-path (file-name fi))))
47 (multiple-value-bind (suffix v-suffix-free-name)
48 (suffix canon-name #\,)
49 (when (and suffix (string= suffix "v"))
50 (let ((attic-free-name
51 (remove-attic-component v-suffix-free-name))
52 (f-name (mapping-generate-id :suffix (suffix v-suffix-free-name)
53 :no-dir t)))
54 (link canon-name (path-cat *up-dir*
55 target-dir
56 (format nil "~A,v" f-name)))
57 (push (list (path-cat *mcvs-dir* f-name) attic-free-name)
58 filemap)
59 (with-open-file (f (parse-posix-namestring canon-name)
60 :direction :input)
61 (chatter-info "scanning ~a.~%" canon-name)
62 (let ((rcs-file (rcs-parse f)))
63 (multiple-value-bind (version-tags branch-tags)
64 (classify-tags (rcs-admin-symbols (rcs-file-admin rcs-file)))
65 (setf all-version-tags (nunion all-version-tags
66 version-tags
67 :test #'string=))
68 (setf all-branch-tags (nunion all-branch-tags branch-tags
69 :test #'string=))))))))))))
70
71 (current-dir-restore
72 (chdir target-dir)
73 (chatter-info "Writing map.")
74 (mapping-write filemap *mcvs-map-name*)
75
76 (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."
77 "-t/dev/null" ,*mcvs-map-name*))
78 (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))
79
80 (execute-program-xargs '("rcs")
81 (mapcar #'(lambda (tag)
82 (format nil "-n~A:1.1" tag))
83 all-version-tags)
84 (list *mcvs-map-name*))
85
86 (let ((branch-counter 0))
87 (execute-program-xargs '("rcs")
88 (mapcar #'(lambda (tag)
89 (format nil
90 "-n~A:1.1.0.~A"
91 tag (+ 2 branch-counter)))
92 all-branch-tags)
93 (list *mcvs-map-name*))))))
94
95 (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)
96 (declare (ignore cvs-options cvs-command-options))
97 (if (/= (length mcvs-args) 2)
98 (error "mcvs-convert: specify cvs source dir and new target dir."))
99 (mcvs-convert (first mcvs-args) (second mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5