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, Tue Feb 3 11:49:12 2004 UTC
# Line 7  Line 7 
7  (require "chatter")  (require "chatter")
8  (require "split")  (require "split")
9  (require "mapping")  (require "mapping")
10    (require "types")
11  (require "rcs-utils")  (require "rcs-utils")
12  (provide "convert")  (provide "convert")
14  (defun remove-attic-component (path)  (defun remove-attic-component (path)
15    (let* ((split-path (split-fields path "/"))    (let ((split-path (nreverse (split-fields path "/")))
16           (len (length split-path)))          (attic-p nil))
17      (when (and (>= len 2) (string= (nth (- len 2) split-path) "Attic"))      (when (string= (first split-path) "Attic")
18        (setf split-path (append (butlast (butlast split-path))        (pop split-path)
19                                 (last split-path))))        (setf attic-p t))
20      (reduce #'(lambda (x y) (format nil "~a/~a" x y)) split-path)))      (values (reduce #'(lambda (x y) (format nil "~a/~a" x y))
21                        (nreverse split-path)
22                        :initial-value ".")
23                attic-p)))
25  (defun classify-tags (tags)  (defun classify-tags (tags)
26    (let (version-tags branch-tags)    (let (version-tags branch-tags)
# Line 38  Line 42 
42      (if (not created)      (if (not created)
43        (error "unable to create directory ~a." target-dir)))        (error "unable to create directory ~a." target-dir)))
45    (let (filemap all-version-tags all-branch-tags)    (let (filemap all-version-tags all-branch-tags attic-made)
46      (current-dir-restore      (current-dir-restore
47        (chdir source-dir)        (chdir source-dir)
48        (for-each-file-info (fi ".")        (for-each-file-info (fi ".")
49            (when (and (directory-p fi)
50                       (path-equal (basename (file-name fi)) "CVS"))
51              (skip))
52          (when (regular-p fi)          (when (regular-p fi)
53            (let ((canon-name (canonicalize-path (file-name fi))))            (let ((canon-name (canonicalize-path (file-name fi))))
54              (multiple-value-bind (suffix v-suffix-free-name)              (multiple-value-bind (suffix basename dir)
55                                   (suffix canon-name #\,)                                   (suffix canon-name #\,)
56                (when (and suffix (string= suffix "v"))                (multiple-value-bind (no-attic-dir attic-p)
57                  (let ((attic-free-name                                     (remove-attic-component (or dir "."))
58                          (remove-attic-component v-suffix-free-name))                  (when (and suffix (string= suffix "v"))
59                        (f-name (mapping-generate-id :suffix (suffix v-suffix-free-name)                    (let* ((no-attic-suffix-name
60                                                     :no-dir t)))                             (canonicalize-path (path-cat no-attic-dir basename)))
61                    (link canon-name (path-cat *up-dir*                           (f-name (mapping-generate-id :suffix (suffix basename)
62                                               target-dir                                                        :no-dir t))
63                                               (format nil "~A,v" f-name)))                           (orig-rcs (path-cat source-dir canon-name))
64                    (push (make-mapping-entry :kind :file                           (new-rcs (apply #'path-cat `(,target-dir
65                                              :id (path-cat *mcvs-dir* f-name)                                                        ,@(if attic-p '("Attic"))
66                                              :path attic-free-name                                                        ,(format nil "~A,v"
67                                              :executable (executable-p fi))                                                                 f-name)))))
68                          filemap)                      (in-original-dir
69                    (with-open-file (f (parse-posix-namestring canon-name)                        (when attic-p
70                                       :direction :input)                          (unless attic-made
71                      (chatter-info "scanning ~a.~%" canon-name)                            (ensure-directories-exist new-rcs)
72                      (let ((rcs-file (rcs-parse f)))                            (setf attic-made t)))
73                        (multiple-value-bind (version-tags branch-tags)                        (chatter-info "hard linking ~a -> ~a~%" orig-rcs new-rcs)
74                                             (classify-tags (rcs-admin-symbols (rcs-file-admin rcs-file)))                        (link orig-rcs new-rcs))
75                          (setf all-version-tags (nunion all-version-tags                      (push (make-mapping-entry :kind :file
76                                                         version-tags                                                :id (path-cat *mcvs-dir* f-name)
77                                                         :test #'string=))                                                :path no-attic-suffix-name
78                          (setf all-branch-tags (nunion all-branch-tags branch-tags                                                :executable (executable-p fi))
79                                                        :test #'string=))))))))))))                            filemap)
80                        (with-open-file (f (parse-posix-namestring canon-name)
81                                           :direction :input)
82                          (chatter-info "scanning ~a~%" canon-name)
83                          (let ((rcs-file (rcs-parse f)))
84                            (multiple-value-bind (version-tags branch-tags)
85                                                 (classify-tags (rcs-admin-symbols (rcs-file-admin rcs-file)))
86                              (setf all-version-tags (nunion all-version-tags
87                                                             version-tags
88                                                             :test #'string=))
89                              (setf all-branch-tags (nunion all-branch-tags branch-tags
90                                                            :test #'string=)))))))))))))
92      (current-dir-restore      (current-dir-restore
93        (chdir target-dir)        (chdir target-dir)
94        (chatter-info "Writing map.")        (chatter-info "writing ~a~%" *mcvs-map-name*)
95        (mapping-write filemap *mcvs-map-name*)        (mapping-write filemap *mcvs-map-name* :sort-map t)
97        (execute-program `("ci" "-mMeta-CVS MAP file created by mcvs convert."        (chatter-info "writing ~a~%" *mcvs-types-name*)
98                           "-t/dev/null" ,*mcvs-map-name*))        (with-open-file (f *mcvs-types-name* :direction :output)
99            (prin1 nil f)
100            (terpri f))
102          (chatter-info "writing .cvsignore~%")
103          (with-open-file (f (make-pathname :name ".cvsignore") :direction :output)
104            (write-line *mcvs-map-local-name* f)
105            (write-line *mcvs-displaced-name* f))
107          (execute-program `("ci" "-mCreated by Meta-CVS convert operation."
108                             "-t/dev/null" ,*mcvs-map-name*
109                             ,*mcvs-types-name* ".cvsignore"))
110        (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))        (execute-program `("chmod" "ug+rw" ,(format nil "~A,v" *mcvs-map-name*)))
112        (execute-program-xargs '("rcs")        (chatter-info "setting up version and branch tags in ~a, ~a and .cvsignore~%"
113                               (mapcar #'(lambda (tag)                      *mcvs-map-name* *mcvs-types-name*)
114                                           (format nil "-n~A:1.1" tag))        (unless (null all-version-tags)
115                                       all-version-tags)          (execute-program-xargs '("rcs")
116                               (list *mcvs-map-name*))                                 (mapcar #'(lambda (tag)
117                                               (format nil "-n~A:1.1" tag))
118                                           all-version-tags)
119                                   (list *mcvs-map-name* *mcvs-types-name*
120                                         ".cvsignore")))
122        (let ((branch-counter 0))        (let ((branch-counter 0))
123          (execute-program-xargs '("rcs")          (unless (null all-branch-tags)
124                                 (mapcar #'(lambda (tag)            (execute-program-xargs '("rcs")
125                                             (format nil                                   (mapcar #'(lambda (tag)
126                                                     "-n~A:1.1.0.~A"                                               (format nil
127                                                     tag (+ 2 branch-counter)))                                                       "-n~A:1.1.0.~A"
128                                         all-branch-tags)                                                       tag (incf branch-counter
129                                 (list *mcvs-map-name*))))))                                                                 2)))
130                                             all-branch-tags)
131                                     (list *mcvs-map-name* *mcvs-types-name*
132                                           ".cvsignore")))))))
134  (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)  (defun mcvs-convert-wrapper (cvs-options cvs-command-options mcvs-args)
135    (declare (ignore cvs-options cvs-command-options))    (declare (ignore cvs-options cvs-command-options))
136    (if (/= (length mcvs-args) 2)    (if (/= (length mcvs-args) 2)
137      (error "specify cvs source dir and new target dir."))      (error "specify cvs source dir and new target dir."))
138    (mcvs-convert (first mcvs-args) (second mcvs-args)))    (mcvs-convert (first mcvs-args) (second mcvs-args)))
140    (defconstant *convert-help*
141    "Syntax:
143      mcvs convert source-cvs-module target-mcvs-module
145    Options:
147      None.
149    Semantics:
151      The convert command builds a Meta-CVS module directly out of the RCS files of
152      a CVS module.  The source-cvs-module is the pathname to an existing
153      module directory in the CVS repository containing an ordinary CVS module.
154      The target-mcvs-module is the pathname of a new Meta-CVS module directory to
155      be created.
157      The source and target paths have to be on the same filesystem volume.
159      The chmod and rcs programs are required.
161      The algorithm is extremely naive:
163      - A list of the pathnames of the RCS files is collected, as the basis for
164      creating the MAP file. The Attic directory components are removed from these
165      paths, and the ,v suffixes are stripped.
167      - The execute property of files is lifted from the permission bits on
168      the RCS files.
170      - The MAP,v file is created using the ``rcs ci'' command.
172      - The F- files are generated as hard links to the RCS files, to save space
173      and avoid the overhead of copying.
175      - All of the RCS files are scanned to find version and branch tags.  Quite
176      naively, the version tags are installed in the MAP file, all pointing to
177      revision 1.1. The branch tags are installed in MAP, pointing to revisions
178,, ...  This is a lame attempt to make it possible to check
179      out past baselines. But note that the contents of MAP don't vary: only a
180      single version node is generated with a fixed set of files. It is not taken
181      into consideration that some of the CVS files may be deleted in the head
182      revision or some branches.  Therefore, when the resulting Meta-CVS project is
183      checked out, or when past versions are retrieved, there may be complaints
184      from Meta-CVS about nonexistent files.
186      The complaints about nonexistent files may be fixed at the tips of the
187      main trunk or branches using the ``mcvs remap'' command which will purge
188      the working MAP of entries for F- files for which no working copy is found.
189      A commit will then commit the change so that subsequent work may continue
190      without any more complaints.
192      The hard linking of the original RCS objects under F- names means that any
193      permission, ownership or time-stamp changes done in the CVS module will
194      affect the content of the Meta-CVS module and vice versa. Destructive
195      modifications to the file contents, ditto. Be careful!
197      If the hard links make you nervous, do a deep copy of the module,
198      using ``cp -a source-dir target-dir''.
200      Note that CVS does not destructively manipulate RCS files. A commit
201      or tagging operation creates a new RCS object which atomically replaces the
202      old hard link. This means that a commit to a file in the Meta-CVS module will
203      not affect the CVS module and vice versa.")

Removed from v.1.7  
changed lines
  Added in v.

  ViewVC Help
Powered by ViewVC 1.1.5