/[meta-cvs]/meta-cvs/F-C232DEE072E25B4F4683B91342CEC065
ViewVC logotype

Contents of /meta-cvs/F-C232DEE072E25B4F4683B91342CEC065

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Mon Feb 18 06:14:22 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.11: +17 -17 lines
* print.lisp: New file.
(print-assoc-list): New function.
* types.lisp: Use print-assoc-list to nicely print the types.
* import.lisp (mcvs-import): Don't bother getting user to
edit the types if the type list is empty. In fact, don't
even create the file.

* add.lisp (mcvs-add): Use new form of mapping-generate-name.
1 kaz 1.7 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.4 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "dirwalk")
6 kaz 1.10 (require "system")
7 kaz 1.1 (require "mapping")
8 kaz 1.10 (require "types")
9 kaz 1.1 (require "chatter")
10 kaz 1.6 (require "options")
11 kaz 1.1 (provide "import")
12    
13 kaz 1.10 (defconstant *types-comments*
14 kaz 1.11 ";;; For each file suffix that appears in the imported files, you can specify
15     ;;; the CVS keyword expansion mode, or you can specify that the files having
16     ;;; that suffix should not be imported. This is done by editing the list below.
17     ;;; Here are the symbols you can specify next to each suffix.
18 kaz 1.10 ;;;
19     ;;; :default Expand keyword using default form. (CVS -kkv)
20     ;;; :name-only Expand only the keyword name on checkout. (CVS -kk)
21 kaz 1.11 ;;; :keep-old Do not expand keywords, and keep any CVS or RCS keywords
22 kaz 1.10 ;;; that are already present in the files. (CVS -ko)
23     ;;; :binary Like :keep-old except that the file is treated as
24     ;;; binary. Not only are keywords not expanded, but line ending
25     ;;; conversions are not performed either. (CVS -kb)
26 kaz 1.11 ;;; :value-only Expand only the keyword value, no dollar signs. (CVS -kv)
27 kaz 1.10 ;;; :ignore Do not import or add these files.
28     ")
29    
30 kaz 1.2 (defun mcvs-import (module vendor release
31     &optional cvs-options import-options)
32 kaz 1.1 (multiple-value-bind (path created) (ensure-directories-exist *mcvs-map*)
33 kaz 1.3 (declare (ignore path))
34 kaz 1.1 (if (not created)
35 kaz 1.5 (error "mcvs-import: A ~a directory already exists here." *mcvs-dir*)))
36 kaz 1.1
37     (unwind-protect
38     (progn
39 kaz 1.10 (let (filemap types)
40 kaz 1.1 (chatter-info "Mapping.~%")
41 kaz 1.10
42     ;; Gather up list of files to import, and build up mapping,
43     ;; as well as list of suffixes (file types).
44 kaz 1.1 (for-each-file-info (fi ".")
45     (when (regular-p fi)
46 kaz 1.10 (let* ((path (canonicalize-path (file-name fi)))
47     (suffix (suffix (file-name fi)))
48     (file (mapping-generate-name suffix)))
49 kaz 1.1 (chatter-info "~a <- ~a~%" file path)
50 kaz 1.10 (push (list file path) filemap)
51     (when suffix
52     (setf types (adjoin (list suffix :default)
53     types :test #'equal))))))
54    
55     ;; Write out types to file and allow user to edit.
56 kaz 1.12 (when types
57     (types-write types *mcvs-types* :comments *types-comments*)
58     (loop
59     (restart-case
60     (progn
61     (chatter-info "Editing types.~%")
62     (edit-file *mcvs-types*)
63     (let ((edited-types (types-read *mcvs-types*)))
64     (types-sanity-check edited-types)
65     (types-write edited-types *mcvs-types*)
66     (setf types edited-types))
67     (return))
68     (retry ()
69     :report "Correct file type treatment, try again.")
70     (restore-types ()
71     :report "Revert to original file treatment and edit again."
72     (types-write types *mcvs-types* :comments *types-comments*)))))
73 kaz 1.10
74     ;; User has edited, so now we must honor all of the :IGNORE
75     ;; entries in the types, and remove the matching files from the
76     ;; mapping.
77     (let ((ignores (mapcan #'(lambda (type-spec)
78     (if (eq (second type-spec) :ignore)
79     (list (first type-spec))))
80     types)))
81     (setf filemap (remove-if #'(lambda (name)
82     (member (suffix name)
83     ignores :test #'path-equal))
84     filemap :key #'first)))
85    
86     ;; Create F-files by hard linking
87 kaz 1.1 (dolist (item filemap)
88     (link (second item) (first item)))
89    
90 kaz 1.10 ;; Write out mapping, and we are ready to cvs import!
91     (mapping-write filemap *mcvs-map* :sort-map t)
92    
93     (loop
94     (restart-case
95     (current-dir-restore
96     (chdir *mcvs-dir*)
97     (chatter-info "Invoking CVS.~%")
98 kaz 1.1
99 kaz 1.10 (if (not (execute-program `("cvs" ,@(format-opt cvs-options)
100     "import" ,@(format-opt import-options)
101     ,@(types-to-import-wrapper-args types)
102     ,module ,vendor ,release)))
103     (error "CVS import failed."))
104     (return))
105     (retry ()
106     :report "Try invoking CVS again.")))))
107 kaz 1.1 (chatter-info "removing ~a directory~%" *mcvs-dir*)
108     (delete-recursive *mcvs-dir*))
109     (values))
110 kaz 1.2
111 kaz 1.6 (defun mcvs-import-wrapper (cvs-options cvs-command-options mcvs-args)
112 kaz 1.4 (if (< (length mcvs-args) 3)
113     (error "mcvs-import: specify module, vendor tag and release tag."))
114 kaz 1.2 (destructuring-bind (module vendor release &rest superfluous) mcvs-args
115     (when superfluous
116 kaz 1.4 (error "mcvs-import: specify only module, vendor tag and release tag."))
117 kaz 1.6 (mcvs-import module vendor release cvs-options cvs-command-options)))

  ViewVC Help
Powered by ViewVC 1.1.5