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

Contents of /meta-cvs/F-94BF952D29F3DC3FFD457EFFCE570DB2

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Thu Nov 21 06:15:15 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0-3
Changes since 1.12: +3 -2 lines
Merging from mcvs-1-0-branch.

Some security fixes.  Funny I didn't think of this sooner!

* code/types.lisp (types-read): Make sure *read-eval* is bound to
nil when calling READ.

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

  ViewVC Help
Powered by ViewVC 1.1.5