/[meta-cvs]/meta-cvs/F-94BF952D29F3DC3FFD457EFFCE570DB2
ViewVC logotype

Contents of /meta-cvs/F-94BF952D29F3DC3FFD457EFFCE570DB2

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Tue Mar 12 19:54:58 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-9, mcvs-0-8, mcvs-0-11, mcvs-0-10, mcvs-0-13, mcvs-0-12, deferred-adds-branch~branch-point
Branch point for: deferred-adds-branch
Changes since 1.4: +1 -1 lines
* update.lisp (mcvs-update): Changing level of chatter messages.
* move.lisp (mcvs-move): Likewise.
* add.lisp (mcvs-add): Likewise.
* remove.lisp (mcvs-remove): Likewise.
* checkout.lisp (mcvs-checkout): Likewise.
* generic.lisp (mcvs-generic): Likewise.
* import.lisp (mcvs-import): Likewise.
* mapping.lisp (mapping-dupe-check): Likewise.
(mapping-update): Likewise.
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 "mapping")
6 (require "system")
7 (require "print")
8 (require "seqfuncs")
9 (provide "types")
10
11 (eval-when (:compile-toplevel :load-toplevel :execute)
12 (defconstant *mcvs-types-name* "TYPES"))
13
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (defconstant *mcvs-types* #.(path-cat *mcvs-dir* *mcvs-types-name*))
16 (defconstant *mcvs-new-types* #.(path-cat *mcvs-dir* "TYPES-NEW")))
17
18 (defconstant *types-comments*
19 ";;; For each file suffix that appears in the file set, you can specify
20 ;;; the CVS keyword expansion mode, or you can specify that the files having
21 ;;; that suffix should not be imported. This is done by editing the list below.
22 ;;; Here are the symbols you can specify next to each suffix.
23 ;;;
24 ;;; :default Expand keyword using default form. (CVS -kkv)
25 ;;; :name-only Expand only the keyword name on checkout. (CVS -kk)
26 ;;; :keep-old Do not expand keywords, and keep any CVS or RCS keywords
27 ;;; that are already present in the files. (CVS -ko)
28 ;;; :binary Like :keep-old except that the file is treated as
29 ;;; binary. Not only are keywords not expanded, but line ending
30 ;;; conversions are not performed either. (CVS -kb)
31 ;;; :value-only Expand only the keyword value, no dollar signs. (CVS -kv)
32 ;;; :ignore Do not import or add these files.
33 ")
34
35
36 (defun types-read (filename)
37 (with-open-file (file filename :direction :input)
38 (read file)))
39
40 (defun types-write (types filename &key comments)
41 (with-open-file (file filename :direction :output)
42 (let ((sorted-types (sort (copy-list types)
43 #'string-lessp :key #'first)))
44 (when comments
45 (write-string comments file)
46 (terpri file))
47 (print-assoc-list sorted-types file)
48 (terpri file))))
49
50 (defun types-sanity-check (types)
51 (cond
52 ((null types)
53 (values))
54 ((consp types)
55 (let ((type-spec (first types)))
56 (when (or (not (stringp (first type-spec)))
57 (not (symbolp (second type-spec))))
58 (error "bad syntax in file type treatment specification: ~s" type-spec))
59 (when (not (member (second type-spec)
60 '(:name-only :keep-old :default :value-only
61 :binary :ignore)))
62 (error "unrecognized keyword: ~s" type-spec)))
63 (types-sanity-check (rest types)))
64 (t (error "bad syntax in file type treatment specification: ~s" types))))
65
66 (defun types-to-import-wrapper-args (types)
67 (mapcan #'(lambda (type-spec)
68 (destructuring-bind (suffix treatment) type-spec
69 (flet ((gen-option (suf opt) `("-W"
70 ,(format nil "*.~a -k '~a'"
71 suf opt))))
72 (ecase treatment
73 ((:name-only) (gen-option suffix "k"))
74 ((:keep-old) (gen-option suffix "o"))
75 ((:binary) (gen-option suffix "b"))
76 ((:value-only) (gen-option suffix "kv"))
77 ((:ignore) nil)
78 ((:default) nil)))))
79 types))
80
81 (defun types-remove-ignores (types mapping)
82 (let ((ignores (mapcan #'(lambda (type-spec)
83 (if (eq (second type-spec) :ignore)
84 (list (first type-spec))))
85 types)))
86 (remove-if #'(lambda (name)
87 (member (suffix name) ignores :test #'path-equal))
88 mapping :key #'first)))
89
90 (defun types-make-cvs-adds (types mapping)
91 (let (cvs-adds matching files)
92 (dolist (type-entry types)
93 (multiple-value-setq
94 (matching mapping)
95 (separate-if #'(lambda (x)
96 (and x (path-equal (first type-entry) x)))
97 mapping
98 :key #'(lambda (x) (suffix (first x)))))
99 (setf files (mapcar #'basename (mapcar #'first matching)))
100 (when files
101 (ecase (second type-entry)
102 ((:name-only) (setf files (list* "-kk" files)))
103 ((:keep-old) (setf files (list* "-ko" files)))
104 ((:binary) (setf files (list* "-kb" files)))
105 ((:value-only) (setf files (list* "-kv" files)))
106 ((:ignore) (setf files nil))
107 ((:default)))
108 (when files (push files cvs-adds))))
109 (setf files (mapcar #'first mapping))
110 (when files (push files cvs-adds))
111 cvs-adds))
112
113 (defun types-let-user-edit (types filename)
114 (when types
115 (types-write types filename :comments *types-comments*)
116 (loop
117 (restart-case
118 (progn
119 (chatter-debug "Editing types.~%")
120 (edit-file filename)
121 (let ((edited-types (types-read filename)))
122 (types-sanity-check edited-types)
123 (types-write edited-types filename)
124 (return edited-types)))
125 (retry ()
126 :report "Correct file type treatment, try again.")
127 (restore-types ()
128 :report "Revert to original file treatment and edit again."
129 (types-write types filename :comments *types-comments*))))))

  ViewVC Help
Powered by ViewVC 1.1.5