/[meta-cvs]/meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490
ViewVC logotype

Contents of /meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Tue Nov 28 07:47:22 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, asdf-import-branch~branch-point
Branch point for: asdf-import-branch
Changes since 1.26: +4 -4 lines
More renaming to get rid of mcvs- prefix.

* code/chatter.lisp (*mcvs-debug*): Renamed to *chatter-debug*.
(*mcvs-info*, *mcvs-terse*, *mcvs-silent*): Similarly.
(*mcvs-chatter-level*): Renamed to *chatter-level*.

* code/unix.lisp (*mcvs-editor*): Renamed to *edit-program*.

* code/types.lisp (*mcvs-types-name*): Renamed to *types-file*.
(*mcvs-types*): Renamed to *types-path*.
(*mcvs-new-types*): Renamed to *types-new-path*.

* code/mapping.lisp (*mcvs-dir*): Renamed to *admin-dir*.
(*mcvs-map-name*): Renamed to *map-file*.
(*mcvs-map-local-name*): Renamed to *map-local-file*.
(*mcvs-displaced-name*): Renamed to *displaced-file*.
(*mcvs-map*): Renamed to *map-path*.
(*mcvs-map-local*): Renamed to *map-local-path*.
(*mcvs-displaced*): Renamed to *displaced-path*.
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 (defvar *print-usage* nil)
8 (defvar *nometa-option* nil)
9 (defvar *meta-option* nil)
10 (defvar *metaonly-option* nil)
11 (defvar *dry-run-option* nil)
12 (defvar *nesting-escape-option* 0)
13 (defvar *nofilt-option* nil)
14
15 (defun option-spec-expand (num-args string-list)
16 (mapcar #'(lambda (string) (list string num-args))
17 string-list))
18
19 (defmacro option-spec (&rest option-specs)
20 `(append ,@(mapcar #'(lambda (spec)
21 (destructuring-bind (number word &rest strings) spec
22 (when (not (string= (symbol-name word) "ARG"))
23 (error "OPTIONS: word \"ARG\" expected."))
24 `(option-spec-expand ,number ',strings)))
25 option-specs)))
26
27 (defmacro define-option-constant (var &rest option-specs)
28 `(defconstant ,var (option-spec ,@option-specs)))
29
30 (defun parse-opt (arguments option-spec)
31 (flet ((process-option (arg)
32 (let* ((split-opt (split-fields arg #(#\=)))
33 (opt-name (first split-opt))
34 (opt-arg (second split-opt))
35 (spec (find opt-name option-spec
36 :test #'string=
37 :key #'first)))
38 (when (null spec)
39 (error "unknown option ~a." opt-name))
40 (when opt-arg
41 (push opt-arg arguments))
42 (let ((num-req-params (second spec))
43 (opt-args ()))
44 (dotimes (i num-req-params)
45 (let ((opt-arg (pop arguments)))
46 (when (null opt-arg)
47 (error "option ~a requires ~a parameter~:p."
48 opt-name num-req-params))
49 (push opt-arg opt-args)))
50 (cons opt-name (nreverse opt-args))))))
51 (let ((parsed-options ()))
52 (loop
53 (if (null arguments)
54 (return))
55 (let ((arg (pop arguments)))
56 (cond
57 ((string= arg "--")
58 (return))
59 ((and (> (length arg) 2) (string= (subseq arg 0 2) "--"))
60 (push (process-option (subseq arg 2)) parsed-options))
61 ((and (> (length arg) 1) (char= (char arg 0) #\-))
62 (let ((num-chars (- (length arg) 1))
63 (last-iter (- (length arg) 2)))
64 (dotimes (i num-chars)
65 (let ((option (subseq arg (+ i 1) (+ i 2)))
66 (arg (subseq arg (+ i 2))))
67 (when (< i last-iter)
68 (push arg arguments))
69 (let ((result (process-option option)))
70 (push result parsed-options)
71 (when (and (second result)
72 (/= i (- (length arg) 2)))
73 (return))
74 (when (< i last-iter)
75 (pop arguments)))))))
76 (t (push arg arguments)
77 (return)))))
78 (values (nreverse parsed-options) arguments))))
79
80 (defun format-opt (options)
81 "Convert list of options as produced by parse-opt back into a list
82 of strings."
83 (mapcan #'(lambda (option-list)
84 (let ((option (first option-list))
85 (arg (rest option-list)))
86 (if (> (length option) 1)
87 (cons (format nil "--~a" option) arg)
88 (if (= (length arg) 1)
89 (list (format nil "-~a~a" option (first arg)))
90 (cons (format nil "-~a" option) arg)))))
91 options))
92
93 (defun filter-mcvs-options (opts)
94 "Processes and removes any Meta-CVS-specific options."
95 (find-bind (:test #'string= :key #'first)
96 (remainder (meta "meta")
97 (metaonly "metaonly")
98 (nometa "nometa")
99 (ec "error-continue")
100 (et "error-terminate")
101 (nesting-escape "up")
102 (debug "debug")
103 (nofilt "nofilt"))
104 opts
105 (when (and meta nometa)
106 (error "cannot specify both --nometa and --meta"))
107 (when (and metaonly nometa)
108 (error "cannot specify both --nometa and --metaonly"))
109 (setf *meta-option* meta)
110 (setf *metaonly-option* metaonly)
111 (setf *nometa-option* nometa)
112 (when nesting-escape
113 (unless (setf *nesting-escape-option*
114 (parse-integer (second nesting-escape)
115 :junk-allowed t))
116 (error "--up option takes integer argument"))
117 (unless (>= *nesting-escape-option* 0)
118 (error "--up argument must be nonnegative")))
119 (when debug
120 (setf *chatter-level* *chatter-debug*))
121 (setf *nofilt-option* nofilt)
122 (cond
123 (ec (setf *error-treatment* :continue))
124 (et (setf *error-treatment* :terminate)))
125 remainder))
126
127 (defun process-cvs-options (opts)
128 "Take care of any CVS options that must also be interpreted by Meta-CVS."
129 (find-bind (:test #'string= :key #'first)
130 ((help-long "help") (help "H") (quiet "q")
131 (very-quiet "Q") (version "v") (version-long "version")
132 (editor "e") (interpret-file "i") (dry-run "n"))
133 opts
134 (when (or help-long help)
135 (setf *print-usage* t))
136 (when (or version version-long)
137 (let* ((vers (split-words "$Name: $" "$:- "))
138 (major (third vers))
139 (minor (fourth vers))
140 (patch (fifth vers)))
141 (if (and major minor patch)
142 (format t "Meta-CVS version ~a.~a.~a Copyright 2004 Kaz Kylheku~%"
143 major minor patch)
144 (format t "Meta-CVS unknown version Copyright 2004 Kaz Kylheku~%"))
145 (throw 'terminate nil)))
146 (when editor
147 (setf *edit-program* (second editor)))
148 (cond
149 (very-quiet (setf *chatter-level* *chatter-silent*))
150 (quiet (setf *chatter-level* *chatter-terse*)))
151 (when dry-run
152 (setf *dry-run-option* t))
153 (when interpret-file
154 (load (second interpret-file))
155 (throw 'terminate nil)))
156 opts)
157
158 (defun filter-global-options (opts)
159 (process-cvs-options (filter-mcvs-options opts)))
160
161 (defmacro honor-dry-run (vars &rest forms)
162 `(cond
163 (*dry-run-option*
164 (chatter-debug
165 "Because of -n option, not executing ~s with bindings ~s.~%"
166 ',forms
167 (list ,@(mapcar #'(lambda (var) `(list ',var ,var)) vars))))
168 (t ,@forms)))

  ViewVC Help
Powered by ViewVC 1.1.5