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

Contents of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Wed Mar 20 19:32:26 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-20, symlink-branch~branch-point, partial-sandbox-branch~branch-point, mcvs-0-21, old-convert-hacking-branch~branch-point, partial-sandbox-branch~merged-to-HEAD-0, mcvs-0-16, mcvs-0-15, mcvs-0-14, mcvs-0-17, mcvs-0-11, mcvs-0-10, mcvs-0-13, mcvs-0-12, mcvs-0-19, mcvs-0-18, deferred-adds-branch~branch-point
Branch point for: symlink-branch, partial-sandbox-branch, deferred-adds-branch, old-convert-hacking-branch
Changes since 1.3: +1 -1 lines
* rcsparse.lisp: File renamed to rcs-utils.lisp.
(rcs-delta): New slot, delta-hash.
(rcs-make-delta-hash): New function.
(rcs-parse): Calls rcs-make-delta-hash to set up new slot.

* convert.lisp: require changed to match file rename.
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     (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 kaz 1.3 (destructuring-bind (tag-name tag-value) tag
25 kaz 1.1 (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 kaz 1.2 (error "mcvs-convert: unable to create directory ~a." target-dir)))
40 kaz 1.1
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 kaz 1.3 (let ((canon-name (canonicalize-path (file-name fi))))
47     (multiple-value-bind (suffix v-suffix-free-name)
48 kaz 1.1 (suffix canon-name #\,)
49     (when (and suffix (string= suffix "v"))
50     (let ((attic-free-name
51 kaz 1.3 (remove-attic-component v-suffix-free-name))
52     (f-name (mapping-generate-name (suffix v-suffix-free-name)
53     :no-dir t)))
54 kaz 1.1 (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 kaz 1.3 (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 kaz 1.1
71     (current-dir-restore
72     (chdir target-dir)
73 kaz 1.3 (chatter-info "Writing map.")
74 kaz 1.1 (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 kaz 1.2 (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