ViewVC logotype

Diff of /meta-cvs/F-9A67B1893CE1CF23455CD1EF0F486B65

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by kaz, Sun Oct 6 05:25:31 2002 UTC revision by kaz, Thu Jan 29 04:53:13 2004 UTC
# Line 11  Line 11 
11  (provide "convert")  (provide "convert")
13  (defun remove-attic-component (path)  (defun remove-attic-component (path)
14    (let* ((split-path (split-fields path "/"))    (let* ((split-path (nreverse (split-fields path "/"))))
15           (len (length split-path)))      (when (string= (first split-path) "Attic")
16      (when (and (>= len 2) (string= (nth (- len 2) split-path) "Attic"))        (pop split-path))
17        (setf split-path (append (butlast (butlast split-path))      (reduce #'(lambda (x y) (format nil "~a/~a" x y)) (nreverse split-path))))
                                (last split-path))))  
     (reduce #'(lambda (x y) (format nil "~a/~a" x y)) split-path)))  
19  (defun classify-tags (tags)  (defun classify-tags (tags)
20    (let (version-tags branch-tags)    (let (version-tags branch-tags)
# Line 40  Line 38 
39    (let (filemap all-version-tags all-branch-tags)    (let (filemap all-version-tags all-branch-tags)
40      (current-dir-restore      (current-dir-restore
41          (chatter-info "descending into ~a~%" source-dir)
42        (chdir source-dir)        (chdir source-dir)
43        (for-each-file-info (fi ".")        (for-each-file-info (fi ".")
44          (when (regular-p fi)          (when (regular-p fi)
45            (let ((canon-name (canonicalize-path (file-name fi))))            (let ((canon-name (canonicalize-path (file-name fi))))
46              (multiple-value-bind (suffix v-suffix-free-name)              (multiple-value-bind (suffix basename dir)
47                                   (suffix canon-name #\,)                                   (suffix canon-name #\,)
48                (when (and suffix (string= suffix "v"))                (when (and suffix (string= suffix "v"))
49                  (let ((attic-free-name                  (let* ((dir (or dir "."))
50                          (remove-attic-component v-suffix-free-name))                         (no-attic-dir (remove-attic-component dir))
51                        (f-name (mapping-generate-id :suffix (suffix v-suffix-free-name)                         (no-attic-suffix-name (path-cat no-attic-dir basename))
52                                                     :no-dir t)))                         (f-name (mapping-generate-id :suffix (suffix basename)
53                    (link canon-name (path-cat *up-dir*                                                      :no-dir t))
54                                               target-dir                         (rcs-name (path-cat *up-dir* target-dir
55                                               (format nil "~A,v" f-name)))                                             (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                    (push (make-mapping-entry :kind :file                    (push (make-mapping-entry :kind :file
61                                              :id (path-cat *mcvs-dir* f-name)                                              :id (path-cat *mcvs-dir* f-name)
62                                              :path attic-free-name                                              :path no-attic-suffix-name
63                                              :executable (executable-p fi))                                              :executable (executable-p fi))
64                          filemap)                          filemap)
65                    (with-open-file (f (parse-posix-namestring canon-name)                    (with-open-file (f (parse-posix-namestring canon-name)
66                                       :direction :input)                                       :direction :input)
67                      (chatter-info "scanning ~a.~%" canon-name)                      (chatter-info "scanning ~a~%" canon-name)
68                      (let ((rcs-file (rcs-parse f)))                      (let ((rcs-file (rcs-parse f)))
69                        (multiple-value-bind (version-tags branch-tags)                        (multiple-value-bind (version-tags branch-tags)
70                                             (classify-tags (rcs-admin-symbols (rcs-file-admin rcs-file)))                                             (classify-tags (rcs-admin-symbols (rcs-file-admin rcs-file)))
# Line 73  Line 76 
77      (current-dir-restore      (current-dir-restore
78        (chdir target-dir)        (chdir target-dir)
79        (chatter-info "Writing map.")        (chatter-info "writing ~a~%" *mcvs-map-name*)
80        (mapping-write filemap *mcvs-map-name*)        (mapping-write filemap *mcvs-map-name*)
82        (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."        (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."
83                           "-t/dev/null" ,*mcvs-map-name*))                           "-t/dev/null" ,*mcvs-map-name*))
84        (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))        (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))
86        (execute-program-xargs '("rcs")        (chatter-info "setting up version and branch tags in ~a~%" *mcvs-map-name*)
87                               (mapcar #'(lambda (tag)        (unless (null all-version-tags)
88                                           (format nil "-n~A:1.1" tag))          (execute-program-xargs '("rcs")
89                                       all-version-tags)                                 (mapcar #'(lambda (tag)
90                               (list *mcvs-map-name*))                                             (format nil "-n~A:1.1" tag))
91                                           all-version-tags)
92                                   (list *mcvs-map-name*)))
94        (let ((branch-counter 0))        (let ((branch-counter 0))
95          (execute-program-xargs '("rcs")          (unless (null all-branch-tags)
96                                 (mapcar #'(lambda (tag)            (execute-program-xargs '("rcs")
97                                             (format nil                                   (mapcar #'(lambda (tag)
98                                                     "-n~A:1.1.0.~A"                                               (format nil
99                                                     tag (+ 2 branch-counter)))                                                       "-n~A:1.1.0.~A"
100                                         all-branch-tags)                                                       tag (+ 2 branch-counter)))
101                                 (list *mcvs-map-name*))))))                                           all-branch-tags)
102                                     (list *mcvs-map-name*)))))))
104  (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)  (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)
105    (declare (ignore cvs-options cvs-command-options))    (declare (ignore cvs-options cvs-command-options))

Removed from v.1.7  
changed lines
  Added in v.

  ViewVC Help
Powered by ViewVC 1.1.5