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

Contents of /meta-cvs/F-94BF952D29F3DC3FFD457EFFCE570DB2

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9.2.1 - (hide annotations)
Thu Oct 17 15:28:17 2002 UTC (11 years, 6 months ago) by kaz
Branch: mcvs-1-0-branch
Changes since 1.9: +13 -7 lines
Detect failure to start text editor.

* code/posix.lisp (*editor*): Change name to *mcvs-editor*, due
to name-clash with a CLISP extension!

* code/mcvs-main.lisp: Likewise.

* code/types.lisp (types-let-user-edit): Provide an individual
restart-case block around the invocation of the text editor,
which lets the user re-try the editor.
1 kaz 1.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 kaz 1.2 (require "print")
8 kaz 1.4 (require "seqfuncs")
9 kaz 1.1 (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 kaz 1.4 (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 kaz 1.1
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 kaz 1.2 (let ((sorted-types (sort (copy-list types)
43 kaz 1.1 #'string-lessp :key #'first)))
44     (when comments
45     (write-string comments file)
46     (terpri file))
47 kaz 1.2 (print-assoc-list sorted-types file)
48 kaz 1.1 (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 kaz 1.3 (error "bad syntax in file type treatment specification: ~s" type-spec))
59 kaz 1.1 (when (not (member (second type-spec)
60     '(:name-only :keep-old :default :value-only
61     :binary :ignore)))
62 kaz 1.3 (error "unrecognized keyword: ~s" type-spec)))
63 kaz 1.1 (types-sanity-check (rest types)))
64 kaz 1.3 (t (error "bad syntax in file type treatment specification: ~s" types))))
65 kaz 1.1
66     (defun types-to-import-wrapper-args (types)
67     (mapcan #'(lambda (type-spec)
68     (destructuring-bind (suffix treatment) type-spec
69 kaz 1.6 (flet ((gen-option (suf opt)
70     (list "-W" (format nil "*.~a -k '~a'" suf opt))))
71 kaz 1.1 (ecase treatment
72     ((:name-only) (gen-option suffix "k"))
73     ((:keep-old) (gen-option suffix "o"))
74     ((:binary) (gen-option suffix "b"))
75     ((:value-only) (gen-option suffix "kv"))
76     ((:ignore) nil)
77     ((:default) nil)))))
78     types))
79 kaz 1.4
80     (defun types-remove-ignores (types mapping)
81     (let ((ignores (mapcan #'(lambda (type-spec)
82     (if (eq (second type-spec) :ignore)
83     (list (first type-spec))))
84     types)))
85 kaz 1.9 (remove-if #'(lambda (entry)
86     (with-slots (kind id) entry
87     (and (eq kind :file)
88     (member (suffix id) ignores :test #'path-equal))))
89     mapping)))
90 kaz 1.4
91     (defun types-make-cvs-adds (types mapping)
92     (let (cvs-adds matching files)
93     (dolist (type-entry types)
94     (multiple-value-setq
95     (matching mapping)
96     (separate-if #'(lambda (x)
97     (and x (path-equal (first type-entry) x)))
98     mapping
99 kaz 1.9 :key #'(lambda (x) (suffix (mapping-entry-id x)))))
100     (setf files (mapcar #'basename (mapcar #'mapping-entry-id matching)))
101 kaz 1.4 (when files
102     (ecase (second type-entry)
103     ((:name-only) (setf files (list* "-kk" files)))
104     ((:keep-old) (setf files (list* "-ko" files)))
105     ((:binary) (setf files (list* "-kb" files)))
106     ((:value-only) (setf files (list* "-kv" files)))
107     ((:ignore) (setf files nil))
108     ((:default)))
109     (when files (push files cvs-adds))))
110 kaz 1.9 (setf files (mapcar #'basename (mapcar #'mapping-entry-id mapping)))
111 kaz 1.4 (when files (push files cvs-adds))
112     cvs-adds))
113    
114     (defun types-let-user-edit (types filename)
115     (when types
116     (types-write types filename :comments *types-comments*)
117     (loop
118 kaz 1.9.2.1 (loop
119     (restart-case
120     (progn
121     (chatter-debug "Editing types.~%")
122     (unless (invoke-editor-on filename)
123     (error "Failed to invoke text editor."))
124     (return))
125     (retry ()
126     :report "Try invoking editor again.")))
127 kaz 1.4 (restart-case
128 kaz 1.9.2.1 (let ((edited-types (types-read filename)))
129     (types-sanity-check edited-types)
130     (types-write edited-types filename)
131     (return edited-types))
132 kaz 1.4 (retry ()
133     :report "Correct file type treatment, try again.")
134     (restore-types ()
135     :report "Revert to original file treatment and edit again."
136     (types-write types filename :comments *types-comments*))))))

  ViewVC Help
Powered by ViewVC 1.1.5