/[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 - (show 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 ;;; 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 "dirwalk")
6 (require "system")
7 (require "mapping")
8 (require "types")
9 (require "chatter")
10 (require "options")
11 (provide "import")
12
13 (defconstant *types-comments*
14 ";;; 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 ;;;
19 ;;; :default Expand keyword using default form. (CVS -kkv)
20 ;;; :name-only Expand only the keyword name on checkout. (CVS -kk)
21 ;;; :keep-old Do not expand keywords, and keep any CVS or RCS keywords
22 ;;; 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 ;;; :value-only Expand only the keyword value, no dollar signs. (CVS -kv)
27 ;;; :ignore Do not import or add these files.
28 ")
29
30 (defun mcvs-import (module vendor release
31 &optional cvs-options import-options)
32 (multiple-value-bind (path created) (ensure-directories-exist *mcvs-map*)
33 (declare (ignore path))
34 (if (not created)
35 (error "mcvs-import: A ~a directory already exists here." *mcvs-dir*)))
36
37 (unwind-protect
38 (progn
39 (let (filemap types)
40 (chatter-info "Mapping.~%")
41
42 ;; Gather up list of files to import, and build up mapping,
43 ;; as well as list of suffixes (file types).
44 (for-each-file-info (fi ".")
45 (when (regular-p fi)
46 (let* ((path (canonicalize-path (file-name fi)))
47 (suffix (suffix (file-name fi)))
48 (file (mapping-generate-name suffix)))
49 (chatter-info "~a <- ~a~%" file path)
50 (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 (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
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 (dolist (item filemap)
88 (link (second item) (first item)))
89
90 ;; 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
99 (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 (chatter-info "removing ~a directory~%" *mcvs-dir*)
108 (delete-recursive *mcvs-dir*))
109 (values))
110
111 (defun mcvs-import-wrapper (cvs-options cvs-command-options mcvs-args)
112 (if (< (length mcvs-args) 3)
113 (error "mcvs-import: specify module, vendor tag and release tag."))
114 (destructuring-bind (module vendor release &rest superfluous) mcvs-args
115 (when superfluous
116 (error "mcvs-import: specify only module, vendor tag and release tag."))
117 (mcvs-import module vendor release cvs-options cvs-command-options)))

  ViewVC Help
Powered by ViewVC 1.1.5