/[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 - (show annotations)
Sun Oct 6 05:25:31 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0, mcvs-0-99, mcvs-0-98, mcvs-1-0-branch~branch-point, mcvs-0-97, mcvs-1-0-11, mcvs-1-0-10, mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-7, mcvs-1-0-6, mcvs-1-0-1, mcvs-1-0-2
Branch point for: mcvs-1-0-branch
Changes since 1.6: +4 -1 lines
* code/convert.lisp (mcvs-convert): Maintenance so that this tool
at least runs, even though it doesn't do anything resembling a
reasonable conversion job.
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 "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 "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 (make-mapping-entry :kind :file
58 :id (path-cat *mcvs-dir* f-name)
59 :path attic-free-name
60 :executable (executable-p fi))
61 filemap)
62 (with-open-file (f (parse-posix-namestring canon-name)
63 :direction :input)
64 (chatter-info "scanning ~a.~%" canon-name)
65 (let ((rcs-file (rcs-parse f)))
66 (multiple-value-bind (version-tags branch-tags)
67 (classify-tags (rcs-admin-symbols (rcs-file-admin rcs-file)))
68 (setf all-version-tags (nunion all-version-tags
69 version-tags
70 :test #'string=))
71 (setf all-branch-tags (nunion all-branch-tags branch-tags
72 :test #'string=))))))))))))
73
74 (current-dir-restore
75 (chdir target-dir)
76 (chatter-info "Writing map.")
77 (mapping-write filemap *mcvs-map-name*)
78
79 (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."
80 "-t/dev/null" ,*mcvs-map-name*))
81 (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))
82
83 (execute-program-xargs '("rcs")
84 (mapcar #'(lambda (tag)
85 (format nil "-n~A:1.1" tag))
86 all-version-tags)
87 (list *mcvs-map-name*))
88
89 (let ((branch-counter 0))
90 (execute-program-xargs '("rcs")
91 (mapcar #'(lambda (tag)
92 (format nil
93 "-n~A:1.1.0.~A"
94 tag (+ 2 branch-counter)))
95 all-branch-tags)
96 (list *mcvs-map-name*))))))
97
98 (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)
99 (declare (ignore cvs-options cvs-command-options))
100 (if (/= (length mcvs-args) 2)
101 (error "specify cvs source dir and new target dir."))
102 (mcvs-convert (first mcvs-args) (second mcvs-args)))

  ViewVC Help
Powered by ViewVC 1.1.5