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

Contents of /meta-cvs/F-94BF952D29F3DC3FFD457EFFCE570DB2

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Fri Nov 24 04:53:50 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.14: +1 -1 lines
Stylistic change.

* code/add.lisp: Change in-package calls not to use the all-caps
"META-CVS" string string, but rather the :meta-cvs keyword.
* code/branch.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/create.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/error.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/filt.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/link.lisp: Likewise.
* code/main.lisp: Likewise.
* code/mapping.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/move.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/options.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/print.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/purge.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/remap.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/restart.lisp: Likewise.
* code/restore.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/split.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/types.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/update.lisp: Likewise.
* code/watch.lisp: 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 (in-package :meta-cvs)
6
7 (eval-when (:compile-toplevel :load-toplevel :execute)
8 (defconstant *mcvs-types-name* "TYPES"))
9
10 (eval-when (:compile-toplevel :load-toplevel :execute)
11 (defconstant *mcvs-types* #.(path-cat *mcvs-dir* *mcvs-types-name*))
12 (defconstant *mcvs-new-types* #.(path-cat *mcvs-dir* "TYPES-NEW")))
13
14 (defconstant *types-comments*
15 ";;; For each file suffix that appears in the file set, you can specify
16 ;;; the CVS keyword expansion mode, or you can specify that the files having
17 ;;; that suffix should not be imported. This is done by editing the list below.
18 ;;; Here are the symbols you can specify next to each suffix.
19 ;;;
20 ;;; :default Expand keyword using default form. (CVS -kkv)
21 ;;; :name-only Expand only the keyword name on checkout. (CVS -kk)
22 ;;; :keep-old Do not expand keywords, and keep any CVS or RCS keywords
23 ;;; that are already present in the files. (CVS -ko)
24 ;;; :binary Like :keep-old except that the file is treated as
25 ;;; binary. Not only are keywords not expanded, but line ending
26 ;;; conversions are not performed either. (CVS -kb)
27 ;;; :value-only Expand only the keyword value, no dollar signs. (CVS -kv)
28 ;;; :ignore Do not import or add these files.
29 ")
30
31
32 (defun types-read (filename)
33 (let ((*read-eval* nil))
34 (with-open-file (file filename :direction :input)
35 (read file))))
36
37 (defun types-write (types filename &key comments)
38 (when *dry-run-option*
39 (chatter-debug "not writing to ~a because of -n global option.~%"
40 *mcvs-types*)
41 (return-from types-write))
42 (with-open-file (file filename :direction :output)
43 (let ((sorted-types (sort (copy-list types)
44 #'string-lessp :key #'first)))
45 (when comments
46 (write-string comments file)
47 (terpri file))
48 (print-assoc-list sorted-types file)
49 (terpri file))))
50
51 (defun types-sanity-check (types)
52 (cond
53 ((null types)
54 (values))
55 ((consp types)
56 (let ((type-spec (first types)))
57 (when (or (not (stringp (first type-spec)))
58 (not (symbolp (second type-spec))))
59 (error "bad syntax in file type treatment specification: ~s" type-spec))
60 (when (not (member (second type-spec)
61 '(:name-only :keep-old :default :value-only
62 :binary :ignore)))
63 (error "unrecognized keyword: ~s" type-spec)))
64 (types-sanity-check (rest types)))
65 (t (error "bad syntax in file type treatment specification: ~s" types))))
66
67 (defun types-to-import-wrapper-args (types)
68 (mapcan #'(lambda (type-spec)
69 (destructuring-bind (suffix treatment) type-spec
70 (flet ((gen-option (suf opt)
71 (list "-W" (format nil "*.~a -k '~a'" 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 (entry)
87 (with-slots (kind id) entry
88 (and (eq kind :file)
89 (member (suffix id) ignores :test #'path-equal))))
90 mapping)))
91
92 (defun types-make-cvs-adds (types mapping)
93 (let (cvs-adds matching files)
94 (dolist (type-entry types)
95 (multiple-value-setq
96 (matching mapping)
97 (separate-if #'(lambda (x)
98 (and x (path-equal (first type-entry) x)))
99 mapping
100 :key #'(lambda (x) (suffix (mapping-entry-id x)))))
101 (setf files (mapcar #'basename (mapcar #'mapping-entry-id matching)))
102 (when files
103 (ecase (second type-entry)
104 ((:name-only) (setf files (list* "-kk" files)))
105 ((:keep-old) (setf files (list* "-ko" files)))
106 ((:binary) (setf files (list* "-kb" files)))
107 ((:value-only) (setf files (list* "-kv" files)))
108 ((:ignore) (setf files nil))
109 ((:default)))
110 (when files (push files cvs-adds))))
111 (setf files (mapcar #'basename (mapcar #'mapping-entry-id mapping)))
112 (when files (push files cvs-adds))
113 cvs-adds))
114
115 (defun types-let-user-edit (types filename)
116 (when types
117 (types-write types filename :comments *types-comments*)
118 (loop
119 (loop
120 (restart-case
121 (progn
122 (chatter-debug "Editing types.~%")
123 (unless (invoke-editor-on filename)
124 (error "Failed to invoke text editor."))
125 (return))
126 (retry ()
127 :report "Try invoking editor again.")))
128 (restart-case
129 (let ((edited-types (types-read filename)))
130 (types-sanity-check edited-types)
131 (types-write edited-types filename)
132 (return edited-types))
133 (retry ()
134 :report "Correct file type treatment, try again.")
135 (restore-types ()
136 :report "Revert to original file treatment and edit again."
137 (types-write types filename :comments *types-comments*))))))

  ViewVC Help
Powered by ViewVC 1.1.5