/[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.2.1 - (hide annotations)
Thu Jan 29 04:53:13 2004 UTC (10 years, 2 months ago) by kaz
Branch: mcvs-1-0-branch
Changes since 1.7: +35 -29 lines
Fixes to convert command to make it useable.

* code/posix.lisp (suffix): Return dir name as additional value.
(execute-program-xargs): In the case that there are no variable
args passed, the fixed trailing args should still be passed
to the command.

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

  ViewVC Help
Powered by ViewVC 1.1.5