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

Contents of /meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5